-
-
Notifications
You must be signed in to change notification settings - Fork 32
/
package-build.el
1889 lines (1700 loc) · 81 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-2025 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>
;; Maintainer: Jonas Bernoulli <emacs.package-build@jonas.bernoulli.dev>
;; Homepage: https://github.com/melpa/package-build
;; Keywords: maint tools
;; Package-Version: 4.0.0.50-git
;; Package-Requires: ((emacs "26.1") (compat "30.0.0.0"))
;; 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 'format-spec)
(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 REVDESC [TAG]), where COMMIT is the hash of the
commit chosen by the function, TIME is its committer date, VERSION is
the version string chosen for COMMIT, and REVDESC is a representation
of COMMIT. If a tag was involve in determining the version, then TAG
is that tag and REVDESC contains that tag and an abbreviated commit
hash. If TAG exactly matches COMMIT, then REVDESC is just that TAG.
Otherwise if no tag was involved then TAG is omitted and REVDESC is
an abbreviation of 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))
(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 REVDESC [TAG]), where COMMIT is the hash of the
commit chosen by the function, TIME is its committer date, VERSION is
the version string chosen for COMMIT, and REVDESC is a representation
of COMMIT. If a tag was involve in determining the version, then TAG
is that tag and REVDESC contains that tag and an abbreviated commit
hash. If TAG exactly matches COMMIT, then REVDESC is just that TAG.
Otherwise if no tag was involved then TAG is omitted and REVDESC is
an abbreviation of 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-package
"Low-level function used to build a package.
The default, `package-build--build-package', extracts metadata from
the library whose name matches the name of the package, and creates
a tarball, containing at least that library and \"NAME-pkg.el\", which
is generated."
:group 'package-build
:type '(choice (const package-build--build-package) function))
(defcustom package-build-run-recipe-org-exports nil
"Whether to export the files listed in the `:org-exports' recipe slot.
Note that Melpa leaves this disabled."
:group 'package-build
:type 'boolean)
(defcustom package-build-run-recipe-shell-command nil
"Whether to run the shell command from the `:shell-command' recipe slot.
Note that Melpa leaves this disabled."
:group 'package-build
:type 'boolean)
(defcustom package-build-run-recipe-make-targets nil
"Whether to run the make targets from the `:make-targets' recipe slot.
Note that Melpa leaves this disabled."
:group 'package-build
:type 'boolean)
(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
"\\`\\(?:\\|[vVrR]\\|\\(?:release\\|%p\\)[-/]v?\\)?\
\\(?1:[0-9]+\\(\\.[0-9]+\\)*\\)\\'"
"Regexp used to match valid version-strings.
The first capture group 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 certain 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. To support tags that contain
the name of the package (e.g., \"foobar-0.1.3\"), the name of
the package is substituted for \"%p\".
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--use-sandbox (eq system-type 'gnu/linux)
"Whether to run untrusted code using the \"bubblewrap\" sandbox.
\"bubblewrap\" is only available on Linux, where the sandbox is
enabled by default, to avoid accidentally not using it.")
(defvar package-build--sandbox-readonly-binds
'("/bin" "/lib" "/lib64" "/usr" ;fhs
"/etc/alternatives" "/etc/emacs" ;+debian
"/gnu")) ;+guix
(defvar package-build--sandbox-args
'("--unshare-all"
"--dev" "/dev"
"--proc" "/proc"
"--tmpfs" "/tmp"))
(defvar package-build--inhibit-fetch nil
"Whether to inhibit fetching.
If `strict', also inhibit the initial clone, and deleting and
re-cloning an existing clone after the upstream has changed.")
(defvar package-build--inhibit-checkout nil
"Whether to inhibit checkout.")
(defvar package-build--inhibit-update nil
"Whether to inhibit updating metadata and packages.")
(defvar package-build--inhibit-build nil
"Whether to inhibit building packages (while still update metadata).")
;;; 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--version-regexp (rcp)
"Return the version regexp for RCP."
(if-let* ((re (oref rcp version-regexp))
(re (format-spec re '((?v . "\\(?1:[0-9]+\\(\\.[0-9]+\\)*\\)")))))
(progn (unless (string-prefix-p "\\`" re) (setq re (concat "\\`" re)))
(unless (string-suffix-p "\\'" re) (setq re (concat re "\\'")))
re)
(format-spec package-build-version-regexp `((?p . ,(oref rcp name))))))
(defun package-build--select-version (rcp)
(pcase-let*
((default-directory (package-recipe--working-tree rcp))
(`(,commit ,time ,version ,revdesc)
(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)
(oset rcp revdesc revdesc))))
(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))))
(cl-defmethod package-build--revdesc ((_rcp package-git-recipe) rev &optional tag)
(if tag
(car (process-lines "git" "describe" "--always" "--long"
"--abbrev=12" "--match" tag rev))
(car (process-lines "git" "rev-parse" "--short=12" rev))))
(cl-defmethod package-build--revdesc ((_rcp package-hg-recipe) rev &optional tag)
;; Cannot use "{shortest(node, minlength=12)}" because that results
;; in "hg: parse error: can't use a key-value pair in this context".
(car (process-lines
"hg" "id" "--id" "--rev" rev "--template"
(if tag
(format "{latesttag('%s') %% '{tag}-{distance}-m{short(node)}'}\n"
tag)
"{short(node)}\n"))))
;;;; Tag
(defun package-build-tag-version (rcp)
"Determine version corresponding to largest version tag for RCP.
Return (COMMIT-HASH COMMITTER-DATE VERSION-STRING REVDESC TAG) or nil."
(let ((regexp (package-build--version-regexp rcp))
(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))
(setq tag n)
(setq version v))))
(and tag
(pcase-let ((`(,hash ,time)
(package-build--select-commit
rcp (if (cl-typep rcp 'package-git-recipe)
(concat "refs/tags/" tag)
tag)
t)))
(list hash time
(package-version-join version)
(package-build--revdesc rcp hash tag)
tag)))))
(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))
(delete "tip" (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)
"Determine 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 REVDESC) or nil."
(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))
(package-build--revdesc rcp commit)))))))
(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)
"Determine version specified in the \"NAME-pkg.el\" file.
Return (COMMIT-HASH COMMITTER-DATE VERSION-STRING REVDESC) or nil."
(declare (obsolete "extract version from tag and/or main library instead."
"Package-Build 5.0.0"))
(and-let* ((file (package-build--pkgfile rcp)))
(let ((regexp (package-build--version-regexp rcp))
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)
(package-build--revdesc rcp commit))))))
(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 REVDESC).
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))))
(package-build--revdesc rcp hash))))
(cl-defmethod package-build--timestamp-version ((rcp package-git-recipe))
(pcase-let*
(((eieio commit branch) rcp)
(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))
(pcase-let* (((eieio commit branch) rcp)
(rev (format "sort(ancestors(%s), -rev)"
(or commit
(format "max(branch(%s))"
(or branch "default"))))))
(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.
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 REVDESC) or nil."
(pcase-let*
((`(,scommit ,stime ,sversion) (package-build-timestamp-version rcp))
(`(,rcommit ,rtime ,rversion ,rrevdesc ,tag)
(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)))
(package-build--revdesc rcp scommit tag)))
(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) rrevdesc tag)))))
;;;; Release+Count
(defun package-build-release+count-version (rcp &optional single-count)
"Determine version string in the \"RELEASE.0.COUNT\" format for RCP.
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 REVDESC) or nil.
\n(fn RCP)"
(pcase-let*
;; Get the commit but ignore the associated timestamp.
((`(,scommit ,stime ,_) (package-build-timestamp-version rcp))
(`(,rcommit ,rtime ,version ,rrevdesc ,tag)
(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))))
(package-build--revdesc rcp scommit tag)))
(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) rrevdesc tag)))))
(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.
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.
Return (COMMIT-HASH COMMITTER-DATE VERSION-STRING REVDESC)."
(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--call-sandboxed (package command &rest args)
"Like `package-build--call-process' but maybe use a sandbox.
Use a sandbox if `package-build--use-sandbox' is non-nil."
(cond
(package-build--use-sandbox
(let* ((rcp (if (cl-typep package 'package-recipe)
package
(package-recipe-lookup package)))
(dir (package-recipe--working-tree rcp)))
(unless (file-in-directory-p default-directory dir)
(package-build--error rcp "Attempt to use sandbox outside of %s" dir)))
(apply #'package-build--call-process package "bwrap"
`(,@package-build--sandbox-args
,@(list "--bind" default-directory default-directory)
,@(mapcan (lambda (dir)
(setq dir (expand-file-name dir))
(and (file-exists-p dir)
(list "--ro-bind" dir dir)))
(append package-build--sandbox-readonly-binds
(list ".git" ".hg")))
,command ,@args)))
((apply #'package-build--call-process package command args))))
(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")
;;; Fetch
(cl-defmethod package-build--fetch ((rcp package-git-recipe))
(let ((dir (package-recipe--working-tree rcp))
(url (oref rcp url))
(protocol (package-recipe--upstream-protocol rcp)))
(cond
((eq package-build--inhibit-fetch 'strict))
((not (member protocol package-build-allowed-git-protocols))
(package-build--error rcp
"Fetching using the %s protocol is not allowed" protocol))
((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-recipe--working-tree rcp))
(url (oref rcp url)))
(cond
((eq package-build--inhibit-fetch 'strict))
((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
(defvar package-build--extras
'((:url webpage)
(:commit commit)
(:revdesc revdesc)
(:keywords keywords)
(:authors authors)
(:maintainers maintainers)))
(defun package-build--write-archive-entry (rcp)
(with-slots (name version dependencies summary) rcp
(with-temp-file (expand-file-name (format "%s-%s.entry" name version)
package-build-archive-dir)
(set-buffer-file-coding-system 'utf-8)
(pp (cons (intern name)
(vector (version-to-list version)
(mapcar (pcase-lambda (`(,sym ,val))
(list sym (version-to-list val)))
dependencies)
summary
(if (oref rcp tarballp) 'tar 'single)
(nconc (mapcan (pcase-lambda (`(,key ,slot))