/
package-build.el
1723 lines (1543 loc) · 73.4 KB
/
package-build.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; package-build.el --- Tools for assembling a package archive -*- lexical-binding:t; coding:utf-8 -*-
;; Copyright (C) 2011-2024 Donald Ephraim Curtis
;; Copyright (C) 2012-2024 Steve Purcell
;; Copyright (C) 2016-2024 Jonas Bernoulli
;; Copyright (C) 2009 Phil Hagelberg
;; Author: Donald Ephraim Curtis <dcurtis@milkbox.net>
;; Steve Purcell <steve@sanityinc.com>
;; Jonas Bernoulli <emacs.package-build@jonas.bernoulli.dev>
;; Phil Hagelberg <technomancy@gmail.com>
;; Homepage: https://github.com/melpa/package-build
;; Keywords: maint tools
;; Package-Version: 4.0.0.50-git
;; Package-Requires: ((emacs "26.1") (compat "27.1"))
;; SPDX-License-Identifier: GPL-3.0-or-later
;; This file is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this file. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This file allows a curator to publish an archive of Emacs packages.
;; The archive is generated from a set of recipes, which describe elisp
;; projects and repositories from which to get them. The term "package"
;; here is used to mean a specific version of a project that is prepared
;; for download and installation.
;;; Code:
(require 'cl-lib)
(require 'compat nil t)
(require 'pcase)
(require 'subr-x)
(require 'package)
(require 'lisp-mnt)
(require 'json)
(require 'package-recipe)
(require 'package-build-badges)
;;; Options
(defvar package-build--melpa-base
(file-name-directory
(directory-file-name
(file-name-directory (or load-file-name (buffer-file-name))))))
(defgroup package-build nil
"Tools for building package.el-compliant packages from upstream source code."
:group 'development)
(defcustom package-build-working-dir
(expand-file-name "working/" package-build--melpa-base)
"Directory in which to keep checkouts."
:group 'package-build
:type 'string)
(defcustom package-build-archive-dir
(expand-file-name "packages/" package-build--melpa-base)
"Directory in which to keep compiled archives."
:group 'package-build
:type 'string)
(defcustom package-build-recipes-dir
(expand-file-name "recipes/" package-build--melpa-base)
"Directory containing recipe files."
:group 'package-build
:type 'string)
(defcustom package-build-verbose t
"When non-nil, then print additional progress information."
:group 'package-build
:type 'boolean)
(defcustom package-build-stable nil
"Whether to build release or snapshot packages.
If nil, snapshot packages are build, otherwise release packages
are build. `package-build-snapshot-version-functions' and/or
`package-build-release-version-functions' are used to determine
the appropriate version for each package and how the version
string is formatted."
:group 'package-build
:type 'boolean)
(defcustom package-build-all-publishable (not package-build-stable)
"Whether even packages that lack a release can be published.
This option is used to determine whether failure to come up with
a version string should be considered an error or not.
Currently this defaults to (not package-build-stable), but the
default is likely to be changed to just `t' in the future. See
also the commit that added this option."
:group 'package-build
:type 'boolean
:set-after '(package-build-stable))
(make-obsolete-variable 'package-build-get-version-function
'package-build-stable
"Package-Build 5.0.0")
(defvar package-build-get-version-function nil
"This variable is obsolete and its value should be nil.
If this is non-nil, then it overrides
`package-build-release-version-functions' and
`package-build-snapshot-version-functions'.")
(defcustom package-build-release-version-functions
(list #'package-build-tag-version)
"Functions used to determine the current release of a package.
Each function is called in order, with the recipe object as
argument, until one returns non-nil. The returned value must
have the form (COMMIT TIME VERSION), where COMMIT is the commit
chosen by the function, TIME is its committer date, and VERSION
is the version string chosen for COMMIT.
If obsolete `package-build-get-version-function' is non-nil,
then that overrides the value set here."
:group 'package-build
:type 'hook
:options (list #'package-build-tag-version
#'package-build-header-version
#'package-build-pkg-version))
(defcustom package-build-snapshot-version-functions
(list #'package-build-timestamp-version)
"Function used to determine the current snapshot of a package.
Each function is called in order, with the recipe object as
argument, until one returns non-nil. The returned value must
have the form (COMMIT TIME VERSION), where COMMIT is the commit
chosen by the function, TIME is its committer date, and VERSION
is the version string chosen for COMMIT.
Some of the functions that return snapshot versions, internally
use `package-build-release-version-functions' to determine the
current release, which they use as part of the returned VERSION.
If obsolete `package-build-get-version-function' is non-nil,
then that overrides the value set here."
:group 'package-build
:type 'hook
:options (list #'package-build-release+count-version
#'package-build-release+timestamp-version
#'package-build-timestamp-version))
(defcustom package-build-predicate-function nil
"Predicate used by `package-build-all' to determine which packages to build.
If non-nil, this function is called with the recipe object as
argument, and must return non-nil if the package is to be build.
If nil (the default), then all packages are build."
:group 'package-build
:type '(choice (const :tag "build all") function))
(defcustom package-build-build-function
#'package-build--build-multi-file-package
"Low-level function used to build a package.
By default a tarball is used for all packages, including those
consisting of a single file. It this is nil, then single-file
packages are distributed without using tarballs."
:group 'package-build
:type '(choice (const :tag "use tarball for all packages"
package-build--build-multi-file-package)
(const :tag "only use tarball for multi-file packages" nil)
function))
;; NOTE that these hooks are still experimental. Let me know if these
;; are potentially useful for you and whether any changes are required
;; to make them more appropriate for your usecase.
(defvar package-build-worktree-function #'package-recipe--working-tree)
(defvar package-build-early-worktree-function #'package-recipe--working-tree)
(defvar package-build-fetch-function #'package-build--fetch)
(defvar package-build-checkout-function #'package-build--checkout)
(defvar package-build-cleanup-function #'package-build--cleanup)
(defcustom package-build-timeout-executable "timeout"
"Path to a GNU coreutils \"timeout\" command if available.
This must be a version which supports the \"-k\" option.
On MacOS it is possible to install coreutils using Homebrew or
similar, which will provide the GNU timeout program as
\"gtimeout\"."
:group 'package-build
:type '(file :must-match t))
(defcustom package-build-timeout-secs nil
"Wait this many seconds for external processes to complete.
If an external process takes longer than specified here to
complete, then it is terminated. If nil, then no time limit is
applied. This setting requires
`package-build-timeout-executable' to be set."
:group 'package-build
:type 'number)
(defcustom package-build-tar-executable "tar"
"Path to a (preferably GNU) tar command.
Certain package names (e.g., \"@\") may not work properly with a BSD tar.
On MacOS it is possible to install coreutils using Homebrew or
similar, which will provide the GNU timeout program as
\"gtar\"."
:group 'package-build
:type '(file :must-match t))
(defvar package-build--tar-type nil
"Type of `package-build-tar-executable'.
Can be `gnu' or `bsd'; nil means the type is not decided yet.")
(define-obsolete-variable-alias 'package-build-write-melpa-badge-images
'package-build-badge-data "Package-Build 5.0.0")
(defcustom package-build-badge-data nil
"Text and color used in badge images, if any.
If nil (the default), then no badge images are generated,
otherwise this has the form (NAME COLOR). MELPA sets the value
in its top-level Makefile, to different values, depending on the
channel that is being build."
:group 'package-build
:type '(list (string :tag "Archive name") color))
(defcustom package-build-version-regexp
"\\`[rRvV]?\\(?1:[0-9]+\\(\\.[0-9]+\\)*\\)\\'"
"Regexp used to match valid version-strings.
The first capture is used to extract the actual version string.
Strings matched by that group must be valid according to
`version-to-list', but the used regexp can be more strict. The
default value supports only releases but no pre-releases. It
also intentionally ignores cedrtain unfortunate version strings
such as \"1A\" or \".5\", and only supports \".\" as separator.
The part before the first capture group should match prefixes
commonly used in version tags.
Note that this variable can be overridden in a package's recipe,
using the `:version-regexp' slot."
:group 'package-build
:type 'string)
(defcustom package-build-allowed-git-protocols '("https" "file" "ssh")
"Protocols that can be used to fetch from upstream with git.
By default insecure protocols, such as \"http\" or \"git\", are
disallowed."
:group 'package-build
:type '(repeat string))
(defvar package-build-use-git-remote-hg nil
"Whether to use `git-remote-hg' remote helper for mercurial repos.")
(defvar package-build--inhibit-fetch nil
"Whether to inhibit fetching. Useful for testing purposes.")
(defvar package-build--inhibit-checkout nil
"Whether to inhibit checkout. Useful for testing purposes.")
(defvar package-build--inhibit-build nil
"Whether to inhibit building. Useful for testing purposes.")
;;; Generic Utilities
(defun package-build--message (format-string &rest args)
"Behave like `message' if `package-build-verbose' is non-nil.
Otherwise do nothing. FORMAT-STRING and ARGS are as per that function."
(when package-build-verbose
(apply #'message format-string args)))
(defun package-build--error (package format-string &rest args)
"Behave similar to `error' but with additional logging.
Log the error to \"errors.log\" in `package-build-archive-dir'.
Prefix the entry with the date and if possible the name of a
package. PACKAGE identifies a package, it must be a package
name, a `package-recipe' object or nil, if the command is not
being run for a particular package."
(declare (indent defun))
(let ((err (apply #'format-message format-string args)))
;; That's a bit of an inconvenient interface...
(with-temp-buffer
(insert (format "%s %-25s %s\n"
(format-time-string "%FT%T%z" nil t)
(if (cl-typep package 'package-recipe)
(oref package name)
(or package "n/a"))
err))
(unless (eq (char-before) ?\n)
(insert "\n"))
(goto-char (point-min))
(append-to-file
(point)
(1+ (line-end-position))
(expand-file-name "errors.log" package-build-archive-dir)))
(error "%s" err)))
;;; Version Handling
;;;; Common
(defun package-build--select-version (rcp)
(pcase-let*
((default-directory (package-build--working-tree rcp t))
(`(,commit ,time ,version)
(cond
((with-no-warnings package-build-get-version-function)
(display-warning 'package-build "\
Variable `package-build-get-version-function' is obsolete.
Instead set `package-build-release-version-functions'
and/or `package-build-snapshot-version-functions', and
set `package-build-stable' to control whether releases
or snapshots are build.")
(with-no-warnings (funcall package-build-get-version-function rcp)))
(package-build-stable
(run-hook-with-args-until-success
'package-build-release-version-functions rcp))
((run-hook-with-args-until-success
'package-build-snapshot-version-functions rcp)))))
(if (not version)
(funcall (if package-build-all-publishable #'error #'message)
"Cannot determine version for %s" (oref rcp name))
(oset rcp commit commit)
(oset rcp time time)
(oset rcp version version))))
(cl-defmethod package-build--select-commit ((rcp package-git-recipe) rev exact)
(pcase-let*
((`(,hash ,time)
(split-string
(car (apply #'process-lines
"git" "log" "-n1" "--first-parent" "--no-show-signature"
"--pretty=format:%H %cd" "--date=unix" rev
(and (not exact)
(cons "--" (package-build--spec-globs rcp)))))
" ")))
(list hash (string-to-number time))))
(cl-defmethod package-build--select-commit ((rcp package-hg-recipe) rev exact)
(pcase-let*
((`(,hash ,time ,_timezone)
(split-string
(car (apply #'process-lines
;; The "date" keyword uses UTC. The "hgdate" filter
;; returns two integers separated by a space; the
;; unix timestamp and the timezone offset. We use
;; "hgdate" because that makes it easier to discard
;; the time zone offset, which doesn't interest us.
"hg" "log" "--limit" "1"
"--template" "{node} {date|hgdate}\n" "--rev" rev
(and (not exact)
(cons "--" (package-build--spec-globs rcp)))))
" ")))
(list hash (string-to-number time))))
;;;; Tag
(defun package-build-tag-version (rcp)
"Determine version corresponding to largest version tag for RCP.
Return (COMMIT-HASH COMMITTER-DATE VERSION-STRING)."
(let ((regexp (or (oref rcp version-regexp) package-build-version-regexp))
(tag nil)
(version '(0)))
(dolist (n (package-build--list-tags rcp))
(let ((v (ignore-errors
(version-to-list (and (string-match regexp n)
(match-string 1 n))))))
(when (and v (version-list-<= version v))
(if (cl-typep rcp 'package-git-recipe)
(setq tag (concat "refs/tags/" n))
(setq tag n))
(setq version v))))
(and tag
(pcase-let ((`(,hash ,time) (package-build--select-commit rcp tag t)))
(list hash time (package-version-join version))))))
(cl-defmethod package-build--list-tags ((_rcp package-git-recipe))
(process-lines "git" "tag" "--list"))
(cl-defmethod package-build--list-tags ((_rcp package-hg-recipe))
(process-lines "hg" "tags" "--quiet"))
(define-obsolete-function-alias 'package-build-get-tag-version
'package-build-tag-version "Package-Build 5.0.0")
;;;; Header
(defun package-build-header-version (rcp)
"Return version specified in the header of the main library.
Walk the history of the main library until a commit is found
which changes the `Package-Version' or `Version' header in the
main library to a version that qualifies as a release, ignoring
any pre-releases.
Return (COMMIT-HASH COMMITTER-DATE VERSION-STRING)."
(and-let* ((lib (package-build--main-library rcp)))
(with-temp-buffer
(let (commit date version)
(save-excursion
(package-build--insert-version-header-log
rcp (file-relative-name lib)))
(while (and (not version)
(re-search-forward "^commit \\([^ ]+\\) \\(.+\\)" nil t))
(setq commit (match-string 1))
(setq date (match-string 2))
(let ((end (save-excursion (re-search-forward "^$" nil t))))
(when (re-search-forward
"^\\+;;* *\\(Package-\\)?Version: *\\(.+\\)" end t)
(let ((ver (match-string 2)))
(when (and (not (equal ver "0"))
(string-match
"\\`\\([0-9]+\\)\\(\\.[0-9]+\\)*\\'" ver))
(setq version ver))))
(when end
(goto-char end))))
(and version
(list commit
(string-to-number date)
(package-version-join (version-to-list version))))))))
(defun package-build--main-library (rcp)
(package-build--match-library rcp))
(defun package-build--match-library (rcp &optional filename)
(let ((libs (package-build--list-libraries rcp))
(filename (or filename (concat (oref rcp name) ".el"))))
(cond
((car (member (concat "lisp/" filename) libs)))
((car (member filename libs)))
((cl-find filename libs :test #'equal :key #'file-name-nondirectory)))))
(cl-defmethod package-build--list-libraries ((_rcp package-git-recipe))
(process-lines "git" "ls-files" "*.el"))
(cl-defmethod package-build--list-libraries ((_rcp package-hg-recipe))
(process-lines "hg" "files" "--include" "**/*.el"))
(cl-defmethod package-build--insert-version-header-log
((_rcp package-git-recipe) lib)
(call-process "git" nil t nil
"log" "--first-parent" "--no-renames"
"--pretty=format:commit %H %cd" "--date=unix"
"-L" (format "/^;;* *\\(Package-\\)\\?Version:/,+1:%s" lib)))
(cl-defmethod package-build--insert-version-header-log
((_rcp package-hg-recipe) _lib)
(call-process "hg" nil t nil
"log" "--first-parent"
"--template" "commit: {node} {date|hgdate}\n"
)) ; TODO What is the equivalent of Git's "-L"?
;;;; NAME-pkg
(defun package-build-pkg-version (rcp)
"Return version specified in the \"NAME-pkg.el\" file.
Return (COMMIT-HASH COMMITTER-DATE VERSION-STRING)."
(and-let* ((file (package-build--pkgfile rcp)))
(let ((regexp (or (oref rcp version-regexp) package-build-version-regexp))
commit date version)
(catch 'before-latest
(pcase-dolist (`(,c ,d) (package-build--pkgfile-commits rcp file))
(with-temp-buffer
(save-excursion
(package-build--insert-pkgfile rcp c file))
(when-let* ((n (ignore-errors (nth 2 (read (current-buffer)))))
(v (ignore-errors
(version-to-list
(and (string-match regexp n)
;; Use match-group 0, not 1, because in
;; this file a version string without a
;; prefix is expected.
(match-string 0 n))))))
(when (and version (not (equal v version)))
(throw 'before-latest nil))
(setq commit c)
(setq date d)
(setq version v)))))
(and version
(list commit
(string-to-number date)
(package-version-join version))))))
(defun package-build--pkgfile (rcp)
(package-build--match-library rcp (concat (oref rcp name) "-pkg.el")))
(cl-defmethod package-build--pkgfile-commits
((_rcp package-git-recipe) file)
(mapcar (lambda (line) (split-string line " "))
(process-lines "git" "log" "--first-parent"
"--pretty=format:%H %cd" "--date=unix"
"--" file)))
(cl-defmethod package-build--pkgfile-commits
((_rcp package-hg-recipe) file)
(mapcar (lambda (line) (seq-take (split-string line " ") 2))
(process-lines "hg" "log"
"--template" "{node} {date|hgdate}\n"
"--" file)))
(cl-defmethod package-build--insert-pkgfile
((_rcp package-git-recipe) commit file)
(call-process "git" nil t nil "show" (concat commit ":" file)))
(cl-defmethod package-build--insert-pkgfile
((_rcp package-hg-recipe) commit file)
(call-process "hg" nil t nil "cat" "-r" commit file))
;;;; Timestamp
(defun package-build-timestamp-version (rcp)
"Determine timestamp version corresponding to latest relevant commit for RCP.
Return (COMMIT-HASH COMMITTER-DATE VERSION-STRING), where
VERSION-STRING has the format \"%Y%m%d.%H%M\"."
(pcase-let ((`(,hash ,time) (package-build--timestamp-version rcp)))
(list hash time
;; We remove zero-padding of the HH portion, as
;; that is lost when stored in archive-contents.
(concat (format-time-string "%Y%m%d." time t)
(format "%d" (string-to-number
(format-time-string "%H%M" time t)))))))
(cl-defmethod package-build--timestamp-version ((rcp package-git-recipe))
(pcase-let*
((commit (oref rcp commit))
(branch (oref rcp branch))
(branch (and branch (concat "origin/" branch)))
(rev (or commit branch "origin/HEAD"))
(`(,rev-hash ,rev-time) (package-build--select-commit rcp rev commit))
(`(,tag-hash ,tag-time) (package-build-tag-version rcp)))
;; If the latest commit that touches a relevant file is an ancestor of
;; the latest tagged release and the tag is reachable from origin/HEAD
;; (i.e., it isn't on a separate release branch) then use the tagged
;; release. Snapshots should not be older than the latest release.
(if (and tag-hash
(zerop (call-process "git" nil nil nil
"merge-base" "--is-ancestor"
rev-hash tag-hash))
(zerop (call-process "git" nil nil nil
"merge-base" "--is-ancestor"
tag-hash rev)))
(list tag-hash tag-time)
(list rev-hash rev-time))))
(cl-defmethod package-build--timestamp-version ((rcp package-hg-recipe))
(let* ((commit (oref rcp commit))
(branch (or (oref rcp branch) "default"))
(rev (format "sort(ancestors(%s), -rev)"
(or commit (format "max(branch(%s))" branch)))))
(package-build--select-commit rcp rev nil)))
(define-obsolete-function-alias 'package-build-get-snapshot-version
'package-build-snapshot-version "Package-Build 5.0.0")
;;;; Release+Timestamp
(defun package-build-release+timestamp-version (rcp)
"Determine version string in the \"RELEASE.0.TIMESTAMP\" format for RCP.
*Experimental* This function is still subject to change.
Use `package-build-release-version-functions' to determine
RELEASE. TIMESTAMP is the COMMITTER-DATE for the identified
last relevant commit, using the format \"%Y%m%d.%H%M\".
Return (COMMIT-HASH COMMITTER-DATE VERSION-STRING)."
(pcase-let*
((`(,scommit ,stime ,sversion) (package-build-timestamp-version rcp))
(`(,rcommit ,rtime ,rversion)
(run-hook-with-args-until-success
'package-build-release-version-functions rcp))
(ahead (package-build--commit-count rcp scommit rcommit)))
(cond
((> ahead 0)
(list scommit stime
(package-version-join
(nconc (if rversion (version-to-list rversion) (list 0 0))
(list 0)
(version-to-list sversion)))))
(t
;; The latest commit, which touched a relevant file, is either the
;; latest release itself, or a commit before that. Distribute the
;; same commit/release as on the stable channel; as it would not
;; make sense for the development channel to lag behind the latest
;; release.
(list rcommit rtime (package-version-join rversion))))))
;;;; Release+Count
(defun package-build-release+count-version (rcp &optional single-count)
"Determine version string in the \"RELEASE.0.COUNT\" format for RCP.
*Experimental* This function is still subject to change.
Use `package-build-release-version-functions' to determine
RELEASE. COUNT is the number of commits since RELEASE until the
last relevant commit. If RELEASE is the same as for the last
snapshot but COUNT is not larger than for that snapshot because
history was rewritten, then use \"RELEASE.0.OLDCOUNT.NEWCOUNT\".
Return (COMMIT-HASH COMMITTER-DATE VERSION-STRING).
\n(fn RCP)"
(pcase-let*
;; Get the commit but ignore the associated timestamp.
((`(,scommit ,stime ,_) (package-build-timestamp-version rcp))
(`(,rcommit ,rtime ,version)
(run-hook-with-args-until-success
'package-build-release-version-functions rcp))
(version (and rcommit (version-to-list version)))
(merge-base (and rcommit
(package-build--merge-base rcp scommit rcommit)))
(ahead (package-build--commit-count rcp scommit rcommit)))
(cond
((or (when (not rcommit)
;; No appropriate release detected.
(setq version (list 0 0))
t)
(when (not merge-base)
;; As a result of butchered history rewriting, version tags
;; share no history at all with what is currently reachable
;; from the tip. Completely ignore these unreachable tags and
;; behave as if no version tags existed at all. Unfortunately
;; that means that users, who have installed a snapshot based
;; on a now abandoned tag, are stuck on that snapshot until
;; upstream creates a new version tag.
(setq version (list 0 0))
t)
;; Snapshot commit is newer than latest release (or there is no
;; release).
(> ahead 0))
(list scommit stime
(package-version-join
(append version
(list 0)
;; (This argument *could* be used by a wrapper.)
(if single-count
ahead ; Pretend time-travel doesn't happen.
(package-build--ensure-count-increase
rcp (copy-sequence version) ahead))))))
(t
;; The latest commit, which touched a relevant file, is either the
;; latest release itself, or a commit before that. Distribute the
;; same commit/release as on the stable channel; as it would not
;; make sense for the development channel to lag behind the latest
;; release.
(list rcommit rtime (package-version-join version))))))
(defun package-build--ensure-count-increase (rcp version ahead)
(if-let ((previous (cdr (assq (intern (oref rcp name))
(package-build-archive-alist)))))
;; Because upstream may have rewritten history, we cannot be certain
;; that appending the new count of commits would result in a version
;; string that is greater than the version string used for the
;; previous snapshot.
(let ((count (list ahead))
(pversion (aref previous 0))
(pcount nil))
(when (and
;; If there is no zero part, then we know that the previous
;; snapshot exactly matched a tagged release (in which case
;; we do not append zero and the count).
(memq 0 pversion)
;; Likewise if there is a tag that exactly matches the
;; previous (non-)snapshot, then there is no old count
;; which we would have to compare with the new count.
(not (member (mapconcat #'number-to-string pversion ".")
(package-build--list-tags rcp))))
;; The previous snapshot does not exactly match a tagged
;; version. We must split the version string into its tag
;; and count parts. The last zero part is the boundary.
(let ((split (cl-position 0 pversion :from-end t))
(i 0)
(tagged nil))
(while (< i split)
(push (pop pversion) tagged)
(cl-incf i))
(setq pcount (cdr pversion))
(setq pversion (nreverse tagged)))
;; Determine whether we can reset the count or increase it, or
;; whether we have to preserve the old count due to rewritten
;; history in order to ensure that the new snapshot version is
;; greater than the previous snapshot.
;; If the previous and current snapshot commits do not follow
;; the same tag, then their respective counts of commits since
;; their respective tag have no relation to each other and we
;; can simply reset the count, determined above.
(when (equal version pversion)
;; If the new count is smaller than the old, then we keep the
;; old count and append the new count as a separate version
;; part.
;;
;; We may have had to do that for previous snapshots, possibly
;; even for multiple consecutive snapshots. Beginning at the
;; end, scrape of all counts that are smaller than the current
;; count, but leave the others intact.
(setq pcount (nreverse pcount))
(while (and pcount (> ahead (car pcount)))
(pop pcount))
(when pcount
;; This snapshot is based on the same tag as the previous
;; snapshot and, due to history rewriting, the count did
;; not increase.
(setq count (nreverse (cons (car count) pcount))))))
count)
(list ahead)))
(cl-defmethod package-build--merge-base ((_rcp package-git-recipe) a b)
(ignore-errors (car (process-lines "git" "merge-base" a b))))
(cl-defmethod package-build--merge-base ((_rcp package-hg-recipe) a b)
(car (process-lines "hg" "log" "--template" "{node}\\n" "--rev"
(format "ancestor(%s, %s)" a b))))
(cl-defmethod package-build--commit-count ((_rcp package-git-recipe) rev since)
(string-to-number
(car (if since
(process-lines "git" "rev-list" "--count" rev (concat "^" since))
(process-lines "git" "rev-list" "--count" rev)))))
(cl-defmethod package-build--commit-count ((_rcp package-hg-recipe) rev since)
(length (process-lines "hg" "log" "--template" "{rev}\\n" "--rev"
(if since
(format "only(%s, %s)" rev since)
(format "ancestors(%s)" rev)))))
;;;; Fallback-Count
(defun package-build-fallback-count-version (rcp)
"Determine version string in the \"0.0.0.COUNT\" format for RCP.
*Experimental* This function is still subject to change.
This function implements a fallback that can be used on the
release channel, for packages that don't do releases. It should
be the last element of `package-build-release-version-functions',
and at the same time `package-build-snapshot-version-functions'
should contain only `package-build-release+count-version'.
The result of such a configuration is that, for packages that
don't do releases, the release and snapshot channels provide
the same \"0.0.0.COUNT\" snapshot. That way, all packages are
available on the release channel, which makes that channel more
attractive to users, which might encourage some maintainers to
release more often, or if they have never done a release before,
to finally get around to that initial release. In other words,
this might help overcome the release channel's chicken and egg
problem."
(let ((package-build-release-version-functions nil))
(package-build-release+count-version rcp)))
;;; Call Process
(defun package-build--call-process (package command &rest args)
"For PACKAGE, run COMMAND with ARGS in `default-directory'.
We use this to wrap commands is proper environment settings and
with a timeout so that no command can block the build process,
and so we can properly log errors. PACKAGE must be the name of
a package, a `package-recipe' object or nil, and is only used
for logging purposes."
(unless (file-directory-p default-directory)
(error "Cannot run process in non-existent directory: %s"
default-directory))
(with-temp-buffer
(pcase-let* ((args-orig (cons command args))
(`(,command . ,args)
(nconc (and (not (eq system-type 'windows-nt))
(list "env" "LC_ALL=C"))
(if (and package-build-timeout-secs
package-build-timeout-executable)
(nconc (list package-build-timeout-executable
"-k" "60"
(number-to-string
package-build-timeout-secs)
command)
args)
(cons command args))))
(exit-code
(apply #'call-process command nil (current-buffer) nil args)))
(unless (equal exit-code 0) ; may also be a string
(let ((summary (format-message
"Command `%s' exited with non-zero exit-code: %s"
(mapconcat #'shell-quote-argument args-orig " ")
exit-code)))
;; Duplicating the summary like this is a bit unfortunate, but
;; still the best option because we want to show it before the
;; output, but also want it to appear as an error message,
;; without making the, potentially multi-line, output part of
;; the error message.
(message "%s" summary)
(message "%s" (buffer-string))
(package-build--error package "%s" summary))))))
(defun package-build--run-process (command &rest args)
"Like `package-build--call-process', but lacks the PACKAGE argument."
(apply #'package-build--call-process nil command args))
(make-obsolete 'package-build--run-process 'package-build--call-process "5.0.0")
;;; Worktree
(defun package-build--working-tree (rcp &optional early)
(if early
(funcall package-build-early-worktree-function rcp)
(funcall package-build-worktree-function rcp)))
;;; Fetch
(cl-defmethod package-build--fetch ((rcp package-git-recipe))
(let ((dir (package-build--working-tree rcp t))
(url (package-recipe--upstream-url rcp))
(protocol (package-recipe--upstream-protocol rcp)))
(unless (member protocol package-build-allowed-git-protocols)
(package-build--error rcp
"Fetching using the %s protocol is not allowed" protocol))
(cond
((and (file-exists-p (expand-file-name ".git" dir))
(let ((default-directory dir))
(string= (car (process-lines "git" "config" "remote.origin.url"))
url)))
(unless package-build--inhibit-fetch
(let ((default-directory dir))
(package-build--message "Updating %s" dir)
(package-build--call-process rcp "git" "fetch" "-f" "--tags" "origin")
;; We might later checkout "origin/HEAD". Sadly "git fetch"
;; cannot be told to keep it up-to-date, so we have to make
;; a second request.
(package-build--call-process
rcp "git" "remote" "set-head" "origin" "--auto"))))
(t
(when (file-exists-p dir)
(delete-directory dir t))
(package-build--message "Cloning %s to %s" url dir)
(make-directory package-build-working-dir t)
(let ((default-directory package-build-working-dir))
(package-build--call-process rcp "git" "clone" url dir))))))
(cl-defmethod package-build--fetch ((rcp package-hg-recipe))
(let ((dir (package-build--working-tree rcp t))
(url (package-recipe--upstream-url rcp)))
(cond
((and (file-exists-p (expand-file-name ".hg" dir))
(let ((default-directory dir))
(string= (car (process-lines "hg" "paths" "default")) url)))
(unless package-build--inhibit-fetch
(let ((default-directory dir))
(package-build--message "Updating %s" dir)
(package-build--call-process rcp "hg" "pull")
(package-build--call-process rcp "hg" "update"))))
(t
(when (file-exists-p dir)
(delete-directory dir t))
(package-build--message "Cloning %s to %s" url dir)
(make-directory package-build-working-dir t)
(let ((default-directory package-build-working-dir))
(package-build--call-process rcp "hg" "clone" url dir))))))
;;; Checkout
(cl-defmethod package-build--checkout ((rcp package-git-recipe))
(unless package-build--inhibit-checkout
(let ((rev (oref rcp commit)))
(package-build--message "Checking out %s" rev)
(package-build--call-process rcp "git" "reset" "--hard" rev))))
(cl-defmethod package-build--checkout ((rcp package-hg-recipe))
(unless package-build--inhibit-checkout
(let ((rev (oref rcp commit)))
(package-build--message "Checking out %s" rev)
(package-build--call-process rcp "hg" "update" rev))))
;;; Generate Files
(defun package-build--write-pkg-file (desc dir)
(let ((name (package-desc-name desc)))
(with-temp-file (expand-file-name (format "%s-pkg.el" name) dir)
(pp `(define-package ,(symbol-name name)
,(package-version-join (package-desc-version desc))
,(package-desc-summary desc)
',(mapcar (pcase-lambda (`(,pkg ,ver))
(list pkg (package-version-join ver)))
(package-desc-reqs desc))
,@(cl-mapcan (pcase-lambda (`(,key . ,val))
(when (or (symbolp val) (listp val))
;; We must quote lists and symbols,
;; because Emacs 24.3 and earlier evaluate
;; the package information, which would
;; break for unquoted symbols or lists.
;; While this library does not support
;; such old Emacsen, the packages that
;; we produce should remain compatible.
(setq val (list 'quote val)))
(list key val))
(package-desc-extras desc)))
(current-buffer))
(princ ";; Local Variables:\n;; no-byte-compile: t\n;; End:\n"
(current-buffer)))))
(defun package-build--tar-type ()
"Return `bsd' or `gnu' depending on type of Tar executable.
Tests and sets variable `package-build--tar-type' if not already set."
(or package-build--tar-type
(and package-build-tar-executable
(let ((v (shell-command-to-string
(format "%s --version" package-build-tar-executable))))
(setq package-build--tar-type
(cond ((string-match-p "bsdtar" v) 'bsd)
((string-match-p "GNU tar" v) 'gnu)
(t 'gnu)))))))
(defun package-build--create-tar (rcp directory)
"Create a tar file containing the package version specified by RCP.
DIRECTORY is a temporary directory that contains the directory
that is put in the tarball."
(let* ((name (oref rcp name))
(version (oref rcp version))
(time (oref rcp time))
(tar (expand-file-name (concat name "-" version ".tar")
package-build-archive-dir))
(dir (concat name "-" version)))
(when (and (eq system-type 'windows-nt)
(eq (package-build--tar-type) 'gnu))
(setq tar (replace-regexp-in-string "^\\([a-z]\\):" "/\\1" tar)))
(let ((default-directory directory))
(process-file
package-build-tar-executable nil
(get-buffer-create "*package-build-checkout*") nil
"-cf" tar dir
;; Arguments that are need to strip metadata that
;; prevent a reproducible tarball as described at
;; https://reproducible-builds.org/docs/archives.
"--sort=name"
(format "--mtime=@%d" time)
"--owner=0" "--group=0" "--numeric-owner"
"--pax-option=exthdr.name=%d/PaxHeaders/%f,delete=atime,delete=ctime"))
(when (and package-build-verbose noninteractive)
(message "Created %s containing:" (file-name-nondirectory tar))
(dolist (line (sort (process-lines package-build-tar-executable
"--list" "--file" tar)
#'string<))
(message " %s" line)))))
(defun package-build--write-pkg-readme (pkg files)
(when-let* ((name (oref pkg name))
(commentary
(let* ((file (concat name ".el"))
(file (or (car (rassoc file files)) file))
(file (and file (expand-file-name file))))
(and (file-exists-p file)
(lm-commentary file)))))
(with-temp-buffer
(if (>= emacs-major-version 28)
(insert commentary)
;; Taken from 28.0's `lm-commentary'.
(insert
(replace-regexp-in-string ; Get rid of...
"[[:blank:]]*$" "" ; trailing white-space
(replace-regexp-in-string
(format "%s\\|%s\\|%s"
;; commentary header
(concat "^;;;[[:blank:]]*\\("
lm-commentary-header
"\\):[[:blank:]\n]*")
"^;;[[:blank:]]?" ; double semicolon prefix
"[[:blank:]\n]*\\'") ; trailing new-lines
"" commentary))))
(unless (or (bobp) (= (char-before) ?\n))
(insert ?\n))
;; We write the file even if it is empty, which is perhaps
;; a questionable choice, but at least it's consistent.
(let ((coding-system-for-write buffer-file-coding-system))
(write-region nil nil
(expand-file-name (concat name "-readme.txt")
package-build-archive-dir))))))
(defun package-build--generate-info-files (rcp files target-dir)
"Create an info file for each texinfo file listed in FILES.
Also create the info dir file. Remove each original texinfo
file. The source and destination file paths are expanded in
`default-directory' and TARGET-DIR respectively."
(pcase-dolist (`(,src . ,tmp) files)
(let ((extension (file-name-extension tmp)))
(when (member extension '("info" "texi" "texinfo"))
(let* ((src (expand-file-name src))
(tmp (expand-file-name tmp target-dir))
(texi src)
(info tmp))
(when (member extension '("texi" "texinfo"))
(delete-file tmp)
(setq info (concat (file-name-sans-extension tmp) ".info"))