-
Notifications
You must be signed in to change notification settings - Fork 151
/
straight.el
7334 lines (6690 loc) · 322 KB
/
straight.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
;;; straight.el --- Next-generation package manager -*- lexical-binding: t -*-
;; Copyright (C) 2017-2023 Radian LLC and contributors
;; Author: Radian LLC <contact+straight@radian.codes>
;; Created: 1 Jan 2017
;; Homepage: https://github.com/radian-software/straight.el
;; Keywords: extensions
;; Package-Requires: ((emacs "25.1"))
;; SPDX-License-Identifier: MIT
;; Version: prerelease
;;; Commentary:
;; straight.el is a next-generation package manager for Emacs. It
;; clones packages into your ~/.emacs.d and handles byte-compilation,
;; autoload generation, and load path management. Dependency
;; management, powerful tools for managing your packages in bulk, and
;; out-of-the-box compatibility with MELPA, GNU ELPA, and Emacsmirror
;; are also included.
;; straight.el improves on other package managers in several ways.
;; Most importantly, it offers first-class support for easily
;; modifying packages and contributing your changes upstream. It also
;; supports complete reproducibility for your configuration by writing
;; a lockfile with the versions of all your packages. Alternatively,
;; straight.el will work with manually managed packages, if you prefer
;; to merge in packages as subtrees.
;; Please see https://github.com/radian-software/straight.el for more
;; information.
;;; Code:
;; To see the outline of this file, run M-x outline-minor-mode and
;; then press C-c @ C-t. To also show the top-level functions and
;; variable declarations in each section, run M-x occur with the
;; following query: ^;;;;* \|^(
;;;; Detect change in Emacs version
;; This throws an error if you byte-compile it with one Emacs version
;; and then try to run the byte-compiled code in another Emacs
;; version. See bootstrap.el.
(eval
`(unless (equal
(emacs-version)
,(eval-when-compile (emacs-version)))
(throw 'emacs-version-changed nil)))
(defun straight--executable-find (name)
"`executable-find' NAME. If not found, throw an error."
(or (executable-find name)
(error "Straight unable to find required executable: %S" name)))
(straight--executable-find "git")
;;;; Libraries
(require 'cl-lib)
(require 'subr-x)
;;;; Backports
;; Note that we use `eval-and-compile' even for macros, because
;; otherwise libraries which load the byte-compiled version of this
;; file won't be able to use those macros.
;; Not defined before Emacs 25.1
(eval-and-compile
(unless (boundp 'inhibit-message)
(defvar inhibit-message nil
"Non-nil means calls to ‘message’ are not displayed.
They are still logged to the *Messages* buffer.")))
;;;; Functions from other packages
;; `comp'
(declare-function native-compile-async "comp.el")
(defvar native-comp-deferred-compilation-deny-list)
(defvar native-comp-jit-compilation-deny-list)
;; `finder-inf'
(defvar package--builtins)
;; `flycheck'
(declare-function flycheck-checker-get "flycheck")
(declare-function flycheck-get-next-checker-for-buffer "flycheck")
(declare-function flycheck-start-current-syntax-check "flycheck")
;; `package'
(defvar package-selected-packages)
(declare-function package--ensure-init-file "package")
(declare-function package--save-selected-packages "package")
;; `use-package'
(defvar use-package-defaults)
(defvar use-package-ensure-function)
(defvar use-package-keywords)
(defvar use-package-pre-ensure-function)
(declare-function use-package-as-symbol "use-package")
(declare-function use-package-error "use-package")
(declare-function use-package-handler/:ensure "use-package")
(declare-function use-package-normalize/:ensure "use-package")
(declare-function use-package-only-one "use-package")
(declare-function use-package-process-keywords "use-package")
;;;; Customization variables
(defgroup straight-faces nil
"Faces used in straight.el."
:group 'straight
:group 'faces)
(defgroup straight nil
"Next-generation, purely functional package manager for the Emacs hacker."
:group 'applications
:prefix "straight-")
(defface straight-process-error
'((t (:weight bold :foreground "red")))
"Face for process errors in `straight-process-buffer'."
:group 'straight-faces)
(defface straight-process-command
'((t (:weight bold)))
"Face for process commands in `straight-process-buffer'."
:group 'straight-faces)
(defcustom straight-arrow
(if (char-displayable-p ?→) " → " " -> ")
"The string to use for an arrow in messages."
:type 'string)
(defcustom straight-profiles
'((nil . "default.el"))
"Alist mapping package profile names to version lockfile names.
The profile names should be symbols, and the filenames may be
relative (to straight/versions/) or absolute."
:type '(alist :key-type symbol :value-type string))
(defcustom straight-current-profile nil
"Symbol identifying the current package profile.
This symbol should have an entry in `straight-profiles'. If you
wish to take advantage of the multiple-profile system, you should
bind this variable to different symbols using `let' over
different parts of your init-file."
:type 'symbol)
(defcustom straight-repository-user "radian-software"
"String identifying the GitHub user from which to clone straight.el.
You must set this variable before straight.el is bootstrapped for
it to have an effect. (It is used in the default recipe for
straight.el which is registered during bootstrap.)
If you have forked radian-software/straight.el to
your-name/straight.el, then to use your fork you should set
`straight-repository-user' to \"your-name\"."
:type 'string)
(defcustom straight-repository-branch "master"
"String identifying the branch of straight.el to clone.
You must set this variable before straight.el is bootstrapped for
it to have an effect. (It is used in the default recipe for
straight.el which is registered during bootstrap.)"
:type '(choice
(const :tag "Stable version (master)" "master")
(const :tag "Development version (develop)" "develop")
(string :tag "Use a custom branch")))
(defcustom straight-default-vc 'git
"VC backend to use by default, if a recipe has no `:type'.
Functions named like `straight-vc-TYPE-clone', etc. should be
defined, where TYPE is the value of this variable."
:type 'symbol)
(defcustom straight-recipe-repositories nil
"List of recipe repositories to find recipes in.
These are used when you provide only a package name, rather than
a full recipe, to `straight-use-package' or
`straight-use-recipes'. The order in this list determines the
precedence. Functions named like `straight-recipes-NAME-list',
etc. should be defined, where NAME is any element of this list."
:type '(list symbol))
(defcustom straight-recipe-overrides nil
"Alist specifying recipes to override those provided explicitly.
The keys are symbols naming profiles, and the values are lists of
MELPA-style package recipes. Because the car of a MELPA-style
recipe is the package name as a symbol, this means the values can
also be interpreted as alists whose keys are symbols naming
packages.
If you have no need of the profile system, then using the default
profile (nil) will suffice without additional setup."
:type '(alist :key-type symbol :value-type
(alist :key-type symbol :value-type
(plist :key-type symbol :value-type sexp))))
(defcustom straight-allow-recipe-inheritance t
"Non-nil allows partially overriding recipes.
If you override a recipe, every component that is not explicitly
overriden will be searched for in original recipe. If found, that
value will be added to the overriden recipe. This allows you to
only override the recipe components you are interested in,
instead of being required to override them all. The supported
components are the ones listed by `straight-vc-git-keywords' and
`:files'. Note that enabling this feature has the side effect
that all recipe repos (i.e. melpa, elpa) will always be cloned,
even if you explicitly specify all your recipes.
The `:fork' keyword is handled specially. If its value is a
string instead of a list, then it is assigned as the `:repo' of
the fork. Also the fork recipe will inherit its `:host' component
from the default recipe.
For example, the following are all equivalent with recipe
inheritance enabled.
\\='(package :host \\='gitlab :repo \"other-user/repo\"
:fork (:host \\='gitlab :repo \"my-user/repo\"))
\\='(package :fork (:host \\='gitlab :repo \"my-user/repo\"))
\\='(package :fork (:repo \"my-user/repo\"))
\\='(package :fork \"my-user/repo\")
The `:inherit' keyword overrides this option on a per-recipe basis."
:type 'boolean)
(defcustom straight-safe-mode nil
"Non-nil means avoid doing anything that modifies the filesystem.
In safe mode, package modifications will still be detected
according to `straight-check-for-modifications'. However, if a
package needs to be cloned, built, or rebuilt, straight.el
instead generates an error. The build cache will not be written
back to disk, nor will the filesystem watcher be started (if
enabled).
As one example of a use case for safe mode, suppose you want to
byte-compile your Emacs configuration asynchronously in the
background. To avoid multiple Emacs processes modifying the
filesystem concurrently via straight.el, you might want to enable
safe mode for the background Emacs process.
Safe mode is not guaranteed to be as performant as normal
operation."
:type 'boolean)
(defcustom straight-host-usernames nil
"Alist mapping forge :host symbols to username strings.
The username associated with the host name is used to compute the :repo
when the :fork keyword is any of the following values:
- t
- a string prefixed with a forward slash
- a plist which provides a :host and no :repo value
- a plist which provides a :repo string prefixed with a forward slash
For example, with the following alist:
(setq straight-host-usernames
\\='((github . \"githubUser\")
(gitlab . \"gitlabUser\")
(codeberg . \"codebergUser\")
(bitbucket . \"bitbucketUser\")))
(straight-use-package
\\='( example :host github :type git :repo \"upstream/repo\"
:fork t))
computes the fork as \"githubUser/repo\"
(straight-use-package
\\='( example :host github :type git :repo \"upstream/repo\"
:fork \"/fork\"))
computes the fork as \"githubUser/fork\"."
:type '(alist :key-type (choice
(const :tag "github" github)
(const :tag "gitlab" gitlab)
(const :tag "codeberg" codeberg)
(const :tag "sourcehut" sourcehut)
(const :tag "bitbucket" bitbucket))
:value-type (string :tag "username")))
(defcustom straight-hosts '((github "github.com" ".git")
(gitlab "gitlab.com" ".git")
(codeberg "codeberg.org" ".git")
(sourcehut "git.sr.ht")
(bitbucket "bitbucket.com" ".git"))
"Alist containing URI information for hosted forges.
Each element is of the form: (HOST DOMAIN REPO-SUFFIX).
HOST is a unique symbol meant to be used with the :host recipe keyword.
DOMAIN is a string representing the domain and top-level domain.
REPO-SUFFIX is appended to the repository name in the URI."
:type '(repeat sexp))
(defcustom straight-vc-git-post-clone-hook nil
"Functions called after straight.el clones a git repository.
Each hook function is passed the following keyword arguments:
- `:repo-dir' - the local directory to which the repository was cloned
- `:remote' - the name of the remote from which the repository was cloned
- `:url' - the URL from which the repository was cloned
- `:branch' - the branch as specified by the recipe, if any,
otherwise nil
- `:depth' - the clone depth as specified by the recipe or
`straight-vc-git-default-clone-depth'
- `:commit' - the specific commit which was requested via the
lockfile, if any, otherwise nil
Since keyword arguments are used, each function should be defined
via `cl-defun', with `&key' used at the front of the argument
list, and `&allow-other-keys' at the end to ensure forwards
compatibility."
:type 'hook)
(defcustom straight-log nil
"Whether to enable diagnostic logging for straight.el.
This can be used to report additional information which can be
used to more effectively identify the source of a bug when it
cannot be reproduced outside your system."
:type 'boolean)
(defcustom straight-log-buffer "*straight-log*"
"Name of logging buffer when `straight-log' is non-nil."
:type 'string)
;;;; Utility functions
;;;;; Lists
(defun straight--flatten (list)
"Return a flattened copy of LIST.
Backward compatible shim for `flatten-tree'."
(if (listp list)
(apply 'append (mapcar #'straight--flatten list))
(list list)))
(defun straight--emacs-path ()
"Return path to currently running Emacs."
(expand-file-name invocation-name invocation-directory))
;;;;; Association lists
(defun straight--alist-set (key val alist &optional symbol)
"Set property KEY to VAL in ALIST. Return new alist.
This creates the association if it is missing, and otherwise sets
the cdr of the first matching association in the list. It does
not create duplicate associations. By default, key comparison is
done with `equal'. However, if SYMBOL is non-nil, then `eq' is
used instead.
This method may mutate the original alist, but you still need to
use the return value of this method instead of the original
alist, to ensure correct results."
;; See [1] for the genesis of this method, which should really be
;; built in.
;;
;; [1]: https://emacs.stackexchange.com/q/33892/12534
(if-let ((pair (if symbol (assq key alist) (assoc key alist))))
(setcdr pair val)
(push (cons key val) alist))
alist)
;;;;; Property lists
(defmacro straight--with-plist (plist props &rest body)
"Binding from PLIST the given PROPS, eval and return BODY.
PROPS is a list of symbols. Each one is converted to a keyword
and then its value is looked up in the PLIST and bound to the
symbol for the duration of BODY."
(declare (indent 2) (debug (form sexp body)))
`(cl-destructuring-bind (&key ,@props &allow-other-keys) ,plist ,@body))
(defmacro straight--put (plist prop value)
"Make copy of PLIST with key PROP mapped to VALUE, and re-set it.
PLIST must be a literal symbol naming a plist variable. PROP and
VALUE are evaluated."
`(progn
(setq ,plist (copy-sequence ,plist))
(setq ,plist (plist-put ,plist ,prop ,value))))
(defmacro straight--remq (plist props)
"Make copy of PLIST with keys PROPS removed, and re-set it.
PLIST must be a literal symbol naming a plist variable. PROPS is
evaluated and should result in a list. Key comparison is done
with `eq'."
;; The following subroutine is adapted from [1].
;;
;; [1]: https://lists.gnu.org/archive/html/help-gnu-emacs/2015-08/msg00019.html
(let ((props-sym (make-symbol "props")))
`(let ((,props-sym ,props))
(setq ,plist
(cl-loop for (prop val) on ,plist by #'cddr
unless (memq prop ,props-sym)
collect prop and collect val)))))
(defun straight--plist-get (plist prop default)
"Extract a value from a property list, or return a default.
PLIST is a property list, PROP is the key to search for, and
DEFAULT is the value to return if PROP is not in PLIST."
(if-let ((result (plist-member plist prop)))
(cadr result)
default))
;;;;; Hash tables
(defun straight--insert (n key value table)
"Associate index N in KEY with VALUE in hash table TABLE.
TABLE should be a hash whose values are lists. This function will
set the Nth entry of the list mapped to KEY in TABLE to VALUE. If
the list does not have an Nth entry, it will be padded with nils
so that it does, before the setting happens. The TABLE will be
modified and returned."
(let ((list (gethash key table)))
(if (>= n (length list))
(puthash key
(append list
(make-list (- n (length list)) nil)
(list value))
table)
(setcar (nthcdr n list) value))
table))
(defun straight--checkhash (key table)
"Return non-nil if KEY is present in hash TABLE."
(let ((nf (make-symbol "straight--not-found")))
(not (eq nf (gethash key table nf)))))
;;;;; Strings
(defun straight--split-and-trim (string &optional indent max-lines)
"Split the STRING on newlines, returning a list.
Remove any blank lines at the beginning or end. If INDENT is
non-nil, then add that many spaces to the beginning of each line
and concatenate them with newlines, returning a string instead of
a list. If MAX-LINES is non-nil, then it should be a nonnegative
integer, and any lines past that many are discarded."
(let ((parts (split-string string "\n")))
;; Remove blank lines from beginning.
(while (equal (car parts) "")
(setq parts (cdr parts)))
(setq parts (nreverse parts))
;; Remove blank lines from end.
(while (equal (car parts) "")
(setq parts (cdr parts)))
(setq parts (nreverse parts))
;; Remove tail.
(when (and max-lines (< max-lines (length parts)))
(setf (nthcdr max-lines parts) nil))
;; Add indentation.
(if indent
(let ((indent (make-string (or indent 0) ? )))
(mapconcat (lambda (part) (concat indent part))
parts "\n"))
parts)))
(cl-defun straight--uniquify (prefix taken)
"Generate a string with PREFIX that is not in list TAKEN.
This is done by trying PREFIX-1, PREFIX-2, etc. if PREFIX is
already in TAKEN."
(if (member prefix taken)
(let ((n 1))
(while t
(let ((candidate (format "%s-%d" prefix n)))
(if (member candidate taken)
(cl-incf n)
(cl-return-from straight--uniquify candidate)))))
prefix))
;;;;; Functions
(defmacro straight--functionp (object)
"Non-nil if OBJECT, an unquoted symbol, is bound to a function.
However, if OBJECT evaluates to its own symbol value or t, then
return nil. This is useful for allowing a function to be called
with nil, non-nil, or a function object, without worrying about
the non-nil value being interpreted as a function: just call the
function with the quoted name of the argument, or use t."
(let ((object-sym (make-symbol "object")))
`(let ((,object-sym ,object))
(and (not (memq ,object-sym '(,object t)))
(functionp ,object-sym)))))
;;;;; Messaging
(defun straight--output (string &rest objects)
"Same as `message' (which see for STRING and OBJECTS) normally.
However, in batch mode, print to stdout instead of stderr."
(if noninteractive
(progn
(princ (apply #'format string objects))
(terpri))
(apply #'message string objects)))
(defmacro straight--with-progress (task &rest body)
"Displaying TASK as a progress indicator, eval and return BODY.
Display \"TASK...\", eval BODY, display \"TASK...done\", and
return the result of evaluating BODY. If TASK is nil, no messages
are displayed. TASK can also be a cons, whose car and cdr are
used as the TASK for the beginning and end messages
respectively. (Either the car or cdr, or both, can be nil.) See
also `straight--progress-begin' and `straight--progress-end'."
(declare (indent 1) (debug t))
(let ((task-sym (make-symbol "gensym--task"))
(task-car-sym (make-symbol "gensym--task-car"))
(task-cdr-sym (make-symbol "gensym--task-cdr")))
`(let* ((,task-sym ,task)
(,task-car-sym (if (listp ,task-sym)
(car ,task-sym)
,task-sym))
(,task-cdr-sym (if (listp ,task-sym)
(cdr ,task-sym)
,task-sym)))
(prog2
(when ,task-car-sym
(straight--output "%s..." ,task-car-sym))
(progn
,@body)
(when ,task-cdr-sym
(straight--output "%s...done" ,task-cdr-sym))))))
(defun straight--progress-begin (message)
"Display a MESSAGE indicating ongoing progress.
The MESSAGE is postpended with \"...\" and then passed to
`message'. See also `straight--with-progress' and
`straight--progress-end'."
(straight--output "%s..." message))
(defun straight--progress-end (message)
"Display a MESSAGE indicating completed progress.
The MESSAGE is postpended with \"...done\" and then passed to
`message'. See also `straight--with-progress' and
`straight--progress-begin'."
(straight--output "%s...done" message))
(defvar straight--echo-area-dirty nil
"Non-nil if a progress message has been wiped from the echo area.
This is used as an internal bookkeeping variable to determine if
a progress message has been bumped out of the echo area by
another message, and needs to be redisplayed.")
(defun straight--warn (message &rest args)
"Display a warning from `straight'. Return nil.
The warning message is obtained by passing MESSAGE and ARGS to
`format'."
(ignore
(display-warning 'straight (apply #'format message args))))
(defun straight--log (category message &rest args)
"Log diagnostic message to `straight-log-buffer'.
If `straight-log' is nil, this does nothing. CATEGORY is a symbol
that can help in filtering the resulting log output. MESSAGE and
ARGS are interpreted as in `message', except that any of ARGS can
also be a function of no arguments which will be invoked to get
the real value. This is helpful because the function won't be
evaluated if logging is disabled. Only lambda functions are
accepted, to avoid symbols being interpreted as callables by
accident."
(when straight-log
(with-current-buffer (get-buffer-create straight-log-buffer)
(unless (derived-mode-p 'special-mode) (special-mode))
(save-excursion
(goto-char (point-max))
(let ((inhibit-read-only t)
(body nil))
(condition-case err
(let ((args (mapcar
(lambda (arg)
(if (and (listp arg)
(functionp arg))
(funcall arg)
arg))
args)))
(setq body (apply #'format message args)))
(error (setq body (format "Got error formatting log line %S: %s"
message
(error-message-string err)))))
(insert
(format
"%s <%S>: %s\n"
(format-time-string "%Y-%m-%d %H:%M:%S.%3N" (current-time))
category body)))))))
;;;;; Buffers
(defun straight--ensure-blank-lines (n)
"Ensure N newline characters preceding point, unless at beginning of buffer."
(unless (= 1 (point))
(let ((num-existing 0))
(save-excursion
(cl-dotimes (_ n)
(when (or (= 1 (point))
(not (= ?\n (char-before))))
(cl-return))
(cl-incf num-existing)
(backward-char)))
(insert (make-string (- n num-existing) ?\n)))))
;;;;; Predicates
(defun straight--quoted-form-p (object)
"Return t if OBJECT is quoted or backquoted, else nil."
(when (member (car-safe object) '(quote \`)) t))
(defun straight--build-disabled-p (recipe)
"Return t if RECIPE has an explicitly nil `:build` keyword."
(let ((build (plist-member recipe :build)))
(and build (not (cadr build)))))
(defun straight--buildable-p (recipe)
"Return t if RECIPE has a non-nil, or vacuously nil `:build` keyword."
(not (straight--build-disabled-p recipe)))
(defun straight--installed-p (recipe)
"Return t if RECIPE's repository is available and `:local-repo` is non-nil."
(and (plist-get recipe :local-repo)
(straight--repository-is-available-p recipe)))
(defun straight--installed-and-buildable-p (recipe)
"Return t if installed RECIPE has a non-nil or absent `:build'."
(and (straight--buildable-p recipe)
(straight--installed-p recipe)))
;;;;; Windows OS detection
;; THIS FUNCTION MUST BE MANUALLY SYNCED WITH
;; ./install.el straight--windows-os-p
(defun straight--windows-os-p ()
"Check if the current operating system is Windows."
(memq system-type '(ms-dos windows-nt)))
;;;;; Paths
(defcustom straight-base-dir user-emacs-directory
"Directory in which the straight/ subdirectory is created.
Defaults to `user-emacs-directory'."
:type 'string)
(defcustom straight-use-version-specific-build-dir nil
"If non-nil, use an Emacs-version-specific `straight-build-dir' directory.
Normally, straight.el uses a single build directory and throws
\\='emacs-version-changed when attempting to run the byte-compiled
code in a different version of Emacs. This changes that behavior
to use a per-Emacs-version build directory based upon the
variable `emacs-version', for example `build-27.2'.
Setting `straight-build-dir' will override this behavior."
:type 'boolean)
(defcustom straight-build-dir (if straight-use-version-specific-build-dir
(concat "build-" emacs-version)
"build")
"Name of the directory into which packages are built.
Relative to the straight/ subdirectory of `straight-base-dir'.
Defaults to \"build\".
By default, this variable also affects the name of the build
cache file, set the variable `straight-build-cache-fixed-name'
to override this."
:type 'string)
(defcustom straight-build-cache-fixed-name nil
"Name of the build cache file.
If it is nil, uses the default name, namely
\"`straight-build-dir'-cache.el\".
If it is not nil, it has to be a string which is used as the
name of the cache file.
In both cases, the path is relative to the \"straight/\"
subdirectory of `straight-base-dir'."
:type '(choice (const :tag "Default location" nil)
(string :tag "Fixed location")))
(defvar straight--this-file
(file-truename (or load-file-name buffer-file-name))
"Absolute real path to this file, straight.el.")
(defun straight--path-prefix-p (prefix-path full-path)
"Return non-nil if PREFIX-PATH is a prefix of FULL-PATH.
This takes into account case insensitivity on macOS."
(string-prefix-p prefix-path full-path (eq system-type 'darwin)))
(defun straight--emacs-dir (&rest segments)
"Get a subdirectory of the `user-emacs-directory'.
The SEGMENTS are path segments which are concatenated with
slashes and postpended to the straight directory. With no
SEGMENTS, return the `user-emacs-directory' itself.
\(straight--dir \"straight\" \"build\" \"esup\")
=> \"~/.emacs.d/straight/build/esup/\""
(let ((dir straight-base-dir))
(while segments
(setq dir (expand-file-name
(file-name-as-directory (car segments)) dir))
(setq segments (cdr segments)))
dir))
(defun straight--emacs-file (&rest segments)
"Get a file in the `user-emacs-directory'.
The SEGMENTS are path segments with are concatenated with slashes
and postpended to the straight directory.
\(straight--file \"straight\" \"build\" \"esup\" \"esup-autoloads.el\")
=> \"~/.emacs.d/straight/build/esup/esup-autoloads.el\""
(expand-file-name
(substring (apply 'straight--emacs-dir segments) 0 -1)))
(defun straight--dir (&rest segments)
"Get a subdirectory of the straight/ directory.
SEGMENTS are passed to `straight--emacs-dir'. With no SEGMENTS,
return the straight/ directory itself."
(apply #'straight--emacs-dir "straight" segments))
(defun straight--file (&rest segments)
"Get a file in the straight/ directory.
SEGMENTS are passed to `straight--emacs-file'."
(apply #'straight--emacs-file "straight" segments))
(defun straight--build-dir (&rest segments)
"Get a subdirectory of the straight/build/ directory.
SEGMENTS are passed to `straight--dir'. With no SEGMENTS, return
the straight/build/ directory itself."
(apply #'straight--dir straight-build-dir segments))
(defun straight--build-file (&rest segments)
"Get a file in the straight/build/ directory.
SEGMENTS are passed to `straight--file'."
(apply #'straight--file straight-build-dir segments))
(defun straight--autoloads-file (package)
"Get the filename of the autoloads file for PACKAGE.
PACKAGE should be a string."
(straight--build-file package (format "%s-autoloads.el" package)))
(defun straight--build-cache-file ()
"Get the file containing straight.el's build cache."
(straight--file
(or straight-build-cache-fixed-name
(concat straight-build-dir "-cache.el"))))
(defun straight--links-dir (&rest segments)
"Get a subdirectory of straight/links/.
SEGMENTS are passed to `straight--dir'. With no SEGMENTS, return
the straight/links/ directory itself."
(apply #'straight--dir "links" segments))
(defun straight--links-file (&rest segments)
"Get a file in the straight/links/ directory.
SEGMENTS are passed to `straight--file'."
(apply #'straight--file "links" segments))
(defun straight--modified-dir (&rest segments)
"Get a subdirectory of straight/modified/.
SEGMENTS are passed to `straight--dir'. With no SEGMENTS, return
the straight/modified/ directory itself."
(apply #'straight--dir "modified" segments))
(defun straight--modified-file (&rest segments)
"Get a file in the straight/modified/ directory.
SEGMENTS are passed to `straight--file'."
(apply #'straight--file "modified" segments))
(defun straight--mtimes-dir (&rest segments)
"Get a subdirectory of straight/mtimes/.
SEGMENTS are passed to `straight--dir'. With no SEGMENTS, return
the straight/mtimes/ directory itself."
(apply #'straight--dir "mtimes" segments))
(defun straight--mtimes-file (&rest segments)
"Get a file in the straight/mtimes/ directory.
SEGMENTS are passed to `straight--file'."
(apply #'straight--file "mtimes" segments))
(defun straight--repos-dir (&rest segments)
"Get a subdirectory of the straight/repos/ directory.
SEGMENTS are passed to `straight--dir'. With no SEGMENTS, return
the straight/repos/ directory itself."
(apply #'straight--dir "repos" segments))
(defun straight--repos-file (&rest segments)
"Get a file in the straight/repos/ directory.
SEGMENTS are passed to `straight--file'."
(apply #'straight--file "repos" segments))
(defun straight--versions-dir (&rest segments)
"Get a subdirectory of the straight/versions/ directory.
SEGMENTS are passed to `straight--dir'. With no SEGMENTS, return
the straight/versions/ directory itself."
(apply #'straight--dir "versions" segments))
(defun straight--versions-file (&rest segments)
"Get a file in the straight/versions/ directory.
SEGMENTS are passed to `straight--file'."
(apply #'straight--file "versions" segments))
(defun straight--watcher-dir (&rest segments)
"Get a subdirectory of the straight/watcher/ directory.
SEGMENTS are passed to `straight--dir'. With no SEGMENTS, return
the straight/watcher/ directory itself."
(apply #'straight--dir "watcher" segments))
(defun straight--watcher-file (&rest segments)
"Get a file in the straight/watcher/ directory.
SEGMENTS are passed to `straight--file'."
(apply #'straight--file "watcher" segments))
(defun straight--watcher-python ()
"Get the path to the filesystem virtualenv's Python executable."
(if (straight--windows-os-p)
(straight--watcher-file "virtualenv" "Scripts" "python.exe")
(straight--watcher-file "virtualenv" "bin" "python")))
(defun straight--versions-lockfile (profile)
"Get the version lockfile for given PROFILE, a symbol."
(if-let ((filename (alist-get profile straight-profiles)))
(straight--versions-file filename)
(error "Unknown profile: %S" profile)))
(defun straight--determine-repo (path)
"Determine the local repository containing PATH, if any.
If PATH, a string, corresponds to a file or directory inside (or
equal to) any subfolder of `straight--repos-dir', then return the
name of the local repository (not a path), as a string.
Otherwise, return nil."
(let ((repos-dir (straight--repos-dir)))
(when (straight--path-prefix-p repos-dir path)
;; Remove the ~/.emacs.d/straight/repos/ part.
(let ((relative-path (substring path (length repos-dir))))
;; Trim off any more path components after hte local
;; repository.
(replace-regexp-in-string
"/.*" "" relative-path 'fixedcase 'literal)))))
;;;;; Filesystem operations
(defun straight--symlinks-are-usable-p ()
"Return non-nil if symlinks are well-supported by the OS.
This means that they are used to build packages rather than
copying files, which is slower and less space-efficient.
All operating systems support symlinks; however, on Microsoft
Windows you may need additional system configuration (see
variable `straight-use-symlinks')."
(not (straight--windows-os-p)))
(defcustom straight-use-symlinks (straight--symlinks-are-usable-p)
"Whether to use symlinks for building packages.
Using symlinks is always preferable.
On Microsoft Windows, this variable has to be set to non-nil
manually, if desired, as symlink-functionality is not always
available. On most versions of Windows 10, the user's account
needs to be assigned the right to \"Create symbolic links\" in
\"secpol.msc\". For more information about the symlink-setup on
MS Windows please refer to the section \"Customizing how packages
are built\" in the user manual.
Beware that copying is slower, less space-efficient, and
requiring of additional hacks."
:type 'boolean)
(defun straight--directory-files (&optional directory match full sort)
"Like `directory-files', but with better defaults.
DIRECTORY, MATCH, and FULL are as in `directory-files', but their
order has been changed. Also, DIRECTORY defaults to
`default-directory' if omitted. The meaning of the last argument
SORT has been inverted from `directory-files'. Finally, the . and
.. entries are never returned, and .git is removed from the
results if present."
(cl-remove-if
(lambda (file)
(string-match-p "\\(?:\\(?:\\.\\(?:\\.\\|git\\)?\\)$\\)" file))
(directory-files (or directory default-directory) full match (not sort))))
(defun straight--symlink-recursively (link-target link-name)
"Make a symbolic link to LINK-TARGET, named LINK-NAME, recursively.
This means that if the link target is a directory, then a
corresponding directory is created (called LINK-NAME) and all
descendants of LINK-TARGET are linked separately into
LINK-NAME (except for directories, which are created directly).
If `straight-use-symlinks' is nil, then instead of creating a
symlink, the file is copied directly, and a corresponding entry
is created in the straight/links/ directory so that the file may
be interpreted later as a symlink."
(if (and (file-directory-p link-target)
(not (file-symlink-p link-target)))
(progn
(make-directory link-name 'parents)
(dolist (entry (straight--directory-files link-target))
(straight--symlink-recursively
(expand-file-name entry link-target)
(expand-file-name entry link-name))))
(make-directory (file-name-directory link-name) 'parents)
(condition-case _
(if straight-use-symlinks
(if (straight--windows-os-p)
(straight--process-output
"cmd" "/c" "mklink"
(subst-char-in-string ?/ ?\\ link-name)
(subst-char-in-string ?/ ?\\ link-target))
(make-symbolic-link link-target link-name))
(copy-file link-target link-name)
(let ((build-dir (straight--build-dir)))
(when (straight--path-prefix-p build-dir link-name)
(let* ((relative-path (substring link-name (length build-dir)))
(link-record (straight--links-file relative-path)))
;; This call may fail in the case that there was
;; previously a directory being symlinked, and now
;; there is a file by the same name being symlinked.
;; That edge case will need to be dealt with
;; eventually, but it's rather nontrivial so I'm not
;; doing it now.
(make-directory (file-name-directory link-record) 'parents)
(with-temp-file link-record
(insert link-target))))))
(file-already-exists
;; We're OK with the recipe specifying to create the symlink
;; twice, as long as it's pointing to the same place both
;; times. Otherwise, signal a warning.
(unless (string= link-target
(file-symlink-p link-name))
(straight--warn "Attempted to link %S to both %S and %S"
link-name (file-symlink-p link-name) link-target))))))
;;;;; External processes
(defvar straight--process-log t
"If non-nil, log process output to `straight-process-buffer'.")
(defvar straight--process-warn nil
"If non-nil, warn for nonzero/failed processes.")
(defvar straight--default-directory nil
"Overrides value of `default-directory'.
This is used because `default-directory' is buffer-local, which
means binding it for the duration of a recursive edit causes fun
side-effects like random buffers permanently forgetting which
directory they're in, and straight.el executing Git commands
against the wrong repositories.
If you set this globally to something other than nil, you may be
eaten by a grue.")
(defconst straight--process-stderr
(expand-file-name (format "straight-stderr-%s" (emacs-pid))
temporary-file-directory)
"File for storing proccesses' stderr.")
(defcustom straight-process-buffer "*straight-process*"
"Name of buffer used for process output."
:type 'string)
(defun straight--delete-stderr-file ()
"Remove `straight--process-stderr' file."
(when (and (boundp 'straight--process-stderr)
(file-exists-p straight--process-stderr))
(delete-file straight--process-stderr)))
(add-hook 'kill-emacs-hook #'straight--delete-stderr-file)
(defun straight--process-buffer ()
"Return `straight-process-buffer' in `special-mode'."
(with-current-buffer (get-buffer-create straight-process-buffer)
(unless (derived-mode-p 'special-mode) (special-mode))
(current-buffer)))
(defun straight--process-call (program &rest args)
"Run PROGRAM syncrhonously with ARGS.
Return a list of form: (EXITCODE STDOUT STDERR).
If the process is unable to start, return an elisp error object."
(when (string-match-p "/" program)
(setq program (expand-file-name program)))
(condition-case e
(with-temp-buffer
(list
(apply #'call-process program nil
(list t straight--process-stderr)
nil args)
(let ((s (buffer-substring-no-properties (point-min) (point-max))))
(unless (string-empty-p s) s))
(progn
(insert-file-contents
straight--process-stderr nil nil nil 'replace)
(let ((s (buffer-substring-no-properties (point-min) (point-max))))
(unless (string-empty-p s) s)))))
(error e)))
(defmacro straight--process-with-result (result &rest body)
"Provide anaphoric RESULT bindings for duration of BODY.
RESULT must be an expression which evaluates to a list of form:
(EXITCODE STDOUT STDERR)
Anaphroic bindings provided:
result: the raw process result list
exit: the exit code of the process
invoked: t if process executed without an elisp error
success: t if process exited with exit code 0