d45f01292371d7d1661fa9e89e20d16f884fc1fc
[elinstall.git] / elinstall.el
blobd45f01292371d7d1661fa9e89e20d16f884fc1fc
1 ;;;_ elinstall.el --- Automatically and flexibly install elisp files
3 ;;;_. Headers
4 ;;;_ , License
5 ;; Copyright (C) 2010 Tom Breton (Tehom)
7 ;; Author: Tom Breton (Tehom) <tehom@panix.com>
8 ;; Keywords: maint, tools, internal
10 ;; This file is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
15 ;; This file is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to
22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24 ;;;_ , Version
25 ;;Version: 1.0
27 ;;;_ , Commentary:
29 ;; Entry points:
30 ;; elinstall Use this for overall loading
32 ;; elinstall-arrange-preload - Use this for non-autogenerated
33 ;; files that need to be linked in.
35 ;; elinstall-update-directory-autoloads
36 ;; elinstall-update-file-autoloads
38 ;;;_ , Requires
40 (require 'autoload)
41 (require 'pp)
42 (require 'cus-edit) ;;Because we save "installedness" manually
43 (require 'byte-compile nil t) ;;
46 ;;;_. Body
47 ;;;_ , Customizations
48 ;;;_ . Group
49 (defgroup elinstall
50 '()
51 "Customizations for elinstall"
52 :group 'development)
53 ;;;_ . elinstall-default-priority
54 (defcustom elinstall-default-priority
56 "Default priority for site-start"
57 :group 'elinstall
58 :type 'integer)
59 ;;;_ . elinstall-default-preload-target
60 (defcustom elinstall-default-preload-target
61 "~/.emacs.d/site-start.d/"
62 "Default preload-target for registering autoloads"
63 :group 'elinstall
64 :type
65 '(choice
66 (const "~/.emacs.d/site-start.d/")
67 (const "/etc/emacs/site-start.d/")
68 (directory "" )
69 (const nil)
70 (const 'dot-emacs)))
71 ;;;_ . elinstall-restrain-install
72 (defcustom elinstall-restrain-install '()
73 "Restrain elinstall for specific packages"
74 :group 'elinstall
75 :type
76 '(repeat
77 (list
78 (choice :format "%[%t%]: %v"
79 (string :tag "Package name")
80 (const :tag "All packages" t))
81 (repeat :tag "Actions to restrain:"
82 (group
83 (choice
84 (const install)
85 (const autoloads)
86 (const byte-compile)
87 (const preloads)
88 (const load-path)
89 (const info-path)
90 (const :tag "Use as default" t))
91 (choice
92 (const
93 :tag "Do this unless it's up to date"
94 update)
95 (const
96 :tag "Use the package spec for this"
98 (const
99 :tag "Don't do this at all"
100 nil)
101 (const
102 :tag "Always ask."
103 ask)
104 (const
105 :tag "Ask only when it's up-to-date."
106 ask-for-old)
107 (const
108 :tag "Do everything even if it's up to date."
109 always)))))))
112 ;;;_ . elinstall-already-installed
113 (with-no-warnings
114 (defcustom elinstall-already-installed
116 "(AUTOMATIC) Things that have already been installed.
117 This exists for recording what has been installed.
119 Though it's saved as customizable, user interaction is not
120 contemplated." ))
121 ;;Tell the byte-compiler it's a variable.
122 (defvar elinstall-already-installed)
123 ;;;_ , Types
124 ;;;_ . elinstall-stages
125 (defstruct (elinstall-stages
126 (:constructor elinstall-make-stages)
127 (:conc-name elinstall-stages->)
128 (:copier nil))
129 "The elinstall stages"
130 build-deffiles
131 run-tests
132 byte-compile
133 arrange-preloads)
134 ;;;_ , Data
135 ;;;_ . Regular expressions
136 ;;;_ , elinstall-elisp-regexp
137 (defconst elinstall-elisp-regexp
138 (let ((tmp nil))
139 (dolist
140 (suf (get-load-suffixes))
141 (unless (string-match "\\.elc" suf) (push suf tmp)))
142 (concat "^[^=.].*" (regexp-opt tmp t) "\\'"))
143 "Regular expression that matches elisp files" )
144 ;;;_ , Utilities
145 ;;;_ . elinstall-file-mod-time
146 (defsubst elinstall-file-mod-time (file)
147 "Return the modification time of FILE"
148 (nth 5 (file-attributes file)))
150 ;;;_ . elinstall-directory-true-name
151 (defun elinstall-directory-true-name ()
152 "Get the true name of the directory the calling code lives in.
153 CAUTION: This is sensitive to where it's called. That's the point of it."
154 (file-name-directory
155 (if load-file-name
156 (file-truename load-file-name)
157 (file-truename buffer-file-name))))
158 ;;;_ . Checking installedness
159 ;;;_ , elinstall-get-installation-record
160 (defun elinstall-get-installation-record (project-name)
161 "Return the installation record for PROJECT-NAME."
163 (assoc project-name elinstall-already-installed))
165 ;;;_ , elinstall-already-installed
166 (defun elinstall-already-installed (project-name)
167 "Return non-nil if PROJECT-NAME has been installed."
168 (elinstall-get-installation-record project-name))
170 ;;;_ , elinstall-record-installed
171 (defun elinstall-record-installed (project-name &optional version)
172 "Record that PROJECT-NAME has been installed."
173 (let
174 ((new-item
175 (list
176 project-name
177 (or version "0")
178 (current-time)
179 'installed))
180 (old-item
181 (elinstall-get-installation-record project-name))
182 (print-length nil)
183 (print-level nil))
184 (when old-item
185 (setq elinstall-already-installed
186 (delete old-item elinstall-already-installed)))
187 (push new-item elinstall-already-installed)
188 (customize-save-variable
189 'elinstall-already-installed
190 elinstall-already-installed
191 "Set by elinstall-record-installed")))
192 ;;;_ . Finding deffiles
193 ;;;_ , elinstall-expand-deffile-name
194 (defun elinstall-expand-deffile-name (deffile)
195 "Expand DEFFILE autoload.el's way."
197 (expand-file-name (or deffile "loaddefs.el")
198 (expand-file-name "lisp"
199 source-directory)))
200 ;;;_ . Checking restraint specs
201 ;;;_ , elinstall-call-with-restraints
202 (defun elinstall-call-with-restraints (restraints package func &rest args)
203 "Call FUNC with ARGS, in scope of RESTRAINTS.
204 RESTRAINTS is a list of package restraints. User restraints for the
205 given package will also be applied in scope.
207 PACKAGE can be `t' or a string naming a package."
209 (let*
210 ((elinstall:*pkg-restraints* restraints)
211 (elinstall:*user-restraints*
212 (let
213 ((cell
215 (assoc package elinstall-restrain-install)
216 (assoc t elinstall-restrain-install))))
217 (if cell
218 (second cell)
219 '()))))
220 (declare (special
221 elinstall:*pkg-restraints*
222 elinstall:*user-restraints*))
223 (apply func args)))
224 ;;;_ , elinstall-proceed-p
225 (defun elinstall-proceed-p
226 (topic message-params &optional already-p)
227 "Return non-nil if actions on TOPIC should proceed.
228 Call this transitively only thru `elinstall-call-with-restraints'.
229 TOPIC is a symbol indicating the topic, such as `byte-compile'.
230 MESSAGE-PARAMS is a cons of:
231 * A list of format strings:
232 * To ask whether to do this action
233 * To ask whether to redo this action, for `ask-for-old'
234 * To report that this action was skipped because already done.
235 * The arguments to the formatter.
236 ALREADY-P is an extended boolean whether the task has been done
237 before, if caller can tell."
239 (check-type topic symbol)
240 (declare (special
241 elinstall:*pkg-restraints*
242 elinstall:*user-restraints*))
243 (unless (and
244 (boundp 'elinstall:*pkg-restraints*)
245 (boundp 'elinstall:*user-restraints*))
246 (error "elinstall-proceed-p called out of scope"))
248 (destructuring-bind
249 ((ask-prompt &optional redo-prompt noredo-msg) &rest message-args)
250 message-params
251 (let*
252 ( ;;Get the applicable cell. We look in several places.
253 (cell
255 (assq topic elinstall:*user-restraints*)
256 (assq t elinstall:*user-restraints*)))
257 (cell
258 ;;`t' means use the pkg-restraints value instead.
259 (if
260 (or (not cell) (eq (second cell) t))
262 (assq topic elinstall:*pkg-restraints*)
263 (assq t elinstall:*pkg-restraints*))
264 cell))
265 (treatment
266 ;;Default is to just update.
267 (if cell (second cell) 'update)))
268 (case treatment
269 ((nil)
270 nil)
271 ((t always)
273 (update
274 (if already-p
275 (progn
276 (apply #'message noredo-msg message-args)
277 nil)
279 (ask-for-old
280 (if already-p
281 (y-or-n-p (apply #'format redo-prompt message-args))
283 (ask
284 (y-or-n-p
285 (apply #'format ask-prompt message-args)))))))
287 ;;;_ , Work
288 ;;;_ . Doing actions
290 ;;;_ , Doing autoload actions (adapted from autoload.el)
291 ;;;_ . Utilities about the action list
292 ;;;_ , elinstall-remove-autogen-action
293 (defun elinstall-remove-autogen-action (file actions)
294 "Return ACTIONS minus any add-file-autoloads on FILE removed."
296 (delq nil
297 (mapcar
298 #'(lambda (act)
299 (case (car act)
300 (add-file-autoloads
301 (if (equal file (third act))
303 act))
304 (t act)))
305 actions)))
306 ;;;_ , elinstall-get-autogen-action
307 (defun elinstall-get-autogen-action (file actions)
309 (let
310 ((the-act))
311 (dolist (act actions)
312 (case (car act)
313 (add-file-autoloads
314 (when (equal file (third act))
315 (setq the-act act)))))
316 the-act))
317 ;;;_ . About printing to autoload file
318 ;;;_ , elinstall-insert-section-header
319 (defun elinstall-insert-section-header (outbuf form)
320 "Insert the section-header line,
321 which lists the file name and which functions are in it, etc."
322 (insert generate-autoload-section-header)
323 (prin1 form outbuf)
324 (terpri outbuf)
325 ;; Break that line at spaces, to avoid very long lines.
326 ;; Make each sub-line into a comment.
327 (with-current-buffer outbuf
328 (save-excursion
329 (forward-line -1)
330 (while (not (eolp))
331 (move-to-column 64)
332 (skip-chars-forward "^ \n")
333 (or (eolp)
334 (insert "\n" generate-autoload-section-continuation))))))
336 ;;;_ , elinstall-insert-autoload-section
337 (defun elinstall-insert-autoload-section (text form &optional comment-string)
338 "Insert TEXT into current buffer as an autoload section"
340 (let* (
341 (print-length nil)
342 (print-level nil)
343 ;; This does something in Lucid Emacs.
344 (print-readably t)
345 (float-output-format nil))
347 (elinstall-insert-section-header (current-buffer) form)
348 (when comment-string
349 (insert ";;; " comment-string "\n"))
350 (insert text)
351 (insert generate-autoload-section-trailer)))
353 ;;;_ . Making autoloads
354 ;;;_ , elinstall-make-autoload-action
355 (defun elinstall-make-autoload-action (buf def-file load-path-element full-path)
356 "Return the autoloads for current buffer as a string"
358 ;;We put all the text into a temp buffer, then get that buffer's
359 ;;string.
360 (let
361 ((outbuf
362 (generate-new-buffer " *temp*"))
363 (autoloads-done '())
364 (short-name
365 (file-name-nondirectory full-path))
367 (print-length nil)
368 (print-level nil)
369 ;; Apparently this does something in Lucid Emacs.
370 (print-readably t)
371 (float-output-format nil)
373 ;;load-name relative to a member of load-path.
374 (relative-name
375 (file-name-sans-extension
376 (file-relative-name
377 full-path
378 load-path-element))))
380 (with-current-buffer buf
381 (unwind-protect
382 (save-excursion
383 (save-restriction
384 (widen)
385 (goto-char (point-min))
386 (message "Finding autoloads for %s..." short-name)
387 (while (not (eobp))
388 (skip-chars-forward " \t\n\f")
389 (cond
390 ((looking-at (regexp-quote generate-autoload-cookie))
391 (search-forward generate-autoload-cookie)
392 (skip-chars-forward " \t")
393 (if (eolp)
394 ;; Read the next form and make an autoload.
395 (let* ((form (prog1 (read (current-buffer))
396 (or (bolp) (forward-line 1))))
397 (autoload
398 (make-autoload form relative-name)))
399 (if autoload
400 (push (nth 1 form) autoloads-done)
401 (setq autoload form))
402 (let ((autoload-print-form-outbuf outbuf))
403 (autoload-print-form autoload)))
405 ;; Copy the rest of the line to the output.
406 (princ (buffer-substring
407 (progn
408 ;; Back up over whitespace,
409 ;; to preserve it.
410 (skip-chars-backward " \f\t")
411 (if (= (char-after (1+ (point))) ? )
412 ;; Eat one space.
413 (forward-char 1))
414 (point))
415 (progn (forward-line 1) (point)))
416 outbuf)))
417 ((looking-at ";")
418 ;; Don't read the comment.
419 (forward-line 1))
421 (forward-sexp 1)
422 (forward-line 1))))
423 (message "Finding autoloads for %s...done" short-name))
425 ;;Return this action. The temp buffer's contents is
426 ;;our final string.
427 `(add-file-autoloads
428 ,def-file
429 ,relative-name
430 ,full-path
431 ,(with-current-buffer outbuf (buffer-string))
432 ,autoloads-done))
434 ;;This in unwind-protected
435 (when (buffer-live-p outbuf) (kill-buffer outbuf))))))
438 ;;;_ , elinstall-generate-file-autoloads
440 (defun elinstall-generate-file-autoloads
441 (relative-name full-name text autoloads-done)
442 "Insert at point a loaddefs autoload section for FILE.
443 Autoloads are generated for defuns and defmacros in FILE
444 marked by `generate-autoload-cookie' (which see).
445 If FILE is being visited in a buffer, the contents of the buffer
446 are used.
447 Return non-nil in the case where no autoloads were added at point.
449 FULL-NAME is the absolute name of the file.
450 RELATIVE-NAME is its name respective to some component of load-path."
451 (if (not (equal text ""))
452 ;; Insert the section-header line which lists the file name and
453 ;; which functions are in it, etc.
454 (elinstall-insert-autoload-section
455 text
456 (list 'autoloads
457 autoloads-done
458 relative-name
459 (autoload-trim-file-name full-name)
460 (elinstall-file-mod-time full-name))
461 (concat
462 "Generated autoloads from "
463 (autoload-trim-file-name full-name)))
466 ;;;_ , elinstall-deffile-insert-autoloads
467 (defun elinstall-deffile-insert-autoloads (file args)
468 "Update the autoloads for FILE in current buffer.
469 Return FILE if there was no autoload cookie in it, else nil.
471 Current buffer must be a loaddef-style file.
473 LOAD-NAME is the absolute name of the file.
474 RELATIVE-NAME is its name respective to some component of load-path."
475 (let (
476 (found nil)
477 (no-autoloads nil))
479 (save-excursion
480 (save-restriction
481 (widen)
482 (goto-char (point-min))
483 ;; Look for the section for FILE
484 (while (and (not found)
485 (search-forward generate-autoload-section-header nil t))
486 (let ((form (autoload-read-section-header)))
487 (cond
488 ((equal (nth 2 form) file)
489 ;; We found the section for this file.
490 (let ((begin (match-beginning 0)))
491 (progn
492 (search-forward generate-autoload-section-trailer)
493 (delete-region begin (point))
494 (setq found t))))
495 ((string< file (nth 2 form))
496 ;; We've come to a section alphabetically later than
497 ;; FILE. We assume the file is in order and so
498 ;; there must be no section for FILE. We will
499 ;; insert one before the section here.
500 (goto-char (match-beginning 0))
501 (setq found 'new)))))
502 (unless found
503 (progn
504 (setq found 'new)
505 ;; No later sections in the file. Put before the last page.
506 (goto-char (point-max))
507 (search-backward "\f" nil t)))
508 (setq no-autoloads
509 (apply #'elinstall-generate-file-autoloads
510 file args))))
512 (if no-autoloads file nil)))
513 ;;;_ . Arranging to add to info-path and load-path
514 ;;;_ , elinstall-generate-add-to-path
515 (defun elinstall-generate-add-to-path (path-element type)
516 "Insert code at point to add PATH-ELEMENT to a path.
517 If TYPE is:
518 * `add-to-load-path', add to load-path
519 * `add-to-info-path', add to Info-additional-directory-list
521 Current buffer must be a loaddef-style file."
522 (let ( (path-symbol
523 (case type
524 (add-to-load-path 'load-path)
525 (add-to-info-path 'Info-additional-directory-list)
526 (t (error "Type not recognized"))))
527 (description
528 (case type
529 (add-to-load-path "load-path")
530 (add-to-info-path "info-path")))
531 (autoloads-done '())
532 (print-length nil)
533 (print-level nil)
534 ;; This does something in Lucid Emacs.
535 (print-readably t)
536 (float-output-format nil))
538 (message "Generating %s additions..." description)
540 (elinstall-insert-autoload-section
541 (pp-to-string
542 `(add-to-list ',path-symbol
543 (expand-file-name
544 ,(file-relative-name path-element)
545 (if load-file-name
546 (file-name-directory
547 (file-truename load-file-name))))))
548 (list type (list path-element) nil nil nil)
549 nil)
550 (message "Generating %s additions...done" description)))
553 ;;;_ , elinstall-deffile-insert-add-to-path
554 (defun elinstall-deffile-insert-add-to-path (path-element type)
555 "Insert code in current buffer to add PATH-ELEMENT to a path.
556 If TYPE is:
557 * `add-to-load-path', add to load-path
558 * `add-to-info-path', add to Info-default-directory-list
560 Current buffer must be a loaddef-style file."
561 (let (
562 (found nil)
563 (no-autoloads nil))
565 (save-excursion
566 (save-restriction
567 (widen)
568 (goto-char (point-min))
569 ;; Look for the section for PATH-ELEMENT
570 (while (and (not found)
571 (search-forward generate-autoload-section-header nil t))
572 (let ((form (autoload-read-section-header)))
573 (cond
574 ((and
575 (equal (nth 0 form) type)
576 (member path-element (nth 1 form)))
578 ;; We found the section for this add.
579 (let ((begin (match-beginning 0)))
580 (progn
581 (search-forward generate-autoload-section-trailer)
582 (delete-region begin (point))
583 (setq found t)))))))
585 (unless found
586 (progn
587 (setq found 'new)
588 ;; No later sections in the file. Put before the last page.
589 (goto-char (point-max))
590 (search-backward "\f" nil t)))
592 (elinstall-generate-add-to-path path-element type)))
594 ;;This never belongs in the no-autoloads section.
595 nil))
596 ;;;_ . elinstall-deffile-insert
598 (defun elinstall-deffile-insert (action)
599 "Insert autoloads etc into current file according to ACTION.
600 The format of ACTION is described in the design docs.
602 Return filename if this action belongs in the no-autoload section."
604 (when action
605 (case (car action)
606 (add-file-autoloads
607 (elinstall-deffile-insert-autoloads
608 (third action)
609 (nthcdr 3 action)))
611 (add-to-load-path
612 (elinstall-deffile-insert-add-to-path
613 (third action)
614 'add-to-load-path)
615 nil)
617 (add-to-info-path
618 (elinstall-deffile-insert-add-to-path
619 (third action)
620 'add-to-info-path)
621 nil)
623 ((preload-file run-tests byte-compile)
624 (error "This case should not come here.")))))
626 ;;;_ . elinstall-prepare-deffile
627 (defun elinstall-prepare-deffile (deffile)
628 "Try to ensure that DEFFILE is available for receiving autoloads"
630 (autoload-ensure-default-file deffile)
631 (with-current-buffer (find-file-noselect deffile)
634 ;; We must read/write the file without any code conversion,
635 ;; but still decode EOLs.
636 (let ((coding-system-for-read 'raw-text))
638 ;; This is to make generated-autoload-file have Unix EOLs, so
639 ;; that it is portable to all platforms.
640 (setq buffer-file-coding-system 'raw-text-unix))
641 (or (> (buffer-size) 0)
642 (error "Autoloads file %s does not exist" buffer-file-name))
643 (or (file-writable-p buffer-file-name)
644 (error "Autoloads file %s is not writable"
645 buffer-file-name))))
647 ;;;_ . elinstall-update-deffile
649 ;;Adapted from autoload.el `update-directory-autoloads'.
651 (defun elinstall-update-deffile (target actions &optional
652 use-load-path force)
654 Update file TARGET with current autoloads as specified by ACTIONS.
655 Also remove any old definitions pointing to libraries that can no
656 longer be found.
658 ACTIONS must be a list of actions (See the format doc). Each one's
659 filename must be relative to some element of load-path.
661 USE-LOAD-PATH is a list to use as load-path. It should include
662 any new load-path that we are arranging to create. If it's not given,
663 load-path itself is used.
665 If FORCE is `t', do it regardless of timestamps etc. (Not implemented)
666 Other non-nil cases of FORCE are reserved for future development.
668 This uses `update-file-autoloads' (which see) to do its work.
669 In an interactive call, you must give one argument, the name
670 of a single directory."
671 (let
673 (use-load-path (or use-load-path load-path))
674 (this-time (current-time))
675 ;;files with no autoload cookies.
676 (no-autoloads nil))
678 (elinstall-prepare-deffile target)
679 (with-current-buffer
680 (find-file-noselect target)
681 (save-excursion
682 (setq actions
683 (elinstall-remove-autogen-action
684 (autoload-trim-file-name target)
685 actions))
687 (goto-char (point-min))
688 (while (search-forward generate-autoload-section-header nil t)
689 (let* ((form (autoload-read-section-header))
690 (file (nth 3 form)))
691 (cond ((and (consp file) (stringp (car file)))
692 ;; This is a list of files that have no
693 ;; autoload cookies.
694 ;; There shouldn't be more than one such entry.
695 ;; Remove the obsolete section.
696 (autoload-remove-section (match-beginning 0))
697 (let ((last-time (nth 4 form)))
698 (dolist (file file)
699 (let ((file-time (elinstall-file-mod-time file)))
700 (when (and file-time
701 (not (time-less-p last-time file-time)))
702 ;; file unchanged
703 (push file no-autoloads)
704 (setq actions
705 (elinstall-remove-autogen-action
706 file actions)))))))
707 ((not (stringp file)))
709 (let
710 ((file-path
711 (locate-library file nil use-load-path)))
712 (cond
713 ;;File doesn't exist, so remove its
714 ;;section.
715 ((not file-path)
716 (autoload-remove-section
717 (match-beginning 0)))
719 ;; File hasn't changed, so do nothing.
720 ((equal
721 (nth 4 form)
722 (elinstall-file-mod-time file-path))
723 nil)
725 (elinstall-deffile-insert
726 (elinstall-get-autogen-action
727 file actions))))
729 (setq actions
730 (elinstall-remove-autogen-action
731 file actions))))))))
733 ;; Remaining actions have no existing autoload sections yet.
734 (setq no-autoloads
735 (append no-autoloads
736 (delq nil (mapcar #'elinstall-deffile-insert actions))))
737 (when no-autoloads
738 ;; Sort them for better readability.
739 (setq no-autoloads (sort no-autoloads 'string<))
740 ;; Add the `no-autoloads' section.
741 (goto-char (point-max))
742 (search-backward "\f" nil t)
743 (elinstall-insert-autoload-section
745 (list 'autoloads nil nil no-autoloads this-time)))
746 (save-buffer))))
748 ;;;_ . elinstall-stage-update-deffiles
749 (defun elinstall-stage-update-deffiles (segment-list force use-load-path)
750 "Update any deffiles mentioned in SEGMENT-LIST.
751 FORCE and USE-LOAD-PATH have the same meaning as in
752 `elinstall-update-deffile'.
754 (mapcar
755 #'(lambda (segment)
756 (let*
757 ((deffile (car segment)))
758 (if (stringp deffile)
759 (elinstall-update-deffile deffile (cdr segment) force
760 use-load-path))))
761 segment-list))
763 ;;;_ , Doing actions to arrange preloads
764 ;;;_ . elinstall-symlink-on-emacs-start
765 (defun elinstall-symlink-on-emacs-start
766 (filename target-basename target-dir &optional priority force)
767 "Symlink to TARGET-BASENAME.el in TARGET-DIR
769 If PRIORITY is given, it will be used as the priority prefix,
770 otherwise elinstall-default-priority will be.
771 PRIORITY must be an integer or nil.
772 If FORCE is `t', do it regardless of timestamps etc.
773 Other non-nil cases of FORCE are reserved for future development."
774 (let*
776 (priority (or priority elinstall-default-priority))
777 (target-name-nodir
778 (format
779 "%d%s.el"
780 priority
781 target-basename))
782 (target
783 (expand-file-name target-name-nodir target-dir)))
786 (cond
787 ;;Path should already exist.
788 ((not
789 (file-exists-p target-dir))
790 (message "The target directory doesn't exist."))
791 ;;Target shouldn't already exist, but if force is given, let
792 ;;user override.
794 ;;$$IMPROVE ME If it is a symlink pointing to the same place,
795 ;;do nothing.
797 ;;$$IMPROVE ME The condition here is not updating but
798 ;;bulldozing a possibly different symlink. Add another
799 ;;treatment symbol meaning to bulldoze what's in the way.
800 ((elinstall-proceed-p 'preloads-compile
801 (list
802 '( "Symlink %s? "
803 "Really overwrite %s? "
804 "File %s already exists")
805 target)
806 (file-exists-p target))
807 (make-symbolic-link
808 filename
809 target
810 nil)))))
812 ;;;_ . elinstall-add-to-dot-emacs
813 (defun elinstall-add-to-dot-emacs (dot-emacs-name filename force &rest r)
814 "Add code to load FILENAME to .emacs.
815 FILENAME should not have an extension"
817 ;;Visit .emacs
818 (with-current-buffer (find-file-noselect dot-emacs-name)
819 (save-excursion
820 ;;add at end of file
821 (goto-char (point-max))
822 (insert "\n;;Added by elinstall")
823 (insert "\n;;Consider using my-site-start to manage .emacs\n")
824 (pp `(load ,filename) (current-buffer))
825 (save-buffer))))
828 ;;;_ . elinstall-arrange-preload
829 ;;;###autoload
830 (defun elinstall-arrange-preload (force filename basename &optional priority)
831 "Arrange for FILENAME to be loaded on emacs start.
832 FORCE has its usual meaning.
833 BASENAME and PRIORITY are used as arguments to
834 `elinstall-symlink-on-emacs-start'.
837 (let
838 ((preload-target elinstall-default-preload-target))
840 ;;Dispatch the possibilities.
841 (cond
842 ((eq preload-target 'dot-emacs)
843 (elinstall-add-to-dot-emacs "~/.emacs" filename force))
844 ((stringp preload-target)
845 (elinstall-symlink-on-emacs-start
846 filename basename preload-target priority force))
847 ((null preload-target)
848 (message "Not arranging for preloads"))
850 (message "I don't recognize that")))))
851 ;;;_ . elinstall-stage-arrange-preloads
852 (defun elinstall-stage-arrange-preloads (actions deffiles-used force)
853 "Arrange any preloads mentioned in ACTIONS."
855 (mapcar
856 #'(lambda (act)
857 (case (car act)
858 (preload-file
859 (let*
860 ( (filename
861 (caddr act))
862 (proceed-p
863 (case (second act)
864 ((t) t)
865 ((nil) nil)
866 (if-used
867 (member filename deffiles-used)))))
869 (when proceed-p
870 (apply
871 #'elinstall-arrange-preload
872 force
873 (cddr act)))))
875 (error
876 "elinstall-stage-arrange-preloads: Action not
877 recognized."))) )
878 actions))
881 ;;;_ , Run tests
882 ;;;_ . elinstall-stage-run-tests
883 (defun elinstall-stage-run-tests (actions)
884 "Run any tests mentioned in ACTIONS."
886 (mapcar
887 #'(lambda (act)
888 (case (car act)
889 (run-tests
890 ;;$$WRITE ME - not a high priority right now.
891 nil)
893 (error
894 "elinstall-stage-run-tests: Action not
895 recognized."))) )
896 actions))
899 ;;;_ , Byte compile
900 ;;;_ . elinstall-stage-byte-compile
901 (defun elinstall-stage-byte-compile (actions)
902 "Do any byte-compilation mentioned in ACTIONS."
904 (mapcar
905 #'(lambda (act)
906 (case (car act)
907 ;;$$IMPROVE ME Understand flags to control second
908 ;;argument (whether to load file after
909 ;;compilation)
910 (byte-compile
911 (byte-compile-file (second act)))
913 (error
914 "elinstall-stage-byte-compile: Action not
915 recognized."))) )
916 actions))
917 ;;;_ . Segregating actions
918 ;;;_ , elinstall-remove-empty-segs
919 (defun elinstall-remove-empty-segs (segment-list)
920 "Return SEGMENT-LIST minus any segments that have no actions.
921 Intended only for the deffile stage data."
922 (delq nil
923 (mapcar
924 #'(lambda (segment)
925 (if (cdr segment)
926 segment
927 nil))
928 segment-list)))
930 ;;;_ , elinstall-segregate-actions
931 (defun elinstall-segregate-actions (actions)
932 "Return actions segregated by deffile.
934 Returns a list whose elements are each a cons of:
935 * deffile filename or nil
936 * A list of actions to be done for that deffile."
938 (let
940 (build-deffiles '())
941 (run-tests '())
942 (byte-compile '())
943 (arrange-preloads '()))
945 (dolist (act actions)
946 (when act
947 (case (car act)
948 ((add-file-autoloads
949 add-to-info-path
950 add-to-load-path)
951 (let*
952 ((deffile-name (second act))
953 (cell-already
954 (assoc deffile-name build-deffiles)))
955 (if cell-already
956 ;;There are already actions on this deffile.
957 ;;Splice this action in.
958 (setcdr cell-already
959 (cons act (cdr cell-already)))
960 ;;There are no actions on this deffile. Add a
961 ;;place for them and include this action.
962 (push (list deffile-name act) build-deffiles))))
963 (preload-file
964 (push act arrange-preloads))
965 (run-tests
966 (push act run-tests))
967 (byte-compile
968 (push act byte-compile)))))
970 (elinstall-make-stages
971 :build-deffiles
972 (elinstall-remove-empty-segs build-deffiles)
973 :run-tests
974 run-tests
975 :byte-compile
976 byte-compile
977 :arrange-preloads
978 arrange-preloads)))
979 ;;;_ . Finding actions
980 ;;;_ , Utility
981 ;;;_ . elinstall-dir-has-info
983 ;;$$IMPROVE ME - Can this test be made more precise?
984 (defun elinstall-dir-has-info (dir)
985 "Return non-nil if DIR has info files in it.
986 DIR should be an absolute path."
988 (string-match "/info/" dir)
989 (directory-files dir nil "\\.info\\(-[0-9]+\\)?\\(\\.gz\\)?$")))
990 ;;;_ . elinstall-directory-files
991 (defun elinstall-directory-files (dirname)
992 "Return a list of files in directory DIRNAME, minus certain files.
993 The following files are omitted:
994 * Dot files
995 * Files that match an entry in `block-in-subtree'.
996 Filenames are relative."
997 (declare (special
998 def-file block-in-dir block-in-subtree))
999 (let*
1001 ;;Relative filenames of this directory's files.
1002 (all-files
1003 ;; Don't include dot files. If user really wants to
1004 ;;explore one he can use (dir ".NAME") or (file ".NAME")
1005 (directory-files dirname nil "[^\\.]"))
1006 ;;We know our def-file isn't really source so remove it.
1007 ;;We'd have removed it anyways after seeing file local vars.
1008 (all-files
1009 (remove def-file all-files))
1011 (all-files
1012 (delq nil
1013 (mapcar
1014 #'(lambda (filename)
1016 (and
1017 block-in-subtree
1018 (some
1019 #'(lambda (blocked)
1020 (string-match blocked filename))
1021 block-in-subtree))
1023 filename))
1024 all-files))))
1025 all-files))
1028 ;;;_ , Workers
1029 ;;;_ . List of special variables used in this section
1030 ;;load-path-element - The relevant element of load-path
1031 ;;def-file - The file the autoload definitions etc will go into.
1032 ;;add-to-load-path-p - Controls whether to add to load-path.
1033 ;;recurse-dirs-p - Whether to recurse into subdirectories.
1035 ;;block-in-dir - (NOT IMPLEMENTED) List of filenames to reject. They
1036 ;;may include wildcards. They apply wrt the original directory.
1038 ;;block-in-subtree - (NOT IMPLEMENTED) List of filenames to reject.
1039 ;;They may include wildcards. They apply wrt any directory in the
1040 ;;tree. Specifically, in the spec tree, which may differ from the
1041 ;;file subtree.
1042 ;;byte-compile - whether to byte-compile at all, t by default.
1043 ;;autoloads - boolean whether to make autoloads, t by default.
1044 ;;preloads - boolean whether to set up preloads, t by default.
1045 (defconst elinstall-find-actions-control-vars
1046 '(add-to-load-path-p recurse-dirs-p byte-compile
1047 autoloads preloads)
1048 "Control special variables that the find-actions tree recognizes" )
1049 ;;;_ . elinstall-actions-for-source-file
1050 (defun elinstall-actions-for-source-file (filename dir)
1051 "Return a list of actions to do for FILENAME in DIR.
1052 Special variables are as noted in \"List of special variables\"."
1053 (declare (special
1054 load-path-element def-file byte-compile))
1055 (let
1056 ((full-path
1057 (expand-file-name filename dir)))
1058 (when
1059 (and
1060 (file-readable-p full-path)
1061 (not (auto-save-file-name-p full-path)))
1062 ;;$$IMPROVE ME Use more of the control variables.
1063 (let*
1065 (visited (get-file-buffer full-path))
1066 (buf
1067 (or
1068 visited
1069 ;;Visit the file cheaply.
1070 ;;hack-local-variables can give errors.
1071 (ignore-errors (autoload-find-file full-path))))
1072 (def-file
1074 (ignore-errors
1075 (with-current-buffer buf
1076 (if (local-variable-p 'generated-autoload-file)
1077 (elinstall-expand-deffile-name
1078 generated-autoload-file)
1079 nil)))
1080 def-file))
1081 ;;Figure out whether to run some actions, by file local vars.
1082 (autoloads-p
1083 (ignore-errors
1084 (with-current-buffer buf
1085 (not no-update-autoloads))))
1086 (do-compile-p
1087 (and
1088 byte-compile
1089 (featurep 'byte-compile)
1090 (string-match emacs-lisp-file-regexp filename)
1091 (ignore-errors
1092 (with-current-buffer buf
1093 (not no-byte-compile)))
1094 (elinstall-proceed-p 'byte-compile
1095 (list
1096 '( "Compile %s? "
1097 "Recompile %s? "
1098 "Already compiled %s.")
1099 filename)
1100 (let
1101 ((dest (byte-compile-dest-file full-path)))
1102 (and
1103 (file-exists-p dest)
1104 (file-newer-than-file-p full-path dest)))))))
1106 (prog1
1107 (list
1108 (if do-compile-p
1109 `(byte-compile ,full-path)
1110 nil)
1111 (if autoloads-p
1112 (elinstall-make-autoload-action
1113 buf def-file load-path-element full-path)
1114 nil))
1115 (unless visited (kill-buffer-if-not-modified buf)))))))
1116 ;;;_ . elinstall-actions-for-dir
1117 (defun elinstall-actions-for-dir (dirname &optional recurse-dirs-p)
1118 "Make actions for DIR.
1119 Recurse just if RECURSE-DIRS-P"
1120 (declare (special
1121 load-path-element def-file add-to-load-path-p))
1122 ;;This does not treat symlinks specially. $$IMPROVE ME it could
1123 ;;treat/not treat them conditional on control variables.
1124 (let*
1126 (files (elinstall-directory-files dirname))
1128 ;;Relative filenames of elisp source
1129 (elisp-source-files
1130 (delq nil
1131 (mapcar
1132 #'(lambda (filename)
1134 (string-match elinstall-elisp-regexp filename)
1135 filename
1136 nil))
1137 files)))
1139 ;;Absolute filenames of subdirectories.
1140 (sub-dirs
1141 (if recurse-dirs-p
1142 (delq nil
1143 (mapcar
1144 #'(lambda (filename)
1145 (let
1146 ((fn (expand-file-name filename dirname)))
1148 (file-directory-p fn)
1150 nil)))
1151 files))
1152 '()))
1154 (load-path-here-p
1155 (and
1156 elisp-source-files ;;If list is not empty.
1157 add-to-load-path-p))
1158 (load-path-element
1159 (if load-path-here-p
1160 dirname
1161 load-path-element)))
1163 (append
1164 ;;Sometimes arrange to add this directory to load-path.
1165 (if load-path-here-p
1166 `((add-to-load-path
1167 ,def-file
1168 ,load-path-element))
1169 '())
1171 ;;$$IMPROVE ME - be controlled by a control variable.
1172 ;;Sometimes add this directory to info path.
1174 (elinstall-dir-has-info dirname)
1175 `((add-to-info-path
1176 ,def-file
1177 "."))
1178 '())
1180 (apply #'nconc
1181 (mapcar
1182 #'(lambda (filename)
1183 (elinstall-actions-for-source-file
1184 filename
1185 dirname))
1186 elisp-source-files))
1188 (if recurse-dirs-p
1189 (apply #'nconc
1190 (mapcar
1191 #'(lambda (filename)
1192 (elinstall-find-actions-by-spec-x
1194 (expand-file-name
1195 filename
1196 dirname)))
1197 sub-dirs))
1198 '()))))
1200 ;;;_ . elinstall-find-actions-by-spec-x
1202 (defun elinstall-find-actions-by-spec-x (spec dir)
1203 "Return a list of actions to do, controlled by SPEC."
1204 (declare (special
1205 load-path-element def-file add-to-load-path-p
1206 recurse-dirs-p block-in-dir block-in-subtree))
1208 (if (consp spec)
1209 (case (car spec)
1210 (all
1211 ;;(all . SPEC*)
1212 (apply #'nconc
1213 (mapcar
1214 #'(lambda (sub-spec)
1215 (elinstall-find-actions-by-spec-x
1216 sub-spec
1217 dir))
1218 (cdr spec))))
1219 (block-in-subtree
1220 ;;(block-in-subtree (* FN) SPEC)
1221 (let
1222 ((block-in-subtree (second spec)))
1223 (elinstall-find-actions-by-spec-x
1224 (third spec)
1225 dir)))
1227 ;;Rather than trying to bind all control variables each time
1228 ;;thru, we use `set' and `unwind-protect'.
1229 (control
1230 ;;control TYPE DISPOSITION SPEC
1231 (let
1232 ((key (second spec))
1233 old-value)
1234 (if (memq key elinstall-find-actions-control-vars)
1235 (unwind-protect
1236 (progn
1237 (setq old-value (symbol-value key))
1238 (set key (third spec))
1239 (elinstall-find-actions-by-spec-x
1240 (fourth spec)
1241 dir))
1242 (set key old-value))
1243 (error "Unrecognized control variable %s" key))))
1246 (def-file
1247 ;;(def-file FN ARGS SPEC)
1248 (let
1249 ((def-file
1250 (expand-file-name
1251 (second spec)
1252 dir))
1253 (for-preload (third spec)))
1254 (assert (listp for-preload))
1255 (append
1256 (list
1258 (and for-preload (car for-preload))
1259 `(preload-file
1260 ,(car for-preload)
1261 ,def-file
1262 ,@(cdr for-preload))
1263 '()))
1265 (elinstall-find-actions-by-spec-x
1266 (fourth spec) dir))))
1268 (dir
1269 ;;(dir FN)
1270 (elinstall-actions-for-dir
1271 (expand-file-name
1272 (second spec)
1273 dir)
1274 nil))
1276 (file
1277 ;;(file FN)
1278 (elinstall-actions-for-source-file
1279 (second spec) dir))
1282 ;;(in FN SPEC)
1283 (let
1284 ((new-dir
1285 (expand-file-name
1286 (second spec)
1287 dir)))
1289 (elinstall-find-actions-by-spec-x
1290 (third spec)
1291 new-dir)))
1293 (load-path
1294 ;;(load-path SPEC)
1295 (append
1296 `((add-to-load-path ,def-file ,dir))
1297 (let
1298 ((load-path-element dir)
1299 (add-to-load-path-p nil))
1300 (elinstall-find-actions-by-spec-x
1301 (second spec)
1302 dir))))
1304 (matching
1305 ;;(matching PATTERN SPEC)
1306 (apply #'nconc
1307 (mapcar
1308 #'(lambda (dir)
1309 ;;$$PUNT Assume that `block-in-subtree' and
1310 ;;`block-in-dir' aren't matched.
1311 (elinstall-find-actions-by-spec-x
1312 (third spec)
1313 dir))
1314 (directory-files
1315 dir t (second spec)))))
1316 (preload
1317 ;;(preload FN SYM &rest ARGS)
1318 (let
1319 ((key (third spec)))
1321 (and (symbolp key) (symbol-value key))
1322 `((preload-file
1324 ,(expand-file-name (second spec) dir)
1325 ,@(nthcdr 3 spec)))
1326 '()))))
1328 ;;Single symbols
1329 (case spec
1330 (dir
1331 (elinstall-actions-for-dir dir nil))
1332 ((t)
1333 (elinstall-actions-for-dir dir t)))))
1335 ;;;_ . elinstall-find-actions-by-spec
1336 (defun elinstall-find-actions-by-spec
1337 (spec load-path-element dir def-file redo-old)
1338 "Find the list of actions to do according to SPEC."
1340 (let
1342 (def-file-time (elinstall-file-mod-time def-file))
1343 (add-to-load-path-p t)
1344 (recurse-dirs-p t)
1345 (byte-compile t)
1346 (autoloads t)
1347 (preloads t)
1348 (block-in-dir '())
1349 (block-in-subtree '(".git" "RCS" "CVS" "SVN" "^tests\.el")))
1351 (declare (special
1352 load-path-element def-file add-to-load-path-p
1353 recurse-dirs-p byte-compile
1354 block-in-dir block-in-subtree))
1356 (elinstall-find-actions-by-spec-x spec dir)))
1358 ;;;_ . high-level work
1359 ;;;_ , elinstall-get-relevant-load-path
1360 (defun elinstall-get-relevant-load-path (actions)
1362 (delq nil
1363 (mapcar
1364 #'(lambda (act)
1365 (case (car act)
1366 (add-to-load-path
1367 (second act))
1368 (t nil)))
1369 actions)))
1370 ;;;_ , elinstall-get-deffile-list
1371 (defun elinstall-get-deffile-list (stages)
1372 "Get a list of deffile names"
1374 (mapcar
1375 #'car
1376 (elinstall-stages->build-deffiles stages)))
1377 ;;;_ , elinstall-x
1378 (defun elinstall-x (dir spec &optional force)
1379 "High-level worker function to install elisp files."
1380 (let*
1382 ;;This is just the default deffile, spec can override it.
1383 (def-file
1384 (elinstall-expand-deffile-name nil))
1385 (actions
1386 (elinstall-find-actions-by-spec
1387 spec
1390 def-file
1391 (eq force 'redo-old)))
1392 (stages (elinstall-segregate-actions actions))
1393 (use-load-path
1394 (elinstall-get-relevant-load-path
1395 actions)))
1397 (elinstall-stage-update-deffiles
1398 (elinstall-stages->build-deffiles stages)
1399 force
1400 use-load-path)
1401 (elinstall-stage-arrange-preloads
1402 (elinstall-stages->arrange-preloads stages)
1403 (elinstall-get-deffile-list stages)
1404 force)
1405 (elinstall-stage-byte-compile
1406 (elinstall-stages->byte-compile stages))
1408 ;;;_ , elinstall-package
1409 (defun elinstall-package (project-name path spec version-string)
1410 "Install elisp files. See doc for `elinstall'."
1411 (when
1412 (elinstall-proceed-p 'install
1413 (list
1414 '("Install %s? "
1415 "Re-install %s? "
1416 "Already installed %s.")
1417 project-name)
1418 (elinstall-already-installed project-name))
1419 (elinstall-x
1420 path
1421 `(def-file "loaddefs.el" (if-used ,project-name) ,spec)
1422 force)
1423 (elinstall-record-installed project-name version-string)))
1425 ;;;_ , Entry points
1426 ;;;_ . elinstall
1427 ;;;###autoload
1428 (defun elinstall (project-name path spec &optional force version-string)
1429 "Install elisp files.
1430 They need not be a formal package.
1432 Parameters:
1434 PROJECT-NAME - the name of the project
1436 PATH - Path to the project.
1437 Suggestion: Use (elinstall-directory-true-name) to get the real
1438 current directoery name even from loaded files.
1440 SPEC - a spec for the autoloads etc to make. It can be as simple
1441 as `t'.
1443 If FORCE is `t', install a package even if it has already been
1444 installed. If it's a list or `nil', it's treated as a list of
1445 installation restraints. User customizations override this
1446 argument.
1448 VERSION-STRING, if given, must be a string of the version for this package."
1450 (elinstall-call-with-restraints
1451 (if (eq force t)
1452 '((install always))
1453 force)
1454 project-name
1455 #'elinstall-package
1456 project-name path spec version-string))
1458 ;;;_ . elinstall-update-directory-autoloads
1460 ;;;###autoload
1461 (defun elinstall-update-directory-autoloads (dir)
1462 "Update autoloads for directory DIR"
1464 (interactive "DUpdate autoloads for all elisp files from directory: ")
1465 (elinstall-call-with-restraints
1466 '((autoloads t)
1467 (t nil))
1469 #'elinstall-x
1471 '(dir ".")))
1473 ;;;_ . elinstall-update-directory
1474 ;;;###autoload
1475 (defun elinstall-update-directory (dir)
1476 "Update autoloads for directory DIR"
1478 (interactive "DInstall all elisp files from directory: ")
1479 (elinstall-call-with-restraints
1482 #'elinstall-x
1484 '(dir ".")))
1486 ;;;_ . elinstall-update-file-autoloads
1487 ;;;###autoload
1488 (defun elinstall-update-file-autoloads (file)
1489 "Update autoloads for elisp file FILE"
1491 (interactive "fUpdate autoloads for elisp file: ")
1492 (elinstall-call-with-restraints
1495 #'elinstall-x
1496 (file-name-directory file)
1497 `(file ,(file-name-nondirectory file))))
1499 ;;;_ . elinstall-update-file
1500 ;;;###autoload
1501 (defun elinstall-update-file (file)
1502 "Install elisp file FILE"
1504 (interactive "fInstall elisp file: ")
1505 (elinstall-call-with-restraints
1506 '((autoloads t)
1507 (t nil))
1509 #'elinstall-x
1510 (file-name-directory file)
1511 `(file ,(file-name-nondirectory file))))
1513 ;;;_. Footers
1514 ;;;_ , Provides
1516 (provide 'elinstall)
1518 ;;;_ * Local emacs vars.
1519 ;;;_ + Local variables:
1520 ;;;_ + mode: allout
1521 ;;;_ + End:
1523 ;;;_ , End
1524 ;;; elinstall.el ends here