diff --git a/el-get-core.el b/el-get-core.el index f22a7bdf6..024c459ea 100644 --- a/el-get-core.el +++ b/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 diff --git a/el-get-list-packages.el b/el-get-list-packages.el index 8b20a6d6f..5b503d78e 100644 --- a/el-get-list-packages.el +++ b/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) diff --git a/el-get-status.el b/el-get-status.el index 806f105aa..28e618714 100644 --- a/el-get-status.el +++ b/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) diff --git a/el-get.el b/el-get.el index f8d231a28..6b9d82d80 100644 --- a/el-get.el +++ b/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) diff --git a/test/el-get-tests.el b/test/el-get-tests.el index 54e59de88..a93179bb6 100644 --- a/test/el-get-tests.el +++ b/test/el-get-tests.el @@ -7,6 +7,16 @@ (defmacro* ert-deftest (name () &body docstring-keys-and-body) (message "Skipping tests, ERT is not available")))) +(defun el-get-plist-equal (plist1 plist2) + (let ((keys (el-get-plist-keys plist1))) + (and (equal (sort keys #'string<) + (sort (el-get-plist-keys plist2) #'string<)) + (loop for key in keys + unless (equal (plist-get plist1 key) + (plist-get plist2 key)) + return nil + finally return t)))) + (defvar el-get-test-output-buffer nil) (when noninteractive (defadvice message (around el-get-test-catch-output activate) @@ -232,3 +242,105 @@ John.Doe-123_@example.com")) (lambda (package url) (error "Leave 'el-get-insecure-check to git")))) (should (el-get-do-update "dummy"))))) + +(defun el-get-test-compute-new-status-equal (status1 status2) + "Check equality for `el-get-compute-new-status' results." + (and (el-get-plist-equal (nth 0 status1) (nth 0 status2)) + (equal (nth 1 status1) (nth 1 status2)) + (el-get-plist-equal (nth 2 status1) (nth 2 status2)) + (el-get-plist-equal (nth 3 status1) (nth 3 status2)))) + +(ert-deftest el-get-test-compute-new-status () + "Test `el-get-compute-new-status'." + (let* ((old '(:name a + :type git + :load-path "load-old" + :depends (depends old) + :build (("build" "old")) + :build/gnu-linux (("build/gnu-linux" "old")) + :url "http://example.com/url/old")) + (new '(:name a + :type git + :load-path "load-new" + :depends (depends new) + :build (("build" "new")) + :build/gnu-linux (("build/gnu-linux" "new")) + :url "http://example.com/url/new")) + (expected '((:name a + :type git + :load-path "load-new" + :depends (depends old) + :build (("build" "old")) + :build/gnu-linux (("build/gnu-linux" "old")) + :url "http://example.com/url/old") + (reinstall) + (:depends (depends new) + :build (("build new")) + :build/gnu-linux (("build/gnu-linux" "new")) + :url "http://example.com/url/new") + (:depends (depends old) + :build (("build old")) + :build/gnu-linux (("build/gnu-linux" "old")) + :url "http://example.com/url/old"))) + (update-expected '((:name a + :type git + :load-path "load-new" + :depends (depends new) + :build (("build" "new")) + :build/gnu-linux (("build/gnu-linux" "new")) + :url "http://example.com/url/old") + (reinstall) + (:url "http://example.com/url/new") + (:url "http://example.com/url/old")))) + (should (el-get-test-compute-new-status-equal + (el-get-compute-new-status 'init old new) + expected)) + (should (el-get-test-compute-new-status-equal + (el-get-compute-new-status 'update old new) + update-expected)) + (should (el-get-test-compute-new-status-equal + (el-get-compute-new-status 'reinstall old new) + (list new nil nil nil))))) + +(ert-deftest el-get-test-compute-new-status-2 () + "Test `el-get-compute-new-status'." + (let* ((old '(:name a + :type git + :load-path "load-old" + :depends (depends old) + :build (("build" "old")) + :build/gnu-linux (("build/gnu-linux" "old")) + :url "http://example.com/url/old")) + (new '(:name a + :type git + :load-path "load-new" + :depends (depends new) + :build (("build" "new")) + :build/gnu-linux (("build/gnu-linux" "new")) + :url "http://example.com/url/old")) + (init-result (el-get-compute-new-status 'init old new)) + (init-expected '((:name a + :type git + :load-path "load-new" + :depends (depends old) + :build (("build" "old")) + :build/gnu-linux (("build/gnu-linux" "old")) + :url "http://example.com/url/old") + (update reinstall) + (:depends (depends new) + :build (("build new")) + :build/gnu-linux (("build/gnu-linux" "new"))) + (:depends (depends old) + :build (("build old")) + :build/gnu-linux (("build/gnu-linux" "old"))))) + (update-result (el-get-compute-new-status 'update old new)) + (update-expected '((:name a + :type git + :load-path "load-new" + :depends (depends new) + :build (("build" "new")) + :build/gnu-linux (("build/gnu-linux" "new")) + :url "http://example.com/url/old") + nil nil nil))) + (should (el-get-test-compute-new-status-equal init-result init-expected)) + (should (el-get-test-compute-new-status-equal update-result update-expected))))