From 03e045b40b8ecce882157e59e4de032ebe440dcd Mon Sep 17 00:00:00 2001 From: "Tom Breton (Tehom)" Date: Fri, 24 Dec 2010 14:23:37 -0500 Subject: [PATCH] New function elinstall-call-with-restraints. Use elinstall-proceed-p. --- elinstall.el | 149 +++++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 94 insertions(+), 55 deletions(-) diff --git a/elinstall.el b/elinstall.el index d499793..7eecc9f 100644 --- a/elinstall.el +++ b/elinstall.el @@ -170,19 +170,52 @@ CAUTION: This is sensitive to where it's called. That's the point of it." (expand-file-name "lisp" source-directory))) ;;;_ . Checking restraint specs -(defun elinstall-proceed-p (topic restraints-1 restraints-2 old-p - redo-prompt ask-prompt) - "Return non-nil if actions on TOPIC should proceed." +;;;_ , elinstall-call-with-restraints +(defun elinstall-call-with-restraints (restraints package func &rest args) + "Call FUNC with ARGS, in scope of RESTRAINTS. +RESTRAINTS is a list of package restraints. User restraints for the +given package will also be applied in scope. + +PACKAGE can be `t' or a string naming a package." + + (let* + ((elinstall:*pkg-restraints* restraints) + ;;$$PUNT for now. Figure out user restraints for this + ;;package. + (elinstall:*user-restraints* + nil)) + (declare (special + elinstall:*pkg-restraints* + elinstall:*user-restraints*)) + (apply func args))) +;;;_ , +(defun elinstall-proceed-p (topic ask-prompt &optional old-p redo-prompt) + "Return non-nil if actions on TOPIC should proceed. +Call this transitively only thru `elinstall-call-with-restraints'" (check-type topic symbol) + (declare (special + elinstall:*pkg-restraints* + elinstall:*user-restraints*)) + (unless (and + (boundp 'elinstall:*pkg-restraints*) + (boundp 'elinstall:*user-restraints*)) + (error "elinstall-proceed-p called out of scope")) + (let* - ( (cell (assq topic restraints-1)) + ( (cell (assq topic elinstall:*user-restraints*)) + (cell (or cell (assq t elinstall:*user-restraints*))) (cell + ;;`t' means use the pkg-restraints value instead. (if (or (not cell) (eq (second cell) t)) - (assq topic restraints-2) - cell))) - (case (second cell) + (assq topic elinstall:*pkg-restraints*) + cell)) + (cell (or cell (assq t elinstall:*pkg-restraints*))) + ;;Default is to just update. + (treatment + (if cell (second cell) 'update))) + (case treatment ((nil) nil) ((t always) @@ -1002,21 +1035,14 @@ Special variables are as noted in \"List of special variables\"." (ignore-errors (with-current-buffer buf (not no-byte-compile))) - (let* - ((dest (byte-compile-dest-file full-path)) - (yes-1 - (cond - ((file-exists-p dest) - (or (eq byte-compile 'always) - (file-newer-than-file-p full-path dest))) - ((memq byte-compile '(t update ask)) - t)))) - (if (eq byte-compile 'ask) + (elinstall-proceed-p 'byte-compile + (concat "Compile " filename "? ") + (let + ((dest (byte-compile-dest-file full-path))) (and - yes-1 - (y-or-n-p - (concat "Compile " filename "? "))) - yes-1))))) + (file-exists-p dest) + (file-newer-than-file-p full-path dest))) + (concat "Recompile " filename "? "))))) (prog1 (list @@ -1320,6 +1346,20 @@ Recurse just if RECURSE-DIRS-P" (elinstall-stage-byte-compile (elinstall-stages->byte-compile stages)) t)) +;;;_ , elinstall-package +(defun elinstall-package (project-name path spec version-string) + "Install elisp files. See doc for `elinstall'." + (when + (elinstall-proceed-p 'install + (format "Install %s? " project-name) + (elinstall-already-installed project-name) + (format "Re-install %s? " project-name)) + (elinstall-x + path + `(def-file "loaddefs.el" (if-used ,project-name) ,spec) + force) + (elinstall-record-installed project-name version-string))) + ;;;_ , Entry points ;;;_ . elinstall ;;;###autoload @@ -1335,36 +1375,23 @@ PATH - Path to the project. Suggestion: Use (elinstall-directory-true-name) to get the real current directoery name even from loaded files. -SPEC - a spec for the autoloads etc to make. It can be as simple as -\(dir \"\.\") for installing one directory. +SPEC - a spec for the autoloads etc to make. It can be as simple +as `t'. -If FORCE is t, install a package even if it has already been -installed. If it's a list, it's treated as a list of +If FORCE is `t', install a package even if it has already been +installed. If it's a list or `nil', it's treated as a list of installation restraints. User customizations override this -argument." - - ;;$$IMPROVE ME - override these with user spec if there's one given - ;;for this package. - (let* - ((restraints - (if (eq force t) - '((install 'always)) - force))) - (when ;;(elinstall-proceed-p 'install restraints) - (or - ;;$$ENCAP ME - (let* - ((cell (assq 'install restraints))) - (and cell (eq (second cell) 'always))) - (not (elinstall-already-installed project-name)) - (yes-or-no-p (format "Re-install %s? " project-name))) - (elinstall-x - path - `(def-file "loaddefs.el" (if-used ,project-name) ,spec) - force) - (elinstall-record-installed project-name version-string)))) +argument. +VERSION-STRING, if given, must be a string of the version for this package." + (elinstall-call-with-restraints + (if (eq force t) + '((install 'always)) + force) + project-name + #'elinstall-package + project-name path spec version-string)) ;;;_ . elinstall-update-directory-autoloads @@ -1373,10 +1400,13 @@ argument." "Update autoloads for directory DIR" (interactive "DUpdate autoloads for all elisp files from directory: ") - (elinstall-x + (elinstall-call-with-restraints + '((autoloads t) + (t nil)) + t + #'elinstall-x dir - `(control byte-compile nil - (dir ".")))) + '(dir "."))) ;;;_ . elinstall-update-directory ;;;###autoload @@ -1384,7 +1414,10 @@ argument." "Update autoloads for directory DIR" (interactive "DInstall all elisp files from directory: ") - (elinstall-x + (elinstall-call-with-restraints + '() + t + #'elinstall-x dir '(dir "."))) @@ -1394,10 +1427,12 @@ argument." "Update autoloads for elisp file FILE" (interactive "fUpdate autoloads for elisp file: ") - (elinstall-x + (elinstall-call-with-restraints + '() + t + #'elinstall-x (file-name-directory file) - `(control byte-compile nil - (file ,(file-name-nondirectory file))))) + `(file ,(file-name-nondirectory file)))) ;;;_ . elinstall-update-file ;;;###autoload @@ -1405,7 +1440,11 @@ argument." "Install elisp file FILE" (interactive "fInstall elisp file: ") - (elinstall-x + (elinstall-call-with-restraints + '((autoloads t) + (t nil)) + t + #'elinstall-x (file-name-directory file) `(file ,(file-name-nondirectory file)))) -- 2.11.4.GIT