diff --git a/core/libs/quelpa.el b/core/libs/quelpa.el index 6297fa7e3..9ae9f2f4b 100644 --- a/core/libs/quelpa.el +++ b/core/libs/quelpa.el @@ -142,11 +142,17 @@ If nil the update is disabled and the repo is only updated on (defcustom quelpa-self-upgrade-p t "If non-nil upgrade quelpa itself when doing a - `quelpa-upgrade', otherwise only upgrade the packages in the - quelpa cache." +`quelpa-upgrade-all', otherwise only upgrade the packages in the +quelpa cache." :group 'quelpa :type 'boolean) +(defcustom quelpa-git-clone-depth 1 + "If non-nil shallow clone quelpa git recipes." + :group 'quelpa + :type '(choice (const :tag "Don't shallow clone" nil) + (integer :tag "Depth"))) + (defvar quelpa-initialized-p nil "Non-nil when quelpa has been initialized.") @@ -210,13 +216,15 @@ On error return nil." (package-buffer-info)) (`tar (insert-file-contents-literally file) (tar-mode) - (if (help-function-arglist 'package-tar-file-info) - ;; legacy `package-tar-file-info' requires an arg - (package-tar-file-info file) - (with-no-warnings (package-tar-file-info))))))))) + (with-no-warnings + (if (help-function-arglist 'package-tar-file-info) + ;; legacy `package-tar-file-info' requires an arg + (package-tar-file-info file) + (package-tar-file-info))))))))) (pcase desc ((pred package-desc-p) desc) - ((pred vectorp) (package-desc-from-legacy desc kind))))) + ((pred vectorp) (when (fboundp 'package-desc-from-legacy) + (package-desc-from-legacy desc kind)))))) (defun quelpa-archive-file-name (archive-entry) "Return the path of the file in which the package for ARCHIVE-ENTRY is stored." @@ -235,24 +243,23 @@ On error return nil." (and pkg-desc (version-list-<= (version-to-list version) - (if (functionp 'package-desc-vers) - (package-desc-vers pkg-desc) ;old implementation - (package-desc-version (car pkg-desc)))))) + (package-desc-version (car pkg-desc))))) ;; Also check built-in packages. (package-built-in-p name (version-to-list version))))) (defun quelpa-checkout (rcp dir) - "Return the version of the new package given a RCP. + "Return the version of the new package given a RCP and DIR. Return nil if the package is already installed and should not be upgraded." (pcase-let ((`(,name . ,config) rcp) (quelpa-build-stable quelpa-stable-p)) (unless (or (and (assq name package-alist) (not quelpa-upgrade-p)) (and (not config) (quelpa-message t "no recipe found for package `%s'" name))) - (let ((version (condition-case err + (let ((version (condition-case-unless-debug err (quelpa-build-checkout name config dir) - (error "Failed to checkout `%s': `%s'" - name (error-message-string err))))) + (error + (error "Failed to checkout `%s': `%s'" + name (error-message-string err)))))) (when (quelpa-version>-p name version) version))))) @@ -260,7 +267,7 @@ Return nil if the package is already installed and should not be upgraded." "Build a package from the given recipe RCP. Uses the `package-build' library to get the source code and build an elpa compatible package in `quelpa-build-dir' storing it in -`quelpa-packages-dir'. Return the path to the created file or nil +`quelpa-packages-dir'. Return the path to the created file or nil if no action is necessary (like when the package is installed already and should not be upgraded etc)." (let* ((name (car rcp)) @@ -308,7 +315,7 @@ already and should not be upgraded etc)." (mapcar (lambda (file) (expand-file-name file path)) ;; Without first two entries because they are always "." and "..". - (cddr (directory-files path)))) + (remove ".." (remove "." (directory-files path))))) result)) (defun quelpa-expand-source-file-list (file-path config) @@ -415,6 +422,10 @@ if `quelpa-build-timeout-executable' is non-nil." Certain package names (e.g. \"@\") may not work properly with a BSD tar." :type '(file :must-match t)) +(defvar quelpa--tar-type nil + "Type of `quelpa-build-tar-executable'. Can be `gnu' or `bsd'. +nil means the type is not decided yet.") + (defcustom quelpa-build-explicit-tar-format-p nil "If non-nil pass \"--format=gnu\" option to tar command. @@ -422,6 +433,7 @@ Passing the option is necessary on the systems where the default tar format isn't gnu." :type 'boolean) + (defcustom quelpa-build-version-regexp "^[rRvV]?\\(.*\\)$" "Default pattern for matching valid version-strings within repository tags. The string in the capture group should be parsed as valid by `version-to-list'." @@ -488,15 +500,17 @@ or nil if the version cannot be parsed." (defun quelpa-build--find-parse-time (regexp &optional bound) "Find REGEXP in current buffer and format as a time-based version string. -An optional second argument bounds the search; it is a buffer -position. The match found must not end after that position." +An optional second argument BOUND bounds the search; it is a +buffer position. The match found must not end after that +position." (and (re-search-backward regexp bound t) (quelpa-build--parse-time (match-string-no-properties 1)))) (defun quelpa-build--find-parse-time-newest (regexp &optional bound) "Find REGEXP in current buffer and format as a time-based version string. -An optional second argument bounds the search; it is a buffer -position. The match found must not end after that position." +An optional second argument BOUND bounds the search; it is a +buffer position. The match found must not end after that +position." (save-match-data (let (cur matches) (while (setq cur (quelpa-build--find-parse-time regexp bound)) @@ -505,8 +519,9 @@ position. The match found must not end after that position." (defun quelpa-build--find-version-newest (regexp &optional bound) "Find the newest version matching REGEXP before point. -An optional second argument bounds the search; it is a buffer -position. The match found must not before after that position." +An optional second argument BOUND bounds the search; it is a +buffer position. The match found must not before after that +position." (let ((tags (split-string (buffer-substring-no-properties (or bound (point-min)) (point)) @@ -544,9 +559,13 @@ position. The match found must not before after that position." ;;; Run Process (defun quelpa-build--run-process (dir command &rest args) - "In DIR (or `default-directory' if unset) run COMMAND with ARGS. + "In DIR run COMMAND with ARGS. +If DIR is unset, try to run from `quelpa-build-dir' +or variable `temporary-file-directory'. Output is written to the current buffer." - (let ((default-directory (file-name-as-directory (or dir default-directory))) + (let ((default-directory (file-name-as-directory (or dir + quelpa-build-dir + temporary-file-directory))) (argv (nconc (unless (eq system-type 'windows-nt) (list "env" "LC_ALL=C")) (if quelpa-build-timeout-executable @@ -855,18 +874,21 @@ Return a cons cell whose `car' is the root and whose `cdr' is the repository." ;;;; Git -(defun quelpa-build--git-repo (dir) - "Get the current git repo for DIR." +(defun quelpa-build--git-repo (dir remote) + "Get the current git repo for DIR from REMOTE." (quelpa-build--run-process-match - "Fetch URL: \\(.*\\)" dir "git" "remote" "show" "-n" "origin")) + "Fetch URL: \\(.*\\)" dir "git" "remote" "show" "-n" remote)) (defun quelpa-build--checkout-git (name config dir) "Check package NAME with config CONFIG out of git into DIR." - (let ((repo (plist-get config :url)) - (commit (or (plist-get config :commit) - (let ((branch (plist-get config :branch))) - (when branch - (concat "origin/" branch)))))) + (let* ((repo (plist-get config :url)) + (remote (or (plist-get config :remote) "origin")) + (commit (or (plist-get config :commit) + (let ((branch (plist-get config :branch))) + (when branch (concat remote "/" branch))))) + (depth (or (plist-get config :depth) quelpa-git-clone-depth)) + (force (plist-get config :force)) + (use-current-ref (plist-get config :use-current-ref))) (when (string-match (rx bos "file://" (group (1+ anything))) repo) ;; Expand local file:// URLs (setq repo (expand-file-name (match-string 1 repo)))) @@ -874,14 +896,22 @@ Return a cons cell whose `car' is the root and whose `cdr' is the repository." (goto-char (point-max)) (cond ((and (file-exists-p (expand-file-name ".git" dir)) - (string-equal (quelpa-build--git-repo dir) repo)) + (string-equal (quelpa-build--git-repo dir remote) repo)) (quelpa-build--princ-exists dir) - (quelpa-build--run-process dir "git" "fetch" "--all" "--tags")) + (quelpa-build--run-process dir "git" "fetch" "--tags" remote)) (t (when (file-exists-p dir) (delete-directory dir t)) (quelpa-build--princ-checkout repo dir) - (quelpa-build--run-process nil "git" "clone" repo dir))) + (apply #'quelpa-build--run-process + (append + `(nil "git" "clone" ,repo ,dir) + `("--origin" ,remote) + (when (and depth (not (plist-get config :commit))) + `("--depth" ,(int-to-string depth) + "--no-single-branch")) + (let ((branch (plist-get config :branch))) + (when branch `("--branch" ,branch))))))) (if quelpa-build-stable (let* ((min-bound (goto-char (point-max))) (tag-version @@ -893,12 +923,16 @@ Return a cons cell whose `car' is the root and whose `cdr' is the repository." (error "No valid stable versions found for %s" name))))) ;; Using reset --hard here to comply with what's used for ;; unstable, but maybe this should be a checkout? - (quelpa-build--update-git-to-ref - dir (concat "tags/" (cadr tag-version))) + (unless use-current-ref + (quelpa-build--update-git-to-ref + dir (concat "tags/" (cadr tag-version)) + force)) ;; Return the parsed version as a string (package-version-join (car tag-version))) - (quelpa-build--update-git-to-ref - dir (or commit (concat "origin/" (quelpa-build--git-head-branch dir)))) + (unless use-current-ref + (quelpa-build--update-git-to-ref + dir (or commit (concat remote "/" (quelpa-build--git-head-branch dir))) + force)) (apply 'quelpa-build--run-process dir "git" "log" "--first-parent" "-n1" "--pretty=format:'\%ci'" (quelpa-build--expand-source-file-list dir config)) @@ -919,9 +953,18 @@ Return a cons cell whose `car' is the root and whose `cdr' is the repository." (quelpa-build--run-process-match "\\(.*\\)" dir "git" "rev-parse" "HEAD"))) -(defun quelpa-build--update-git-to-ref (dir ref) - "Update the git repo in DIR so that HEAD is REF." - (quelpa-build--run-process dir "git" "reset" "--hard" ref) +(defun quelpa-build--update-git-to-ref (dir ref &optional force) + "Update the git repo in DIR so that HEAD is REF. +This will perform an checkout or a reset if FORCE." + (condition-case nil + (quelpa-build--run-process dir "git" "cat-file" "-e" ref) + (error + ;; unshallow if needed + (quelpa-build--run-process dir "git" "fetch" "--unshallow" "--tags"))) + (if force + (quelpa-build--run-process dir "git" "reset" "--hard" ref) + (with-demoted-errors "Error: %s" + (quelpa-build--run-process dir "git" "checkout" ref))) (quelpa-build--run-process dir "git" "submodule" "sync" "--recursive") (quelpa-build--run-process dir "git" "submodule" "update" "--init" "--recursive")) @@ -1087,9 +1130,23 @@ Optionally PRETTY-PRINT the data." (when (file-exists-p file) (car (read-from-string (quelpa-build--slurp-file file))))) +(defun quelpa--tar-type () + "Return `bsd' or `gnu' depending on type of Tar executable. +Tests and sets variable `quelpa--tar-type' if not already set." + (or quelpa--tar-type + (when (and quelpa-build-tar-executable + (file-executable-p quelpa-build-tar-executable)) + (setq quelpa--tar-type + (let ((v (shell-command-to-string + (format "%s --version" quelpa-build-tar-executable)))) + (cond ((string-match-p "bsdtar" v) 'bsd) + ((string-match-p "GNU tar" v) 'gnu) + (t 'gnu))))))) + (defun quelpa-build--create-tar (file dir &optional files) "Create a tar FILE containing the contents of DIR, or just FILES if non-nil." - (when (eq system-type 'windows-nt) + (when (and (eq (quelpa--tar-type) 'gnu) + (eq system-type 'windows-nt)) (setq file (replace-regexp-in-string "^\\([a-z]\\):" "/\\1" file))) (apply 'process-file quelpa-build-tar-executable nil @@ -1600,6 +1657,7 @@ Return t in each case." (insert (prin1-to-string quelpa-cache)))))) (defun quelpa-update-cache (cache-item) + "Update `quelpa-cache' with new CACHE-ITEM." ;; try removing existing recipes by name (setq quelpa-cache (cl-remove (car cache-item) quelpa-cache :key #'car)) @@ -1617,7 +1675,7 @@ Return t in each case." (setf (cdr (last cache-item)) '(:stable t)))) (defun quelpa-checkout-melpa () - "Fetch or update the melpa source code from GitHub. + "Fetch or update the melpa source code from Github. If there is no error return non-nil. If there is an error but melpa is already checked out return non-nil. If there is an error and no existing checkout return nil." @@ -1628,7 +1686,7 @@ If there is an error and no existing checkout return nil." 'package-build `(:url ,quelpa-melpa-repo-url :files ("*")) quelpa-melpa-dir) - (error "failed to checkout melpa git repo: `%s'" (error-message-string err))))) + (error "Failed to checkout melpa git repo: `%s'" (error-message-string err))))) (defun quelpa-get-melpa-recipe (name) "Read recipe with NAME for melpa git checkout. @@ -1667,7 +1725,7 @@ Return non-nil if quelpa has been initialized properly." (ignore-errors (delete-directory quelpa-packages-dir t))) (defun quelpa-arg-rcp (arg) - "Given recipe or package name, return an alist '(NAME . RCP). + "Given recipe or package name ARG, return an alist '(NAME . RCP). If RCP cannot be found it will be set to nil" (pcase arg (`(,a . nil) (quelpa-get-melpa-recipe (car arg))) @@ -1696,9 +1754,8 @@ If t, `quelpa' tries building the stable version of a package." (defun quelpa-package-install-file (file) "Workaround problem with `package-install-file'. `package-install-file' uses `insert-file-contents-literally' -which causes problems when the file inserted has crlf line -endings (Windows). So here we replace that with -`insert-file-contents' for non-tar files." +which causes problems when the FILE inserted has crlf line endings (Windows). +So here we replace that with `insert-file-contents' for non-tar files." (if (eq system-type 'windows-nt) (cl-letf* ((insert-file-contents-literally-orig (symbol-function 'insert-file-contents-literally)) @@ -1710,12 +1767,12 @@ endings (Windows). So here we replace that with (package-install-file file)) (package-install-file file))) -(defun quelpa-package-install (arg) +(defun quelpa-package-install (arg &rest plist) "Build and install package from ARG (a recipe or package name). -If the package has dependencies recursively call this function to -install them." +PLIST is a plist that may modify the build and/or fetch process. +If the package has dependencies recursively call this function to install them." (let* ((rcp (quelpa-arg-rcp arg)) - (file (and rcp (quelpa-build rcp)))) + (file (when rcp (quelpa-build (append rcp plist))))) (when file (let* ((pkg-desc (quelpa-get-package-desc file)) (requires (package-desc-reqs pkg-desc))) @@ -1744,7 +1801,7 @@ install them." ;;;###autoload (defun quelpa-expand-recipe (recipe-name) - "Expand a given recipe name into full recipe. + "Expand a given RECIPE-NAME into full recipe. If called interactively, let the user choose a recipe name and insert the result into the current buffer." (interactive (list (quelpa-interactive-candidate))) @@ -1764,11 +1821,12 @@ ARGS are additional options for the quelpa recipe." (quelpa (append quelpa-recipe args) :upgrade t))) ;;;###autoload -(defun quelpa-upgrade () +(defun quelpa-upgrade-all (&optional force) "Upgrade all packages found in `quelpa-cache'. This provides an easy way to upgrade all the packages for which -the `quelpa' command has been run in the current Emacs session." - (interactive) +the `quelpa' command has been run in the current Emacs session. +With prefix FORCE, packages will all be upgraded discarding local changes." + (interactive "P") (when (quelpa-setup-p) (let ((quelpa-upgrade-p t)) (when quelpa-self-upgrade-p @@ -1777,9 +1835,34 @@ the `quelpa' command has been run in the current Emacs session." (cl-remove-if-not #'package-installed-p quelpa-cache :key #'car)) (mapc (lambda (item) (when (package-installed-p (car (quelpa-arg-rcp item))) - (quelpa item))) + (quelpa item :force force))) quelpa-cache)))) +;;;###autoload +(defun quelpa-upgrade (rcp &optional action) + "Upgrade a package found in `quelpa-cache' with recipe RCP. +Optionally, ACTION can be passed for non-interactive call with value of: +- `force' (or \\[universal-argument] \\[quelpa-upgrade]) for forced upgrade. +- `local' (or \\[universal-argument] \\[universal-argument] \\[quelpa-upgrade]) + for upgrade using current working tree." + (interactive + (when (quelpa-setup-p) + (let* ((quelpa-melpa-recipe-stores (list quelpa-cache)) + (name (quelpa-interactive-candidate)) + (prefix (prefix-numeric-value current-prefix-arg))) + (list (assoc name quelpa-cache) + (cond ((eq prefix 4) 'force) + ((eq prefix 16) 'local)))))) + (when rcp + (let ((quelpa-upgrade-p t) + (current-prefix-arg nil) + (config (cond ((eq action 'force) `(:force t)) + ((eq action 'local) `(:use-current-ref t))))) + (setq quelpa-cache + (cl-remove-if-not #'package-installed-p quelpa-cache :key #'car)) + (when (package-installed-p (car (quelpa-arg-rcp rcp))) + (apply #'quelpa rcp config))))) + ;;;###autoload (defun quelpa (arg &rest plist) "Build and install a package with quelpa. @@ -1789,8 +1872,9 @@ If called interactively, `quelpa' will prompt for a MELPA package to install. When `quelpa' is called interactively with a prefix argument (e.g -C-u M-x quelpa) it will try to upgrade the given package even if -the global var `quelpa-upgrade-p' is set to nil." +\\[universal-argument] \\[quelpa]) it will try to upgrade the +given package even if the global var `quelpa-upgrade-p' is set to +nil." (interactive (list (quelpa-interactive-candidate))) (run-hooks 'quelpa-before-hook) @@ -1800,7 +1884,7 @@ the global var `quelpa-upgrade-p' is set to nil." (cache-item (if (symbolp arg) (list arg) arg))) (quelpa-parse-plist plist) (quelpa-parse-stable cache-item) - (quelpa-package-install arg) + (apply #'quelpa-package-install arg plist) (quelpa-update-cache cache-item))) (quelpa-shutdown) (run-hooks 'quelpa-after-hook))