Try harder to keep update cached recipe

el-get-core.el

@@ -235,6 +235,44 @@ entry."
 
 (defalias 'el-get-package-installed-p #'el-get-package-is-installed)
 
+(defun el-get-pkg-op-button-action (button)
+  (let ((package (button-get button 'el-get-package)))
+    (when (y-or-n-p
+           (format "Really %s `%s'? "
+                   (button-get button 'el-get-pkg-verb) package))
+      (apply (button-get button 'el-get-pkg-fun) package
+             (button-get button 'el-get-pkg-extra-args)))))
+
+(define-button-type 'el-get-pkg-op
+  'action #'el-get-pkg-op-button-action
+  'follow-link t)
+
+(defun el-get-define-pkg-op-button-type (operation verb)
+  (define-button-type operation :supertype 'el-get-pkg-op
+    'el-get-pkg-fun operation
+    'el-get-pkg-verb verb
+    'help-echo (format "mouse-2, RET: %s package" verb)))
+
+(el-get-define-pkg-op-button-type 'el-get-install "install")
+(el-get-define-pkg-op-button-type 'el-get-reinstall "reinstall")
+(el-get-define-pkg-op-button-type 'el-get-update "update")
+(el-get-define-pkg-op-button-type 'el-get-remove "remove")
+
+(define-button-type 'el-get-file-jump
+  'action (lambda (button) (find-file (button-get button 'el-get-file)))
+  'follow-link t)
+(define-button-type 'el-get-recipe-file-jump :supertype 'el-get-file-jump
+  :help-echo "mouse-2, RET: find package's recipe file")
+(define-button-type 'el-get-cd :supertype 'el-get-file-jump
+  :help-echo "mouse-2, RET: open directory")
+
+(defun el-get-fmt-button (fmt label &rest props)
+  "`format' + `make-text-button'."
+  (let ((button (copy-sequence label))) ; don't change original string
+    ;; In 24.3, `make-text-button' returns position, not string.
+    (apply #'make-text-button button nil props) ; adds props by side-effect
+    (format fmt button)))
+
 
 ;;
 ;; Some tools

el-get-list-packages.el

@@ -29,59 +29,11 @@
   "Global var holding pointing to the package menu buffer, so
   that it can be updated from `el-get-save-package-status'")
 
-(define-button-type 'el-get-help-package-def
-  :supertype 'help-xref
-  'help-function (lambda (package) (find-file (el-get-recipe-filename package)))
-  'help-echo (purecopy "mouse-2, RET: find package's recipe"))
-
-(define-button-type 'el-get-help-install
-  :supertype 'help-xref
-  'help-function (lambda (package)
-                   (when (y-or-n-p
-                          (format "Do you really want to install `%s'? "
-                                  package))
-                     (el-get-install package)))
-  'help-echo (purecopy "mouse-2, RET: install package"))
-
-(define-button-type 'el-get-help-remove
-  :supertype 'help-xref
-  'help-function (lambda (package)
-                   (when (y-or-n-p
-                          (format "Do you really want to uninstall `%s'? "
-                                  package))
-                     (el-get-remove package)))
-  'help-echo (purecopy "mouse-2, RET: remove package"))
-
-(define-button-type 'el-get-help-update
-  :supertype 'help-xref
-  'help-function (lambda (package)
-                   (when (y-or-n-p
-                          (format "Do you really want to update `%s'? "
-                                  package))
-                     (el-get-update package)))
-  'help-echo (purecopy "mouse-2, RET: update package"))
-
-(define-button-type 'el-get-help-cd
-  :supertype 'help-xref
-  'help-function #'dired
-  'help-echo (purecopy "mouse-2, RET: open directory"))
-
-(define-button-type 'el-get-help-describe-package
+(define-button-type 'el-get-describe-package
   :supertype 'help-xref
   'help-function #'el-get-describe
   'help-echo (purecopy "mouse-2, RET: describe package"))
 
-(defun el-get-describe-princ-button (label regex type &rest args)
-  "Princ a new button with label LABEL.
-
-The LABEL is made clickable by calling `help-xref-button' for a backwards
-matching REGEX with TYPE and ARGS as parameter."
-  (princ label)
-  (with-current-buffer standard-output
-    (save-excursion
-      (re-search-backward regex nil t)
-      (apply #'help-xref-button 1 type args))))
-
 (defun el-get-guess-website (package)
   (let* ((type (el-get-package-type package))
          (guesser (el-get-method type :guess-website)))
@@ -102,70 +54,61 @@ matching REGEX with TYPE and ARGS as parameter."
          (minimum-version (plist-get def :minimum-emacs-version))
          (url (plist-get def :url))
          (depends (plist-get def :depends)))
-    (princ (format "%s is an `el-get' package.  " name))
+    (insert (format "%s is an `el-get' package.  " name))
     (if (eq type 'builtin)
-        (princ (format "It is built-in since Emacs %s" builtin))
-      (princ (format "It is currently %s "
-                     (if status
-                         status
-                       "not installed")))
+        (insert (format "It is built-in since Emacs %s" builtin))
+      (insert (format "It is currently %s "
+                      (or status "not installed")))
       (cond
        ((string= status "installed")
-        (el-get-describe-princ-button "[update]" "\\[\\([^]]+\\)\\]"
-                                      'el-get-help-update package)
-        (el-get-describe-princ-button "[remove]" "\\[\\([^]]+\\)\\]"
-                                      'el-get-help-remove package))
+        (insert (el-get-fmt-button "[%s]" "update" :type 'el-get-update
+                                   'el-get-package package))
+        (insert (el-get-fmt-button "[%s]" "remove" :type 'el-get-remove
+                                   'el-get-package package)))
        ((string= status "required")
-        (el-get-describe-princ-button "[update]" "\\[\\([^]]+\\)\\]"
-                                      'el-get-help-update package))
+        (insert (el-get-fmt-button "[%s]" "update" :type 'el-get-update
+                                   'el-get-package package)))
        (t
-        (el-get-describe-princ-button "[install]" "\\[\\([^]]+\\)\\]"
-                                      'el-get-help-install package))))
-    (princ ".\n\n")
+        (insert (el-get-fmt-button "[%s]" "install" :type 'el-get-install
+                                   'el-get-package package)))))
+    (insert ".\n\n")
 
     (let ((website (or website
                        (el-get-guess-website package))))
       (when website
-        (el-get-describe-princ-button (format "Website: %s\n" website)
-                                      ": \\(.+\\)" 'help-url website)))
+        (insert (el-get-fmt-button "Website: %s\n" website :type 'help-url
+                                   'help-args website))))
     (when descr
-      (princ (format "Description: %s\n" descr)))
+      (insert (format "Description: %s\n" descr)))
     (when depends
-      (if (listp depends)
-          (progn
-            (princ "Dependencies: ")
-            (loop for i in depends
-                  do (el-get-describe-princ-button
-                      (format "`%s'" i) "`\\([^`']+\\)"
-                      'el-get-help-describe-package i)))
-        (princ "Dependency: ")
-        (el-get-describe-princ-button
-         (format "`%s'" depends) "`\\([^`']+\\)"
-         'el-get-help-describe-package depends))
-      (princ ".\n"))
+      (insert "Dependencies:")
+      (loop for d in (el-get-as-list depends)
+            do (insert (el-get-fmt-button
+                        " `%s'" (symbol-name d)
+                        :type 'el-get-describe-package 'help-args d)))
+      (insert ".\n"))
     (when minimum-version
-      (princ (format "Requires minimum Emacs version: %s." minimum-version))
+      (insert (format "Requires minimum Emacs version: %s." minimum-version))
       (when (version-list-< (version-to-list emacs-version)
                             (el-get-version-to-list minimum-version))
-        (princ (format "  Warning: Your Emacs is too old (%s)!" emacs-version)))
-      (princ "\n"))
+        (insert (format "  Warning: Your Emacs is too old (%s)!" emacs-version)))
+      (insert "\n"))
     (if (eq type 'builtin)
-        (princ (format "The package is built-in since Emacs %s.\n" builtin))
-      (princ (format "The default installation method is %s%s.\n" type
-                     (if url (format " from %s" url) ""))))
+        (insert (format "The package is built-in since Emacs %s.\n" builtin))
+      (insert (format "The default installation method is %s%s.\n" type
+                      (if url (format " from %s" url) ""))))
     (when (string= status "installed")
-      (princ "Installed in ")
-      (el-get-describe-princ-button (format "`%s'" directory) "`\\([^']+\\)"
-                                    'el-get-help-cd directory)
-      (princ ".\n"))
-    (princ "\n")
-    (princ "Full definition")
+      (insert "Installed in ")
+      (insert (el-get-fmt-button "`%s'" directory :type 'el-get-cd
+                                 'el-get-file directory))
+      (insert ".\n"))
+    (insert "\n")
+    (insert "Full definition")
     (let ((file (el-get-recipe-filename package)))
-      (if (not file)
-          (princ ":\n")
-        (el-get-describe-princ-button (format " in `%s':\n" file)
-                                      "`\\([^`']+\\)"
-                                      'el-get-help-package-def package)))
+      (when file
+        (insert (el-get-fmt-button " in `%s'" file :type 'el-get-file-jump
+                                   'el-get-file file)))
+      (insert ":\n"))
     (el-get-recipe-pprint def)))
 
 (defun el-get-describe (package &optional interactive-p)

el-get-status.el

@@ -290,22 +290,30 @@ to the operation required."
         else do (setq reinstall (plist-put reinstall k v))
         finally return (list init update reinstall)))
 
-(defun el-get-diagnosis-properties (old-source new-source)
-  "Diagnosis difference between OLD-SOURCE and NEW-SOURCE.
-
-Return a list (REQUIRED-OPS ADDED REMOVED).  REQUIRED-OPS is list
-of one or more of `init', `update', or `reinstall' when
-OLD-SOURCE and NEW-SOURCE are different (nil otherwise).  It
-indicates which operations can perform the change.  ADDED and
-REMOVED are added and removed properties, respectively."
-  (let* ((added   (el-get-classify-new-properties old-source new-source))
-         (removed (el-get-classify-new-properties new-source old-source))
-         (min-op  (cond ((or (nth 2 added) (nth 2 removed)) 2)
-                        ((or (nth 1 added) (nth 1 removed)) 1)
-                        ((or (nth 0 added) (nth 0 removed)) 0))))
-    (list (and min-op (nthcdr min-op '(init update reinstall)))
-          (apply #'append (nthcdr (or min-op 0) added))
-          (apply #'append (nthcdr (or min-op 0) removed)))))
+(defun el-get-compute-new-status (operation old new)
+  "Return an update of OLD with NEW.
+
+Return a list (RESULT REQUIRED TO-ADD TO-REM), where RESULT is
+the updated recipe.  TO-ADD and TO-REM are the list properties
+that prevent a full update with the given OPERATION, REQUIRED is
+a list of operations that would allow a full update."
+  (let* ((ops       '(init update reinstall))
+         (op-rank   (1- (length (memq operation ops))))
+         (ops-given (butlast ops op-rank))
+         (rem-props (el-get-classify-new-properties new old))
+         (add-props (el-get-classify-new-properties old new))
+         (rem-allow (apply #'append (butlast rem-props op-rank)))
+         (add-allow (apply #'append (butlast add-props op-rank)))
+         (no-rem    (last rem-props op-rank))
+         (no-add    (last add-props op-rank)))
+    (list (nconc (loop for (key val) on old by #'cddr
+                       unless (plist-member rem-allow key)
+                       nconc (list key val))
+                 add-allow)
+          (loop for i from (1- (length ops)) downto (length ops-given)
+                when (or (nth i rem-props) (nth i add-props))
+                return (nthcdr i ops))
+          (apply #'append no-add) (apply #'append no-rem))))
 
 (defun el-get-package-or-source (package-or-source)
   "Given either a package name or a full source entry, return a
@@ -328,50 +336,55 @@ REMOVED are added and removed properties, respectively."
         (error "Package %s is nowhere to be found in el-get status file."
                package))))
 
-(defun el-get-merge-properties-into-status (package-or-source
-                                            operation
-                                            &rest keys)
-  "Merge updatable properties for package into package status alist (or status file).
+(el-get-define-pkg-op-button-type 'el-get-merge-properties-into-status
+                                  "force cached recipe update of")
 
-The first argument is either a package source or a package name,
-in which case the source will be read using
-`el-get-package-def'. The named package must already be
-installed.
+(defun el-get-merge-properties-into-status (package operation &rest keys)
+  "Merge updatable properties for package into status file.
 
-If the new source differs only in whitelisted properties (see
-`el-get-status-recipe-updatable-properties'), then the updated
-values for those properties will be written to the status
-file.
+PACKAGE is either a package source or name, in which case the
+source will be read using `el-get-package-def'.  The named
+package must already be installed.
 
-If any non-whitelisted properties differ from the cached values,
-then an error is raise. With optional keyword argument `:noerror
-t', this error is suppressed (but nothing is updated).
+Warn about any non-whitelisted for OPERATION properties differing
+from the cached values.
 
-\(fn PACKAGE-OR-SOURCE &key NOERROR)"
+Interactively, OPERATION is `update' with prefix arg, `reinstall'
+with double prefix arg, or `init' otherwise."
   (interactive
    (list (el-get-read-package-with-status "Update cached recipe" "installed")
-         'init
-         :noerror current-prefix-arg))
-  (let* ((noerror      (cadr (memq :noerror keys)))
-         (source       (el-get-package-or-source package-or-source))
-         (package      (el-get-as-symbol (el-get-source-name source)))
-         (cached-recipe
-          (el-get-read-cached-recipe package source)))
+         (cond ((equal '(16) current-prefix-arg) 'reinstall)
+               (current-prefix-arg 'update)
+               (t 'init))))
+  (let* ((source       (el-get-package-or-source package))
+         (package      (plist-get source :name))
+         (cached       (el-get-read-cached-recipe package source)))
     (unless (el-get-package-is-installed package)
       (error "Package %s is not installed. Cannot update recipe." package))
-    (destructuring-bind (required-ops added removed)
-        (el-get-diagnosis-properties cached-recipe source)
-      (if (and required-ops (not (memq operation required-ops)))
-        ;; Emit a verbose message if `noerror' is t (but still quit
-        ;; the function).
-        (funcall (if noerror 'el-get-verbose-message 'error)
-                 (concat "Must %s `%s' to modify its cached recipe\n"
-                         "  adding:   %s"
-                         "  removing: %s")
-                 (mapconcat #'symbol-name required-ops " or ") package
-                 (if   added (pp-to-string   added) "()\n")
-                 (if removed (pp-to-string removed) "()\n"))
+    (destructuring-bind (new-src required-ops no-add no-rem)
+        (el-get-compute-new-status operation cached source)
+      (el-get-save-package-status package "installed" new-src)
       (when required-ops
-        (el-get-save-package-status package "installed" source))))))
+        (lwarn '(el-get recipe-cache) :warning
+               (concat "Must %s `%s' to modify its cached recipe\n"
+                       "  adding:   %s"
+                       "  removing: %s"
+                       (el-get-fmt-button
+                        "  Or %s if you know these changes are safe.\n"
+                        "force update the cached recipe"
+                        :type 'el-get-merge-properties-into-status
+                        'el-get-package package 'el-get-pkg-extra-args '(reinstall)))
+               (mapconcat (lambda (op)
+                            (el-get-fmt-button
+                             "%s" op :type (intern (concat "el-get-" op))
+                             'el-get-package package))
+                          (mapcar #'symbol-name required-ops) " or ")
+               package
+               (if no-add (pp-to-string no-add) "()\n")
+               (if no-rem (pp-to-string no-rem) "()\n"))))))
+
+;; Using `declare' in `defun' only supported from Emacs 24.3.
+(set-advertised-calling-convention
+ 'el-get-merge-properties-into-status '(package operation) "May 2016")
 
 (provide 'el-get-status)

el-get.el

@@ -375,7 +375,7 @@ this warning either uninstall one of the el-get or package.el
 version of %s, or call `el-get' before `package-initialize' to
 prevent package.el from loading it."  package package)))
   (when el-get-auto-update-cached-recipes
-    (el-get-merge-properties-into-status package 'init :noerror t))
+    (el-get-merge-properties-into-status package 'init))
   (condition-case err
       (let* ((el-get-sources (el-get-package-status-recipes))
              (source   (el-get-read-package-status-recipe package))
@@ -633,7 +633,7 @@ PACKAGE may be either a string or the corresponding symbol."
 (defun el-get-post-update-build (package)
   "Function to call after building the package while updating it."
   ;; fix trailing failed installs
-  (el-get-merge-properties-into-status package 'update :noerror t)
+  (el-get-merge-properties-into-status package 'update)
   (when (string= (el-get-read-package-status package) "required")
     (el-get-save-package-status package "installed"))
   (el-get-invalidate-autoloads package)