commit 8721e87a6ec0874057f83f54498a0e3a64475a53 (HEAD, refs/remotes/origin/master) Author: F. Jason Park Date: Fri Nov 4 18:48:57 2022 -0700 ; * etc/ERC-NEWS: Mention move to erc-common.el. diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index 988eb1e09c..5cabb9b015 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -98,6 +98,11 @@ Although rare, server passwords containing white space are now handled correctly. ** Miscellaneous behavioral changes in the library API. +A number of core macros and other definitions have been moved to a new +file called erc-common.el. This was done to further lessen the +various complications arising from the mutual dependency between 'erc' +and 'erc-backend'. + The function 'erc-network' always returns non-nil in server and target buffers belonging to a successfully established IRC connection, even after that connection has been closed. @@ -109,11 +114,14 @@ network-context identifiers via a new ':id' keyword. The latter carries wider significance beyond autojoin and can be used for unequivocally identifying a connection in a human-readable way. -The function 'erc-auto-query', unused internally, and basically -inscrutable when read, has been deprecated with no public replacement. -This raises a related issue: if you use ERC as a library and need -something only offered internally, please lobby to have it exported by -writing to emacs-erc@gnu.org. +The function 'erc-auto-query' was deemed too difficult to reason +through and has thus been deprecated with no public replacement; it +has also been removed from the client code path. + +A few internal variables have been introduced that could just as well +have been made public, possibly as user options. Likewise for some +internal functions. As always, users needing such functionality +officially exposed are encouraged to write to emacs-erc@gnu.org. * Changes in ERC 5.4.1 commit c2d657e7c4fd9685591f2120007eabf78745919d Author: Dick R. Chiang Date: Fri Jul 1 11:06:51 2022 -0400 Move ERC's core dependencies to separate file Asking people to order require's is about as effective as asking kids to keep off the grass. * lisp/erc/erc-backend.el (erc--target, erc-auto-query, erc-channel-list, erc-channel-users, erc-default-nicks, erc-default-recipients, erc-format-nick-function, erc-format-query-as-channel-p, erc-hide-prompt, erc-input-marker, erc-insert-marker, erc-invitation, erc-join-buffer, erc-kill-buffer-on-part, erc-kill-server-buffer-on-quit, erc-log-p, erc-minibuffer-ignored, erc-networks--id, erc-nick, erc-nick-change-attempt-count, erc-prompt-for-channel-key, erc-prompt-hidden, erc-reuse-buffers, erc-verbose-server-ping, erc-whowas-on-nosuchnick): Forward-declare variables. (erc--open-target, erc--target-from-string, erc-active-buffer, erc-add-default-channel, erc-banlist-update, erc-buffer-filter, erc-buffer-list-with-nick, erc-channel-begin-receiving-names, erc-channel-end-receiving-names, erc-channel-p, erc-channel-receive-names, erc-cmd-JOIN, erc-connection-established, erc-current-nick, erc-current-nick-p, erc-current-time, erc-default-target, erc-delete-default-channel, erc-display-error-notice, erc-display-server-message, erc-emacs-time-to-erc-time, erc-format-message, erc-format-privmessage, erc-get-buffer, erc-handle-login, erc-handle-user-status-change, erc-ignored-reply-p, erc-ignored-user-p, erc-is-message-ctcp-and-not-action-p, erc-is-message-ctcp-p, erc-log-irc-protocol, erc-login, erc-make-notice, erc-network, erc-networks--id-given, erc-networks--id-reload, erc-nickname-in-use, erc-parse-user, erc-process-away, erc-process-ctcp-query, erc-query-buffer-p, erc-remove-channel-member, erc-remove-channel-users, erc-remove-user, erc-sec-to-time, erc-server-buffer, erc-set-active-buffer, erc-set-current-nick, erc-set-modes, erc-time-diff, erc-trim-string, erc-update-mode-line, erc-update-mode-line-buffer, erc-wash-quit-reason, erc-display-message, erc-get-buffer-create, erc-process-ctcp-reply, erc-update-channel-topic, erc-update-modes, erc-update-user-nick, erc-open, erc-update-channel-member): Forward-declare functions. (erc-response): Move to lisp/erc/erc-common.el. (erc-compat--with-memoization): Use "erc-compat-" prefixed macro. * lisp/erc/erc-common.el: New file. Change indentation for `erc-with-all-buffers-of-server' from 1 to 2. * lisp/erc/erc-compat.el (erc-compat--with-memoization): Migrate macro from `erc-backend' and rename. * lisp/erc/erc-goodies.el: Require `erc-common' instead of `erc'. (erc-controls-highlight-regexp, erc-controls-remove-regexp, erc-input-marker, erc-insert-marker, erc-server-process, erc-modules, erc-log-p): Forward declare variables. (erc-buffer-list, erc-error, erc-extract-command-from-line): Forward-declare functions. * lisp/erc/erc-networks.el (erc--target, erc-insert-marker, erc-kill-buffer-hook, erc-kill-server-hook, erc-modules, erc-rename-buffers, erc-reuse-buffers, erc-server-announced-name, erc-server-connected, erc-server-parameters, erc-server-process, erc-session-server): Forward declare variables. (erc--default-target, erc--get-isupport-entry, erc-buffer-filter, erc-current-nick, erc-display-error-notice, erc-error, erc-get-buffer, erc-server-buffer, erc-server-process-alive): Forward-declare functions. (erc-obsolete-var): Also suppress free-variable warnings. * lisp/erc/erc.el: Require `erc-networks', `erc-goodies', and `erc-backend' at top of file. Don't require `erc-compat'. (erc--server-last-reconnect-count, erc--server-reconnecting, erc-channel-members-changed-hook, erc-network, erc-networks--id, erc-server-367-functions, erc-server-announced-name, erc-server-connect-function, erc-server-connected, erc-server-current-nick, erc-server-lag, erc-server-last-sent-time, erc-server-process, erc-server-quitting, erc-server-reconnect-count, erc-server-reconnecting, erc-session-client-certificate, erc-session-connector, erc-session-port, erc-session-server, erc-session-user-full-name) Remove superfluous forward declarations. (erc-message-parsed, tabbar--local-hlf, motif-version-string): Relocate forward declares to central location. (erc-session-password): Move to `erc-backend'. (erc-downcase, erc-with-server-buffer, erc-server-user, erc-channel-user, erc-get-channel-user, erc-get-server-user): Move to lisp/erc/erc-common.el. (erc-add-server-user, erc-remove-server-user, erc-channel-user-owner-p, erc-channel-user-admin-p, erc-channel-user-op-p, erc-channel-user-halfop-p, erc-channel-user-voice-p): Convert from inline functions to normal functions. (define-erc-module, erc--target, erc--target-channel, erc--target-channel-local, erc-log, erc-log-aux, erc-with-buffer, erc-with-all-buffers-of-server): Move to lisp/erc/erc-common.el. (erc-channel-members-changed-hook): Relocate option to avoid compiler warning. (erc-input, erc--input-split): Move to lisp/erc/erc-common.el. (erc-controls-strip): Remove forward declaration temporarily until this file stops requiring `erc-goodies'. * test/lisp/erc/erc-networks-tests.el: Require `erc' instead of `erc-networks'. * test/lisp/erc/erc.el (erc--meta--backend-dependencies): Remove obsolete test. Don't require `erc-networks'. Bug#56340. diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index df9efe4b0c..026b34849a 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -99,24 +99,117 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) -;; There's a fairly strong mutual dependency between erc.el and erc-backend.el. -;; Luckily, erc.el does not need erc-backend.el for macroexpansion whereas the -;; reverse is true: -(require 'erc) +(require 'erc-common) + +(defvar erc--target) +(defvar erc-auto-query) +(defvar erc-channel-list) +(defvar erc-channel-users) +(defvar erc-default-nicks) +(defvar erc-default-recipients) +(defvar erc-format-nick-function) +(defvar erc-format-query-as-channel-p) +(defvar erc-hide-prompt) +(defvar erc-input-marker) +(defvar erc-insert-marker) +(defvar erc-invitation) +(defvar erc-join-buffer) +(defvar erc-kill-buffer-on-part) +(defvar erc-kill-server-buffer-on-quit) +(defvar erc-log-p) +(defvar erc-minibuffer-ignored) +(defvar erc-networks--id) +(defvar erc-nick) +(defvar erc-nick-change-attempt-count) +(defvar erc-prompt-for-channel-key) +(defvar erc-prompt-hidden) +(defvar erc-reuse-buffers) +(defvar erc-verbose-server-ping) +(defvar erc-whowas-on-nosuchnick) + +(declare-function erc--open-target "erc" (target)) +(declare-function erc--target-from-string "erc" (string)) +(declare-function erc-active-buffer "erc" nil) +(declare-function erc-add-default-channel "erc" (channel)) +(declare-function erc-banlist-update "erc" (proc parsed)) +(declare-function erc-buffer-filter "erc" (predicate &optional proc)) +(declare-function erc-buffer-list-with-nick "erc" (nick proc)) +(declare-function erc-channel-begin-receiving-names "erc" nil) +(declare-function erc-channel-end-receiving-names "erc" nil) +(declare-function erc-channel-p "erc" (channel)) +(declare-function erc-channel-receive-names "erc" (names-string)) +(declare-function erc-cmd-JOIN "erc" (channel &optional key)) +(declare-function erc-connection-established "erc" (proc parsed)) +(declare-function erc-current-nick "erc" nil) +(declare-function erc-current-nick-p "erc" (nick)) +(declare-function erc-current-time "erc" (&optional specified-time)) +(declare-function erc-default-target "erc" nil) +(declare-function erc-delete-default-channel "erc" (channel &optional buffer)) +(declare-function erc-display-error-notice "erc" (parsed string)) +(declare-function erc-display-server-message "erc" (_proc parsed)) +(declare-function erc-emacs-time-to-erc-time "erc" (&optional specified-time)) +(declare-function erc-format-message "erc" (msg &rest args)) +(declare-function erc-format-privmessage "erc" (nick msg privp msgp)) +(declare-function erc-get-buffer "erc" (target &optional proc)) +(declare-function erc-handle-login "erc" nil) +(declare-function erc-handle-user-status-change "erc" (type nlh &optional l)) +(declare-function erc-ignored-reply-p "erc" (msg tgt proc)) +(declare-function erc-ignored-user-p "erc" (spec)) +(declare-function erc-is-message-ctcp-and-not-action-p "erc" (message)) +(declare-function erc-is-message-ctcp-p "erc" (message)) +(declare-function erc-log-irc-protocol "erc" (string &optional outbound)) +(declare-function erc-login "erc" nil) +(declare-function erc-make-notice "erc" (message)) +(declare-function erc-network "erc-networks" nil) +(declare-function erc-networks--id-given "erc-networks" (arg &rest args)) +(declare-function erc-networks--id-reload "erc-networks" (arg &rest args)) +(declare-function erc-nickname-in-use "erc" (nick reason)) +(declare-function erc-parse-user "erc" (string)) +(declare-function erc-process-away "erc" (proc away-p)) +(declare-function erc-process-ctcp-query "erc" (proc parsed nick login host)) +(declare-function erc-query-buffer-p "erc" (&optional buffer)) +(declare-function erc-remove-channel-member "erc" (channel nick)) +(declare-function erc-remove-channel-users "erc" nil) +(declare-function erc-remove-user "erc" (nick)) +(declare-function erc-sec-to-time "erc" (ns)) +(declare-function erc-server-buffer "erc" nil) +(declare-function erc-set-active-buffer "erc" (buffer)) +(declare-function erc-set-current-nick "erc" (nick)) +(declare-function erc-set-modes "erc" (tgt mode-string)) +(declare-function erc-time-diff "erc" (t1 t2)) +(declare-function erc-trim-string "erc" (s)) +(declare-function erc-update-mode-line "erc" (&optional buffer)) +(declare-function erc-update-mode-line-buffer "erc" (buffer)) +(declare-function erc-wash-quit-reason "erc" (reason nick login host)) + +(declare-function erc-display-message "erc" + (parsed type buffer msg &rest args)) +(declare-function erc-get-buffer-create "erc" + (server port target &optional tgt-info id)) +(declare-function erc-process-ctcp-reply "erc" + (proc parsed nick login host msg)) +(declare-function erc-update-channel-topic "erc" + (channel topic &optional modify)) +(declare-function erc-update-modes "erc" + (tgt mode-string &optional _nick _host _login)) +(declare-function erc-update-user-nick "erc" + (nick &optional new-nick host login full-name info)) +(declare-function erc-open "erc" + (&optional server port nick full-name connect passwd tgt-list + channel process client-certificate user id)) +(declare-function erc-update-channel-member "erc" + (channel nick new-nick + &optional add voice halfop op admin owner host + login full-name info update-message-time)) ;;;; Variables and options +(defvar-local erc-session-password nil + "The password used for the current session.") + (defvar erc-server-responses (make-hash-table :test #'equal) "Hash table mapping server responses to their handler hooks.") -(cl-defstruct (erc-response (:conc-name erc-response.)) - (unparsed "" :type string) - (sender "" :type string) - (command "" :type string) - (command-args '() :type list) - (contents "" :type string) - (tags '() :type list)) - ;;; User data (defvar-local erc-server-current-nick nil @@ -1662,16 +1755,6 @@ Then display the welcome message." (split-string value ",") (list value))))) -(defmacro erc--with-memoization (table &rest forms) - "Adapter to be migrated to erc-compat." - (declare (indent defun)) - `(cond - ((fboundp 'with-memoization) - (with-memoization ,table ,@forms)) ; 29.1 - ((fboundp 'cl--generic-with-memoization) - (cl--generic-with-memoization ,table ,@forms)) - (t ,@forms))) - (defun erc--get-isupport-entry (key &optional single) "Return an item for \"ISUPPORT\" token KEY, a symbol. When a lookup fails return nil. Otherwise return a list whose @@ -1681,7 +1764,7 @@ ambiguous and only useful for tokens supporting a single primitive value." (if-let* ((table (or erc--isupport-params (erc-with-server-buffer erc--isupport-params))) - (value (erc--with-memoization (gethash key table) + (value (erc-compat--with-memoization (gethash key table) (when-let ((v (assoc (symbol-name key) erc-server-parameters))) (if (cdr v) diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el new file mode 100644 index 0000000000..d8aac36eab --- /dev/null +++ b/lisp/erc/erc-common.el @@ -0,0 +1,271 @@ +;;; erc-common.el --- Macros and types for ERC -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. +;; +;; Maintainer: Amin Bandali , F. Jason Park +;; Keywords: comm, IRC, chat, client, internet +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; by the Free Software Foundation, either version 3 of the License, +;; or (at your option) any later version. +;; +;; GNU Emacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;;; Code: + +(eval-when-compile (require 'cl-lib) (require 'subr-x)) +(require 'erc-compat) + +(defvar erc--casemapping-rfc1459) +(defvar erc--casemapping-rfc1459-strict) +(defvar erc-channel-users) +(defvar erc-dbuf) +(defvar erc-log-p) +(defvar erc-server-users) +(defvar erc-session-server) + +(declare-function erc--get-isupport-entry "erc-backend" (key &optional single)) +(declare-function erc-get-buffer "erc" (target &optional proc)) +(declare-function erc-server-buffer "erc" nil) + +(cl-defstruct erc-input + string insertp sendp) + +(cl-defstruct (erc--input-split (:include erc-input)) + lines cmdp) + +(cl-defstruct (erc-server-user (:type vector) :named) + ;; User data + nickname host login full-name info + ;; Buffers + ;; + ;; This is an alist of the form (BUFFER . CHANNEL-DATA), where + ;; CHANNEL-DATA is either nil or an erc-channel-user struct. + (buffers nil)) + +(cl-defstruct (erc-channel-user (:type vector) :named) + voice halfop op admin owner + ;; Last message time (in the form of the return value of + ;; (current-time) + ;; + ;; This is useful for ordered name completion. + (last-message-time nil)) + +(cl-defstruct erc--target + (string "" :type string :documentation "Received name of target.") + (symbol nil :type symbol :documentation "Case-mapped name as symbol.")) + +;; At some point, it may make sense to add a query type with an +;; account field, which may help support reassociation across +;; reconnects and nick changes (likely requires v3 extensions). +;; +;; These channel variants should probably take on a `joined' field to +;; track "joinedness", which `erc-server-JOIN', `erc-server-PART', +;; etc. should toggle. Functions like `erc--current-buffer-joined-p' +;; may find it useful. + +(cl-defstruct (erc--target-channel (:include erc--target))) +(cl-defstruct (erc--target-channel-local (:include erc--target-channel))) + +(cl-defstruct (erc-response (:conc-name erc-response.)) + (unparsed "" :type string) + (sender "" :type string) + (command "" :type string) + (command-args '() :type list) + (contents "" :type string) + (tags '() :type list)) + +(defmacro define-erc-module (name alias doc enable-body disable-body + &optional local-p) + "Define a new minor mode using ERC conventions. +Symbol NAME is the name of the module. +Symbol ALIAS is the alias to use, or nil. +DOC is the documentation string to use for the minor mode. +ENABLE-BODY is a list of expressions used to enable the mode. +DISABLE-BODY is a list of expressions used to disable the mode. +If LOCAL-P is non-nil, the mode will be created as a buffer-local +mode, rather than a global one. + +This will define a minor mode called erc-NAME-mode, possibly +an alias erc-ALIAS-mode, as well as the helper functions +erc-NAME-enable, and erc-NAME-disable. + +Example: + + ;;;###autoload(autoload \\='erc-replace-mode \"erc-replace\") + (define-erc-module replace nil + \"This mode replaces incoming text according to `erc-replace-alist'.\" + ((add-hook \\='erc-insert-modify-hook + #\\='erc-replace-insert)) + ((remove-hook \\='erc-insert-modify-hook + #\\='erc-replace-insert)))" + (declare (doc-string 3) (indent defun)) + (let* ((sn (symbol-name name)) + (mode (intern (format "erc-%s-mode" (downcase sn)))) + (group (intern (format "erc-%s" (downcase sn)))) + (enable (intern (format "erc-%s-enable" (downcase sn)))) + (disable (intern (format "erc-%s-disable" (downcase sn))))) + `(progn + (define-minor-mode + ,mode + ,(format "Toggle ERC %S mode. +With a prefix argument ARG, enable %s if ARG is positive, +and disable it otherwise. If called from Lisp, enable the mode +if ARG is omitted or nil. +%s" name name doc) + ;; FIXME: We don't know if this group exists, so this `:group' may + ;; actually just silence a valid warning about the fact that the var + ;; is not associated with any group. + :global ,(not local-p) :group (quote ,group) + (if ,mode + (,enable) + (,disable))) + (defun ,enable () + ,(format "Enable ERC %S mode." + name) + (interactive) + (add-to-list 'erc-modules (quote ,name)) + (setq ,mode t) + ,@enable-body) + (defun ,disable () + ,(format "Disable ERC %S mode." + name) + (interactive) + (setq erc-modules (delq (quote ,name) erc-modules)) + (setq ,mode nil) + ,@disable-body) + ,(when (and alias (not (eq name alias))) + `(defalias + ',(intern + (format "erc-%s-mode" + (downcase (symbol-name alias)))) + #',mode)) + ;; For find-function and find-variable. + (put ',mode 'definition-name ',name) + (put ',enable 'definition-name ',name) + (put ',disable 'definition-name ',name)))) + +(defmacro erc-with-buffer (spec &rest body) + "Execute BODY in the buffer associated with SPEC. + +SPEC should have the form + + (TARGET [PROCESS]) + +If TARGET is a buffer, use it. Otherwise, use the buffer +matching TARGET in the process specified by PROCESS. + +If PROCESS is nil, use the current `erc-server-process'. +See `erc-get-buffer' for details. + +See also `with-current-buffer'. + +\(fn (TARGET [PROCESS]) BODY...)" + (declare (indent 1) (debug ((form &optional form) body))) + (let ((buf (make-symbol "buf")) + (proc (make-symbol "proc")) + (target (make-symbol "target")) + (process (make-symbol "process"))) + `(let* ((,target ,(car spec)) + (,process ,(cadr spec)) + (,buf (if (bufferp ,target) + ,target + (let ((,proc (or ,process + (and (processp erc-server-process) + erc-server-process)))) + (if (and ,target ,proc) + (erc-get-buffer ,target ,proc)))))) + (when (buffer-live-p ,buf) + (with-current-buffer ,buf + ,@body))))) + +(defmacro erc-with-server-buffer (&rest body) + "Execute BODY in the current ERC server buffer. +If no server buffer exists, return nil." + (declare (indent 0) (debug (body))) + (let ((buffer (make-symbol "buffer"))) + `(let ((,buffer (erc-server-buffer))) + (when (buffer-live-p ,buffer) + (with-current-buffer ,buffer + ,@body))))) + +(defmacro erc-with-all-buffers-of-server (process pred &rest forms) + "Execute FORMS in all buffers which have same process as this server. +FORMS will be evaluated in all buffers having the process PROCESS and +where PRED matches or in all buffers of the server process if PRED is +nil." + (declare (indent 2) (debug (form form body))) + (macroexp-let2 nil pred pred + `(erc-buffer-filter (lambda () + (when (or (not ,pred) (funcall ,pred)) + ,@forms)) + ,process))) + +(defun erc-log-aux (string) + "Do the debug logging of STRING." + (let ((cb (current-buffer)) + (point 1) + (was-eob nil) + (session-buffer (erc-server-buffer))) + (if session-buffer + (progn + (set-buffer session-buffer) + (if (not (and erc-dbuf (bufferp erc-dbuf) (buffer-live-p erc-dbuf))) + (progn + (setq erc-dbuf (get-buffer-create + (concat "*ERC-DEBUG: " + erc-session-server "*"))))) + (set-buffer erc-dbuf) + (setq point (point)) + (setq was-eob (eobp)) + (goto-char (point-max)) + (insert (concat "** " string "\n")) + (if was-eob (goto-char (point-max)) + (goto-char point)) + (set-buffer cb)) + (message "ERC: ** %s" string)))) + +(define-inline erc-log (string) + "Logs STRING if logging is on (see `erc-log-p')." + (inline-quote + (when erc-log-p + (erc-log-aux ,string)))) + +(defun erc-downcase (string) + "Return a downcased copy of STRING with properties. +Use the CASEMAPPING ISUPPORT parameter to determine the style." + (let* ((mapping (erc--get-isupport-entry 'CASEMAPPING 'single)) + (inhibit-read-only t)) + (if (equal mapping "ascii") + (downcase string) + (with-temp-buffer + (insert string) + (translate-region (point-min) (point-max) + (if (equal mapping "rfc1459-strict") + erc--casemapping-rfc1459-strict + erc--casemapping-rfc1459)) + (buffer-string))))) + +(define-inline erc-get-channel-user (nick) + "Find NICK in the current buffer's `erc-channel-users' hash table." + (inline-quote (gethash (erc-downcase ,nick) erc-channel-users))) + +(define-inline erc-get-server-user (nick) + "Find NICK in the current server's `erc-server-users' hash table." + (inline-letevals (nick) + (inline-quote (erc-with-server-buffer + (gethash (erc-downcase ,nick) erc-server-users))))) + +(provide 'erc-common) + +;;; erc-common.el ends here diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 8a00e711ac..03bd8f1352 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -156,6 +156,18 @@ If START or END is negative, it counts from the end." (setq i (1+ i) start (1+ start))) res)))))) + +;;;; Misc 29.1 + +(defmacro erc-compat--with-memoization (table &rest forms) + (declare (indent defun)) + (cond + ((fboundp 'with-memoization) + `(with-memoization ,table ,@forms)) ; 29.1 + ((fboundp 'cl--generic-with-memoization) + `(cl--generic-with-memoization ,table ,@forms)) + (t `(progn ,@forms)))) + (provide 'erc-compat) ;;; erc-compat.el ends here diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 8fef23945d..59b5f01f23 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -29,10 +29,23 @@ ;;; Code: -(require 'erc) - ;;; Imenu support +(require 'erc-common) + +(defvar erc-controls-highlight-regexp) +(defvar erc-controls-remove-regexp) +(defvar erc-input-marker) +(defvar erc-insert-marker) +(defvar erc-server-process) +(defvar erc-modules) +(defvar erc-log-p) + +(declare-function erc-buffer-list "erc" (&optional predicate proc)) +(declare-function erc-error "erc" (&rest args)) +(declare-function erc-extract-command-from-line "erc" (line)) +(declare-function erc-beg-of-input-line "erc" nil) + (defun erc-imenu-setup () "Setup Imenu support in an ERC buffer." (setq-local imenu-create-index-function #'erc-create-imenu-index)) diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index d8fb879819..dba6ead073 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -39,8 +39,32 @@ ;;; Code: -(require 'erc) (eval-when-compile (require 'cl-lib)) +(require 'erc-common) + +(defvar erc--target) +(defvar erc-insert-marker) +(defvar erc-kill-buffer-hook) +(defvar erc-kill-server-hook) +(defvar erc-modules) +(defvar erc-rename-buffers) +(defvar erc-reuse-buffers) +(defvar erc-server-announced-name) +(defvar erc-server-connected) +(defvar erc-server-parameters) +(defvar erc-server-process) +(defvar erc-session-server) + +(declare-function erc--default-target "erc" nil) +(declare-function erc--get-isupport-entry "erc-backend" (key &optional single)) +(declare-function erc-buffer-filter "erc" (predicate &optional proc)) +(declare-function erc-current-nick "erc" nil) +(declare-function erc-display-error-notice "erc" (parsed string)) +(declare-function erc-error "erc" (&rest args)) +(declare-function erc-get-buffer "erc" (target &optional proc)) +(declare-function erc-server-buffer "erc" nil) +(declare-function erc-server-process-alive "erc-backend" (&optional buffer)) +(declare-function erc-set-active-buffer "erc" (buffer)) ;; Variables @@ -813,7 +837,7 @@ This may have originated from an `:id' arg to entry-point commands (erc-networks--id-symbol nid)) (cl-generic-define-context-rewriter erc-obsolete-var (var spec) - `((with-suppressed-warnings ((obsolete ,var)) ,var) ,spec)) + `((with-suppressed-warnings ((obsolete ,var) (free-vars ,var)) ,var) ,spec)) ;; As a catch-all, derive the symbol from the unquoted printed repr. (cl-defgeneric erc-networks--id-create (id) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 7153305a91..6b14cf87e2 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -60,6 +60,9 @@ (load "erc-loaddefs" 'noerror 'nomessage) +(require 'erc-networks) +(require 'erc-goodies) +(require 'erc-backend) (require 'cl-lib) (require 'format-spec) (require 'pp) @@ -69,8 +72,6 @@ (require 'iso8601) (eval-when-compile (require 'subr-x)) -(require 'erc-compat) - (defconst erc-version "5.4.1" "This version of ERC.") @@ -132,29 +133,12 @@ "Running scripts at startup and with /LOAD." :group 'erc) -;; Defined in erc-backend -(defvar erc--server-last-reconnect-count) -(defvar erc--server-reconnecting) -(defvar erc-channel-members-changed-hook) -(defvar erc-network) -(defvar erc-networks--id) -(defvar erc-server-367-functions) -(defvar erc-server-announced-name) -(defvar erc-server-connect-function) -(defvar erc-server-connected) -(defvar erc-server-current-nick) -(defvar erc-server-lag) -(defvar erc-server-last-sent-time) -(defvar erc-server-process) -(defvar erc-server-quitting) -(defvar erc-server-reconnect-count) -(defvar erc-server-reconnecting) -(defvar erc-session-client-certificate) -(defvar erc-session-connector) -(defvar erc-session-port) -(defvar erc-session-server) -(defvar erc-session-user-full-name) -(defvar erc-session-username) +;; Forward declarations +(defvar erc-message-parsed) + +(defvar tabbar--local-hlf) +(defvar motif-version-string) +(defvar gtk-version-string) ;; tunable connection and authentication parameters @@ -349,9 +333,6 @@ A typical value would be \((\"#emacs\" \"QUIT\" \"JOIN\") :group 'erc-ignore :type 'erc-message-type) -(defvar-local erc-session-password nil - "The password used for the current session.") - (defcustom erc-disconnected-hook nil "Run this hook with arguments (NICK IP REASON) when disconnected. This happens before automatic reconnection. Note, that @@ -436,69 +417,14 @@ It associates nicknames with `erc-server-user' struct instances.") '((?\[ . ?\{) (?\] . ?\}) (?\\ . ?\|)) (mapcar (lambda (c) (cons c (+ c 32))) "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))) -(defun erc-downcase (string) - "Return a downcased copy of STRING with properties. -Use the CASEMAPPING ISUPPORT parameter to determine the style." - (let* ((mapping (erc--get-isupport-entry 'CASEMAPPING 'single)) - (inhibit-read-only t)) - (if (equal mapping "ascii") - (downcase string) - (with-temp-buffer - (insert string) - (translate-region (point-min) (point-max) - (if (equal mapping "rfc1459-strict") - erc--casemapping-rfc1459-strict - erc--casemapping-rfc1459)) - (buffer-string))))) - -(defmacro erc-with-server-buffer (&rest body) - "Execute BODY in the current ERC server buffer. -If no server buffer exists, return nil." - (declare (indent 0) (debug (body))) - (let ((buffer (make-symbol "buffer"))) - `(let ((,buffer (erc-server-buffer))) - (when (buffer-live-p ,buffer) - (with-current-buffer ,buffer - ,@body))))) - -(cl-defstruct (erc-server-user (:type vector) :named) - ;; User data - nickname host login full-name info - ;; Buffers - ;; - ;; This is an alist of the form (BUFFER . CHANNEL-DATA), where - ;; CHANNEL-DATA is either nil or an erc-channel-user struct. - (buffers nil) - ) - -(cl-defstruct (erc-channel-user (:type vector) :named) - voice halfop op admin owner - ;; Last message time (in the form of the return value of - ;; (current-time) - ;; - ;; This is useful for ordered name completion. - (last-message-time nil)) - -(define-inline erc-get-channel-user (nick) - "Find NICK in the current buffer's `erc-channel-users' hash table." - (inline-quote (gethash (erc-downcase ,nick) erc-channel-users))) - -(define-inline erc-get-server-user (nick) - "Find NICK in the current server's `erc-server-users' hash table." - (inline-letevals (nick) - (inline-quote (erc-with-server-buffer - (gethash (erc-downcase ,nick) erc-server-users))))) - -(define-inline erc-add-server-user (nick user) +(defun erc-add-server-user (nick user) "This function is for internal use only. Adds USER with nickname NICK to the `erc-server-users' hash table." - (inline-letevals (nick user) - (inline-quote - (erc-with-server-buffer - (puthash (erc-downcase ,nick) ,user erc-server-users))))) + (erc-with-server-buffer + (puthash (erc-downcase nick) user erc-server-users))) -(define-inline erc-remove-server-user (nick) +(defun erc-remove-server-user (nick) "This function is for internal use only. Removes the user with nickname NICK from the `erc-server-users' @@ -506,10 +432,8 @@ hash table. This user is not removed from the `erc-channel-users' lists of other buffers. See also: `erc-remove-user'." - (inline-letevals (nick) - (inline-quote - (erc-with-server-buffer - (remhash (erc-downcase ,nick) erc-server-users))))) + (erc-with-server-buffer + (remhash (erc-downcase nick) erc-server-users))) (defun erc-change-user-nickname (user new-nick) "This function is for internal use only. @@ -580,55 +504,45 @@ Removes all users in the current channel. This is called by erc-channel-users) (clrhash erc-channel-users))) -(define-inline erc-channel-user-owner-p (nick) +(defun erc-channel-user-owner-p (nick) "Return non-nil if NICK is an owner of the current channel." - (inline-letevals (nick) - (inline-quote - (and ,nick - (hash-table-p erc-channel-users) - (let ((cdata (erc-get-channel-user ,nick))) - (and cdata (cdr cdata) - (erc-channel-user-owner (cdr cdata)))))))) - -(define-inline erc-channel-user-admin-p (nick) + (and nick + (hash-table-p erc-channel-users) + (let ((cdata (erc-get-channel-user nick))) + (and cdata (cdr cdata) + (erc-channel-user-owner (cdr cdata)))))) + +(defun erc-channel-user-admin-p (nick) "Return non-nil if NICK is an admin in the current channel." - (inline-letevals (nick) - (inline-quote - (and ,nick + (and nick (hash-table-p erc-channel-users) - (let ((cdata (erc-get-channel-user ,nick))) + (let ((cdata (erc-get-channel-user nick))) (and cdata (cdr cdata) - (erc-channel-user-admin (cdr cdata)))))))) + (erc-channel-user-admin (cdr cdata)))))) -(define-inline erc-channel-user-op-p (nick) +(defun erc-channel-user-op-p (nick) "Return non-nil if NICK is an operator in the current channel." - (inline-letevals (nick) - (inline-quote - (and ,nick + (and nick (hash-table-p erc-channel-users) - (let ((cdata (erc-get-channel-user ,nick))) + (let ((cdata (erc-get-channel-user nick))) (and cdata (cdr cdata) - (erc-channel-user-op (cdr cdata)))))))) + (erc-channel-user-op (cdr cdata)))))) -(define-inline erc-channel-user-halfop-p (nick) +(defun erc-channel-user-halfop-p (nick) "Return non-nil if NICK is a half-operator in the current channel." - (inline-letevals (nick) - (inline-quote - (and ,nick + (and nick (hash-table-p erc-channel-users) - (let ((cdata (erc-get-channel-user ,nick))) + (let ((cdata (erc-get-channel-user nick))) (and cdata (cdr cdata) - (erc-channel-user-halfop (cdr cdata)))))))) + (erc-channel-user-halfop (cdr cdata)))))) -(define-inline erc-channel-user-voice-p (nick) +(defun erc-channel-user-voice-p (nick) "Return non-nil if NICK has voice in the current channel." - (inline-letevals (nick) - (inline-quote - (and ,nick + (and nick (hash-table-p erc-channel-users) - (let ((cdata (erc-get-channel-user ,nick))) + (let ((cdata (erc-get-channel-user nick))) (and cdata (cdr cdata) - (erc-channel-user-voice (cdr cdata)))))))) + (erc-channel-user-voice (cdr cdata)))))) (defun erc-get-channel-user-list () "Return a list of users in the current channel. @@ -1377,96 +1291,6 @@ See also `erc-show-my-nick'." (defvar-local erc-dbuf nil) -(defmacro define-erc-module (name alias doc enable-body disable-body - &optional local-p) - "Define a new minor mode using ERC conventions. -Symbol NAME is the name of the module. -Symbol ALIAS is the alias to use, or nil. -DOC is the documentation string to use for the minor mode. -ENABLE-BODY is a list of expressions used to enable the mode. -DISABLE-BODY is a list of expressions used to disable the mode. -If LOCAL-P is non-nil, the mode will be created as a buffer-local -mode, rather than a global one. - -This will define a minor mode called erc-NAME-mode, possibly -an alias erc-ALIAS-mode, as well as the helper functions -erc-NAME-enable, and erc-NAME-disable. - -Example: - - ;;;###autoload(autoload \\='erc-replace-mode \"erc-replace\") - (define-erc-module replace nil - \"This mode replaces incoming text according to `erc-replace-alist'.\" - ((add-hook \\='erc-insert-modify-hook - #\\='erc-replace-insert)) - ((remove-hook \\='erc-insert-modify-hook - #\\='erc-replace-insert)))" - (declare (doc-string 3) (indent defun)) - (let* ((sn (symbol-name name)) - (mode (intern (format "erc-%s-mode" (downcase sn)))) - (group (intern (format "erc-%s" (downcase sn)))) - (enable (intern (format "erc-%s-enable" (downcase sn)))) - (disable (intern (format "erc-%s-disable" (downcase sn))))) - `(progn - (define-minor-mode - ,mode - ,(format "Toggle ERC %S mode. -With a prefix argument ARG, enable %s if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. -%s" name name doc) - ;; FIXME: We don't know if this group exists, so this `:group' may - ;; actually just silence a valid warning about the fact that the var - ;; is not associated with any group. - :global ,(not local-p) :group (quote ,group) - (if ,mode - (,enable) - (,disable))) - (defun ,enable () - ,(format "Enable ERC %S mode." - name) - (interactive) - (add-to-list 'erc-modules (quote ,name)) - (setq ,mode t) - ,@enable-body) - (defun ,disable () - ,(format "Disable ERC %S mode." - name) - (interactive) - (setq erc-modules (delq (quote ,name) erc-modules)) - (setq ,mode nil) - ,@disable-body) - ,(when (and alias (not (eq name alias))) - `(defalias - ',(intern - (format "erc-%s-mode" - (downcase (symbol-name alias)))) - #',mode)) - ;; For find-function and find-variable. - (put ',mode 'definition-name ',name) - (put ',enable 'definition-name ',name) - (put ',disable 'definition-name ',name)))) - -;; The rationale for favoring inheritance here (nicer dispatch) is -;; kinda flimsy since there aren't yet any actual methods. - -(cl-defstruct erc--target - (string "" :type string :documentation "Received name of target.") - (symbol nil :type symbol :documentation "Case-mapped name as symbol.")) - -;; These should probably take on a `joined' field to track joinedness, -;; which should be toggled by `erc-server-JOIN', `erc-server-PART', -;; etc. Functions like `erc--current-buffer-joined-p' (bug#48598) may -;; find it useful. - -(cl-defstruct (erc--target-channel (:include erc--target))) - -(cl-defstruct (erc--target-channel-local (:include erc--target-channel))) - -;; At some point, it may make sense to add a query type with an -;; account field, which may help support reassociation across -;; reconnects and nick changes (likely requires v3 extensions). - (defun erc--target-from-string (string) "Construct an `erc--target' variant from STRING." (funcall (if (erc-channel-p string) @@ -1516,12 +1340,6 @@ capabilities." (add-hook hook fun nil t) fun)) -(define-inline erc-log (string) - "Logs STRING if logging is on (see `erc-log-p')." - (inline-quote - (when erc-log-p - (erc-log-aux ,string)))) - (defun erc-server-buffer () "Return the server buffer for the current buffer's process. The buffer-local variable `erc-server-process' is used to find @@ -1577,29 +1395,7 @@ If BUFFER is nil, the current buffer is used." (if erc-online-p "" "not ")) erc-online-p)))) -(defun erc-log-aux (string) - "Do the debug logging of STRING." - (let ((cb (current-buffer)) - (point 1) - (was-eob nil) - (session-buffer (erc-server-buffer))) - (if session-buffer - (progn - (set-buffer session-buffer) - (if (not (and erc-dbuf (bufferp erc-dbuf) (buffer-live-p erc-dbuf))) - (progn - (setq erc-dbuf (get-buffer-create - (concat "*ERC-DEBUG: " - erc-session-server "*"))))) - (set-buffer erc-dbuf) - (setq point (point)) - (setq was-eob (eobp)) - (goto-char (point-max)) - (insert (concat "** " string "\n")) - (if was-eob (goto-char (point-max)) - (goto-char point)) - (set-buffer cb)) - (message "ERC: ** %s" string)))) + ;; Last active buffer, to print server messages in the right place @@ -1841,40 +1637,6 @@ All strings are compared according to IRC protocol case rules, see (throw 'result list) (setq list (cdr list)))))) -(defmacro erc-with-buffer (spec &rest body) - "Execute BODY in the buffer associated with SPEC. - -SPEC should have the form - - (TARGET [PROCESS]) - -If TARGET is a buffer, use it. Otherwise, use the buffer -matching TARGET in the process specified by PROCESS. - -If PROCESS is nil, use the current `erc-server-process'. -See `erc-get-buffer' for details. - -See also `with-current-buffer'. - -\(fn (TARGET [PROCESS]) BODY...)" - (declare (indent 1) (debug ((form &optional form) body))) - (let ((buf (make-symbol "buf")) - (proc (make-symbol "proc")) - (target (make-symbol "target")) - (process (make-symbol "process"))) - `(let* ((,target ,(car spec)) - (,process ,(cadr spec)) - (,buf (if (bufferp ,target) - ,target - (let ((,proc (or ,process - (and (processp erc-server-process) - erc-server-process)))) - (if (and ,target ,proc) - (erc-get-buffer ,target ,proc)))))) - (when (buffer-live-p ,buf) - (with-current-buffer ,buf - ,@body))))) - (defun erc-get-buffer (target &optional proc) "Return the buffer matching TARGET in the process PROC. If PROC is not supplied, all processes are searched." @@ -1921,18 +1683,6 @@ needs to match PROC." (setq predicate (lambda () t))) (erc-buffer-filter predicate proc)) -(defmacro erc-with-all-buffers-of-server (process pred &rest forms) - "Execute FORMS in all buffers which have same process as this server. -FORMS will be evaluated in all buffers having the process PROCESS and -where PRED matches or in all buffers of the server process if PRED is -nil." - (declare (indent 1) (debug (form form body))) - (macroexp-let2 nil pred pred - `(erc-buffer-filter (lambda () - (when (or (not ,pred) (funcall ,pred)) - ,@forms)) - ,process))) - (define-obsolete-function-alias 'erc-iswitchb #'erc-switch-to-buffer "25.1") (defun erc--switch-to-buffer (&optional arg) (read-buffer "Switch to ERC buffer: " @@ -2877,8 +2627,6 @@ every `erc-lurker-cleanup-interval' updates to consumption of lurker state during long Emacs sessions and/or ERC sessions with large numbers of incoming PRIVMSGs.") -(defvar erc-message-parsed) - (defun erc-lurker-update-status (_message) "Update `erc-lurker-state' if necessary. @@ -4090,9 +3838,6 @@ the message given by REASON." t) (put 'erc-cmd-SERVER 'process-not-needed t) -(defvar motif-version-string) -(defvar gtk-version-string) - (defun erc-cmd-SV () "Say the current ERC and Emacs version into channel." (erc-send-message (format "I'm using ERC %s with GNU Emacs %s (%s%s)%s." @@ -5349,6 +5094,12 @@ Example: (operator) o => @, (voiced) v => +." (setq i (1+ i))) alist)))) +(defcustom erc-channel-members-changed-hook nil + "This hook is called every time the variable `channel-members' changes. +The buffer where the change happened is current while this hook is called." + :group 'erc-hooks + :type 'hook) + (defun erc-channel-receive-names (names-string) "This function is for internal use only. @@ -5392,13 +5143,6 @@ channel." name name t voice halfop op admin owner))))) (run-hooks 'erc-channel-members-changed-hook))) - -(defcustom erc-channel-members-changed-hook nil - "This hook is called every time the variable `channel-members' changes. -The buffer where the change happened is current while this hook is called." - :group 'erc-hooks - :type 'hook) - (defun erc-update-user-nick (nick &optional new-nick host login full-name info) "Update the stored user information for the user with nickname NICK. @@ -6008,12 +5752,6 @@ When the returned value is a string, pass it to `erc-error'.") (defvar erc-command-regexp "^/\\([A-Za-z']+\\)\\(\\s-+.*\\|\\s-*\\)$" "Regular expression used for matching commands in ERC.") -(cl-defstruct erc-input - string insertp sendp) - -(cl-defstruct (erc--input-split (:include erc-input)) - lines cmdp) - (defun erc--discard-trailing-multiline-nulls (state) "Ensure last line of STATE's string is non-null. But only when `erc-send-whitespace-lines' is non-nil. STATE is @@ -6957,9 +6695,6 @@ shortened server name instead." (t "")))) ;; erc-goodies is required at end of this file. -(declare-function erc-controls-strip "erc-goodies" (str)) - -(defvar tabbar--local-hlf) ;; FIXME when 29.1 is cut and `format-spec' is added to ELPA Compat, ;; remove the function invocations from the spec form below. @@ -7448,12 +7183,4 @@ Otherwise, connect to HOST:PORT as USER and /join CHANNEL." (provide 'erc) -(require 'erc-backend) - -;; Deprecated. We might eventually stop requiring the goodies automatically. -;; IMPORTANT: This require must appear _after_ the above (provide 'erc) to -;; avoid a recursive require error when byte-compiling the entire package. -(require 'erc-goodies) -(require 'erc-networks) - ;;; erc.el ends here diff --git a/test/lisp/erc/erc-networks-tests.el b/test/lisp/erc/erc-networks-tests.el index 66a334b709..32bdfa11ff 100644 --- a/test/lisp/erc/erc-networks-tests.el +++ b/test/lisp/erc/erc-networks-tests.el @@ -20,7 +20,7 @@ ;;; Code: (require 'ert-x) ; cl-lib -(require 'erc-networks) +(require 'erc) (defun erc-networks-tests--create-dead-proc (&optional buf) (let ((p (start-process "true" (or buf (current-buffer)) "true"))) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index b2ed29e80e..c88dd9888d 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -24,7 +24,6 @@ (require 'ert-x) (require 'erc) (require 'erc-ring) -(require 'erc-networks) (ert-deftest erc--read-time-period () (cl-letf (((symbol-function 'read-string) (lambda (&rest _) ""))) @@ -48,27 +47,6 @@ (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1d"))) (should (equal (erc--read-time-period "foo: ") 86400)))) -(ert-deftest erc--meta--backend-dependencies () - (with-temp-buffer - (insert-file-contents-literally - (concat (file-name-sans-extension (symbol-file 'erc)) ".el")) - (let ((beg (search-forward ";; Defined in erc-backend")) - (end (search-forward "\n\n")) - vars) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (with-syntax-table lisp-data-mode-syntax-table - (condition-case _ - (while (push (cadr (read (current-buffer))) vars)) - (end-of-file))))) - (should (= (point) end)) - (dolist (var vars) - (setq var (concat "\\_<" (symbol-name var) "\\_>")) - (ert-info (var) - (should (save-excursion (search-forward-regexp var nil t)))))))) - (ert-deftest erc-with-all-buffers-of-server () (let (proc-exnet proc-onet commit ae0642f8595e5bc5b521bbfa73ae114bf25a418d Author: F. Jason Park Date: Fri Nov 4 05:01:35 2022 -0700 Offer completions for GET subcommand flags in erc-dcc * lisp/erc/erc-dcc.el (pcomplete/erc-mode/DCC): Add /DCC GET switches. This is unfinished business from bug#54458. * test/lisp/erc/erc-dcc-tests.el (erc-dcc-tests--pcomplete-common, pcomplete/erc-mode/DCC--get-basic, pcomplete/erc-mode/DCC--get-1flag, pcomplete/erc-mode/DCC--get-2flags, pcomplete/erc-mode/DCC--get-2flags-reverse): Add helper and tests for completing /DCC GET switches. diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index 90a10766c4..ebeab921fb 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -411,8 +411,11 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc." "Provide completion for the /DCC command." (pcomplete-here (append '("chat" "close" "get" "list") (when (fboundp 'make-network-process) '("send")))) + (when (equal "get" (downcase (pcomplete-arg 1))) + (pcomplete-opt "ts") + (pcomplete-opt (if (equal "-s" (pcomplete-arg 'first 2)) "t" "s"))) (pcomplete-here - (pcase (intern (downcase (pcomplete-arg 1))) + (pcase (intern (downcase (pcomplete-arg 'first 1))) ('chat (mapcar (lambda (elt) (plist-get elt :nick)) (cl-remove-if-not (lambda (elt) @@ -428,7 +431,7 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc." erc-dcc-list))) ('send (pcomplete-erc-all-nicks)))) (pcomplete-here - (pcase (intern (downcase (pcomplete-arg 2))) + (pcase (intern (downcase (pcomplete-arg 'first 1))) ('get (mapcar (lambda (elt) (plist-get elt :file)) (cl-remove-if-not (lambda (elt) diff --git a/test/lisp/erc/erc-dcc-tests.el b/test/lisp/erc/erc-dcc-tests.el index a1dfbab9dc..8645d7f104 100644 --- a/test/lisp/erc/erc-dcc-tests.el +++ b/test/lisp/erc/erc-dcc-tests.el @@ -20,8 +20,9 @@ ;;; Commentary: ;;; Code: -(require 'ert) +(require 'ert-x) (require 'erc-dcc) +(require 'erc-pcomplete) (ert-deftest erc-dcc-ctcp-query-send-regexp () (let ((s "DCC SEND \"file name\" 2130706433 9899 1405135128")) @@ -164,4 +165,120 @@ (should (eq t (plist-get (car erc-dcc-list) :turbo))) (should (equal (pop calls) (list elt "foo.bin" proc)))))))) +(defun erc-dcc-tests--pcomplete-common (test-fn) + (with-current-buffer (get-buffer-create "*erc-dcc-do-GET-command*") + (let* ((proc (start-process "fake" (current-buffer) "sleep" "10")) + (elt (list :nick "tester!~tester@fake.irc" + :type 'GET + :peer nil + :parent proc + :ip "127.0.0.1" + :port "9899" + :file "foo.bin" + :size 1405135128)) + ;; + erc-accidental-paste-threshold-seconds + erc-insert-modify-hook erc-send-completed-hook + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (erc-mode) + (pcomplete-erc-setup) + (add-hook 'erc-complete-functions #'erc-pcompletions-at-point 0 t) + (setq erc-server-process proc + erc-input-marker (make-marker) + erc-insert-marker (make-marker) + erc-server-current-nick "dummy") + (setq-local erc-dcc-list (list elt)) ; for interactive noodling + (set-process-query-on-exit-flag proc nil) + (goto-char (point-max)) + (set-marker erc-insert-marker (point-max)) + (erc-display-prompt) + (goto-char erc-input-marker) + (funcall test-fn)) + (when noninteractive + (kill-buffer)))) + +(ert-deftest pcomplete/erc-mode/DCC--get-basic () + (erc-dcc-tests--pcomplete-common + (lambda () + (insert "/dcc get ") + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get tester" nil t))) + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get tester foo.bin" nil t)))))) + +(ert-deftest pcomplete/erc-mode/DCC--get-1flag () + (erc-dcc-tests--pcomplete-common + (lambda () + (goto-char erc-input-marker) + (delete-region (point) (point-max)) + (insert "/dcc get -") + (call-interactively #'completion-at-point) + (with-current-buffer (get-buffer "*Completions*") + (goto-char (point-min)) + (search-forward "-s") + (search-forward "-t")) + (insert "s ") + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get -s tester" nil t))) + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get -s tester foo.bin" nil t)))))) + +(ert-deftest pcomplete/erc-mode/DCC--get-2flags () + (erc-dcc-tests--pcomplete-common + (lambda () + (goto-char erc-input-marker) + (delete-region (point) (point-max)) + (insert "/dcc get -") + (call-interactively #'completion-at-point) + (with-current-buffer (get-buffer "*Completions*") + (goto-char (point-min)) + (search-forward "-s") + (search-forward "-t")) + (insert "s -") + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get -s -t " nil t))) + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get -s -t tester" nil t))) + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get -s -t tester foo.bin" nil t)))))) + +(ert-deftest pcomplete/erc-mode/DCC--get-2flags-reverse () + (erc-dcc-tests--pcomplete-common + (lambda () + (goto-char erc-input-marker) + (delete-region (point) (point-max)) + (insert "/dcc get -") + (call-interactively #'completion-at-point) + (with-current-buffer (get-buffer "*Completions*") + (goto-char (point-min)) + (search-forward "-s") + (search-forward "-t")) + (insert "t -") + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get -t -s " nil t))) + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get -t -s tester" nil t))) + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get -t -s tester foo.bin" nil t)))))) + ;;; erc-dcc-tests.el ends here commit 0606b095d2411f43a7e842707bcec006e9952a60 Author: F. Jason Park Date: Fri Nov 4 05:01:35 2022 -0700 * lisp/erc/erc.el (erc-cmd-RECONNECT): Fix macro arg. diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index db39e341b2..7153305a91 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -4071,7 +4071,7 @@ the message given by REASON." (delete-process process)) (erc-server-reconnect) (with-suppressed-warnings ((obsolete erc-server-reconnecting) - ((obsolete erc-reuse-buffers))) + (obsolete erc-reuse-buffers)) (if erc-reuse-buffers (progn (cl-assert (not erc--server-reconnecting)) (cl-assert (not erc-server-reconnecting))) commit 913aa90013d1eab9cebc5696799f41387b3f37f5 Author: F. Jason Park Date: Fri Nov 4 05:01:35 2022 -0700 ; * test/lisp/erc/erc-services-tests.el: Remove cruft. diff --git a/test/lisp/erc/erc-services-tests.el b/test/lisp/erc/erc-services-tests.el index 8e2b8d2927..c22d4cf75e 100644 --- a/test/lisp/erc/erc-services-tests.el +++ b/test/lisp/erc/erc-services-tests.el @@ -469,12 +469,9 @@ (list (assoc 'secret (cdr found))))) (defvar erc-join-tests--auth-source-pass-entries - '(("irc.gnu.org:irc/#chan" - ("port" . "irc") ("user" . "#chan") (secret . "bar")) - ("my.gnu.org:irc/#chan" - ("port" . "irc") ("user" . "#chan") (secret . "baz")) - ("GNU.chat:irc/#chan" - ("port" . "irc") ("user" . "#chan") (secret . "foo")))) + '(("irc.gnu.org:irc/#chan" (secret . "bar")) + ("my.gnu.org:irc/#chan" (secret . "baz")) + ("GNU.chat:irc/#chan" (secret . "foo")))) (ert-deftest erc--auth-source-search--pass-standard () (ert-skip "Pass backend not yet supported") @@ -506,16 +503,11 @@ (ert-skip "Pass backend not yet supported") (let ((store `(,@erc-join-tests--auth-source-pass-entries - ("GNU.chat:6697/#chan" - ("port" . "6697") ("user" . "#chan") (secret . "spam")) - ("my.gnu.org:irc/#fsf" - ("port" . "irc") ("user" . "#fsf") (secret . "42")) - ("irc.gnu.org:6667" - ("port" . "6667") (secret . "sesame")) - ("MyHost:irc" - ("port" . "irc") (secret . "456")) - ("MyHost:6667" - ("port" . "6667") (secret . "123")))) + ("GNU.chat:6697/#chan" (secret . "spam")) + ("my.gnu.org:irc/#fsf" (secret . "42")) + ("irc.gnu.org:6667" (secret . "sesame")) + ("MyHost:irc" (secret . "456")) + ("MyHost:6667" (secret . "123")))) (auth-sources '(password-store)) (auth-source-do-cache nil)) commit 06f0d4793c66b8fa71478fef002d92d2c4d53c92 Author: Dmitry Gutov Date: Sat Nov 5 02:54:20 2022 +0200 project-kill-buffer-conditions: Tweak * lisp/progmodes/project.el (project-kill-buffer-conditions): Tweak. diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index fc916739d0..3f3015b78d 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1228,7 +1228,7 @@ displayed." ;; Most of temp and logging buffers (aside from hidden ones): (and (major-mode . fundamental-mode) - (not "\\` ")) + "\\[^ ]") ;; non-text buffer such as xref, occur, vc, log, ... (and (derived-mode . special-mode) (not (major-mode . help-mode)) commit a0d08878f16b66958d5041bcf6b82f9697b2a5f1 Author: Matt Armstrong Date: Fri Nov 4 15:24:57 2022 -0700 ; Make clang-format handle FOR_EACH_LIVE_BUFFER * .clang-format (ForEachMacros): Add FOR_EACH_LIVE_BUFFER. (Bug#59027) diff --git a/.clang-format b/.clang-format index 8a8391c2e4..464375bd41 100644 --- a/.clang-format +++ b/.clang-format @@ -6,7 +6,10 @@ BreakBeforeBinaryOperators: All BreakBeforeBraces: GNU ColumnLimit: 70 ContinuationIndentWidth: 2 -ForEachMacros: [FOR_EACH_TAIL, FOR_EACH_TAIL_SAFE, ITREE_FOREACH] +ForEachMacros: [FOR_EACH_TAIL, + FOR_EACH_TAIL_SAFE, + FOR_EACH_LIVE_BUFFER, + ITREE_FOREACH] IncludeCategories: - Regex: '^$' Priority: -1 commit 18c184d6d97a66627359df7fa2ba29445a0d6a3c Author: Matt Armstrong Date: Thu Nov 3 14:34:03 2022 -0700 Configure clang-format to use tabs * .clang-format (UseTab): Set to "Always", to match the (indent-tabs-mode . t) in .dir-locals.el. (Bug#59027) diff --git a/.clang-format b/.clang-format index ac9f95c88a..8a8391c2e4 100644 --- a/.clang-format +++ b/.clang-format @@ -21,6 +21,7 @@ MaxEmptyLinesToKeep: 1 PenaltyBreakBeforeFirstCallParameter: 2000 SpaceAfterCStyleCast: true SpaceBeforeParens: Always +UseTab: Always # Local Variables: # mode: yaml commit b2401cdfd21f6b23fbed57ffceec488ed4700de6 Author: Philip Kaludercic Date: Fri Oct 28 19:44:47 2022 +0200 Print "decrypted" rot13 text is buffer is read-only * lisp/rot13.el (rot13-region): Add fallback if buffer is read-only * doc/emacs/rmail.texi (Rmail Rot13): Document new behaviour. diff --git a/doc/emacs/rmail.texi b/doc/emacs/rmail.texi index e38bde036a..7414cdb079 100644 --- a/doc/emacs/rmail.texi +++ b/doc/emacs/rmail.texi @@ -1409,6 +1409,14 @@ might use rot13 to hide important plot points. rot13-other-window}. This displays the current buffer in another window which applies the code when displaying the text. +@findex rot13-region + If you are only interested in a region, the command @kbd{M-x +rot13-region} might be preferable. This will encrypt/decrypt the +active region in-place. If the buffer is read-only, it will attempt +to display the plain text in the echo area. If the text is too long +for the echo area, the command will pop up a temporary buffer with the +encrypted/decrypted text. + @node Movemail @section @command{movemail} program @cindex @command{movemail} program diff --git a/lisp/rot13.el b/lisp/rot13.el index c063725de8..5d1c46e483 100644 --- a/lisp/rot13.el +++ b/lisp/rot13.el @@ -85,9 +85,16 @@ and END, and return the encrypted string." ;;;###autoload (defun rot13-region (start end) - "ROT13 encrypt the region between START and END in current buffer." + "ROT13 encrypt the region between START and END in current buffer. +If invoked interactively and the buffer is read-only, a message +will be printed instead." (interactive "r") - (translate-region start end rot13-translate-table)) + (condition-case nil + (translate-region start end rot13-translate-table) + (buffer-read-only + (when (called-interactively-p 'interactive) + (let ((dec (rot13-string (buffer-substring start end)))) + (message "Buffer is read-only:\n%s" (string-trim dec))))))) ;;;###autoload (defun rot13-other-window () commit f3c138bb1abd1d31bdb794d80eb6ea84d674ed00 Author: Philip Kaludercic Date: Fri Nov 4 23:06:11 2022 +0100 * lisp/net/rcirc.el (rcirc-print): Replace misjudged assertion diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index b7eeab1735..370f388b3e 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -2066,7 +2066,8 @@ connection." (set-marker-insertion-type rcirc-prompt-end-marker t) ;; run markup functions - (cl-assert (bolp)) + (unless (bolp) + (newline)) (save-excursion (save-restriction (narrow-to-region (point) (point)) commit 44ad42240069d8d82772b0c0ef5ec93c2566ca7e Author: Stefan Kangas Date: Fri Nov 4 20:26:01 2022 +0100 * lisp/textmodes/css-mode.el (css-mode-map): Prefer defvar-keymap. diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index d2a35bd550..55dced96b7 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -875,26 +875,24 @@ cannot be completed sensibly: `custom-ident', (modify-syntax-entry ?? "." st) st)) -(defvar css-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [remap info-lookup-symbol] 'css-lookup-symbol) - ;; `info-complete-symbol' is not used. - (define-key map [remap complete-symbol] 'completion-at-point) - (define-key map "\C-c\C-f" 'css-cycle-color-format) - (easy-menu-define css-menu map "CSS mode menu" - '("CSS" - :help "CSS-specific features" - ["Reformat block" fill-paragraph - :help "Reformat declaration block or fill comment at point"] - ["Cycle color format" css-cycle-color-format - :help "Cycle color at point between different formats"] - "-" - ["Describe symbol" css-lookup-symbol - :help "Display documentation for a CSS symbol"] - ["Complete symbol" completion-at-point - :help "Complete symbol before point"])) - map) - "Keymap used in `css-mode'.") +(defvar-keymap css-mode-map + :doc "Keymap used in `css-mode'." + " " #'css-lookup-symbol + ;; `info-complete-symbol' is not used. + " " #'completion-at-point + "C-c C-f" #'css-cycle-color-format + :menu + '("CSS" + :help "CSS-specific features" + ["Reformat block" fill-paragraph + :help "Reformat declaration block or fill comment at point"] + ["Cycle color format" css-cycle-color-format + :help "Cycle color at point between different formats"] + "-" + ["Describe symbol" css-lookup-symbol + :help "Display documentation for a CSS symbol"] + ["Complete symbol" completion-at-point + :help "Complete symbol before point"])) (eval-and-compile (defconst css--uri-re commit 7e2d71dd5cf49e2906e3e501bcb1280c92c6e6ea Author: Stefan Kangas Date: Fri Nov 4 20:23:55 2022 +0100 * lisp/dired-aux.el (dired-check-process): Use progress reporter. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 29f973e506..5e1745069f 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1025,8 +1025,9 @@ If PROGRAM exits successfully, display \"MSG...done\" and return nil. If PROGRAM exits abnormally, save in `dired-log-buffer' the command that invoked PROGRAM and the messages it emitted, and return either the offending ARGUMENTS or PROGRAM if no ARGUMENTS were provided." - (let (err-buffer err (dir default-directory)) - (message "%s..." msg) + (let ((dir default-directory) + (reporter (make-progress-reporter msg)) + err-buffer err) (save-excursion ;; Get a clean buffer for error output: (setq err-buffer (get-buffer-create " *dired-check-process output*")) @@ -1041,8 +1042,8 @@ the offending ARGUMENTS or PROGRAM if no ARGUMENTS were provided." (dired-log err-buffer) (or arguments program t)) (kill-buffer err-buffer) - (message "%s...done" msg) - nil)))) + (progress-reporter-done reporter) + nil)))) (defun dired-shell-command (cmd) "Run CMD, and check for output. commit 5f0af7caecb3096816cc0f2edaefbd7daf838e57 Author: Stefan Kangas Date: Fri Nov 4 20:15:42 2022 +0100 ; package-vc: Pacify byte-compiler * lisp/emacs-lisp/package-vc.el (package-vc-selected-packages): Declare. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index a19bbb1988..aae33096c9 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -116,6 +116,7 @@ symbol is used. The value must be a member of vc-handled-backends)) :version "29.1") +(defvar package-vc-selected-packages) ; pacify byte-compiler (defun package-vc-ensure-packages () "Ensure source packages specified in `package-vc-selected-packages'." (pcase-dolist (`(,(and (pred symbolp) name) . ,spec) commit 784ff9c5d315881e93b0c80c443aa6f5be3b1ef9 Author: Stefan Kangas Date: Fri Nov 4 16:25:21 2022 +0100 Use progress reporter in cpp.el * lisp/progmodes/cpp.el (cpp-highlight-buffer): Use progress reporter. (cpp-progress-time, cpp-progress-message): Make obsolete in favor of 'make-progress-reporter'. (cpp-message-min-time-interval): Doc fix. diff --git a/lisp/progmodes/cpp.el b/lisp/progmodes/cpp.el index 77d7bbd42d..43e430d40c 100644 --- a/lisp/progmodes/cpp.el +++ b/lisp/progmodes/cpp.el @@ -1,6 +1,6 @@ ;;; cpp.el --- highlight or hide text according to cpp conditionals -*- lexical-binding: t -*- -;; Copyright (C) 1994-1995, 2001-2022 Free Software Foundation, Inc. +;; Copyright (C) 1994-2022 Free Software Foundation, Inc. ;; Author: Per Abrahamsen ;; Keywords: c, faces, tools @@ -98,8 +98,8 @@ Each entry is a list with the following elements: (const :tag "Both branches writable" both))))) (defcustom cpp-message-min-time-interval 1.0 - "Minimum time interval in seconds for `cpp-progress-message' messages. -If nil, `cpp-progress-message' prints no progress messages." + "Minimum time interval in seconds for `cpp-highlight-buffer' progress messages. +If nil, `cpp-highlight-buffer' prints no progress messages." :type '(choice (const :tag "Disable progress messages" nil) float) :version "26.1") @@ -218,14 +218,15 @@ A prefix arg suppresses display of that buffer." (cpp-parse-reset) (if (null cpp-edit-list) (cpp-edit-load)) - (let (cpp-state-stack) + (let ((reporter + (and cpp-message-min-time-interval + (make-progress-reporter "Parsing..." (point-min) (point-max) + nil nil cpp-message-min-time-interval))) + cpp-state-stack) (save-excursion (goto-char (point-min)) - (cpp-progress-message "Parsing...") (while (re-search-forward cpp-parse-regexp nil t) - (cpp-progress-message "Parsing...%d%%" - (floor (* 100.0 (- (point) (point-min))) - (buffer-size))) + (when reporter (progress-reporter-update reporter (point))) (let ((match (buffer-substring (match-beginning 0) (match-end 0)))) (cond ((or (string-equal match "'") (string-equal match "\"")) @@ -268,7 +269,7 @@ A prefix arg suppresses display of that buffer." (cpp-parse-close from to)) (t (cpp-parse-error "Parser error")))))))) - (cpp-progress-message "Parsing...done")) + (when reporter (progress-reporter-done reporter))) (if cpp-state-stack (save-excursion (goto-char (nth 3 (car cpp-state-stack))) @@ -814,6 +815,7 @@ Type must be one of the types defined in `cpp-face-type-list'." ;;; Utilities: +(make-obsolete-variable 'cpp-progress-time nil "29.1") (defvar cpp-progress-time 0 "Last time `cpp-progress-message' issued a progress message.") @@ -823,6 +825,7 @@ Type must be one of the types defined in `cpp-face-type-list'." Print messages at most once every `cpp-message-min-time-interval' seconds. If that option is nil, don't prints messages. ARGS are the same as for `message'." + (declare (obsolete make-progress-reporter "29.1")) (when cpp-message-min-time-interval (let ((time (current-time))) (unless (time-less-p cpp-message-min-time-interval commit 3620aff8a9b6613c09cd373c4cd41d1d5fb845e4 Author: Stefan Kangas Date: Fri Nov 4 15:38:41 2022 +0100 * lisp/progmodes/cpp.el (cpp-edit-mode-map): Prefer defvar-keymap. diff --git a/lisp/progmodes/cpp.el b/lisp/progmodes/cpp.el index f4584b6311..77d7bbd42d 100644 --- a/lisp/progmodes/cpp.el +++ b/lisp/progmodes/cpp.el @@ -410,47 +410,45 @@ A prefix arg suppresses display of that buffer." ;;; Edit Buffer: -(defvar cpp-edit-mode-map - (let ((map (make-keymap))) - (suppress-keymap map) - (define-key map [ down-mouse-2 ] 'cpp-push-button) - (define-key map [ mouse-2 ] 'ignore) - (define-key map " " 'scroll-up-command) - (define-key map [?\S-\ ] 'scroll-down-command) - (define-key map "\C-?" 'scroll-down-command) - (define-key map [ delete ] 'scroll-down) - (define-key map "\C-c\C-c" 'cpp-edit-apply) - (define-key map "a" 'cpp-edit-apply) - (define-key map "A" 'cpp-edit-apply) - (define-key map "r" 'cpp-edit-reset) - (define-key map "R" 'cpp-edit-reset) - (define-key map "s" 'cpp-edit-save) - (define-key map "S" 'cpp-edit-save) - (define-key map "l" 'cpp-edit-load) - (define-key map "L" 'cpp-edit-load) - (define-key map "h" 'cpp-edit-home) - (define-key map "H" 'cpp-edit-home) - (define-key map "b" 'cpp-edit-background) - (define-key map "B" 'cpp-edit-background) - (define-key map "k" 'cpp-edit-known) - (define-key map "K" 'cpp-edit-known) - (define-key map "u" 'cpp-edit-unknown) - (define-key map "u" 'cpp-edit-unknown) - (define-key map "t" 'cpp-edit-true) - (define-key map "T" 'cpp-edit-true) - (define-key map "f" 'cpp-edit-false) - (define-key map "F" 'cpp-edit-false) - (define-key map "w" 'cpp-edit-write) - (define-key map "W" 'cpp-edit-write) - (define-key map "X" 'cpp-edit-toggle-known) - (define-key map "x" 'cpp-edit-toggle-known) - (define-key map "Y" 'cpp-edit-toggle-unknown) - (define-key map "y" 'cpp-edit-toggle-unknown) - (define-key map "q" 'bury-buffer) - (define-key map "Q" 'bury-buffer) - map) - "Keymap for `cpp-edit-mode'.") - +(defvar-keymap cpp-edit-mode-map + :doc "Keymap for `cpp-edit-mode'." + :full t + :suppress t + "" #'cpp-push-button + "" #'ignore + "SPC" #'scroll-up-command + "S-SPC" #'scroll-down-command + "DEL" #'scroll-down-command + "" #'scroll-down + "C-c C-c" #'cpp-edit-apply + "a" #'cpp-edit-apply + "A" #'cpp-edit-apply + "r" #'cpp-edit-reset + "R" #'cpp-edit-reset + "s" #'cpp-edit-save + "S" #'cpp-edit-save + "l" #'cpp-edit-load + "L" #'cpp-edit-load + "h" #'cpp-edit-home + "H" #'cpp-edit-home + "b" #'cpp-edit-background + "B" #'cpp-edit-background + "k" #'cpp-edit-known + "K" #'cpp-edit-known + "u" #'cpp-edit-unknown + "U" #'cpp-edit-unknown + "t" #'cpp-edit-true + "T" #'cpp-edit-true + "f" #'cpp-edit-false + "F" #'cpp-edit-false + "w" #'cpp-edit-write + "W" #'cpp-edit-write + "X" #'cpp-edit-toggle-known + "x" #'cpp-edit-toggle-known + "Y" #'cpp-edit-toggle-unknown + "y" #'cpp-edit-toggle-unknown + "q" #'bury-buffer + "Q" #'bury-buffer) (defvar-local cpp-edit-symbols nil commit 90a0aac3e8ebfb9f3c1df04deb9c85414f3530c0 Author: Paul Eggert Date: Fri Nov 4 11:00:49 2022 -0700 Pacify gcc -Wanalyzer-null-dereference This is for gcc 12.2.1 20220819 (Red Hat 12.2.1-2) x86-64 when Emacs is configured with --enable-gcc-warnings. * src/buffer.c (Fmove_overlay): Prefer BASE_EQ to EQ in a place where they’re equivalent because the only symbol allowed here is nil. diff --git a/src/buffer.c b/src/buffer.c index ee0b7e1350..745e62f53f 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -3619,7 +3619,7 @@ buffer. */) o_end = OVERLAY_END (overlay); } - if (! EQ (buffer, obuffer)) + if (! BASE_EQ (buffer, obuffer)) { if (! NILP (obuffer)) remove_buffer_overlay (XBUFFER (obuffer), XOVERLAY (overlay)); commit 5fa2f116799b8a7c17ff6eedd6e1b1af077c116b Merge: 616aa23d8a f762c5bb2c Author: Philip Kaludercic Date: Fri Nov 4 18:57:45 2022 +0100 Merge branch 'feature/package+vc' commit f762c5bb2c96ec9608807bf3c1e3655fb59fc4d6 (refs/remotes/origin/feature/package+vc) Author: Philip Kaludercic Date: Fri Nov 4 18:53:02 2022 +0100 * lisp/emacs-lisp/package-vc.el: Expand commentary diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 4a9c168533..a19bbb1988 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -23,6 +23,17 @@ ;; While packages managed by package.el use tarballs for distributing ;; the source code, this extension allows for packages to be fetched ;; and updated directly from a version control system. +;; +;; To install a package from source use `package-vc-install'. If you +;; aren't interested in activating a package, you can use +;; `package-vc-checkout' instead, which will prompt you for a target +;; directory. If you wish to re-use an existing checkout, the command +;; `package-vc-link-directory' will create a symbolic link and prepare +;; the package. +;; +;; If you make local changes that you wish to share with an upstream +;; maintainer, the command `package-vc-prepare-patch' can prepare +;; these as patches to send via Email. ;;; TODO: commit 184f0c3e60aef89e625aa0666266fd623d62dc06 Author: Philip Kaludercic Date: Fri Nov 4 18:19:01 2022 +0100 ; * lisp/emacs-lisp/package-vc.el (package-vc): Add missing :prefix diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 2e0a6b6a60..4a9c168533 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -44,6 +44,7 @@ "Manage packages from VC checkouts." :group 'package :link '(custom-manual "(emacs) Package from Source") + :prefix "package-vc-" :version "29.1") (defconst package-vc--elpa-packages-version 1 commit f17fadd01ac291cd3d917df4255b25fa7e81212a Author: Philip Kaludercic Date: Fri Nov 4 18:17:45 2022 +0100 Link to Manual from the package-vc group * lisp/emacs-lisp/package-vc.el (package-vc): Add 'custom-manual' link. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index b18b5b1e48..2e0a6b6a60 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -43,6 +43,7 @@ (defgroup package-vc nil "Manage packages from VC checkouts." :group 'package + :link '(custom-manual "(emacs) Package from Source") :version "29.1") (defconst package-vc--elpa-packages-version 1 commit d69edfc7956b3194e6b84c4030670c8a8c409b1c Author: Philip Kaludercic Date: Fri Nov 4 18:17:02 2022 +0100 ; * doc/emacs/package.texi: Rename to "Fetching Package Sources" diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index 51b86bb147..bd11648e57 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -49,7 +49,7 @@ Manual}. * Package Statuses:: Which statuses a package can have. * Package Installation:: Options for package installation. * Package Files:: Where packages are installed. -* Package from Source:: Managing packages directly from source. +* Fetching Package Sources:: Managing packages directly from source. @end menu @node Package Menu @@ -532,8 +532,8 @@ corresponding package subdirectory. This only works for packages installed in @code{package-user-dir}; if told to act on a package in a system-wide package directory, the deletion command signals an error. -@node Package from Source -@section Package from Source +@node Fetching Package Sources +@section Fetching Package Sources @cindex package development source @cindex upstream source, for packages @cindex git source of package @c "git" is not technically correct commit b5850ba3ae8758731d9420cf62c4fca6b765905c Author: Philip Kaludercic Date: Fri Nov 4 18:04:35 2022 +0100 Document 'package-vc-selected-packages' * doc/emacs/package.texi: Expand documentation and give example. * etc/NEWS: Mention 'package-vc-selected-packages'. * lisp/emacs-lisp/package-vc.el (package-vc--select-packages): Remove function. (package-vc-ensure-packages): Add function based on 'package-vc--select-packages'. (package-vc-selected-packages): Call 'package-vc-ensure-packages' from custom setter. diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index bd6d91a785..51b86bb147 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -558,6 +558,29 @@ regular package listing. If you just wish to clone the source of a package, without adding it to the package list, use @code{package-vc-checkout}. +@vindex package-vc-selected-packages +@findex package-vc-ensure-packages + An alternative way to use @code{package-vc-install} is via the +@code{package-vc-selected-packages} user option. This is an alist of +packages to install, where each key is a package name and the value is +@code{nil}, indicating that any revision is to install, a string, +indicating a specific revision or a package specification plist. The +side effect of setting the user option is to install the package, but +the process can also be manually triggered using the function +@code{package-vc-ensure-packages}. Here is an example of how the user +option: + +@example +@group +(setopt package-vc-selected-packages + '((modus-themes . "0f39eb3fd9") ;specific revision + (auctex . nil) ;any revision + (foo ;a package specification + :url "https://git.sv.gnu.org/r/foo-mode.git" + :branch "trunk"))) +@end group +@end example + @findex package-report-bug @findex package-vc-prepare-patch With the source checkout, you might want to reproduce a bug against diff --git a/etc/NEWS b/etc/NEWS index d808e7ab90..7550310935 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1573,6 +1573,11 @@ packages checked out using 'package-vc-install'. This command helps you compose an email for sending bug reports to package maintainers. ++++ +*** New user option 'package-vc-selected-packages' +By customising this user option you can specify specific packages to +install. + ** Emacs Sessions (Desktop) +++ diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 3eac55ba54..b18b5b1e48 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -103,13 +103,13 @@ symbol is used. The value must be a member of vc-handled-backends)) :version "29.1") -(defun package-vc--select-packages (sym val) - "Custom setter for `package-vc-selected-packages'. -It will ensure that all the packages are installed as source -packages. Finally SYM is set to VAL." - (pcase-dolist (`(,(and (pred symbolp) name) . ,spec) val) +(defun package-vc-ensure-packages () + "Ensure source packages specified in `package-vc-selected-packages'." + (pcase-dolist (`(,(and (pred symbolp) name) . ,spec) + package-vc-selected-packages) (let ((pkg-desc (cadr (assoc name package-alist #'string=)))) - (unless (and name (package-installed-p name) (package-vc-p pkg-desc)) + (unless (and name (package-installed-p name) + (package-vc-p pkg-desc)) (cond ((null spec) (package-vc-install name)) @@ -117,8 +117,7 @@ packages. Finally SYM is set to VAL." (package-vc-install name nil spec)) ((listp spec) (package-vc--archives-initialize) - (package-vc--unpack pkg-desc spec)))))) - (custom-set-default sym val)) + (package-vc--unpack pkg-desc spec))))))) ;;;###autoload (defcustom package-vc-selected-packages '() @@ -134,7 +133,8 @@ is a symbol designating the package and SPEC is one of: specification. This user option differs from `package-selected-packages' in that -it is meant to be specified manually." +it is meant to be specified manually. You can also use the +function `package-vc-selected-packages' to apply the changes." :type '(alist :tag "List of ensured packages" :key-type (symbol :tag "Package") :value-type @@ -145,7 +145,9 @@ it is meant to be specified manually." (:lisp-dir string) (:main-file string) (:vc-backend symbol))))) - :set #'package-vc--select-packages + :set (lambda (sym val) + (custom-set-default sym val) + (package-vc-ensure-packages)) :version "29.1") (defvar package-vc--archive-spec-alist nil commit 616aa23d8a130a664a2ce3bb05f3518ce0f5a018 Author: Stefan Monnier Date: Fri Nov 4 11:59:51 2022 -0400 * lisp/simple.el (function-documentation): Fix bug#59014 diff --git a/lisp/simple.el b/lisp/simple.el index e804f717b0..5f676ea50d 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2647,10 +2647,7 @@ function as needed." ((or `(lambda ,_args . ,body) `(closure ,_env ,_args . ,body) `(autoload ,_file . ,body)) (let ((doc (car body))) - (when (and (funcall docstring-p doc) - ;; Handle a doc reference--but these never come last - ;; in the function body, so reject them if they are last. - (or (cdr body) (eq 'autoload (car-safe function)))) + (when (funcall docstring-p doc) doc))) (_ (signal 'invalid-function (list function)))))) commit 5d6e919a90bc3ad3c73f9c6b20b25837d283af0e Author: Michael Albinus Date: Fri Nov 4 15:39:58 2022 +0100 Fix calling file name handler for `load'. * lisp/net/ange-ftp.el (ange-ftp-load): Add MUST-SUFFIX argument. * lisp/net/tramp.el (tramp-handle-load): Adapt MUST_SUFFIX test. * src/lread.c (Fload): Call handler with must_suffix. * test/lisp/net/tramp-tests.el (tramp-test27-load): Extend test. diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 6ffa65a2dd..d6d0fb9a25 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -4242,7 +4242,7 @@ directory, so that Emacs will know its current contents." ((eq identification 'localname) localname) (t (ange-ftp-replace-name-component file "")))))) -(defun ange-ftp-load (file &optional noerror nomessage nosuffix) +(defun ange-ftp-load (file &optional noerror nomessage nosuffix must-suffix) (if (ange-ftp-ftp-name file) (let ((tryfiles (if nosuffix (list file) @@ -4264,7 +4264,7 @@ directory, so that Emacs will know its current contents." (or noerror (signal 'file-error (list "Cannot open load file" file))) nil)) - (ange-ftp-real-load file noerror nomessage nosuffix))) + (ange-ftp-real-load file noerror nomessage nosuffix must-suffix))) ;; Calculate default-unhandled-directory for a given ange-ftp buffer. (defun ange-ftp-unhandled-file-name-directory (_filename) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 9552e51c48..b08bc63e8a 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -4584,14 +4584,9 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (setq file (concat file ".elc"))) ((file-exists-p (concat file ".el")) (setq file (concat file ".el"))))) - (when must-suffix - ;; The first condition is always true for absolute file names. - ;; Included for safety's sake. - (unless (or (file-name-directory file) - (string-match-p (rx ".el" (? "c") eos) file)) - (tramp-error - v 'file-error - "File `%s' does not include a `.el' or `.elc' suffix" file))) + (when (and must-suffix (not (string-match-p (rx ".el" (? "c") eos) file))) + (tramp-error + v 'file-error "File `%s' does not include a `.el' or `.elc' suffix" file)) (unless (or noerror (file-exists-p file)) (tramp-error v 'file-missing file)) (if (not (file-exists-p file)) diff --git a/src/lread.c b/src/lread.c index dfa4d9afb5..957bc6895e 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1236,7 +1236,8 @@ Return t if the file exists and loads successfully. */) /* If file name is magic, call the handler. */ handler = Ffind_file_name_handler (file, Qload); if (!NILP (handler)) - return call5 (handler, Qload, file, noerror, nomessage, nosuffix); + return + call6 (handler, Qload, file, noerror, nomessage, nosuffix, must_suffix); /* The presence of this call is the result of a historical accident: it used to be in every file-operation and when it got removed diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 2db4449438..46fef558bf 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -4616,10 +4616,13 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (load tmp-name 'noerror 'nomessage)) (should-not (featurep 'tramp-test-load)) (write-region "(provide 'tramp-test-load)" nil tmp-name) - ;; `load' in lread.c does not pass `must-suffix'. Why? - ;;(should-error - ;; (load tmp-name nil 'nomessage 'nosuffix 'must-suffix) - ;; :type 'file-error) + ;; `load' in lread.c passes `must-suffix' since Emacs 29. + ;; In Ange-FTP, `must-suffix' is ignored. + (when (and (tramp--test-emacs29-p) + (not (tramp--test-ange-ftp-p))) + (should-error + (load tmp-name nil 'nomessage 'nosuffix 'must-suffix) + :type 'file-error)) (load tmp-name nil 'nomessage 'nosuffix) (should (featurep 'tramp-test-load))) commit f0f960050b1d3931331bf0ce42d2e106f8c7832b Author: Stefan Kangas Date: Fri Nov 4 15:00:02 2022 +0100 Normalize some syntax table definitions * lisp/nxml/rng-cmpct.el (rng-c-syntax-table): * lisp/progmodes/cperl-mode.el (cperl-mode-syntax-table) (cperl-string-syntax-table2): * lisp/progmodes/dcl-mode.el (dcl-mode-syntax-table): Normalize definitions to better follow modern ELisp conventions. diff --git a/lisp/nxml/rng-cmpct.el b/lisp/nxml/rng-cmpct.el index 453c2b736d..85db33b9a9 100644 --- a/lisp/nxml/rng-cmpct.el +++ b/lisp/nxml/rng-cmpct.el @@ -1,6 +1,6 @@ ;;; rng-cmpct.el --- parsing of RELAX NG Compact Syntax schemas -*- lexical-binding:t -*- -;; Copyright (C) 2003, 2007-2022 Free Software Foundation, Inc. +;; Copyright (C) 2003-2022 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML, RelaxNG @@ -82,19 +82,17 @@ Return a pattern." (concat "\\`\\(" (regexp-opt rng-c-keywords) "\\)\\'") "Regular expression to match a keyword in the compact syntax.") -(defvar rng-c-syntax-table nil +(defvar rng-c-syntax-table + (let ((st (make-syntax-table))) + (modify-syntax-entry ?# "<" st) + (modify-syntax-entry ?\n ">" st) + (modify-syntax-entry ?- "w" st) + (modify-syntax-entry ?. "w" st) + (modify-syntax-entry ?_ "w" st) + (modify-syntax-entry ?: "_" st) + st) "Syntax table for parsing the compact syntax.") -(if rng-c-syntax-table - () - (setq rng-c-syntax-table (make-syntax-table)) - (modify-syntax-entry ?# "<" rng-c-syntax-table) - (modify-syntax-entry ?\n ">" rng-c-syntax-table) - (modify-syntax-entry ?- "w" rng-c-syntax-table) - (modify-syntax-entry ?. "w" rng-c-syntax-table) - (modify-syntax-entry ?_ "w" rng-c-syntax-table) - (modify-syntax-entry ?: "_" rng-c-syntax-table)) - (defconst rng-c-literal-1-re "'\\(''\\([^']\\|'[^']\\|''[^']\\)*''\\|[^'\n]*\\)'" "Regular expression to match a single-quoted literal.") diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 539b277149..b36896ae7c 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -1429,10 +1429,40 @@ the last)." (rx (sequence line-start (0+ blank) (eval cperl--imenu-entries-rx))) "The regular expression used for `outline-minor-mode'.") -(defvar cperl-mode-syntax-table nil +(defvar cperl-mode-syntax-table + (let ((st (make-syntax-table))) + (modify-syntax-entry ?\\ "\\" st) + (modify-syntax-entry ?/ "." st) + (modify-syntax-entry ?* "." st) + (modify-syntax-entry ?+ "." st) + (modify-syntax-entry ?- "." st) + (modify-syntax-entry ?= "." st) + (modify-syntax-entry ?% "." st) + (modify-syntax-entry ?< "." st) + (modify-syntax-entry ?> "." st) + (modify-syntax-entry ?& "." st) + (modify-syntax-entry ?$ "\\" st) + (modify-syntax-entry ?\n ">" st) + (modify-syntax-entry ?# "<" st) + (modify-syntax-entry ?' "\"" st) + (modify-syntax-entry ?` "\"" st) + (if cperl-under-as-char + (modify-syntax-entry ?_ "w" st)) + (modify-syntax-entry ?: "_" st) + (modify-syntax-entry ?| "." st) + st) "Syntax table in use in CPerl mode buffers.") -(defvar cperl-string-syntax-table nil +(defvar cperl-string-syntax-table + (let ((st (copy-syntax-table cperl-mode-syntax-table))) + (modify-syntax-entry ?$ "." st) + (modify-syntax-entry ?\{ "." st) + (modify-syntax-entry ?\} "." st) + (modify-syntax-entry ?\" "." st) + (modify-syntax-entry ?' "." st) + (modify-syntax-entry ?` "." st) + (modify-syntax-entry ?# "." st) ; (?# comment ) + st) "Syntax table in use in CPerl mode string-like chunks.") (defsubst cperl-1- (p) @@ -1441,38 +1471,6 @@ the last)." (defsubst cperl-1+ (p) (min (point-max) (1+ p))) -(if cperl-mode-syntax-table - () - (setq cperl-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "\\" cperl-mode-syntax-table) - (modify-syntax-entry ?/ "." cperl-mode-syntax-table) - (modify-syntax-entry ?* "." cperl-mode-syntax-table) - (modify-syntax-entry ?+ "." cperl-mode-syntax-table) - (modify-syntax-entry ?- "." cperl-mode-syntax-table) - (modify-syntax-entry ?= "." cperl-mode-syntax-table) - (modify-syntax-entry ?% "." cperl-mode-syntax-table) - (modify-syntax-entry ?< "." cperl-mode-syntax-table) - (modify-syntax-entry ?> "." cperl-mode-syntax-table) - (modify-syntax-entry ?& "." cperl-mode-syntax-table) - (modify-syntax-entry ?$ "\\" cperl-mode-syntax-table) - (modify-syntax-entry ?\n ">" cperl-mode-syntax-table) - (modify-syntax-entry ?# "<" cperl-mode-syntax-table) - (modify-syntax-entry ?' "\"" cperl-mode-syntax-table) - (modify-syntax-entry ?` "\"" cperl-mode-syntax-table) - (if cperl-under-as-char - (modify-syntax-entry ?_ "w" cperl-mode-syntax-table)) - (modify-syntax-entry ?: "_" cperl-mode-syntax-table) - (modify-syntax-entry ?| "." cperl-mode-syntax-table) - (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table)) - (modify-syntax-entry ?$ "." cperl-string-syntax-table) - (modify-syntax-entry ?\{ "." cperl-string-syntax-table) - (modify-syntax-entry ?\} "." cperl-string-syntax-table) - (modify-syntax-entry ?\" "." cperl-string-syntax-table) - (modify-syntax-entry ?' "." cperl-string-syntax-table) - (modify-syntax-entry ?` "." cperl-string-syntax-table) - (modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment ) - - (defvar cperl-faces-init nil) ;; Fix for msb.el diff --git a/lisp/progmodes/dcl-mode.el b/lisp/progmodes/dcl-mode.el index 1f363931b3..f1d7f236b9 100644 --- a/lisp/progmodes/dcl-mode.el +++ b/lisp/progmodes/dcl-mode.el @@ -258,17 +258,15 @@ See `imenu-generic-expression' for details." ;;; *** Global variables **************************************************** -(defvar dcl-mode-syntax-table nil +(defvar dcl-mode-syntax-table + (let ((st (make-syntax-table))) + (modify-syntax-entry ?! "<" st) ; comment start + (modify-syntax-entry ?\n ">" st) ; comment end + (modify-syntax-entry ?< "(>" st) ; < and ... + (modify-syntax-entry ?> ")<" st) ; > is a matching pair + (modify-syntax-entry ?\\ "_" st) ; not an escape + st) "Syntax table used in DCL-buffers.") -(unless dcl-mode-syntax-table - (setq dcl-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?! "<" dcl-mode-syntax-table) ; comment start - (modify-syntax-entry ?\n ">" dcl-mode-syntax-table) ; comment end - (modify-syntax-entry ?< "(>" dcl-mode-syntax-table) ; < and ... - (modify-syntax-entry ?> ")<" dcl-mode-syntax-table) ; > is a matching pair - (modify-syntax-entry ?\\ "_" dcl-mode-syntax-table) ; not an escape -) - (defvar-keymap dcl-mode-map :doc "Keymap used in DCL-mode buffers." commit 0dcdc60dded3d74f17bf6536e39bc199b47261ef Author: Stefan Kangas Date: Fri Nov 4 14:30:48 2022 +0100 * lisp/progmodes/dcl-mode.el (dcl-mode-map): Prefer defvar-keymap. diff --git a/lisp/progmodes/dcl-mode.el b/lisp/progmodes/dcl-mode.el index 8f79cdaaab..1f363931b3 100644 --- a/lisp/progmodes/dcl-mode.el +++ b/lisp/progmodes/dcl-mode.el @@ -1,6 +1,6 @@ ;;; dcl-mode.el --- major mode for editing DCL command files -*- lexical-binding: t; -*- -;; Copyright (C) 1997, 2001-2022 Free Software Foundation, Inc. +;; Copyright (C) 1997-2022 Free Software Foundation, Inc. ;; Author: Odd Gripenstam ;; Maintainer: emacs-devel@gnu.org @@ -270,26 +270,24 @@ See `imenu-generic-expression' for details." ) -(defvar dcl-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\e\n" #'dcl-split-line) - (define-key map "\e\t" #'tempo-complete-tag) - (define-key map "\e^" #'dcl-delete-indentation) - (define-key map "\em" #'dcl-back-to-indentation) - (define-key map "\ee" #'dcl-forward-command) - (define-key map "\ea" #'dcl-backward-command) - (define-key map "\e\C-q" #'dcl-indent-command) - (define-key map "\t" #'dcl-tab) - (define-key map ":" #'dcl-electric-character) - (define-key map "F" #'dcl-electric-character) - (define-key map "f" #'dcl-electric-character) - (define-key map "E" #'dcl-electric-character) - (define-key map "e" #'dcl-electric-character) - (define-key map "\C-c\C-o" #'dcl-set-option) - (define-key map "\C-c\C-f" #'tempo-forward-mark) - (define-key map "\C-c\C-b" #'tempo-backward-mark) - map) - "Keymap used in DCL-mode buffers.") +(defvar-keymap dcl-mode-map + :doc "Keymap used in DCL-mode buffers." + "M-RET" #'dcl-split-line + "M-TAB" #'tempo-complete-tag + "M-^" #'dcl-delete-indentation + "M-m" #'dcl-back-to-indentation + "M-e" #'dcl-forward-command + "M-a" #'dcl-backward-command + "C-M-q" #'dcl-indent-command + "TAB" #'dcl-tab + ":" #'dcl-electric-character + "F" #'dcl-electric-character + "f" #'dcl-electric-character + "E" #'dcl-electric-character + "e" #'dcl-electric-character + "C-c C-o" #'dcl-set-option + "C-c C-f" #'tempo-forward-mark + "C-c C-b" #'tempo-backward-mark) (easy-menu-define dcl-mode-menu dcl-mode-map "Menu for DCL-mode buffers." commit 5890e40a277a24d8f0e945c3faea3341ff1d7ed3 Author: Stefan Kangas Date: Thu Nov 3 16:58:17 2022 +0100 * admin/authors.el: Don't recommend deprecated fgrep. diff --git a/admin/authors.el b/admin/authors.el index 12fe25fa4e..fd8ba9cb01 100644 --- a/admin/authors.el +++ b/admin/authors.el @@ -990,7 +990,7 @@ in the repository.") ;; to how a file was mentioned in the respective ChangeLog. It is ;; advisable to run a Grep command such as ;; -;; fgrep -R BASENAME . --include='ChangeLog*' +;; grep -F -R BASENAME . --include='ChangeLog*' ;; ;; where BASENAME is the old basename of the renamed file. This will ;; show all the different reference forms of the file in the various commit dcb11202acdecfd3ce504cc8faaf1ba103bbfb45 Author: Eli Zaretskii Date: Fri Nov 4 15:56:30 2022 +0200 ; * lisp/progmodes/project.el (project-buffers): Doc fix. diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 0fe0a945ec..fc916739d0 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -355,8 +355,8 @@ Also quote LOCAL-FILES if `default-directory' is quoted." (cl-defgeneric project-buffers (project) "Return the list of all live buffers that belong to PROJECT. -The default implementation matches the existing buffers to -PROJECT root using the value of `default-directory' in each one." +The default implementation matches each buffer to PROJECT root using +the buffer's value of `default-directory'." (let ((root (expand-file-name (file-name-as-directory (project-root project)))) bufs) (dolist (buf (buffer-list)) commit fd3f51b7c3a6649ee3db12d33b056b1afdbfa7e9 Author: Basil L. Contovounesios Date: Wed Nov 2 03:52:16 2022 +0200 Fix manual noverlay tests * test/manual/noverlay/Makefile.in: Add copyright notice. (LIBS): Rename... (PACKAGES): ...to this, to avoid confusion with Autoconf's LIBS. All uses changed. (CFLAGS): Break out -I flag... (CPPFLAGS): ...into this new variable. (LDFLAGS): Rename... (LDLIBS): ...to this, which is expected to hold -l flags. (top_builddir): New variable. (EMACS): Define in terms of it. (.PHONY): Add clean, distclean, and perf targets. (have-libcheck): Remove redundant target. All uses updated. (itree-tests.o): Remove redundant dependency on its source file. (itree-tests): Remove redundant (and uncompilable) rule. * test/manual/noverlay/check-sanitize.sh: Use /usr/bin/env. Add copyright notice. Enable pipefail option, to propagate itree-tests exit status to caller. Fix typo in usage message. Strip less information from Check's error messages. * test/manual/noverlay/emacs-compat.h: Add copyright notice. Include stdlib.h. (emacs_abort, eassert): Consistently use EXIT_FAILURE. (eassume): Define when necessary. * test/manual/noverlay/itree-tests.c: Add copyright notice. Include standard headers before third-party ones. Use most narrowly applicable ck_assert* macro for the types being checked, e.g. ck_assert_ptr_* macros for pointer values. Replace removed names and APIs with current ones, e.g. the itree_node field 'color' is now called 'red'. Ensure preconditions of itree API are satisfied before use, e.g. itree_node otick being set appropriately before insertion, or global iterator being initialized before (implicit) use (bug#58976). Make all functions static. (DEF_TEST_SETUP): Remove all instances, replacing with... (test_insert1_setup, test_insert2_setup, test_remove1_setup) (test_remove2_setup): ...these new test fixtures. (A, B, C, D, E, N_05, N_10, N_15, N_20, N_30, N_40, N_50, N_70) (N_80, N_90, N_85, N_95): Define as static variables rather than macros. (test_get_tree4): Remove, inlining salient parts. (shuffle): Move closer to users. (test_create_tree): Accept itree_nodes as argument instead of dynamically allocating them. All callers changed. (FOREACH): Remove unused macro. (N_BEG, N_END): Define in terms of itree_node_begin and itree_node_end, respectively. (test_gap_insert_1, test_gap_insert_2, test_gap_insert_3) (test_gap_insert_5, test_gap_insert_7, test_gap_insert_11): Use test_setup_gap_node_noadvance. (basic_suite): Group unit tests into test cases and fixtures. Run previously forgotten test_insert_14. (main): Run suite as CK_ENV to allow specifying desired verbosity in the environment. diff --git a/test/manual/noverlay/Makefile.in b/test/manual/noverlay/Makefile.in index beef1dbc09..3c8dba1ce1 100644 --- a/test/manual/noverlay/Makefile.in +++ b/test/manual/noverlay/Makefile.in @@ -1,26 +1,41 @@ +### @configure_input@ + +# Copyright (C) 2017-2022 Free Software Foundation, Inc. + +# This file is part of GNU Emacs. + +# GNU Emacs is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. + +# GNU Emacs is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with GNU Emacs. If not, see . + PROGRAM = itree-tests -LIBS = check +PACKAGES = check top_srcdir = @top_srcdir@ -CFLAGS += -O0 -g3 $(shell pkg-config --cflags $(LIBS)) -I $(top_srcdir)/src -LDFLAGS += $(shell pkg-config --libs $(LIBS)) -lm +top_builddir = @top_builddir@ +CPPFLAGS += -I $(top_srcdir)/src +CFLAGS += -O0 -g3 $(shell pkg-config --cflags $(PACKAGES)) +LDLIBS += $(shell pkg-config --libs $(PACKAGES)) -lm OBJECTS = itree-tests.o CC = gcc -EMACS ?= ../../../src/emacs +EMACS ?= $(top_builddir)/src/emacs -.PHONY: all check have-libcheck +.PHONY: all check clean distclean perf all: check -have-libcheck: - pkg-config --cflags $(LIBS) - -check: have-libcheck $(PROGRAM) +check: $(PROGRAM) ./check-sanitize.sh ./$(PROGRAM) -itree-tests.o: emacs-compat.h itree-tests.c $(top_srcdir)/src/itree.c $(top_srcdir)/src/itree.h - -$(PROGRAM): $(OBJECTS) - $(CC) $(CFLAGS) $(LDFLAGS) $(OBJECTS) -o $(PROGRAM) +itree-tests.o: emacs-compat.h $(top_srcdir)/src/itree.c $(top_srcdir)/src/itree.h perf: -$(EMACS) -Q -l ./overlay-perf.el -f perf-run-batch diff --git a/test/manual/noverlay/check-sanitize.sh b/test/manual/noverlay/check-sanitize.sh index 03eedce8a6..9a67818dc8 100755 --- a/test/manual/noverlay/check-sanitize.sh +++ b/test/manual/noverlay/check-sanitize.sh @@ -1,11 +1,33 @@ -#!/bin/bash +#!/usr/bin/env bash +### check-sanitize.sh - strip confusing parts of Check error output + +## Copyright (C) 2017-2022 Free Software Foundation, Inc. + +## This file is part of GNU Emacs. + +## GNU Emacs is free software: you can redistribute it and/or modify +## it under the terms of the GNU General Public License as published by +## the Free Software Foundation, either version 3 of the License, or +## (at your option) any later version. + +## GNU Emacs is distributed in the hope that it will be useful, +## but WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. + +## You should have received a copy of the GNU General Public License +## along with GNU Emacs. If not, see . + +set -o pipefail prog=$1 shift [ -z "$prog" ] && { - echo "usage:$(basename $0) CHECK_PRGOGRAM"; + echo "usage:$(basename $0) CHECK_PROGRAM"; exit 1; } -"$prog" "$@" | sed -e 's/^\([^:]\+\):\([0-9]\+\):[PFE]:[^:]*:\([^:]*\):[^:]*: *\(.*\)/\1:\2:\3:\4/' +# FIXME: This would be unnecessary if +# compilation-error-regexp-alist-alist understood libcheck OOTB. +"$prog" "$@" | sed -e 's/^\([^:]\+\):\([0-9]\+\):\([PFE]\):\([^:]*\):\([^:]*\):[^:]*:\(.*\)/\1:\2:\3:\4:\5:\6/' diff --git a/test/manual/noverlay/emacs-compat.h b/test/manual/noverlay/emacs-compat.h index 812f8e48a3..d2448b12db 100644 --- a/test/manual/noverlay/emacs-compat.h +++ b/test/manual/noverlay/emacs-compat.h @@ -1,8 +1,28 @@ +/* Mock necessary parts of lisp.h. + +Copyright (C) 2017-2022 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + #ifndef TEST_COMPAT_H #define TEST_COMPAT_H -#include #include +#include +#include typedef int Lisp_Object; @@ -28,20 +48,24 @@ void emacs_abort () { fprintf (stderr, "Aborting...\n"); - exit (1); + exit (EXIT_FAILURE); } #ifndef eassert #define eassert(cond) \ do { \ if (! (cond)) { \ - fprintf (stderr, "\n%s:%d:eassert condition failed: %s\n", \ - __FILE__, __LINE__ ,#cond); \ - exit (1); \ + fprintf (stderr, "%s:%d:eassert condition failed: %s\n", \ + __FILE__, __LINE__ , # cond); \ + exit (EXIT_FAILURE); \ } \ } while (0) #endif +#ifndef eassume +#define eassume eassert +#endif + #ifndef max #define max(x,y) ((x) >= (y) ? (x) : (y)) #endif @@ -49,4 +73,4 @@ emacs_abort () #define min(x,y) ((x) <= (y) ? (x) : (y)) #endif -#endif +#endif /* TEST_COMPAT_H */ diff --git a/test/manual/noverlay/itree-tests.c b/test/manual/noverlay/itree-tests.c index a318389213..278e65f9bf 100644 --- a/test/manual/noverlay/itree-tests.c +++ b/test/manual/noverlay/itree-tests.c @@ -1,7 +1,28 @@ +/* Test the interval data-structure in itree.c. + +Copyright (c) 2017-2022 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + #include -#include -#include + #include +#include + +#include #include "emacs-compat.h" #define EMACS_LISP_H /* lisp.h inclusion guard */ @@ -9,7 +30,14 @@ #define ITREE_TESTING #include "itree.c" -/* Basic tests of the interval_tree data-structure. */ +/* Globals. */ + +static struct itree_tree tree; +static struct itree_node A, B, C, D, E; +static struct itree_node N_05, N_10, N_15, N_20, N_30, N_40; +static struct itree_node N_50, N_70, N_80, N_90, N_85, N_95; + +/* Basic tests of the itree_tree data-structure. */ /* +===================================================================================+ * | Insert @@ -17,25 +45,21 @@ /* The graphs below display the trees after each insertion (as they should be). See the source code for the different cases - applied. */ - -#define N_50 (n[0]) -#define N_30 (n[1]) -#define N_20 (n[2]) -#define N_10 (n[3]) -#define N_15 (n[4]) -#define N_05 (n[5]) - -#define DEF_TEST_SETUP() \ - struct interval_tree tree; \ - struct interval_node n[6]; \ - interval_tree_init (&tree); \ - const int values[] = {50, 30, 20, 10, 15, 5}; \ - for (int i = 0; i < 6; ++i) \ - { \ - n[i].begin = values[i]; \ - n[i].end = values[i]; \ + applied. */ + +static void +test_insert1_setup (void) +{ + enum { N = 6 }; + const int values[N] = {50, 30, 20, 10, 15, 5}; + struct itree_node *nodes[N] = {&N_50, &N_30, &N_20, &N_10, &N_15, &N_05}; + interval_tree_init (&tree); + for (int i = 0; i < N; ++i) + { + nodes[i]->begin = nodes[i]->end = values[i]; + nodes[i]->otick = tree.otick; } +} START_TEST (test_insert_1) { @@ -43,10 +67,9 @@ START_TEST (test_insert_1) * [50] */ - DEF_TEST_SETUP (); interval_tree_insert (&tree, &N_50); - ck_assert (N_50.color == ITREE_BLACK); - ck_assert (&N_50 == tree.root); + ck_assert (! N_50.red); + ck_assert_ptr_eq (&N_50, tree.root); } END_TEST @@ -58,17 +81,16 @@ START_TEST (test_insert_2) * (30) */ - DEF_TEST_SETUP (); interval_tree_insert (&tree, &N_50); interval_tree_insert (&tree, &N_30); - ck_assert (N_50.color == ITREE_BLACK); - ck_assert (N_30.color == ITREE_RED); - ck_assert (&N_50 == tree.root); - ck_assert (N_30.parent == &N_50); - ck_assert (N_50.left == &N_30); - ck_assert (N_50.right == &tree.nil); - ck_assert (N_30.left == &tree.nil); - ck_assert (N_30.right == &tree.nil); + ck_assert (! N_50.red); + ck_assert (N_30.red); + ck_assert_ptr_eq (&N_50, tree.root); + ck_assert_ptr_eq (N_30.parent, &N_50); + ck_assert_ptr_eq (N_50.left, &N_30); + ck_assert_ptr_null (N_50.right); + ck_assert_ptr_null (N_30.left); + ck_assert_ptr_null (N_30.right); } END_TEST @@ -80,20 +102,19 @@ START_TEST (test_insert_3) * (20) (50) */ - DEF_TEST_SETUP (); interval_tree_insert (&tree, &N_50); interval_tree_insert (&tree, &N_30); interval_tree_insert (&tree, &N_20); - ck_assert (N_50.color == ITREE_RED); - ck_assert (N_30.color == ITREE_BLACK); - ck_assert (N_20.color == ITREE_RED); - ck_assert (&N_30 == tree.root); - ck_assert (N_50.parent == &N_30); - ck_assert (N_30.right == &N_50); - ck_assert (N_30.left == &N_20); - ck_assert (N_20.left == &tree.nil); - ck_assert (N_20.right == &tree.nil); - ck_assert (N_20.parent == &N_30); + ck_assert (N_50.red); + ck_assert (! N_30.red); + ck_assert (N_20.red); + ck_assert_ptr_eq (&N_30, tree.root); + ck_assert_ptr_eq (N_50.parent, &N_30); + ck_assert_ptr_eq (N_30.right, &N_50); + ck_assert_ptr_eq (N_30.left, &N_20); + ck_assert_ptr_null (N_20.left); + ck_assert_ptr_null (N_20.right); + ck_assert_ptr_eq (N_20.parent, &N_30); } END_TEST @@ -107,25 +128,24 @@ START_TEST (test_insert_4) * (10) */ - DEF_TEST_SETUP (); interval_tree_insert (&tree, &N_50); interval_tree_insert (&tree, &N_30); interval_tree_insert (&tree, &N_20); interval_tree_insert (&tree, &N_10); - ck_assert (N_50.color == ITREE_BLACK); - ck_assert (N_30.color == ITREE_BLACK); - ck_assert (N_20.color == ITREE_BLACK); - ck_assert (N_10.color == ITREE_RED); - ck_assert (&N_30 == tree.root); - ck_assert (N_50.parent == &N_30); - ck_assert (N_30.right == &N_50); - ck_assert (N_30.left == &N_20); - ck_assert (N_20.left == &N_10); - ck_assert (N_20.right == &tree.nil); - ck_assert (N_20.parent == &N_30); - ck_assert (N_10.parent == &N_20); - ck_assert (N_20.left == &N_10); - ck_assert (N_10.right == &tree.nil); + ck_assert (! N_50.red); + ck_assert (! N_30.red); + ck_assert (! N_20.red); + ck_assert (N_10.red); + ck_assert_ptr_eq (&N_30, tree.root); + ck_assert_ptr_eq (N_50.parent, &N_30); + ck_assert_ptr_eq (N_30.right, &N_50); + ck_assert_ptr_eq (N_30.left, &N_20); + ck_assert_ptr_eq (N_20.left, &N_10); + ck_assert_ptr_null (N_20.right); + ck_assert_ptr_eq (N_20.parent, &N_30); + ck_assert_ptr_eq (N_10.parent, &N_20); + ck_assert_ptr_eq (N_20.left, &N_10); + ck_assert_ptr_null (N_10.right); } END_TEST @@ -139,31 +159,29 @@ START_TEST (test_insert_5) * (10) (20) */ - DEF_TEST_SETUP (); interval_tree_insert (&tree, &N_50); interval_tree_insert (&tree, &N_30); interval_tree_insert (&tree, &N_20); interval_tree_insert (&tree, &N_10); interval_tree_insert (&tree, &N_15); - ck_assert (N_50.color == ITREE_BLACK); - ck_assert (N_30.color == ITREE_BLACK); - ck_assert (N_20.color == ITREE_RED); - ck_assert (N_10.color == ITREE_RED); - ck_assert (N_15.color == ITREE_BLACK); - ck_assert (&N_30 == tree.root); - ck_assert (N_50.parent == &N_30); - ck_assert (N_30.right == &N_50); - ck_assert (N_30.left == &N_15); - ck_assert (N_20.left == &tree.nil); - ck_assert (N_20.right == &tree.nil); - ck_assert (N_20.parent == &N_15); - ck_assert (N_10.parent == &N_15); - ck_assert (N_20.left == &tree.nil); - ck_assert (N_10.right == &tree.nil); - ck_assert (N_15.right == &N_20); - ck_assert (N_15.left == &N_10); - ck_assert (N_15.parent == &N_30); - + ck_assert (! N_50.red); + ck_assert (! N_30.red); + ck_assert (N_20.red); + ck_assert (N_10.red); + ck_assert (! N_15.red); + ck_assert_ptr_eq (&N_30, tree.root); + ck_assert_ptr_eq (N_50.parent, &N_30); + ck_assert_ptr_eq (N_30.right, &N_50); + ck_assert_ptr_eq (N_30.left, &N_15); + ck_assert_ptr_null (N_20.left); + ck_assert_ptr_null (N_20.right); + ck_assert_ptr_eq (N_20.parent, &N_15); + ck_assert_ptr_eq (N_10.parent, &N_15); + ck_assert_ptr_null (N_20.left); + ck_assert_ptr_null (N_10.right); + ck_assert_ptr_eq (N_15.right, &N_20); + ck_assert_ptr_eq (N_15.left, &N_10); + ck_assert_ptr_eq (N_15.parent, &N_30); } END_TEST @@ -179,67 +197,54 @@ START_TEST (test_insert_6) * (5) */ - DEF_TEST_SETUP (); interval_tree_insert (&tree, &N_50); interval_tree_insert (&tree, &N_30); interval_tree_insert (&tree, &N_20); interval_tree_insert (&tree, &N_10); interval_tree_insert (&tree, &N_15); interval_tree_insert (&tree, &N_05); - ck_assert (N_50.color == ITREE_BLACK); - ck_assert (N_30.color == ITREE_BLACK); - ck_assert (N_20.color == ITREE_BLACK); - ck_assert (N_10.color == ITREE_BLACK); - ck_assert (N_15.color == ITREE_RED); - ck_assert (N_05.color == ITREE_RED); - ck_assert (&N_30 == tree.root); - ck_assert (N_50.parent == &N_30); - ck_assert (N_30.right == &N_50); - ck_assert (N_30.left == &N_15); - ck_assert (N_20.left == &tree.nil); - ck_assert (N_20.right == &tree.nil); - ck_assert (N_20.parent == &N_15); - ck_assert (N_10.parent == &N_15); - ck_assert (N_20.left == &tree.nil); - ck_assert (N_10.right == &tree.nil); - ck_assert (N_15.right == &N_20); - ck_assert (N_15.left == &N_10); - ck_assert (N_15.parent == &N_30); - ck_assert (N_05.parent == &N_10); - ck_assert (N_10.left == &N_05); - ck_assert (N_05.right == &tree.nil); + ck_assert (! N_50.red); + ck_assert (! N_30.red); + ck_assert (! N_20.red); + ck_assert (! N_10.red); + ck_assert (N_15.red); + ck_assert (N_05.red); + ck_assert_ptr_eq (&N_30, tree.root); + ck_assert_ptr_eq (N_50.parent, &N_30); + ck_assert_ptr_eq (N_30.right, &N_50); + ck_assert_ptr_eq (N_30.left, &N_15); + ck_assert_ptr_null (N_20.left); + ck_assert_ptr_null (N_20.right); + ck_assert_ptr_eq (N_20.parent, &N_15); + ck_assert_ptr_eq (N_10.parent, &N_15); + ck_assert_ptr_null (N_20.left); + ck_assert_ptr_null (N_10.right); + ck_assert_ptr_eq (N_15.right, &N_20); + ck_assert_ptr_eq (N_15.left, &N_10); + ck_assert_ptr_eq (N_15.parent, &N_30); + ck_assert_ptr_eq (N_05.parent, &N_10); + ck_assert_ptr_eq (N_10.left, &N_05); + ck_assert_ptr_null (N_05.right); } END_TEST -#undef N_50 -#undef N_30 -#undef N_20 -#undef N_10 -#undef N_15 -#undef N_05 -#undef DEF_TEST_SETUP - /* These are the mirror cases to the above ones. */ -#define N_50 (n[0]) -#define N_70 (n[1]) -#define N_80 (n[2]) -#define N_90 (n[3]) -#define N_85 (n[4]) -#define N_95 (n[5]) - -#define DEF_TEST_SETUP() \ - struct interval_tree tree; \ - struct interval_node n[6]; \ - interval_tree_init (&tree); \ - const int values[] = {50, 70, 80, 90, 85, 95}; \ - for (int i = 0; i < 6; ++i) \ - { \ - n[i].begin = values[i]; \ - n[i].end = values[i]; \ +static void +test_insert2_setup (void) +{ + enum { N = 6 }; + const int values[] = {50, 70, 80, 90, 85, 95}; + struct itree_node *nodes[N] = {&N_50, &N_70, &N_80, &N_90, &N_85, &N_95}; + interval_tree_init (&tree); + for (int i = 0; i < N; ++i) + { + nodes[i]->begin = nodes[i]->end = values[i]; + nodes[i]->otick = tree.otick; } +} START_TEST (test_insert_7) { @@ -247,10 +252,9 @@ START_TEST (test_insert_7) * [50] */ - DEF_TEST_SETUP (); interval_tree_insert (&tree, &N_50); - ck_assert (N_50.color == ITREE_BLACK); - ck_assert (&N_50 == tree.root); + ck_assert (! N_50.red); + ck_assert_ptr_eq (&N_50, tree.root); } END_TEST @@ -262,17 +266,16 @@ START_TEST (test_insert_8) * (70) */ - DEF_TEST_SETUP (); interval_tree_insert (&tree, &N_50); interval_tree_insert (&tree, &N_70); - ck_assert (N_50.color == ITREE_BLACK); - ck_assert (N_70.color == ITREE_RED); - ck_assert (&N_50 == tree.root); - ck_assert (N_70.parent == &N_50); - ck_assert (N_50.right == &N_70); - ck_assert (N_50.left == &tree.nil); - ck_assert (N_70.right == &tree.nil); - ck_assert (N_70.left == &tree.nil); + ck_assert (! N_50.red); + ck_assert (N_70.red); + ck_assert_ptr_eq (&N_50, tree.root); + ck_assert_ptr_eq (N_70.parent, &N_50); + ck_assert_ptr_eq (N_50.right, &N_70); + ck_assert_ptr_null (N_50.left); + ck_assert_ptr_null (N_70.right); + ck_assert_ptr_null (N_70.left); } END_TEST @@ -284,20 +287,19 @@ START_TEST (test_insert_9) * (50) (80) */ - DEF_TEST_SETUP (); interval_tree_insert (&tree, &N_50); interval_tree_insert (&tree, &N_70); interval_tree_insert (&tree, &N_80); - ck_assert (N_50.color == ITREE_RED); - ck_assert (N_70.color == ITREE_BLACK); - ck_assert (N_80.color == ITREE_RED); - ck_assert (&N_70 == tree.root); - ck_assert (N_50.parent == &N_70); - ck_assert (N_70.right == &N_80); - ck_assert (N_70.left == &N_50); - ck_assert (N_80.right == &tree.nil); - ck_assert (N_80.left == &tree.nil); - ck_assert (N_80.parent == &N_70); + ck_assert (N_50.red); + ck_assert (! N_70.red); + ck_assert (N_80.red); + ck_assert_ptr_eq (&N_70, tree.root); + ck_assert_ptr_eq (N_50.parent, &N_70); + ck_assert_ptr_eq (N_70.right, &N_80); + ck_assert_ptr_eq (N_70.left, &N_50); + ck_assert_ptr_null (N_80.right); + ck_assert_ptr_null (N_80.left); + ck_assert_ptr_eq (N_80.parent, &N_70); } END_TEST @@ -311,25 +313,24 @@ START_TEST (test_insert_10) * (90) */ - DEF_TEST_SETUP (); interval_tree_insert (&tree, &N_50); interval_tree_insert (&tree, &N_70); interval_tree_insert (&tree, &N_80); interval_tree_insert (&tree, &N_90); - ck_assert (N_50.color == ITREE_BLACK); - ck_assert (N_70.color == ITREE_BLACK); - ck_assert (N_80.color == ITREE_BLACK); - ck_assert (N_90.color == ITREE_RED); - ck_assert (&N_70 == tree.root); - ck_assert (N_50.parent == &N_70); - ck_assert (N_70.right == &N_80); - ck_assert (N_70.left == &N_50); - ck_assert (N_80.right == &N_90); - ck_assert (N_80.left == &tree.nil); - ck_assert (N_80.parent == &N_70); - ck_assert (N_90.parent == &N_80); - ck_assert (N_80.right == &N_90); - ck_assert (N_90.left == &tree.nil); + ck_assert (! N_50.red); + ck_assert (! N_70.red); + ck_assert (! N_80.red); + ck_assert (N_90.red); + ck_assert_ptr_eq (&N_70, tree.root); + ck_assert_ptr_eq (N_50.parent, &N_70); + ck_assert_ptr_eq (N_70.right, &N_80); + ck_assert_ptr_eq (N_70.left, &N_50); + ck_assert_ptr_eq (N_80.right, &N_90); + ck_assert_ptr_null (N_80.left); + ck_assert_ptr_eq (N_80.parent, &N_70); + ck_assert_ptr_eq (N_90.parent, &N_80); + ck_assert_ptr_eq (N_80.right, &N_90); + ck_assert_ptr_null (N_90.left); } END_TEST @@ -343,30 +344,29 @@ START_TEST (test_insert_11) * (80) (90) */ - DEF_TEST_SETUP (); interval_tree_insert (&tree, &N_50); interval_tree_insert (&tree, &N_70); interval_tree_insert (&tree, &N_80); interval_tree_insert (&tree, &N_90); interval_tree_insert (&tree, &N_85); - ck_assert (N_50.color == ITREE_BLACK); - ck_assert (N_70.color == ITREE_BLACK); - ck_assert (N_80.color == ITREE_RED); - ck_assert (N_90.color == ITREE_RED); - ck_assert (N_85.color == ITREE_BLACK); - ck_assert (&N_70 == tree.root); - ck_assert (N_50.parent == &N_70); - ck_assert (N_70.right == &N_85); - ck_assert (N_70.left == &N_50); - ck_assert (N_80.right == &tree.nil); - ck_assert (N_80.left == &tree.nil); - ck_assert (N_80.parent == &N_85); - ck_assert (N_90.parent == &N_85); - ck_assert (N_80.right == &tree.nil); - ck_assert (N_90.left == &tree.nil); - ck_assert (N_85.right == &N_90); - ck_assert (N_85.left == &N_80); - ck_assert (N_85.parent == &N_70); + ck_assert (! N_50.red); + ck_assert (! N_70.red); + ck_assert (N_80.red); + ck_assert (N_90.red); + ck_assert (! N_85.red); + ck_assert_ptr_eq (&N_70, tree.root); + ck_assert_ptr_eq (N_50.parent, &N_70); + ck_assert_ptr_eq (N_70.right, &N_85); + ck_assert_ptr_eq (N_70.left, &N_50); + ck_assert_ptr_null (N_80.right); + ck_assert_ptr_null (N_80.left); + ck_assert_ptr_eq (N_80.parent, &N_85); + ck_assert_ptr_eq (N_90.parent, &N_85); + ck_assert_ptr_null (N_80.right); + ck_assert_ptr_null (N_90.left); + ck_assert_ptr_eq (N_85.right, &N_90); + ck_assert_ptr_eq (N_85.left, &N_80); + ck_assert_ptr_eq (N_85.parent, &N_70); } END_TEST @@ -383,139 +383,90 @@ START_TEST (test_insert_12) * (95) */ - DEF_TEST_SETUP (); interval_tree_insert (&tree, &N_50); interval_tree_insert (&tree, &N_70); interval_tree_insert (&tree, &N_80); interval_tree_insert (&tree, &N_90); interval_tree_insert (&tree, &N_85); interval_tree_insert (&tree, &N_95); - ck_assert (N_50.color == ITREE_BLACK); - ck_assert (N_70.color == ITREE_BLACK); - ck_assert (N_80.color == ITREE_BLACK); - ck_assert (N_90.color == ITREE_BLACK); - ck_assert (N_85.color == ITREE_RED); - ck_assert (N_95.color == ITREE_RED); - ck_assert (&N_70 == tree.root); - ck_assert (N_50.parent == &N_70); - ck_assert (N_70.right == &N_85); - ck_assert (N_70.left == &N_50); - ck_assert (N_80.right == &tree.nil); - ck_assert (N_80.left == &tree.nil); - ck_assert (N_80.parent == &N_85); - ck_assert (N_90.parent == &N_85); - ck_assert (N_80.right == &tree.nil); - ck_assert (N_90.left == &tree.nil); - ck_assert (N_85.right == &N_90); - ck_assert (N_85.left == &N_80); - ck_assert (N_85.parent == &N_70); - ck_assert (N_95.parent == &N_90); - ck_assert (N_90.right == &N_95); - ck_assert (N_95.left == &tree.nil); + ck_assert (! N_50.red); + ck_assert (! N_70.red); + ck_assert (! N_80.red); + ck_assert (! N_90.red); + ck_assert (N_85.red); + ck_assert (N_95.red); + ck_assert_ptr_eq (&N_70, tree.root); + ck_assert_ptr_eq (N_50.parent, &N_70); + ck_assert_ptr_eq (N_70.right, &N_85); + ck_assert_ptr_eq (N_70.left, &N_50); + ck_assert_ptr_null (N_80.right); + ck_assert_ptr_null (N_80.left); + ck_assert_ptr_eq (N_80.parent, &N_85); + ck_assert_ptr_eq (N_90.parent, &N_85); + ck_assert_ptr_null (N_80.right); + ck_assert_ptr_null (N_90.left); + ck_assert_ptr_eq (N_85.right, &N_90); + ck_assert_ptr_eq (N_85.left, &N_80); + ck_assert_ptr_eq (N_85.parent, &N_70); + ck_assert_ptr_eq (N_95.parent, &N_90); + ck_assert_ptr_eq (N_90.right, &N_95); + ck_assert_ptr_null (N_95.left); } END_TEST -#undef N_50 -#undef N_70 -#undef N_80 -#undef N_90 -#undef N_85 -#undef N_95 -#undef DEF_TEST_SETUP - -struct interval_tree* -test_get_tree4 (struct interval_node **n) -{ - static struct interval_tree tree; - static struct interval_node nodes[4]; - memset (&tree, 0, sizeof (struct interval_tree)); - memset (&nodes, 0, 4 * sizeof (struct interval_node)); - interval_tree_init (&tree); - for (int i = 0; i < 4; ++i) - { - nodes[i].begin = 10 * (i + 1); - nodes[i].end = nodes[i].begin; - interval_tree_insert (&tree, &nodes[i]); - } - *n = nodes; - return &tree; -} - -static void -shuffle (int *index, int n) -{ - for (int i = n - 1; i >= 0; --i) - { - int j = random () % (i + 1); - int h = index[j]; - index[j] = index[i]; - index[i] = h; - } -} - -#define N_10 (nodes[0]) -#define N_20 (nodes[1]) -#define N_30 (nodes[2]) -#define N_40 (nodes[3]) - START_TEST (test_insert_13) { - struct interval_node *nodes = NULL; - struct interval_tree *tree = test_get_tree4 (&nodes); - - - ck_assert (tree->root == &N_20); - ck_assert (N_20.left == &N_10); - ck_assert (N_20.right == &N_30); - ck_assert (N_30.right == &N_40); - ck_assert (N_10.color == ITREE_BLACK); - ck_assert (N_20.color == ITREE_BLACK); - ck_assert (N_30.color == ITREE_BLACK); - ck_assert (N_40.color == ITREE_RED); + enum { N = 4 }; + const int values[N] = {10, 20, 30, 40}; + struct itree_node *nodes[N] = {&N_10, &N_20, &N_30, &N_40}; + interval_tree_init (&tree); + for (int i = 0; i < N; ++i) + itree_insert (&tree, nodes[i], values[i], values[i]); + + ck_assert_ptr_eq (tree.root, &N_20); + ck_assert_ptr_eq (N_20.left, &N_10); + ck_assert_ptr_eq (N_20.right, &N_30); + ck_assert_ptr_eq (N_30.right, &N_40); + ck_assert (! N_10.red); + ck_assert (! N_20.red); + ck_assert (! N_30.red); + ck_assert (N_40.red); } END_TEST START_TEST (test_insert_14) { - struct interval_tree tree; - struct interval_node nodes[3]; - - nodes[0].begin = nodes[1].begin = nodes[2].begin = 10; - nodes[0].end = nodes[1].end = nodes[2].end = 10; + enum { N = 3 }; + struct itree_node nodes[N]; + interval_tree_init (&tree); - for (int i = 0; i < 3; ++i) - interval_tree_insert (&tree, &nodes[i]); - for (int i = 0; i < 3; ++i) + for (int i = 0; i < N; ++i) + itree_insert (&tree, &nodes[i], 10, 10); + for (int i = 0; i < N; ++i) ck_assert (interval_tree_contains (&tree, &nodes[i])); } END_TEST - - /* +===================================================================================+ * | Remove * +===================================================================================+ */ -#define A (nodes[0]) -#define B (nodes[1]) -#define C (nodes[2]) -#define D (nodes[3]) -#define E (nodes[4]) - /* Creating proper test trees for the formal tests via insertions is - way to tedious, so we just fake it and only test the - fix-routine. */ -#define DEF_TEST_SETUP() \ - struct interval_tree tree; \ - struct interval_node nodes[5]; \ - interval_tree_init (&tree); \ - tree.root = &B; \ - A.parent = &B; B.parent = &tree.nil; C.parent = &D; \ - D.parent = &B; E.parent = &D; \ - A.left = A.right = C.left = C.right = &tree.nil; \ - E.left = E.right = &tree.nil; \ - B.left = &A; B.right = &D; D.left = &C; D.right = &E \ + way too tedious, so we just fake it and only test the + fix-routine. */ +static void +test_remove1_setup (void) +{ + interval_tree_init (&tree); + tree.root = &B; + A.parent = &B; B.parent = NULL; C.parent = &D; D.parent = &B; E.parent = &D; + A.left = A.right = C.left = C.right = E.left = E.right = NULL; + B.left = &A; B.right = &D; + D.left = &C; D.right = &E; + A.offset = B.offset = C.offset = D.offset = E.offset = 0; + A.otick = B.otick = C.otick = D.otick = E.otick = tree.otick; +} /* 1.a -> 2.a * [B] @@ -525,126 +476,106 @@ END_TEST * [C] [E] */ - START_TEST (test_remove_1) { - DEF_TEST_SETUP (); - B.color = A.color = C.color = E.color = ITREE_BLACK; - D.color = ITREE_RED; - interval_tree_remove_fix (&tree, &A); - - ck_assert (A.color == ITREE_BLACK); - ck_assert (B.color == ITREE_BLACK); - ck_assert (C.color == ITREE_RED); - ck_assert (D.color == ITREE_BLACK); - ck_assert (E.color == ITREE_BLACK); - ck_assert (A.parent == &B); - ck_assert (B.left == &A); - ck_assert (B.right == &C); - ck_assert (C.parent == &B); - ck_assert (E.parent == &D); - ck_assert (D.right == &E); - ck_assert (D.left == &B); - ck_assert (tree.root == &D); + B.red = A.red = C.red = E.red = false; + D.red = true; + interval_tree_remove_fix (&tree, &A, &B); + + ck_assert (! A.red); + ck_assert (! B.red); + ck_assert (C.red); + ck_assert (! D.red); + ck_assert (! E.red); + ck_assert_ptr_eq (A.parent, &B); + ck_assert_ptr_eq (B.left, &A); + ck_assert_ptr_eq (B.right, &C); + ck_assert_ptr_eq (C.parent, &B); + ck_assert_ptr_eq (E.parent, &D); + ck_assert_ptr_eq (D.right, &E); + ck_assert_ptr_eq (D.left, &B); + ck_assert_ptr_eq (tree.root, &D); } END_TEST /* 2.a */ START_TEST (test_remove_2) { - DEF_TEST_SETUP (); - B.color = D.color = A.color = C.color = E.color = ITREE_BLACK; - interval_tree_remove_fix (&tree, &A); - - ck_assert (A.color == ITREE_BLACK); - ck_assert (B.color == ITREE_BLACK); - ck_assert (C.color == ITREE_BLACK); - ck_assert (D.color == ITREE_RED); - ck_assert (E.color == ITREE_BLACK); - ck_assert (A.parent == &B); - ck_assert (B.left == &A); - ck_assert (B.right == &D); - ck_assert (C.parent == &D); - ck_assert (E.parent == &D); - ck_assert (tree.root == &B); + B.red = D.red = A.red = C.red = E.red = false; + interval_tree_remove_fix (&tree, &A, &B); + + ck_assert (! A.red); + ck_assert (! B.red); + ck_assert (! C.red); + ck_assert (D.red); + ck_assert (! E.red); + ck_assert_ptr_eq (A.parent, &B); + ck_assert_ptr_eq (B.left, &A); + ck_assert_ptr_eq (B.right, &D); + ck_assert_ptr_eq (C.parent, &D); + ck_assert_ptr_eq (E.parent, &D); + ck_assert_ptr_eq (tree.root, &B); } END_TEST -/* 3.a -> 4.a*/ +/* 3.a -> 4.a */ START_TEST (test_remove_3) { - DEF_TEST_SETUP (); - D.color = A.color = E.color = ITREE_BLACK; - B.color = C.color = ITREE_RED; - interval_tree_remove_fix (&tree, &A); - - ck_assert (A.color == ITREE_BLACK); - ck_assert (B.color == ITREE_BLACK); - ck_assert (C.color == ITREE_BLACK); - ck_assert (D.color == ITREE_BLACK); - ck_assert (E.color == ITREE_BLACK); - ck_assert (A.parent == &B); - ck_assert (B.left == &A); - ck_assert (B.right == &tree.nil); - ck_assert (&C == tree.root); - ck_assert (C.left == &B); - ck_assert (C.right == &D); - ck_assert (E.parent == &D); - ck_assert (D.left == &tree.nil); - + D.red = A.red = E.red = false; + B.red = C.red = true; + interval_tree_remove_fix (&tree, &A, &B); + + ck_assert (! A.red); + ck_assert (! B.red); + ck_assert (! C.red); + ck_assert (! D.red); + ck_assert (! E.red); + ck_assert_ptr_eq (A.parent, &B); + ck_assert_ptr_eq (B.left, &A); + ck_assert_ptr_null (B.right); + ck_assert_ptr_eq (&C, tree.root); + ck_assert_ptr_eq (C.left, &B); + ck_assert_ptr_eq (C.right, &D); + ck_assert_ptr_eq (E.parent, &D); + ck_assert_ptr_null (D.left); } END_TEST /* 4.a */ START_TEST (test_remove_4) { - DEF_TEST_SETUP (); - B.color = C.color = E.color = ITREE_RED; - A.color = D.color = ITREE_BLACK; - interval_tree_remove_fix (&tree, &A); - - ck_assert (A.color == ITREE_BLACK); - ck_assert (B.color == ITREE_BLACK); - ck_assert (C.color == ITREE_RED); - ck_assert (D.color == ITREE_BLACK); - ck_assert (E.color == ITREE_BLACK); - ck_assert (A.parent == &B); - ck_assert (B.left == &A); - ck_assert (B.right == &C); - ck_assert (C.parent == &B); - ck_assert (E.parent == &D); - ck_assert (tree.root == &D); + B.red = C.red = E.red = true; + A.red = D.red = false; + interval_tree_remove_fix (&tree, &A, &B); + + ck_assert (! A.red); + ck_assert (! B.red); + ck_assert (C.red); + ck_assert (! D.red); + ck_assert (! E.red); + ck_assert_ptr_eq (A.parent, &B); + ck_assert_ptr_eq (B.left, &A); + ck_assert_ptr_eq (B.right, &C); + ck_assert_ptr_eq (C.parent, &B); + ck_assert_ptr_eq (E.parent, &D); + ck_assert_ptr_eq (tree.root, &D); } END_TEST - -#undef A -#undef B -#undef C -#undef D -#undef E -#undef DEF_TEST_SETUP - -/* These are the mirrored cases. */ - -#define A (nodes[0]) -#define B (nodes[1]) -#define C (nodes[2]) -#define D (nodes[3]) -#define E (nodes[4]) - -#define DEF_TEST_SETUP() \ - struct interval_tree tree; \ - struct interval_node nodes[5]; \ - interval_tree_init (&tree); \ - tree.root = &B; \ - A.parent = &B; B.parent = &tree.nil; C.parent = &D; \ - D.parent = &B; E.parent = &D; \ - A.right = A.left = C.right = C.left = &tree.nil; \ - E.right = E.left = &tree.nil; \ - B.right = &A; B.left = &D; D.right = &C; D.left = &E \ +/* These are the mirrored cases. */ + +static void +test_remove2_setup (void) +{ + interval_tree_init (&tree); + tree.root = &B; + A.parent = &B; B.parent = NULL; C.parent = &D; D.parent = &B; E.parent = &D; + A.right = A.left = C.right = C.left = E.right = E.left = NULL; + B.right = &A; B.left = &D; + D.right = &C; D.left = &E; +} /* 1.b -> 2.b * [B] @@ -654,161 +585,159 @@ END_TEST * [C] [E] */ - START_TEST (test_remove_5) { - DEF_TEST_SETUP (); - B.color = A.color = C.color = E.color = ITREE_BLACK; - D.color = ITREE_RED; - interval_tree_remove_fix (&tree, &A); - - ck_assert (A.color == ITREE_BLACK); - ck_assert (B.color == ITREE_BLACK); - ck_assert (C.color == ITREE_RED); - ck_assert (D.color == ITREE_BLACK); - ck_assert (E.color == ITREE_BLACK); - ck_assert (A.parent == &B); - ck_assert (B.right == &A); - ck_assert (B.left == &C); - ck_assert (C.parent == &B); - ck_assert (E.parent == &D); - ck_assert (D.left == &E); - ck_assert (D.right == &B); - ck_assert (tree.root == &D); + B.red = A.red = C.red = E.red = false; + D.red = true; + interval_tree_remove_fix (&tree, &A, &B); + + ck_assert (! A.red); + ck_assert (! B.red); + ck_assert (C.red); + ck_assert (! D.red); + ck_assert (! E.red); + ck_assert_ptr_eq (A.parent, &B); + ck_assert_ptr_eq (B.right, &A); + ck_assert_ptr_eq (B.left, &C); + ck_assert_ptr_eq (C.parent, &B); + ck_assert_ptr_eq (E.parent, &D); + ck_assert_ptr_eq (D.left, &E); + ck_assert_ptr_eq (D.right, &B); + ck_assert_ptr_eq (tree.root, &D); } END_TEST /* 2.b */ START_TEST (test_remove_6) { - DEF_TEST_SETUP (); - B.color = D.color = A.color = C.color = E.color = ITREE_BLACK; - interval_tree_remove_fix (&tree, &A); - - ck_assert (A.color == ITREE_BLACK); - ck_assert (B.color == ITREE_BLACK); - ck_assert (C.color == ITREE_BLACK); - ck_assert (D.color == ITREE_RED); - ck_assert (E.color == ITREE_BLACK); - ck_assert (A.parent == &B); - ck_assert (B.right == &A); - ck_assert (B.left == &D); - ck_assert (C.parent == &D); - ck_assert (E.parent == &D); - ck_assert (tree.root == &B); + B.red = D.red = A.red = C.red = E.red = false; + interval_tree_remove_fix (&tree, &A, &B); + + ck_assert (! A.red); + ck_assert (! B.red); + ck_assert (! C.red); + ck_assert (D.red); + ck_assert (! E.red); + ck_assert_ptr_eq (A.parent, &B); + ck_assert_ptr_eq (B.right, &A); + ck_assert_ptr_eq (B.left, &D); + ck_assert_ptr_eq (C.parent, &D); + ck_assert_ptr_eq (E.parent, &D); + ck_assert_ptr_eq (tree.root, &B); } END_TEST -/* 3.b -> 4.b*/ +/* 3.b -> 4.b */ START_TEST (test_remove_7) { - DEF_TEST_SETUP (); - D.color = A.color = E.color = ITREE_BLACK; - B.color = C.color = ITREE_RED; - interval_tree_remove_fix (&tree, &A); - - ck_assert (A.color == ITREE_BLACK); - ck_assert (B.color == ITREE_BLACK); - ck_assert (C.color == ITREE_BLACK); - ck_assert (D.color == ITREE_BLACK); - ck_assert (E.color == ITREE_BLACK); - ck_assert (A.parent == &B); - ck_assert (B.right == &A); - ck_assert (B.left == &tree.nil); - ck_assert (&C == tree.root); - ck_assert (C.right == &B); - ck_assert (C.left == &D); - ck_assert (E.parent == &D); - ck_assert (D.right == &tree.nil); - + D.red = A.red = E.red = false; + B.red = C.red = true; + interval_tree_remove_fix (&tree, &A, &B); + + ck_assert (! A.red); + ck_assert (! B.red); + ck_assert (! C.red); + ck_assert (! D.red); + ck_assert (! E.red); + ck_assert_ptr_eq (A.parent, &B); + ck_assert_ptr_eq (B.right, &A); + ck_assert_ptr_null (B.left); + ck_assert_ptr_eq (&C, tree.root); + ck_assert_ptr_eq (C.right, &B); + ck_assert_ptr_eq (C.left, &D); + ck_assert_ptr_eq (E.parent, &D); + ck_assert_ptr_null (D.right); } END_TEST /* 4.b */ START_TEST (test_remove_8) { - DEF_TEST_SETUP (); - B.color = C.color = E.color = ITREE_RED; - A.color = D.color = ITREE_BLACK; - interval_tree_remove_fix (&tree, &A); - - ck_assert (A.color == ITREE_BLACK); - ck_assert (B.color == ITREE_BLACK); - ck_assert (C.color == ITREE_RED); - ck_assert (D.color == ITREE_BLACK); - ck_assert (E.color == ITREE_BLACK); - ck_assert (A.parent == &B); - ck_assert (B.right == &A); - ck_assert (B.left == &C); - ck_assert (C.parent == &B); - ck_assert (E.parent == &D); - ck_assert (tree.root == &D); + B.red = C.red = E.red = true; + A.red = D.red = false; + interval_tree_remove_fix (&tree, &A, &B); + + ck_assert (! A.red); + ck_assert (! B.red); + ck_assert (C.red); + ck_assert (! D.red); + ck_assert (! E.red); + ck_assert_ptr_eq (A.parent, &B); + ck_assert_ptr_eq (B.right, &A); + ck_assert_ptr_eq (B.left, &C); + ck_assert_ptr_eq (C.parent, &B); + ck_assert_ptr_eq (E.parent, &D); + ck_assert_ptr_eq (tree.root, &D); } END_TEST - -#undef A -#undef B -#undef C -#undef D -#undef E -#undef DEF_TEST_SETUP - - START_TEST (test_remove_9) { - struct interval_node *nodes = NULL; - struct interval_tree *tree = test_get_tree4 (&nodes); + enum { N = 4 }; + const int values[N] = {10, 20, 30, 40}; + struct itree_node *nodes[N] = {&N_10, &N_20, &N_30, &N_40}; + interval_tree_init (&tree); + for (int i = 0; i < N; ++i) + itree_insert (&tree, nodes[i], values[i], values[i]); - ck_assert (tree->root == &N_20); + ck_assert (tree.root == &N_20); ck_assert (N_20.left == &N_10); ck_assert (N_20.right == &N_30); ck_assert (N_30.right == &N_40); - ck_assert (N_20.color == ITREE_BLACK); - ck_assert (N_10.color == ITREE_BLACK); - ck_assert (N_30.color == ITREE_BLACK); - ck_assert (N_40.color == ITREE_RED); - - interval_tree_remove (tree, &N_10); - - ck_assert (tree->root == &N_30); - ck_assert (N_30.parent == &tree->nil); - ck_assert (N_30.left == &N_20); - ck_assert (N_30.right == &N_40); - ck_assert (N_20.color == ITREE_BLACK); - ck_assert (N_30.color == ITREE_BLACK); - ck_assert (N_40.color == ITREE_BLACK); + ck_assert (! N_20.red); + ck_assert (! N_10.red); + ck_assert (! N_30.red); + ck_assert (N_40.red); + + itree_remove (&tree, &N_10); + + ck_assert_ptr_eq (tree.root, &N_30); + ck_assert_ptr_null (N_30.parent); + ck_assert_ptr_eq (N_30.left, &N_20); + ck_assert_ptr_eq (N_30.right, &N_40); + ck_assert (! N_20.red); + ck_assert (! N_30.red); + ck_assert (! N_40.red); } END_TEST -#define N 3 +static void +shuffle (int *index, int n) +{ + for (int i = n - 1; i >= 0; --i) + { + int j = random () % (i + 1); + int h = index[j]; + index[j] = index[i]; + index[i] = h; + } +} START_TEST (test_remove_10) { - struct interval_tree tree; - struct interval_node nodes[N]; + enum { N = 3 }; int index[N]; - + for (int i = 0; i < N; ++i) + index[i] = i; srand (42); + shuffle (index, N); + interval_tree_init (&tree); + struct itree_node nodes[N]; for (int i = 0; i < N; ++i) { - nodes[i].begin = (i + 1) * 10; - nodes[i].end = nodes[i].begin + 1; - index[i] = i; + ptrdiff_t pos = (i + 1) * 10; + itree_insert (&tree, &nodes[index[i]], pos, pos + 1); } - shuffle (index, N); - for (int i = 0; i < N; ++i) - interval_tree_insert (&tree, &nodes[index[i]]); shuffle (index, N); for (int i = 0; i < N; ++i) { ck_assert (interval_tree_contains (&tree, &nodes[index[i]])); - interval_tree_remove (&tree, &nodes[index[i]]); + itree_remove (&tree, &nodes[index[i]]); } - ck_assert (tree.root == &tree.nil); - ck_assert (tree.size == 0); + ck_assert_ptr_null (tree.root); + ck_assert_int_eq (tree.size, 0); } END_TEST @@ -819,70 +748,57 @@ END_TEST START_TEST (test_generator_1) { - struct interval_tree tree; - struct interval_node node, *n; - struct interval_generator *g; + struct itree_node node, *n; + struct itree_iterator *g; interval_tree_init (&tree); - node.begin = 10; - node.end = 20; - interval_tree_insert (&tree, &node); - g = interval_generator_create (&tree); - interval_generator_reset (g, 0, 30, ITREE_ASCENDING); - n = interval_generator_next (g); - ck_assert (n == &node); - ck_assert (n->begin == 10 && n->end == 20); - ck_assert (interval_generator_next (g) == NULL); - ck_assert (interval_generator_next (g) == NULL); - ck_assert (interval_generator_next (g) == NULL); - interval_generator_destroy (g); - - g = interval_generator_create (&tree); - interval_generator_reset (g, 30, 50, ITREE_ASCENDING); - ck_assert (interval_generator_next (g) == NULL); - ck_assert (interval_generator_next (g) == NULL); - ck_assert (interval_generator_next (g) == NULL); - interval_generator_destroy (g); + + itree_insert (&tree, &node, 10, 20); + g = itree_iterator_start (&tree, 0, 30, ITREE_ASCENDING, NULL, 0); + n = itree_iterator_next (g); + ck_assert_ptr_eq (n, &node); + ck_assert_int_eq (n->begin, 10); + ck_assert_int_eq (n->end, 20); + ck_assert_ptr_null (itree_iterator_next (g)); + ck_assert_ptr_null (itree_iterator_next (g)); + ck_assert_ptr_null (itree_iterator_next (g)); + itree_iterator_finish (g); + + g = itree_iterator_start (&tree, 30, 50, ITREE_ASCENDING, NULL, 0); + ck_assert_ptr_null (itree_iterator_next (g)); + ck_assert_ptr_null (itree_iterator_next (g)); + ck_assert_ptr_null (itree_iterator_next (g)); + itree_iterator_finish (g); } END_TEST -void -test_check_generator (struct interval_tree *tree, +static void +test_check_generator (struct itree_tree *tree, ptrdiff_t begin, ptrdiff_t end, int n, ...) { va_list ap; - struct interval_generator *g = interval_generator_create (tree); - interval_generator_reset (g, begin, end, ITREE_ASCENDING); + struct itree_iterator *g = + itree_iterator_start (tree, begin, end, ITREE_ASCENDING, NULL, 0); va_start (ap, n); for (int i = 0; i < n; ++i) { - ptrdiff_t begin = va_arg (ap, ptrdiff_t); - struct interval_node *node = interval_generator_next (g); - ck_assert (node); - ck_assert_int_eq (node->begin, begin); + struct itree_node *node = itree_iterator_next (g); + ck_assert_ptr_nonnull (node); + ck_assert_int_eq (node->begin, va_arg (ap, ptrdiff_t)); } va_end (ap); - ck_assert (! interval_generator_next (g)); - ck_assert (! interval_generator_next (g)); - interval_generator_destroy (g); + ck_assert_ptr_null (itree_iterator_next (g)); + ck_assert_ptr_null (itree_iterator_next (g)); + itree_iterator_finish (g); } -#define DEF_TEST_SETUP() \ - - START_TEST (test_generator_2) { - struct interval_tree tree; - struct interval_node nodes[3]; - interval_tree_init (&tree); - - for (int i = 0; i < 3; ++i) { - nodes[i].begin = 10 * (i + 1); - nodes[i].end = 10 * (i + 2); - interval_tree_insert (&tree, &nodes[i]); - } + struct itree_node nodes[3]; + for (int i = 0; i < 3; ++i) + itree_insert (&tree, &nodes[i], 10 * (i + 1), 10 * (i + 2)); test_check_generator (&tree, 0, 50, 3, 10, 20, 30); @@ -902,72 +818,56 @@ START_TEST (test_generator_2) } END_TEST - -struct interval_node* -test_create_tree (struct interval_tree *tree, int n, - bool doshuffle, ...) +static void +test_create_tree (struct itree_node *nodes, int n, bool doshuffle) { - va_list ap; - struct interval_node *nodes = calloc (n, sizeof (struct interval_node)); int *index = calloc (n, sizeof (int)); - - interval_tree_init (tree); - va_start (ap, doshuffle); for (int i = 0; i < n; ++i) + index[i] = i; + if (doshuffle) { - ptrdiff_t begin = va_arg (ap, ptrdiff_t); - ptrdiff_t end = va_arg (ap, ptrdiff_t); - nodes[i].begin = begin; - nodes[i].end = end; - index[i] = i; + srand (42); + shuffle (index, n); } - va_end (ap); - srand (42); - if (doshuffle) - shuffle (index, n); + + interval_tree_init (&tree); for (int i = 0; i < n; ++i) - interval_tree_insert (tree, &nodes[index[i]]); + { + struct itree_node *node = &nodes[index[i]]; + itree_insert (&tree, node, node->begin, node->end); + } free (index); - - return nodes; } START_TEST (test_generator_3) { - struct interval_tree tree; - struct interval_node *nodes = NULL; - - nodes = test_create_tree (&tree, 3, true, - 10, 10, - 10, 10, - 10, 10); + enum { N = 3 }; + struct itree_node nodes[N] = {{.begin = 10, .end = 10}, + {.begin = 10, .end = 10}, + {.begin = 10, .end = 10}}; + test_create_tree (nodes, N, true); test_check_generator (&tree, 0, 10, 0); - test_check_generator (&tree, 10, 10, 3, 10, 10, 10); - test_check_generator (&tree, 10, 20, 3, 10, 10, 10); - free (nodes); + test_check_generator (&tree, 10, 10, 3, + 10, 10, 10); + test_check_generator (&tree, 10, 20, 3, + 10, 10, 10); } END_TEST -#define FOREACH(n, g) \ - for ((n) = interval_generator_next (g); (n) != NULL; \ - (n) = interval_generator_next (g)) - START_TEST (test_generator_5) { - struct interval_tree tree; - struct interval_node *nodes; - struct interval_generator *g; - nodes = test_create_tree (&tree, 4, false, - 10, 30, - 20, 40, - 30, 50, - 40, 60); - g = interval_generator_create (&tree); - interval_generator_reset (g, 0, 100, ITREE_PRE_ORDER); - for (int i = 0; i < 4; ++i) + enum { N = 4 }; + struct itree_node nodes[N] = {{.begin = 10, .end = 30}, + {.begin = 20, .end = 40}, + {.begin = 30, .end = 50}, + {.begin = 40, .end = 60}}; + test_create_tree (nodes, N, false); + struct itree_iterator *g = + itree_iterator_start (&tree, 0, 100, ITREE_PRE_ORDER, NULL, 0); + for (int i = 0; i < N; ++i) { - struct interval_node *n = interval_generator_next (g); - ck_assert (n); + struct itree_node *n = itree_iterator_next (g); + ck_assert_ptr_nonnull (n); switch (i) { case 0: ck_assert_int_eq (20, n->begin); break; @@ -976,28 +876,24 @@ START_TEST (test_generator_5) case 3: ck_assert_int_eq (40, n->begin); break; } } - interval_generator_destroy (g); - free (nodes); - + itree_iterator_finish (g); } END_TEST START_TEST (test_generator_6) { - struct interval_tree tree; - struct interval_node *nodes; - struct interval_generator *g; - nodes = test_create_tree (&tree, 4, true, - 10, 30, - 20, 40, - 30, 50, - 40, 60); - g = interval_generator_create (&tree); - interval_generator_reset (g, 0, 100, ITREE_ASCENDING); - for (int i = 0; i < 4; ++i) + enum { N = 4 }; + struct itree_node nodes[N] = {{.begin = 10, .end = 30}, + {.begin = 20, .end = 40}, + {.begin = 30, .end = 50}, + {.begin = 40, .end = 60}}; + test_create_tree (nodes, N, true); + struct itree_iterator *g = + itree_iterator_start (&tree, 0, 100, ITREE_ASCENDING, NULL, 0); + for (int i = 0; i < N; ++i) { - struct interval_node *n = interval_generator_next (g); - ck_assert (n); + struct itree_node *n = itree_iterator_next (g); + ck_assert_ptr_nonnull (n); switch (i) { case 0: ck_assert_int_eq (10, n->begin); break; @@ -1006,28 +902,24 @@ START_TEST (test_generator_6) case 3: ck_assert_int_eq (40, n->begin); break; } } - interval_generator_destroy (g); - free (nodes); - + itree_iterator_finish (g); } END_TEST START_TEST (test_generator_7) { - struct interval_tree tree; - struct interval_node *nodes; - struct interval_generator *g; - nodes = test_create_tree (&tree, 4, true, - 10, 30, - 20, 40, - 30, 50, - 40, 60); - g = interval_generator_create (&tree); - interval_generator_reset (g, 0, 100, ITREE_DESCENDING); - for (int i = 0; i < 4; ++i) + enum { N = 4 }; + struct itree_node nodes[N] = {{.begin = 10, .end = 30}, + {.begin = 20, .end = 40}, + {.begin = 30, .end = 50}, + {.begin = 40, .end = 60}}; + test_create_tree (nodes, N, true); + struct itree_iterator *g = + itree_iterator_start (&tree, 0, 100, ITREE_DESCENDING, NULL, 0); + for (int i = 0; i < N; ++i) { - struct interval_node *n = interval_generator_next (g); - ck_assert (n); + struct itree_node *n = itree_iterator_next (g); + ck_assert_ptr_nonnull (n); switch (i) { case 0: ck_assert_int_eq (40, n->begin); break; @@ -1036,48 +928,41 @@ START_TEST (test_generator_7) case 3: ck_assert_int_eq (10, n->begin); break; } } - interval_generator_destroy (g); - free (nodes); - + itree_iterator_finish (g); } END_TEST START_TEST (test_generator_8) { - struct interval_tree tree; - struct interval_node *nodes, *n; - struct interval_generator *g; - nodes = test_create_tree (&tree, 2, false, - 20, 30, - 40, 50); - g = interval_generator_create (&tree); - interval_generator_reset (g, 1, 60, ITREE_DESCENDING); - n = interval_generator_next (g); + enum { N = 2 }; + struct itree_node nodes[N] = {{.begin = 20, .end = 30}, + {.begin = 40, .end = 50}}; + test_create_tree (nodes, N, false); + struct itree_iterator *g = + itree_iterator_start (&tree, 1, 60, ITREE_DESCENDING, NULL, 0); + struct itree_node *n = itree_iterator_next (g); ck_assert_int_eq (n->begin, 40); - interval_generator_narrow (g, 50, 60); - n = interval_generator_next (g); - ck_assert (n == NULL); - free (nodes); + itree_iterator_narrow (g, 50, 60); + n = itree_iterator_next (g); + ck_assert_ptr_null (n); + itree_iterator_finish (g); } END_TEST - START_TEST (test_generator_9) { - struct interval_tree tree; - struct interval_node *nodes, *n; - struct interval_generator *g; - nodes = test_create_tree (&tree, 2, false, - 25, 25, - 20, 30); - g = interval_generator_create (&tree); - interval_generator_reset (g, 1, 30, ITREE_DESCENDING); - n = interval_generator_next (g); + enum { N = 2 }; + struct itree_node nodes[N] = {{.begin = 25, .end = 25}, + {.begin = 20, .end = 30}}; + test_create_tree (nodes, N, false); + struct itree_iterator *g = + itree_iterator_start (&tree, 1, 30, ITREE_DESCENDING, NULL, 0); + struct itree_node *n = itree_iterator_next (g); ck_assert_int_eq (n->begin, 25); - interval_generator_narrow (g, 25, 35); - n = interval_generator_next (g); + itree_iterator_narrow (g, 25, 30); + n = itree_iterator_next (g); ck_assert_int_eq (n->begin, 20); - free (nodes); + itree_iterator_finish (g); } END_TEST @@ -1086,22 +971,20 @@ END_TEST * | Insert Gap * +===================================================================================+ */ -static struct interval_tree gap_tree; -static struct interval_node gap_node; +static struct itree_tree gap_tree; +static struct itree_node gap_node; -#define N_BEG (interval_tree_validate (&gap_tree, &gap_node)->begin) -#define N_END (interval_tree_validate (&gap_tree, &gap_node)->end) +#define N_BEG (itree_node_begin (&gap_tree, &gap_node)) +#define N_END (itree_node_end (&gap_tree, &gap_node)) static void test_setup_gap_node (ptrdiff_t begin, ptrdiff_t end, bool front_advance, bool rear_advance) { interval_tree_init (&gap_tree); - gap_node.begin = begin; - gap_node.end = end; gap_node.front_advance = front_advance; gap_node.rear_advance = rear_advance; - interval_tree_insert (&gap_tree, &gap_node); + itree_insert (&gap_tree, &gap_node, begin, end); } static void @@ -1112,8 +995,8 @@ test_setup_gap_node_noadvance (ptrdiff_t begin, ptrdiff_t end) START_TEST (test_gap_insert_1) { - test_setup_gap_node (100, 200, false, false); - interval_tree_insert_gap (&gap_tree, 100 + 10, 20); + test_setup_gap_node_noadvance (100, 200); + itree_insert_gap (&gap_tree, 100 + 10, 20, false); ck_assert_int_eq (N_BEG, 100); ck_assert_int_eq (N_END, 200 + 20); } @@ -1121,8 +1004,8 @@ END_TEST START_TEST (test_gap_insert_2) { - test_setup_gap_node (100, 200, false, false); - interval_tree_insert_gap (&gap_tree, 300, 10); + test_setup_gap_node_noadvance (100, 200); + itree_insert_gap (&gap_tree, 300, 10, false); ck_assert_int_eq (N_BEG, 100); ck_assert_int_eq (N_END, 200); } @@ -1130,8 +1013,8 @@ END_TEST START_TEST (test_gap_insert_3) { - test_setup_gap_node (100, 200, false, false); - interval_tree_insert_gap (&gap_tree, 0, 15); + test_setup_gap_node_noadvance (100, 200); + itree_insert_gap (&gap_tree, 0, 15, false); ck_assert_int_eq (N_BEG, 100 + 15); ck_assert_int_eq (N_END, 200 + 15); } @@ -1140,7 +1023,7 @@ END_TEST START_TEST (test_gap_insert_4) { test_setup_gap_node (100, 200, true, false); - interval_tree_insert_gap (&gap_tree, 100, 20); + itree_insert_gap (&gap_tree, 100, 20, false); ck_assert_int_eq (N_BEG, 100 + 20); ck_assert_int_eq (N_END, 200 + 20); @@ -1149,8 +1032,8 @@ END_TEST START_TEST (test_gap_insert_5) { - test_setup_gap_node (100, 200, false, false); - interval_tree_insert_gap (&gap_tree, 100, 20); + test_setup_gap_node_noadvance (100, 200); + itree_insert_gap (&gap_tree, 100, 20, false); ck_assert_int_eq (N_BEG, 100); ck_assert_int_eq (N_END, 200 + 20); @@ -1160,7 +1043,7 @@ END_TEST START_TEST (test_gap_insert_6) { test_setup_gap_node (100, 200, false, true); - interval_tree_insert_gap (&gap_tree, 200, 20); + itree_insert_gap (&gap_tree, 200, 20, false); ck_assert_int_eq (N_BEG, 100); ck_assert_int_eq (N_END, 200 + 20); @@ -1169,8 +1052,8 @@ END_TEST START_TEST (test_gap_insert_7) { - test_setup_gap_node (100, 200, false, false); - interval_tree_insert_gap (&gap_tree, 200, 20); + test_setup_gap_node_noadvance (100, 200); + itree_insert_gap (&gap_tree, 200, 20, false); ck_assert_int_eq (N_BEG, 100); ck_assert_int_eq (N_END, 200); @@ -1180,7 +1063,7 @@ END_TEST START_TEST (test_gap_insert_8) { test_setup_gap_node (100, 100, true, true); - interval_tree_insert_gap (&gap_tree, 100, 20); + itree_insert_gap (&gap_tree, 100, 20, false); ck_assert_int_eq (N_BEG, 100 + 20); ck_assert_int_eq (N_END, 100 + 20); @@ -1190,7 +1073,7 @@ END_TEST START_TEST (test_gap_insert_9) { test_setup_gap_node (100, 100, false, true); - interval_tree_insert_gap (&gap_tree, 100, 20); + itree_insert_gap (&gap_tree, 100, 20, false); ck_assert_int_eq (N_BEG, 100); ck_assert_int_eq (N_END, 100 + 20); @@ -1200,7 +1083,7 @@ END_TEST START_TEST (test_gap_insert_10) { test_setup_gap_node (100, 100, true, false); - interval_tree_insert_gap (&gap_tree, 100, 20); + itree_insert_gap (&gap_tree, 100, 20, false); ck_assert_int_eq (N_BEG, 100); ck_assert_int_eq (N_END, 100); @@ -1209,8 +1092,8 @@ END_TEST START_TEST (test_gap_insert_11) { - test_setup_gap_node (100, 100, false, false); - interval_tree_insert_gap (&gap_tree, 100, 20); + test_setup_gap_node_noadvance (100, 100); + itree_insert_gap (&gap_tree, 100, 20, false); ck_assert_int_eq (N_BEG, 100); ck_assert_int_eq (N_END, 100); @@ -1225,7 +1108,7 @@ END_TEST START_TEST (test_gap_delete_1) { test_setup_gap_node_noadvance (100, 200); - interval_tree_delete_gap (&gap_tree, 100 + 10, 20); + itree_delete_gap (&gap_tree, 100 + 10, 20); ck_assert_int_eq (N_BEG, 100); ck_assert_int_eq (N_END, 200 - 20); @@ -1235,7 +1118,7 @@ END_TEST START_TEST (test_gap_delete_2) { test_setup_gap_node_noadvance (100, 200); - interval_tree_delete_gap (&gap_tree, 200 + 10, 20); + itree_delete_gap (&gap_tree, 200 + 10, 20); ck_assert_int_eq (N_BEG, 100); ck_assert_int_eq (N_END, 200); @@ -1245,7 +1128,7 @@ END_TEST START_TEST (test_gap_delete_3) { test_setup_gap_node_noadvance (100, 200); - interval_tree_delete_gap (&gap_tree, 200, 20); + itree_delete_gap (&gap_tree, 200, 20); ck_assert_int_eq (N_BEG, 100); ck_assert_int_eq (N_END, 200); @@ -1255,7 +1138,7 @@ END_TEST START_TEST (test_gap_delete_4) { test_setup_gap_node_noadvance (100, 200); - interval_tree_delete_gap (&gap_tree, 100 - 20, 20); + itree_delete_gap (&gap_tree, 100 - 20, 20); ck_assert_int_eq (N_BEG, 100 - 20); ck_assert_int_eq (N_END, 200 - 20); @@ -1265,7 +1148,7 @@ END_TEST START_TEST (test_gap_delete_5) { test_setup_gap_node_noadvance (100, 200); - interval_tree_delete_gap (&gap_tree, 70, 20); + itree_delete_gap (&gap_tree, 70, 20); ck_assert_int_eq (N_BEG, 100 - 20); ck_assert_int_eq (N_END, 200 - 20); @@ -1275,7 +1158,7 @@ END_TEST START_TEST (test_gap_delete_6) { test_setup_gap_node_noadvance (100, 200); - interval_tree_delete_gap (&gap_tree, 80, 100); + itree_delete_gap (&gap_tree, 80, 100); ck_assert_int_eq (N_BEG, 80); ck_assert_int_eq (N_END, 100); } @@ -1284,7 +1167,7 @@ END_TEST START_TEST (test_gap_delete_7) { test_setup_gap_node_noadvance (100, 200); - interval_tree_delete_gap (&gap_tree, 120, 100); + itree_delete_gap (&gap_tree, 120, 100); ck_assert_int_eq (N_BEG, 100); ck_assert_int_eq (N_END, 120); } @@ -1293,7 +1176,7 @@ END_TEST START_TEST (test_gap_delete_8) { test_setup_gap_node_noadvance (100, 200); - interval_tree_delete_gap (&gap_tree, 100 - 20, 200 + 20); + itree_delete_gap (&gap_tree, 100 - 20, 200 + 20); ck_assert_int_eq (N_BEG, 100 - 20); ck_assert_int_eq (N_END, 100 - 20); @@ -1302,36 +1185,58 @@ END_TEST -Suite * basic_suite () +static Suite * +basic_suite () { - Suite *s = suite_create ("basic_suite"); - TCase *tc = tcase_create ("basic_test"); + Suite *s = suite_create ("basic"); + TCase *tc = tcase_create ("insert1"); + tcase_add_checked_fixture (tc, test_insert1_setup, NULL); tcase_add_test (tc, test_insert_1); tcase_add_test (tc, test_insert_2); tcase_add_test (tc, test_insert_3); tcase_add_test (tc, test_insert_4); tcase_add_test (tc, test_insert_5); tcase_add_test (tc, test_insert_6); + suite_add_tcase (s, tc); + + tc = tcase_create ("insert2"); + tcase_add_checked_fixture (tc, test_insert2_setup, NULL); tcase_add_test (tc, test_insert_7); tcase_add_test (tc, test_insert_8); tcase_add_test (tc, test_insert_9); tcase_add_test (tc, test_insert_10); tcase_add_test (tc, test_insert_11); tcase_add_test (tc, test_insert_12); + suite_add_tcase (s, tc); + + tc = tcase_create ("insert3"); tcase_add_test (tc, test_insert_13); + tcase_add_test (tc, test_insert_14); + suite_add_tcase (s, tc); + tc = tcase_create ("remove1"); + tcase_add_checked_fixture (tc, test_remove1_setup, NULL); tcase_add_test (tc, test_remove_1); tcase_add_test (tc, test_remove_2); tcase_add_test (tc, test_remove_3); tcase_add_test (tc, test_remove_4); + suite_add_tcase (s, tc); + + tc = tcase_create ("remove2"); + tcase_add_checked_fixture (tc, test_remove2_setup, NULL); tcase_add_test (tc, test_remove_5); tcase_add_test (tc, test_remove_6); tcase_add_test (tc, test_remove_7); tcase_add_test (tc, test_remove_8); + suite_add_tcase (s, tc); + + tc = tcase_create ("remove3"); tcase_add_test (tc, test_remove_9); tcase_add_test (tc, test_remove_10); + suite_add_tcase (s, tc); + tc = tcase_create ("generator"); tcase_add_test (tc, test_generator_1); tcase_add_test (tc, test_generator_2); tcase_add_test (tc, test_generator_3); @@ -1340,7 +1245,9 @@ Suite * basic_suite () tcase_add_test (tc, test_generator_7); tcase_add_test (tc, test_generator_8); tcase_add_test (tc, test_generator_9); + suite_add_tcase (s, tc); + tc = tcase_create ("insert_gap"); tcase_add_test (tc, test_gap_insert_1); tcase_add_test (tc, test_gap_insert_2); tcase_add_test (tc, test_gap_insert_3); @@ -1352,7 +1259,9 @@ Suite * basic_suite () tcase_add_test (tc, test_gap_insert_9); tcase_add_test (tc, test_gap_insert_10); tcase_add_test (tc, test_gap_insert_11); + suite_add_tcase (s, tc); + tc = tcase_create ("delete_gap"); tcase_add_test (tc, test_gap_delete_1); tcase_add_test (tc, test_gap_delete_2); tcase_add_test (tc, test_gap_delete_3); @@ -1361,21 +1270,20 @@ Suite * basic_suite () tcase_add_test (tc, test_gap_delete_6); tcase_add_test (tc, test_gap_delete_7); tcase_add_test (tc, test_gap_delete_8); - - /* tcase_set_timeout (tc, 120); */ suite_add_tcase (s, tc); + return s; } int main (void) { - int nfailed; Suite *s = basic_suite (); SRunner *sr = srunner_create (s); - srunner_run_all (sr, CK_NORMAL); - nfailed = srunner_ntests_failed (sr); + init_itree (); + srunner_run_all (sr, CK_ENV); + int nfailed = srunner_ntests_failed (sr); srunner_free (sr); return (nfailed == 0) ? EXIT_SUCCESS : EXIT_FAILURE; } commit 01471b5fdff21fcb23b7718d9cd99bf5c08645ba Author: Po Lu Date: Fri Nov 4 19:21:22 2022 +0800 Avoid using too up-to-date values when restoring valuators * src/xterm.c (xi_has_scroll_valuators): New function. (xi_handle_device_changed): If the device changed event provides scroll valuators, then use the values in there. (bug#58980) diff --git a/src/xterm.c b/src/xterm.c index 71ff69ece4..4178526c31 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -13026,6 +13026,23 @@ xi_get_scroll_valuator (struct xi_device_t *device, int number) return NULL; } +/* Check if EVENT, a DeviceChanged event, contains any scroll + valuators. */ + +static bool +xi_has_scroll_valuators (XIDeviceChangedEvent *event) +{ + int i; + + for (i = 0; i < event->num_classes; ++i) + { + if (event->classes[i]->type == XIScrollClass) + return true; + } + + return false; +} + #endif /* Handle EVENT, a DeviceChanged event. Look up the device that @@ -13049,21 +13066,93 @@ xi_handle_device_changed (struct x_display_info *dpyinfo, #endif #ifdef HAVE_XINPUT2_1 - /* When a DeviceChange event is received for a master device, we - don't get any scroll valuators along with it. This is possibly - an X server bug but I really don't want to dig any further, so - fetch the scroll valuators manually. (bug#57020) */ + if (xi_has_scroll_valuators (event)) + { + /* Scroll valuators are provided by this event. Use the values + provided in this event to populate the device's new scroll + valuator list, as if this event's is a SlaveSwitch event + caused by wheel movement, querying for the device info will + probably return newer values, leading to a delta of 0 being + computed when handling the subsequent XI_Motion event. + (bug#58980) */ - x_catch_errors (dpyinfo->display); - info = XIQueryDevice (dpyinfo->display, event->deviceid, - /* ndevices is always 1 if a deviceid is - specified. If the request fails, NULL will - be returned. */ - &ndevices); - x_uncatch_errors (); + device->valuators = xrealloc (device->valuators, + (event->num_classes + * sizeof *device->valuators)); + device->scroll_valuator_count = 0; +#ifdef HAVE_XINPUT2_2 + device->direct_p = false; +#endif + + for (i = 0; i < event->num_classes; ++i) + { + switch (event->classes[i]->type) + { + case XIScrollClass: + scroll = (XIScrollClassInfo *) event->classes[i]; + + valuator = &device->valuators[device->scroll_valuator_count++]; + valuator->horizontal = (scroll->scroll_type + == XIScrollTypeHorizontal); + valuator->invalid_p = true; + valuator->emacs_value = 0; + valuator->increment = scroll->increment; + valuator->number = scroll->number; + break; + +#ifdef HAVE_XINPUT2_2 + case XITouchClass: + touch = (XITouchClassInfo *) event->classes[i]; + + if (touch->mode == XIDirectTouch) + device->direct_p = true; + break; +#endif + } + } + + /* Restore the values of any scroll valuators that we already + know about. */ + + for (i = 0; i < event->num_classes; ++i) + { + switch (event->classes[i]->type) + { + case XIValuatorClass: + valuator_info = (XIValuatorClassInfo *) event->classes[i]; + + valuator = xi_get_scroll_valuator (device, + valuator_info->number); + if (valuator) + { + valuator->invalid_p = false; + valuator->current_value = valuator_info->value; + valuator->emacs_value = 0; + } - if (info) + break; + } + } + } + else { + /* When a DeviceChange event is received for a master device, + the X server sometimes does not send any scroll valuators + along with it. This is possibly an X server bug but I really + don't want to dig any further, so fetch the scroll valuators + manually. (bug#57020) */ + + x_catch_errors (dpyinfo->display); + info = XIQueryDevice (dpyinfo->display, event->deviceid, + /* ndevices is always 1 if a deviceid is + specified. If the request fails, NULL will + be returned. */ + &ndevices); + x_uncatch_errors (); + + if (!info) + return; + device->valuators = xrealloc (device->valuators, (info->num_classes * sizeof *device->valuators)); @@ -13115,32 +13204,32 @@ xi_handle_device_changed (struct x_display_info *dpyinfo, { valuator->invalid_p = false; valuator->current_value = valuator_info->value; + valuator->emacs_value = 0; } break; } } -#ifdef HAVE_XINPUT2_2 - /* The device is no longer a DirectTouch device, so - remove any touchpoints that we might have - recorded. */ - if (!device->direct_p) - { - tem = device->touchpoints; + XIFreeDeviceInfo (info); + } +#endif - while (tem) - { - last = tem; - tem = tem->next; - xfree (last); - } +#ifdef HAVE_XINPUT2_2 + /* The device is no longer a DirectTouch device, so remove any + touchpoints that we might have recorded. */ + if (!device->direct_p) + { + tem = device->touchpoints; - device->touchpoints = NULL; + while (tem) + { + last = tem; + tem = tem->next; + xfree (last); } -#endif - XIFreeDeviceInfo (info); + device->touchpoints = NULL; } #endif } commit a248eb3d184d018795461b5d1a27a373fda4bce8 Author: Dmitry Gutov Date: Fri Nov 4 12:40:50 2022 +0200 ; Minor rephrase diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 6d062aa8fa..0fe0a945ec 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -355,7 +355,7 @@ Also quote LOCAL-FILES if `default-directory' is quoted." (cl-defgeneric project-buffers (project) "Return the list of all live buffers that belong to PROJECT. -The default implementation matches the current open buffers to +The default implementation matches the existing buffers to PROJECT root using the value of `default-directory' in each one." (let ((root (expand-file-name (file-name-as-directory (project-root project)))) bufs) commit 23868658a20b66d40ed7aa9e9af3c1da141d511e Author: Eli Zaretskii Date: Fri Nov 4 09:49:48 2022 +0200 ; * lisp/subr.el (setq-local): Fix last doc change. diff --git a/lisp/subr.el b/lisp/subr.el index b60bc11079..6b83196d05 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -161,16 +161,18 @@ of previous VARs. `(progn . ,(nreverse exps)))) (defmacro setq-local (&rest pairs) - "Make VARIABLEs buffer-local and assign them the corresponding VALUEs. + "Make each VARIABLE buffer-local and assign to it the corresponding VALUE. -The args are a list of variable/value pairs. For each VARIABLE, -make it buffer-local and assign it the corresponding VALUE. The -variables are literal symbols and should not be quoted. +The arguments are variable/value pairs For each VARIABLE in a pair, +make VARIABLE buffer-local and assign to it the corresponding VALUE +of the pair. The VARIABLEs are literal symbols and should not be quoted. -The second VALUE is not computed until after the first VARIABLE -is set, and so on; each VALUE can use the new value of variables -set earlier in the `setq-local'. The return value of the -`setq-local' form is the value of the last VALUE. +The VALUE of the Nth pair is not computed until after the VARIABLE +of the (N-1)th pair is set; thus, each VALUE can use the new VALUEs +of VARIABLEs set by earlier pairs. + +The return value of the `setq-local' form is the VALUE of the last +pair. \(fn [VARIABLE VALUE]...)" (declare (debug setq)) commit ca3763af5cc2758ec71700029558e6ecc4379ea9 Author: Juri Linkov Date: Fri Nov 4 09:47:06 2022 +0200 * lisp/tab-bar.el (tab-bar-fixed-width): New user option. (tab-bar-fixed-width-max): New user option. (tab-bar-fixed-width-min): New variable. (tab-bar-fixed-width-faces): New variable. (tab-bar--fixed-width-hash): New function. (tab-bar-make-keymap-1): Use 'tab-bar-fixed-width'. https://lists.gnu.org/archive/html/emacs-devel/2022-10/msg02067.html diff --git a/etc/NEWS b/etc/NEWS index a185967483..f3a58366fe 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1076,6 +1076,11 @@ the corresponding deleted frame. ** Tab Bars and Tab Lines +--- +*** New user option 'tab-bar-fixed-width' to automatically resize tabs. +Another option 'tab-bar-fixed-width-max' defines the maximum tab width +that by default is 220 pixels on GUI and 20 characters on a tty. + --- *** 'C-x t RET' creates a new tab when the provided tab name doesn't exist. diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 2032689c65..810cb4edd7 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -963,7 +963,117 @@ on the tab bar instead." (defun tab-bar-make-keymap-1 () "Generate an actual keymap from `tab-bar-map', without caching." - (append tab-bar-map (tab-bar-format-list tab-bar-format))) + (let ((items (tab-bar-format-list tab-bar-format))) + (when tab-bar-fixed-width + (setq items (tab-bar-fixed-width items))) + (append tab-bar-map items))) + + +(defcustom tab-bar-fixed-width t + "Automatically resize tabs on the tab bar to the fixed width. +This variable is intended to solve two problems. When switching buffers +on the current tab, the tab changes its name to buffer names of +various lengths, thus resizing the tab and shifting the tab positions +on the tab bar. But with the fixed width, the size of the tab name +doesn't change when the tab name changes, thus keeping the fixed +tab bar layout. The second problem solved by this variable is to prevent +wrapping the long tab bar to the second line, thus keeping the height of +the tab bar always fixed to one line. + +The maximum tab width is defined by the variable `tab-bar-fixed-width-max'." + :type 'boolean + :group 'tab-bar + :version "29.1") + +(defcustom tab-bar-fixed-width-max '(220 . 20) + "Maximum number of pixels or characters allowed for the tab name width. +The car of the cons cell is the maximum number of pixels when used on +a GUI session. The cdr of the cons cell defines the maximum number of +characters when used on a tty. When set to nil, there is no limit +on maximum width, and tabs are resized evenly to the whole width +of the tab bar when `tab-bar-fixed-width' is non-nil." + :type '(choice + (const :tag "No limit" nil) + (cons (integer :tag "Max width (pixels)" :value 220) + (integer :tag "Max width (chars)" :value 20))) + :group 'tab-bar + :version "29.1") + +(defvar tab-bar-fixed-width-min '(20 . 2) + "Minimum number of pixels or characters allowed for the tab name width. +It's not recommended to change this value since with a bigger value, the +tab bar might wrap to the second line.") + +(defvar tab-bar-fixed-width-faces + '( tab-bar-tab tab-bar-tab-inactive + tab-bar-tab-ungrouped + tab-bar-tab-group-inactive) + "Resize tabs only with these faces.") + +(defvar tab-bar--fixed-width-hash nil + "Memoization table for `tab-bar-fixed-width'.") + +(defun tab-bar-fixed-width (items) + "Return tab-bar items with resized tab names." + (unless tab-bar--fixed-width-hash + (define-hash-table-test 'tab-bar--fixed-width-hash-test + #'equal-including-properties + #'sxhash-equal-including-properties) + (setq tab-bar--fixed-width-hash + (make-hash-table :test 'tab-bar--fixed-width-hash-test))) + (let ((tabs nil) ;; list of resizable tabs + (non-tabs "") ;; concatenated names of non-resizable tabs + (width 0)) ;; resize tab names to this width + (dolist (item items) + (when (and (eq (nth 1 item) 'menu-item) (stringp (nth 2 item))) + (if (memq (get-text-property 0 'face (nth 2 item)) + tab-bar-fixed-width-faces) + (push item tabs) + (unless (eq (nth 0 item) 'align-right) + (setq non-tabs (concat non-tabs (nth 2 item))))))) + (when tabs + (setq width (/ (- (frame-pixel-width) + (string-pixel-width + (propertize non-tabs 'face 'tab-bar))) + (length tabs))) + (when tab-bar-fixed-width-min + (setq width (max width (if window-system + (car tab-bar-fixed-width-min) + (cdr tab-bar-fixed-width-min))))) + (when tab-bar-fixed-width-max + (setq width (min width (if window-system + (car tab-bar-fixed-width-max) + (cdr tab-bar-fixed-width-max))))) + (dolist (item tabs) + (setf (nth 2 item) + (with-memoization (gethash (cons width (nth 2 item)) + tab-bar--fixed-width-hash) + (let* ((name (nth 2 item)) + (len (length name)) + (close-p (get-text-property (1- len) 'close-tab name)) + (pixel-width (string-pixel-width + (propertize name 'face 'tab-bar-tab)))) + (cond + ((< pixel-width width) + (let ((space (apply 'propertize " " (text-properties-at 0 name))) + (ins-pos (- len (if close-p 1 0)))) + (while (< pixel-width width) + (setf (substring name ins-pos ins-pos) space) + (setq pixel-width (string-pixel-width + (propertize name 'face 'tab-bar-tab)))))) + ((> pixel-width width) + (let (del-pos) + (while (> pixel-width width) + (setq len (length name) + del-pos (- len (if close-p 1 0))) + (setf (substring name (1- del-pos) del-pos) "") + (setq pixel-width (string-pixel-width + (propertize name 'face 'tab-bar-tab)))) + (add-face-text-property (max (- del-pos 3) 1) + (1- del-pos) + 'shadow nil name)))) + name))))) + items)) ;; Some window-configuration parameters don't need to be persistent. commit 4fa8f57cc627166f4f7f1a915bb24923f413a3d0 Author: Juanma Barranquero Date: Fri Nov 4 08:41:43 2022 +0100 ; * lisp/emacs-lisp/oclosure.el: Fix typos. diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index c77ac151d7..a17fdb7e35 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -216,7 +216,7 @@ is a list of additional properties among the following: function) named COPIER. It will take an object of type NAME as first argument followed by ARGS. ARGS lists the names of the slots that will be updated with the value of the corresponding argument. -SLOTS is a list if slot descriptions. Each slot can be a single symbol +SLOTS is a list of slot descriptions. Each slot can be a single symbol which is the name of the slot, or it can be of the form (SLOT-NAME . SPROPS) where SLOT-NAME is then the name of the slot and SPROPS is a property list of slot properties. The currently known properties are the following: @@ -341,11 +341,11 @@ list of slot properties. The currently known properties are the following: (defmacro oclosure--lambda (type bindings mutables args &rest body) "Low level construction of an OClosure object. -TYPE should be a form returning an OClosure type (a symbol) +TYPE should be a form returning an OClosure type (a symbol). BINDINGS should list all the slots expected by this type, in the proper order. MUTABLE is a list of symbols indicating which of the BINDINGS should be mutable. -No checking is performed," +No checking is performed." (declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body))) ;; FIXME: Fundamentally `oclosure-lambda' should be a special form. ;; We define it here as a macro which expands to something that commit 0efc611697466551368c5c2deb05f598f4ec0eeb Author: Philip Kaludercic Date: Thu Nov 3 23:15:12 2022 +0100 Autoload all entry functions diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 56762d39b2..3eac55ba54 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -619,6 +619,7 @@ repository can be set by BACKEND. If missing, rev))) ((user-error "Unknown package to fetch: %s" name-or-url)))) +;;;###autoload (defun package-vc-checkout (pkg-desc directory &optional rev) "Clone the sources for PKG-DESC into DIRECTORY and open it. An explicit revision can be requested by passing a string to the @@ -649,6 +650,7 @@ special value `:last-release' as REV." (package-vc--clone pkg-desc pkg-spec directory rev) (find-file directory))) +;;;###autoload (defun package-vc-link-directory (dir name) "Install the package NAME in DIR by linking it into the ELPA directory. If invoked interactively with a prefix argument, the user will be @@ -670,6 +672,7 @@ from the base name of DIR." :kind 'vc) pkg-dir))) +;;;###autoload (defun package-vc-refresh (pkg-desc) "Refresh the installation for PKG-DESC." (interactive (package-vc--read-pkg "Refresh package: ")) commit 38efed50dc7226f1692254120d531668f6508fb9 Author: Philip Kaludercic Date: Thu Nov 3 19:41:46 2022 +0100 ; Mention that 'package-vc-checkout' open a directory * lisp/emacs-lisp/package-vc.el (package-vc-checkout): Mention it in the docstring. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index ae92006c99..56762d39b2 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -620,7 +620,7 @@ repository can be set by BACKEND. If missing, ((user-error "Unknown package to fetch: %s" name-or-url)))) (defun package-vc-checkout (pkg-desc directory &optional rev) - "Clone the sources for PKG-DESC into DIRECTORY. + "Clone the sources for PKG-DESC into DIRECTORY and open it. An explicit revision can be requested by passing a string to the optional argument REV. If the command is invoked with a prefix argument, the revision used for the last release in the package commit f5fb7069f35ea5eb1815668a0b95b9b1730d74bf Author: Philip Kaludercic Date: Thu Nov 3 19:38:34 2022 +0100 ; Explicitly mark internal functions as such diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index faebd6ad6c..ae92006c99 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -45,7 +45,7 @@ :group 'package :version "29.1") -(defconst package-vc-elpa-packages-version 1 +(defconst package-vc--elpa-packages-version 1 "Version number of the package specification format understood by package-vc.") (defcustom package-vc-heuristic-alist @@ -89,7 +89,7 @@ (defcustom package-vc-repository-store (expand-file-name "emacs/vc-packages" (xdg-data-home)) - "Directory used by `package-vc-unpack' to store repositories." + "Directory used by `package-vc--unpack' to store repositories." :type 'directory :version "29.1") @@ -117,7 +117,7 @@ packages. Finally SYM is set to VAL." (package-vc-install name nil spec)) ((listp spec) (package-vc--archives-initialize) - (package-vc-unpack pkg-desc spec)))))) + (package-vc--unpack pkg-desc spec)))))) (custom-set-default sym val)) ;;;###autoload @@ -148,7 +148,7 @@ it is meant to be specified manually." :set #'package-vc--select-packages :version "29.1") -(defvar package-vc-archive-spec-alist nil +(defvar package-vc--archive-spec-alist nil "List of package specifications for each archive. The list maps package names as string to plist. Valid keys include @@ -182,7 +182,7 @@ onto the archive default or `package-vc-default-backend'. All other values are ignored.") -(defvar package-vc-archive-data-alist nil +(defvar package-vc--archive-data-alist nil "List of package specification archive metadata. Each element of the list has the form (ARCHIVE . PLIST), where PLIST keys are one of: @@ -190,7 +190,7 @@ PLIST keys are one of: `:version' (integer) Indicating the version of the file formatting, to be compared -with `package-vc-elpa-packages-version'. +with `package-vc--elpa-packages-version'. `:vc-backend' (symbol) @@ -201,7 +201,7 @@ ought to be a member of `vc-handled-backends'. If missing, All other values are ignored.") -(defun package-vc-desc->spec (pkg-desc &optional name) +(defun package-vc--desc->spec (pkg-desc &optional name) "Retrieve the package specification for PKG-DESC. The optional argument NAME can be used to override the default name for PKG-DESC." @@ -209,19 +209,19 @@ name for PKG-DESC." (or name (package-desc-name pkg-desc)) (if (package-desc-archive pkg-desc) (alist-get (intern (package-desc-archive pkg-desc)) - package-vc-archive-spec-alist) - (mapcan #'append (mapcar #'cdr package-vc-archive-spec-alist))) + package-vc--archive-spec-alist) + (mapcan #'append (mapcar #'cdr package-vc--archive-spec-alist))) nil nil #'string=)) -(define-inline package-vc-query-spec (pkg-desc prop) +(define-inline package-vc--query-spec (pkg-desc prop) "Query the property PROP for the package specification for PKG-DESC. If no package specification can be determined, the function will return nil." (inline-letevals (pkg-desc prop) - (inline-quote (plist-get (package-vc-desc->spec ,pkg-desc) ,prop)))) + (inline-quote (plist-get (package-vc--desc->spec ,pkg-desc) ,prop)))) (defun package-vc--read-archive-data (archive) - "Update `package-vc-archive-spec-alist' with the contents of ARCHIVE. + "Update `package-vc--archive-spec-alist' with the contents of ARCHIVE. This function is meant to be used as a hook for `package--read-archive-hook'." (let ((contents-file (expand-file-name @@ -237,11 +237,11 @@ This function is meant to be used as a hook for ;; :version 1 ;; :default-vc Git) (let ((spec (read (current-buffer)))) - (when (eq package-vc-elpa-packages-version + (when (eq package-vc--elpa-packages-version (plist-get (cdr spec) :version)) - (setf (alist-get (intern archive) package-vc-archive-spec-alist) + (setf (alist-get (intern archive) package-vc--archive-spec-alist) (car spec))) - (setf (alist-get (intern archive) package-vc-archive-data-alist) + (setf (alist-get (intern archive) package-vc--archive-data-alist) (cdr spec)) (when-let ((default-vc (plist-get (cdr spec) :default-vc)) ((not (memq default-vc vc-handled-backends)))) @@ -250,7 +250,7 @@ This function is meant to be used as a hook for (defun package-vc--download-and-read-archives (&optional async) "Download specifications of all `package-archives' and read them. -Populate `package-vc-archive-spec-alist' with the result. +Populate `package-vc--archive-spec-alist' with the result. If optional argument ASYNC is non-nil, perform the downloads asynchronously." @@ -273,10 +273,10 @@ asynchronously." when (vc-working-revision file) return it finally return "unknown")) -(defun package-vc-version (pkg) +(defun package-vc--version (pkg) "Extract the commit of a development package PKG." (cl-assert (package-vc-p pkg)) - (if-let ((main-file (package-vc-main-file pkg))) + (if-let ((main-file (package-vc--main-file pkg))) (with-temp-buffer (insert-file-contents main-file) (package-strip-rcs-id @@ -284,10 +284,10 @@ asynchronously." (lm-header "version")))) "0")) -(defun package-vc-main-file (pkg-desc) +(defun package-vc--main-file (pkg-desc) "Return the main file for PKG-DESC." (cl-assert (package-vc-p pkg-desc)) - (let ((pkg-spec (package-vc-desc->spec pkg-desc))) + (let ((pkg-spec (package-vc--desc->spec pkg-desc))) (or (plist-get pkg-spec :main-file) (expand-file-name (format "%s.el" (package-desc-name pkg-desc)) @@ -298,14 +298,14 @@ asynchronously." package-user-dir)) (plist-get pkg-spec :lisp-dir)))))) -(defun package-vc-generate-description-file (pkg-desc pkg-file) +(defun package-vc--generate-description-file (pkg-desc pkg-file) "Generate a package description file for PKG-DESC. The output is written out into PKG-FILE." (let ((name (package-desc-name pkg-desc))) ;; Infer the subject if missing. (unless (package-desc-summary pkg-desc) (setf (package-desc-summary pkg-desc) - (let ((main-file (package-vc-main-file pkg-desc))) + (let ((main-file (package-vc--main-file pkg-desc))) (or (package-desc-summary pkg-desc) (and-let* ((pkg (cadr (assq name package-archive-contents)))) (package-desc-summary pkg)) @@ -326,7 +326,7 @@ The output is written out into PKG-FILE." (nconc (list 'define-package (symbol-name name) - (cons 'vc (package-vc-version pkg-desc)) + (cons 'vc (package-vc--version pkg-desc)) (package-desc-summary pkg-desc) (let ((requires (package-desc-reqs pkg-desc))) (list 'quote @@ -343,7 +343,7 @@ The output is written out into PKG-FILE." (declare-function org-export-to-file "ox" (backend file)) -(defun package-vc-build-documentation (pkg-desc file) +(defun package-vc--build-documentation (pkg-desc file) "Build documentation FILE for PKG-DESC." (let ((pkg-dir (package-desc-dir pkg-desc))) (when (string-match-p "\\.org\\'" file) @@ -356,7 +356,7 @@ The output is written out into PKG-FILE." (call-process "install-info" nil nil nil file pkg-dir))) -(defun package-vc-unpack-1 (pkg-desc pkg-dir) +(defun package-vc--unpack-1 (pkg-desc pkg-dir) "Install PKG-DESC that is already located in PKG-DIR." ;; In case the package was installed directly from source, the ;; dependency list wasn't know beforehand, and they might have @@ -384,13 +384,13 @@ The output is written out into PKG-FILE." (package-generate-autoloads name pkg-dir) ;; Generate package file - (package-vc-generate-description-file pkg-desc pkg-file) + (package-vc--generate-description-file pkg-desc pkg-file) ;; Detect a manual - (when-let ((pkg-spec (package-vc-desc->spec pkg-desc)) + (when-let ((pkg-spec (package-vc--desc->spec pkg-desc)) ((executable-find "install-info"))) (dolist (doc-file (ensure-list (plist-get pkg-spec :doc))) - (package-vc-build-documentation pkg-desc doc-file)))) + (package-vc--build-documentation pkg-desc doc-file)))) ;; Update package-alist. (let ((new-desc (package-load-descriptor pkg-dir))) @@ -414,7 +414,7 @@ The output is written out into PKG-FILE." package-selected-packages)) ;; Confirm that the installation was successful - (let ((main-file (package-vc-main-file pkg-desc))) + (let ((main-file (package-vc--main-file pkg-desc))) (message "Source package `%s' installed (Version %s, Revision %S)." (package-desc-name pkg-desc) (lm-with-file main-file @@ -424,14 +424,14 @@ The output is written out into PKG-FILE." (vc-working-revision main-file))) t) -(defun package-vc-guess-backend (url) +(defun package-vc--guess-backend (url) "Guess the VC backend for URL. This function will internally query `package-vc-heuristic-alist' and return nil if no reasonable guess can be made." (and url (alist-get url package-vc-heuristic-alist nil nil #'string-match-p))) -(defun package-vc-clone (pkg-desc pkg-spec dir rev) +(defun package-vc--clone (pkg-desc pkg-spec dir rev) "Clone the source of a package into a directory DIR. The package is described by a package descriptions PKG-DESC and a package specification PKG-SPEC." @@ -442,10 +442,10 @@ package specification PKG-SPEC." (unless (file-exists-p dir) (make-directory (file-name-directory dir) t) (let ((backend (or (plist-get pkg-spec :vc-backend) - (package-vc-query-spec pkg-desc :vc-backend) - (package-vc-guess-backend url) + (package-vc--query-spec pkg-desc :vc-backend) + (package-vc--guess-backend url) (plist-get (alist-get (package-desc-archive pkg-desc) - package-vc-archive-data-alist + package-vc--archive-data-alist nil nil #'string=) :vc-backend) package-vc-default-backend))) @@ -455,15 +455,15 @@ package specification PKG-SPEC." ;; Check out the latest release if requested (when (eq rev :last-release) - (if-let ((release-rev (package-vc-release-rev pkg-desc))) + (if-let ((release-rev (package-vc--release-rev pkg-desc))) (vc-retrieve-tag dir release-rev) (message "No release revision was found, continuing..."))))) -(defun package-vc-unpack (pkg-desc pkg-spec &optional rev) +(defun package-vc--unpack (pkg-desc pkg-spec &optional rev) "Install the package described by PKG-DESC. PKG-SPEC is a package specification is a property list describing how to fetch and build the package PKG-DESC. See -`package-vc-archive-spec-alist' for details. The optional argument +`package-vc--archive-spec-alist' for details. The optional argument REV specifies a specific revision to checkout. This overrides the `:brach' attribute in PKG-SPEC." (pcase-let* (((map :url :lisp-dir) pkg-spec) @@ -485,30 +485,30 @@ the `:brach' attribute in PKG-SPEC." (if (yes-or-no-p "Overwrite previous checkout?") (package--delete-directory pkg-dir pkg-desc) (error "There already exists a checkout for %s" name))) - (package-vc-clone pkg-desc pkg-spec real-dir rev) + (package-vc--clone pkg-desc pkg-spec real-dir rev) (unless (eq pkg-dir real-dir) ;; Link from the right position in `repo-dir' to the package ;; directory in the ELPA store. (make-symbolic-link (file-name-concat real-dir lisp-dir) pkg-dir)) - (package-vc-unpack-1 pkg-desc pkg-dir))) + (package-vc--unpack-1 pkg-desc pkg-dir))) -(defun package-vc-sourced-packages-list () +(defun package-vc--sourced-packages-list () "Generate a list of packages with VC data." (seq-filter (lambda (pkg) - (or (package-vc-desc->spec (cadr pkg)) + (or (package-vc--desc->spec (cadr pkg)) ;; If we have no explicit VC data, we can try a kind of ;; heuristic and use the URL header, that might already be ;; pointing towards a repository, and use that as a backup (and-let* ((extras (package-desc-extras (cadr pkg))) (url (alist-get :url extras)) - ((package-vc-guess-backend url)))))) + ((package-vc--guess-backend url)))))) package-archive-contents)) (defun package-vc-update (pkg-desc) "Attempt to update the packager PKG-DESC." - ;; HACK: To run `package-vc-unpack-1' after checking out the new + ;; HACK: To run `package-vc--unpack-1' after checking out the new ;; revision, we insert a hook into `vc-post-command-functions', and ;; remove it right after it ran. To avoid running the hook multiple ;; times or even for the wrong repository (as `vc-pull' is often @@ -517,7 +517,7 @@ the `:brach' attribute in PKG-SPEC." ;; side effect, and store them in the lexical scope. When the hook ;; is run, we check if the arguments are the same (`eq') as the ones ;; previously extracted, and only in that case will be call - ;; `package-vc-unpack-1'. Ugh... + ;; `package-vc--unpack-1'. Ugh... ;; ;; If there is a better way to do this, it should be done. (letrec ((pkg-dir (package-desc-dir pkg-desc)) @@ -535,7 +535,7 @@ the `:brach' attribute in PKG-SPEC." (memq (nth 1 args) (list file-or-list empty)) (memq (nth 2 args) (list flags empty))) (with-demoted-errors "Failed to activate: %S" - (package-vc-unpack-1 pkg-desc pkg-dir)) + (package-vc--unpack-1 pkg-desc pkg-dir)) (remove-hook 'vc-post-command-functions post-upgrade))))) (add-hook 'vc-post-command-functions post-upgrade) (with-demoted-errors "Failed to fetch: %S" @@ -544,13 +544,13 @@ the `:brach' attribute in PKG-SPEC." (defun package-vc--archives-initialize () "Initialise package.el and fetch package specifications." (package--archives-initialize) - (unless package-vc-archive-data-alist + (unless package-vc--archive-data-alist (package-vc--download-and-read-archives))) -(defun package-vc-release-rev (pkg-desc) +(defun package-vc--release-rev (pkg-desc) "Find the latest revision that bumps the \"Version\" tag for PKG-DESC. If no such revision can be found, return nil." - (with-current-buffer (find-file-noselect (package-vc-main-file pkg-desc)) + (with-current-buffer (find-file-noselect (package-vc--main-file pkg-desc)) (vc-buffer-sync) (save-excursion (goto-char (point-min)) @@ -583,13 +583,13 @@ archive is used. This can also be reproduced by passing the special value `:last-release' as REV. If a NAME-OR-URL is a URL, that is to say a string, the VC backend used to clone the repository can be set by BACKEND. If missing, -`package-vc-guess-backend' will be used." +`package-vc--guess-backend' will be used." (interactive (progn ;; Initialize the package system to get the list of package ;; symbols for completion. (package-vc--archives-initialize) - (let* ((packages (package-vc-sourced-packages-list)) + (let* ((packages (package-vc--sourced-packages-list)) (input (completing-read "Fetch package source (name or URL): " packages)) (name (file-name-base input))) @@ -598,22 +598,22 @@ repository can be set by BACKEND. If missing, (package-vc--archives-initialize) (cond ((and-let* (((stringp name-or-url)) - (backend (or backend (package-vc-guess-backend name-or-url)))) - (package-vc-unpack + (backend (or backend (package-vc--guess-backend name-or-url)))) + (package-vc--unpack (package-desc-create :name (or name (intern (file-name-base name-or-url))) :kind 'vc) (list :vc-backend backend :url name-or-url) rev))) ((and-let* ((desc (assoc name-or-url package-archive-contents #'string=))) - (package-vc-unpack + (package-vc--unpack (let ((copy (copy-package-desc (cadr desc)))) (setf (package-desc-kind copy) 'vc) copy) - (or (package-vc-desc->spec (cadr desc)) + (or (package-vc--desc->spec (cadr desc)) (and-let* ((extras (package-desc-extras (cadr desc))) (url (alist-get :url extras)) - (backend (package-vc-guess-backend url))) + (backend (package-vc--guess-backend url))) (list :vc-backend backend :url url)) (user-error "Package has no VC data")) rev))) @@ -631,7 +631,7 @@ special value `:last-release' as REV." ;; Initialize the package system to get the list of package ;; symbols for completion. (package-vc--archives-initialize) - (let* ((packages (package-vc-sourced-packages-list)) + (let* ((packages (package-vc--sourced-packages-list)) (input (completing-read "Fetch package source (name or URL): " packages))) (list (cadr (assoc input package-archive-contents #'string=)) @@ -640,13 +640,13 @@ special value `:last-release' as REV." (directory-empty-p dir)))) (and current-prefix-arg :last-release))))) (package-vc--archives-initialize) - (let ((pkg-spec (or (package-vc-desc->spec pkg-desc) + (let ((pkg-spec (or (package-vc--desc->spec pkg-desc) (and-let* ((extras (package-desc-extras pkg-desc)) (url (alist-get :url extras)) - (backend (package-vc-guess-backend url))) + (backend (package-vc--guess-backend url))) (list :vc-backend backend :url url)) (user-error "Package has no VC data")))) - (package-vc-clone pkg-desc pkg-spec directory rev) + (package-vc--clone pkg-desc pkg-spec directory rev) (find-file directory))) (defun package-vc-link-directory (dir name) @@ -665,17 +665,17 @@ from the base name of DIR." (let* ((name (or name (file-name-base (directory-file-name dir)))) (pkg-dir (expand-file-name name package-user-dir))) (make-symbolic-link dir pkg-dir) - (package-vc-unpack-1 (package-desc-create + (package-vc--unpack-1 (package-desc-create :name (intern name) :kind 'vc) pkg-dir))) (defun package-vc-refresh (pkg-desc) "Refresh the installation for PKG-DESC." - (interactive (package-vc-read-pkg "Refresh package: ")) - (package-vc-unpack-1 pkg-desc (package-desc-dir pkg-desc))) + (interactive (package-vc--read-pkg "Refresh package: ")) + (package-vc--unpack-1 pkg-desc (package-desc-dir pkg-desc))) -(defun package-vc-read-pkg (prompt) +(defun package-vc--read-pkg (prompt) "Query for a source package description with PROMPT." (cadr (assoc (completing-read prompt @@ -691,7 +691,7 @@ from the base name of DIR." SUBJECT and REVISIONS are used passed on to `vc-prepare-patch'. PKG must be a package description." (interactive - (list (package-vc-read-pkg "Package to prepare a patch for: ") + (list (package-vc--read-pkg "Package to prepare a patch for: ") (and (not vc-prepare-patches-separately) (read-string "Subject: " "[PATCH] " nil nil t)) (or (log-view-get-marked) commit 0e75099da83a9019bd35a37ecfad67fc4e0849e2 Author: Philip Kaludercic Date: Thu Nov 3 19:28:47 2022 +0100 * lisp/emacs-lisp/package-vc.el (package-vc-version): Use main file diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index dd23247974..faebd6ad6c 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -276,17 +276,13 @@ asynchronously." (defun package-vc-version (pkg) "Extract the commit of a development package PKG." (cl-assert (package-vc-p pkg)) - (cl-loop with dir = (package-desc-dir pkg) ;FIXME: dir is nil - for file in (sort (directory-files dir t "\\.el\\'") - (lambda (s1 s2) - (< (length s1) (length s2)))) - when (with-temp-buffer - (insert-file-contents file) - (package-strip-rcs-id - (or (lm-header "package-version") - (lm-header "version")))) - return it - finally return "0")) + (if-let ((main-file (package-vc-main-file pkg))) + (with-temp-buffer + (insert-file-contents main-file) + (package-strip-rcs-id + (or (lm-header "package-version") + (lm-header "version")))) + "0")) (defun package-vc-main-file (pkg-desc) "Return the main file for PKG-DESC." commit ec01d9a2092319a90fd95e068af689bd24fc255d Author: Philip Kaludercic Date: Thu Nov 3 19:26:21 2022 +0100 Add command 'package-vc-checkout' * doc/emacs/package.texi: Document feature. * etc/NEWS: Mention feature. * lisp/emacs-lisp/package-vc.el (package-vc-clone): Extract functionality out of 'package-vc-unpack'. (package-vc-unpack): Extract functionality out to 'package-vc-clone'. (package-vc-checkout): Add command. diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index db9705aaca..bd6d91a785 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -546,6 +546,7 @@ source. This often makes it easier to develop patches and report bugs. @findex package-vc-install +@findex package-vc-checkout One way to do this is to use @code{package-vc-install}, to fetch the source code for a package directly from source. The command will also automatically ensure that all files are byte-compiled and auto-loaded, @@ -553,7 +554,9 @@ just like with a regular package. Packages installed this way behave just like any other package. You can update them using @code{package-update} or @code{package-update-all} and delete them again using @code{package-delete}. They are even displayed in the -regular package listing. +regular package listing. If you just wish to clone the source of a +package, without adding it to the package list, use +@code{package-vc-checkout}. @findex package-report-bug @findex package-vc-prepare-patch diff --git a/etc/NEWS b/etc/NEWS index cbde7afecb..d808e7ab90 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1558,6 +1558,11 @@ repository. An existing checkout can now be loaded via package.el, by creating a symbolic link from the usual package directory to the checkout. ++++ +*** New command 'package-vc-checkout' +Used to fetch the source of a package by cloning a repository without +activating the package. + +++ *** New command 'package-vc-prepare-patch' This command allows you to send patches to package maintainers, for diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 1dc62d83a9..dd23247974 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -435,6 +435,34 @@ and return nil if no reasonable guess can be made." (and url (alist-get url package-vc-heuristic-alist nil nil #'string-match-p))) +(defun package-vc-clone (pkg-desc pkg-spec dir rev) + "Clone the source of a package into a directory DIR. +The package is described by a package descriptions PKG-DESC and a +package specification PKG-SPEC." + (pcase-let* ((name (package-desc-name pkg-desc)) + ((map :url :branch) pkg-spec)) + + ;; Clone the repository into `repo-dir' if necessary + (unless (file-exists-p dir) + (make-directory (file-name-directory dir) t) + (let ((backend (or (plist-get pkg-spec :vc-backend) + (package-vc-query-spec pkg-desc :vc-backend) + (package-vc-guess-backend url) + (plist-get (alist-get (package-desc-archive pkg-desc) + package-vc-archive-data-alist + nil nil #'string=) + :vc-backend) + package-vc-default-backend))) + (unless (vc-clone url backend dir + (or (and (not (eq rev :last-release)) rev) branch)) + (error "Failed to clone %s from %s" name url)))) + + ;; Check out the latest release if requested + (when (eq rev :last-release) + (if-let ((release-rev (package-vc-release-rev pkg-desc))) + (vc-retrieve-tag dir release-rev) + (message "No release revision was found, continuing..."))))) + (defun package-vc-unpack (pkg-desc pkg-spec &optional rev) "Install the package described by PKG-DESC. PKG-SPEC is a package specification is a property list describing @@ -442,52 +470,31 @@ how to fetch and build the package PKG-DESC. See `package-vc-archive-spec-alist' for details. The optional argument REV specifies a specific revision to checkout. This overrides the `:brach' attribute in PKG-SPEC." - (let* ((name (package-desc-name pkg-desc)) - (dirname (package-desc-full-name pkg-desc)) - (pkg-dir (expand-file-name dirname package-user-dir))) + (pcase-let* (((map :url :lisp-dir) pkg-spec) + (name (package-desc-name pkg-desc)) + (dirname (package-desc-full-name pkg-desc)) + (pkg-dir (expand-file-name dirname package-user-dir)) + (real-dir (if (null lisp-dir) + pkg-dir + (unless (file-exists-p package-vc-repository-store) + (make-directory package-vc-repository-store t)) + (file-name-concat + package-vc-repository-store + ;; FIXME: We aren't sure this directory + ;; will be unique, but we can try other + ;; names to avoid an unnecessary error. + (file-name-base url))))) (setf (package-desc-dir pkg-desc) pkg-dir) (when (file-exists-p pkg-dir) (if (yes-or-no-p "Overwrite previous checkout?") (package--delete-directory pkg-dir pkg-desc) (error "There already exists a checkout for %s" name))) - (pcase-let* (((map :url :branch :lisp-dir) pkg-spec) - (repo-dir - (if (null lisp-dir) - pkg-dir - (unless (file-exists-p package-vc-repository-store) - (make-directory package-vc-repository-store t)) - (file-name-concat - package-vc-repository-store - ;; FIXME: We aren't sure this directory - ;; will be unique, but we can try other - ;; names to avoid an unnecessary error. - (file-name-base url))))) - - ;; Clone the repository into `repo-dir' if necessary - (unless (file-exists-p repo-dir) - (make-directory (file-name-directory repo-dir) t) - (let ((backend (or (plist-get pkg-spec :vc-backend) - (package-vc-query-spec pkg-desc :vc-backend) - (package-vc-guess-backend url) - (plist-get (alist-get (package-desc-archive pkg-desc) - package-vc-archive-data-alist - nil nil #'string=) - :vc-backend) - package-vc-default-backend))) - (unless (vc-clone url backend repo-dir - (or (and (not (eq rev :last-release)) rev) branch)) - (error "Failed to clone %s from %s" name url)))) - - ;; Check out the latest release if requested - (when (eq rev :last-release) - (if-let ((release-rev (package-vc-release-rev pkg-desc))) - (vc-retrieve-tag pkg-dir release-rev) - (message "No release revision was found, continuing..."))) - - (unless (eq pkg-dir repo-dir) - ;; Link from the right position in `repo-dir' to the package - ;; directory in the ELPA store. - (make-symbolic-link (file-name-concat repo-dir lisp-dir) pkg-dir))) + (package-vc-clone pkg-desc pkg-spec real-dir rev) + (unless (eq pkg-dir real-dir) + ;; Link from the right position in `repo-dir' to the package + ;; directory in the ELPA store. + (make-symbolic-link (file-name-concat real-dir lisp-dir) pkg-dir)) + (package-vc-unpack-1 pkg-desc pkg-dir))) (defun package-vc-sourced-packages-list () @@ -616,6 +623,36 @@ repository can be set by BACKEND. If missing, rev))) ((user-error "Unknown package to fetch: %s" name-or-url)))) +(defun package-vc-checkout (pkg-desc directory &optional rev) + "Clone the sources for PKG-DESC into DIRECTORY. +An explicit revision can be requested by passing a string to the +optional argument REV. If the command is invoked with a prefix +argument, the revision used for the last release in the package +archive is used. This can also be reproduced by passing the +special value `:last-release' as REV." + (interactive + (progn + ;; Initialize the package system to get the list of package + ;; symbols for completion. + (package-vc--archives-initialize) + (let* ((packages (package-vc-sourced-packages-list)) + (input (completing-read + "Fetch package source (name or URL): " packages))) + (list (cadr (assoc input package-archive-contents #'string=)) + (read-file-name "Clone into new or empty directory: " nil nil t nil + (lambda (dir) (or (not (file-exists-p dir)) + (directory-empty-p dir)))) + (and current-prefix-arg :last-release))))) + (package-vc--archives-initialize) + (let ((pkg-spec (or (package-vc-desc->spec pkg-desc) + (and-let* ((extras (package-desc-extras pkg-desc)) + (url (alist-get :url extras)) + (backend (package-vc-guess-backend url))) + (list :vc-backend backend :url url)) + (user-error "Package has no VC data")))) + (package-vc-clone pkg-desc pkg-spec directory rev) + (find-file directory))) + (defun package-vc-link-directory (dir name) "Install the package NAME in DIR by linking it into the ELPA directory. If invoked interactively with a prefix argument, the user will be commit 7705b66ed3a63cece4ae6ce78af00e581ddda43e Author: Philip Kaludercic Date: Wed Nov 2 17:16:39 2022 +0100 ; Update TODO section diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 74f1c35ea6..1dc62d83a9 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -26,16 +26,8 @@ ;;; TODO: -;; - Allow for automatic updating -;; * Detect merge conflicts -;; * Check if there are upstream changes -;; - Allow for ELPA specifications to be respected without -;; endangering the user with arbitrary code execution ;; - Allow maintaining patches that are ported back onto regular ;; packages and maintained between versions. -;; - Allow locking the specific revisions of sourced packages -;; (comparable to `package-selected-packages') so that specific -;; revisions can be re-installed. ;;; Code: commit 57708df032d1c24cedaab68e705ea818dacdcd3f Author: Philip Kaludercic Date: Wed Nov 2 13:58:14 2022 +0100 ; Handle case that was forgotten in the last commit diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 4593ae7d1b..27324f2b9b 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1819,7 +1819,7 @@ similar to an entry in `package-alist'. Save the cached copy to (when good-sigs (write-region (mapconcat #'epg-signature-to-string good-sigs "\n") nil (concat local-file ".signed") nil 'silent))) - (lambda () (package--update-downloads-in-progress archive)))))))) + (lambda () (package--update-downloads-in-progress (cons archive file))))))))) (defun package--download-and-read-archives (&optional async) "Download descriptions of all `package-archives' and read them. commit b5dfd1dfe1147aa3bcceb8a2bc40f358aa1f29a4 Author: Philip Kaludercic Date: Wed Nov 2 11:56:42 2022 +0100 Track file name in 'package--downloads-in-progress' * lisp/emacs-lisp/package.el (package--download-one-archive): Move 'cl-pushnew' call from 'package--download-one-archive' and cons file name onto the archive. (package--download-one-archive): Cons the file name onto the archive. (package--download-and-read-archives): Remove 'cl-pushnew' call. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index ae3a1b7b83..4593ae7d1b 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1783,9 +1783,14 @@ Once it's empty, run `package--post-download-archives-hook'." ARCHIVE should be a cons cell of the form (NAME . LOCATION), similar to an entry in `package-alist'. Save the cached copy to \"archives/NAME/FILE\" in `package-user-dir'." + ;; The downloaded archive contents will be read as part of + ;; `package--update-downloads-in-progress'. + (dolist (archive package-archives) + (cl-pushnew (cons archive file) package--downloads-in-progress + :test #'equal)) (package--with-response-buffer (cdr archive) :file file :async async - :error-form (package--update-downloads-in-progress archive) + :error-form (package--update-downloads-in-progress (cons archive file)) (let* ((location (cdr archive)) (name (car archive)) (content (buffer-string)) @@ -1798,10 +1803,10 @@ similar to an entry in `package-alist'. Save the cached copy to ;; If we don't care about the signature, save the file and ;; we're done. (progn - (cl-assert (not enable-multibyte-characters)) - (let ((coding-system-for-write 'binary)) - (write-region content nil local-file nil 'silent)) - (package--update-downloads-in-progress archive)) + (cl-assert (not enable-multibyte-characters)) + (let ((coding-system-for-write 'binary)) + (write-region content nil local-file nil 'silent)) + (package--update-downloads-in-progress (cons archive file))) ;; If we care, check it (perhaps async) and *then* write the file. (package--check-signature location file content async @@ -1822,11 +1827,6 @@ Populate `package-archive-contents' with the result. If optional argument ASYNC is non-nil, perform the downloads asynchronously." - ;; The downloaded archive contents will be read as part of - ;; `package--update-downloads-in-progress'. - (dolist (archive package-archives) - (cl-pushnew archive package--downloads-in-progress - :test #'equal)) (dolist (archive package-archives) (condition-case-unless-debug nil (package--download-one-archive archive "archive-contents" async) commit b21f80bbb971d5e5193c04823536265ecd2ca8e8 Author: Philip Kaludercic Date: Wed Nov 2 10:15:28 2022 +0100 ; Replace 'let*' with 'let' where possible * lisp/emacs-lisp/package-vc.el (package-vc--select-packages): Do it. (package-vc--read-archive-data): Do it. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 6134e6ed3d..74f1c35ea6 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -116,7 +116,7 @@ symbol is used. The value must be a member of It will ensure that all the packages are installed as source packages. Finally SYM is set to VAL." (pcase-dolist (`(,(and (pred symbolp) name) . ,spec) val) - (let* ((pkg-desc (cadr (assoc name package-alist #'string=)))) + (let ((pkg-desc (cadr (assoc name package-alist #'string=)))) (unless (and name (package-installed-p name) (package-vc-p pkg-desc)) (cond ((null spec) @@ -232,9 +232,9 @@ return nil." "Update `package-vc-archive-spec-alist' with the contents of ARCHIVE. This function is meant to be used as a hook for `package--read-archive-hook'." - (let* ((contents-file (expand-file-name - (format "archives/%s/elpa-packages.eld" archive) - package-user-dir))) + (let ((contents-file (expand-file-name + (format "archives/%s/elpa-packages.eld" archive) + package-user-dir))) (when (file-exists-p contents-file) (with-temp-buffer (let ((coding-system-for-read 'utf-8)) commit bbe5a1ca8374a078fe8a77dec0692b75e1b9efbc Author: Philip Kaludercic Date: Tue Nov 1 16:35:23 2022 +0100 Ensure 'package-vc-update' runs 'package-vc-unpack-1' only once * lisp/emacs-lisp/package-vc.el (package-vc-update): Use 'vc-sourced-packages-list' and other hacks. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index d475010eaa..6134e6ed3d 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -513,17 +513,38 @@ the `:brach' attribute in PKG-SPEC." (defun package-vc-update (pkg-desc) "Attempt to update the packager PKG-DESC." - (let* ((default-directory (package-desc-dir pkg-desc)) - (ret (with-demoted-errors "Error during package update: %S" - (vc-pull))) - (buf (cond - ((processp ret) (process-buffer ret)) - ((bufferp ret) ret)))) - (if buf - (with-current-buffer buf - (vc-run-delayed - (package-vc-unpack-1 pkg-desc default-directory))) - (package-vc-unpack-1 pkg-desc default-directory)))) + ;; HACK: To run `package-vc-unpack-1' after checking out the new + ;; revision, we insert a hook into `vc-post-command-functions', and + ;; remove it right after it ran. To avoid running the hook multiple + ;; times or even for the wrong repository (as `vc-pull' is often + ;; asynchronous), we extract the relevant arguments using a pseudo + ;; filter for `vc-filter-command-function', executed only for the + ;; side effect, and store them in the lexical scope. When the hook + ;; is run, we check if the arguments are the same (`eq') as the ones + ;; previously extracted, and only in that case will be call + ;; `package-vc-unpack-1'. Ugh... + ;; + ;; If there is a better way to do this, it should be done. + (letrec ((pkg-dir (package-desc-dir pkg-desc)) + (empty (make-symbol empty)) + (args (list empty empty empty)) + (vc-filter-command-function + (lambda (command file-or-list flags) + (setf (nth 0 args) command + (nth 1 args) file-or-list + (nth 2 args) flags) + (list command file-or-list flags))) + (post-upgrade + (lambda (command file-or-list flags) + (when (and (memq (nth 0 args) (list command empty)) + (memq (nth 1 args) (list file-or-list empty)) + (memq (nth 2 args) (list flags empty))) + (with-demoted-errors "Failed to activate: %S" + (package-vc-unpack-1 pkg-desc pkg-dir)) + (remove-hook 'vc-post-command-functions post-upgrade))))) + (add-hook 'vc-post-command-functions post-upgrade) + (with-demoted-errors "Failed to fetch: %S" + (vc-pull)))) (defun package-vc--archives-initialize () "Initialise package.el and fetch package specifications." commit 17b017d55c49b7218a52bea3b6ddcd1705024bbe Author: Philip Kaludercic Date: Mon Oct 31 10:51:40 2022 +0100 ; Avoid loading package-vc in 'package-load-descriptor' * lisp/emacs-lisp/package.el (package-load-descriptor): Remove the :commit check. The property is mostly unused anyway, and this unnecessarily slows down initialisation if a package is installed from source. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 977a16a7e1..ae3a1b7b83 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -726,10 +726,6 @@ return it." (read (current-buffer))) (error "Can't find define-package in %s" pkg-file)))) (setf (package-desc-dir pkg-desc) pkg-dir) - (when (package-vc-p pkg-desc) - (require 'package-vc) - (push (cons :commit (package-vc-commit pkg-desc)) - (package-desc-extras pkg-desc))) (if (file-exists-p signed-file) (setf (package-desc-signed pkg-desc) t)) pkg-desc))))) commit 462a66e79edcc34ecbeef7cc1604765adfdc038e Author: Philip Kaludercic Date: Mon Oct 31 09:59:48 2022 +0100 ; Actually check if NAME-OR-URL is a string * lisp/emacs-lisp/package-vc.el (package-vc-install): Use stringp as predicate instead of binding it as a variable. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 77a9e9e11c..d475010eaa 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -581,7 +581,7 @@ repository can be set by BACKEND. If missing, (and current-prefix-arg :last-release))))) (package-vc--archives-initialize) (cond - ((and-let* ((stringp name-or-url) + ((and-let* (((stringp name-or-url)) (backend (or backend (package-vc-guess-backend name-or-url)))) (package-vc-unpack (package-desc-create commit c2088c0849dad7a3ba36d7a2137389713160f450 Author: Philip Kaludercic Date: Mon Oct 31 09:58:37 2022 +0100 Allow specifying and pinning source packages to be installed * lisp/emacs-lisp/package-vc.el (package-vc--select-packages): Add custom setter for 'package-vc-selected-packages'. (package-vc-selected-packages): Add user option. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index fefb560276..77a9e9e11c 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -111,6 +111,51 @@ symbol is used. The value must be a member of vc-handled-backends)) :version "29.1") +(defun package-vc--select-packages (sym val) + "Custom setter for `package-vc-selected-packages'. +It will ensure that all the packages are installed as source +packages. Finally SYM is set to VAL." + (pcase-dolist (`(,(and (pred symbolp) name) . ,spec) val) + (let* ((pkg-desc (cadr (assoc name package-alist #'string=)))) + (unless (and name (package-installed-p name) (package-vc-p pkg-desc)) + (cond + ((null spec) + (package-vc-install name)) + ((stringp spec) + (package-vc-install name nil spec)) + ((listp spec) + (package-vc--archives-initialize) + (package-vc-unpack pkg-desc spec)))))) + (custom-set-default sym val)) + +;;;###autoload +(defcustom package-vc-selected-packages '() + "List of packages to ensure being installed. +Each entry of the list is of the form (NAME . SPEC), where NAME +is a symbol designating the package and SPEC is one of: + +- the value nil, if any package version is to be installed, +- a string, if a specific revision, as designating by the string + is to be installed, +- a property list of the form described in + `package-vc-archive-spec-alist', giving a package + specification. + +This user option differs from `package-selected-packages' in that +it is meant to be specified manually." + :type '(alist :tag "List of ensured packages" + :key-type (symbol :tag "Package") + :value-type + (choice (const :tag "Any revision" nil) + (string :tag "Specific revision") + (plist :options ((:url string) + (:branch string) + (:lisp-dir string) + (:main-file string) + (:vc-backend symbol))))) + :set #'package-vc--select-packages + :version "29.1") + (defvar package-vc-archive-spec-alist nil "List of package specifications for each archive. The list maps package names as string to plist. Valid keys commit 8e7bb5bb87c61b891a1a65c6c4ee4b459bc46520 Author: Philip Kaludercic Date: Sun Oct 30 21:12:48 2022 +0100 ; Update TODO section diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 52e7e25e9f..fefb560276 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -29,9 +29,6 @@ ;; - Allow for automatic updating ;; * Detect merge conflicts ;; * Check if there are upstream changes -;; - Allow finding revisions that bump the version tag -;; * Allow for `package-vc-install' to use the version -;; of the package if already installed. ;; - Allow for ELPA specifications to be respected without ;; endangering the user with arbitrary code execution ;; - Allow maintaining patches that are ported back onto regular commit 2a4f37fe520b4f18295cff6671f289a47c1578df Merge: d33998ed3b 3fa4cca3d2 Author: Philip Kaludercic Date: Sun Oct 30 18:45:37 2022 +0100 Merge remote-tracking branch 'origin/master' into feature/package+vc commit d33998ed3b5e05a40b9c4c1799b6e911b582ef01 Author: Philip Kaludercic Date: Sun Oct 30 16:52:08 2022 +0100 Have 'last-change' accept a line number instead of a range * lisp/emacs-lisp/package-vc.el (package-vc-release-rev): Use new signature. * lisp/vc/vc-git.el (vc-git-last-change): Update signature * lisp/vc/vc.el (vc-default-last-change): Update signature and use 'annotate-command'. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index c3f54c1be8..52e7e25e9f 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -507,8 +507,8 @@ If no such revision can be found, return nil." (ignore-error vc-not-supported (vc-call-backend (vc-backend (buffer-file-name)) 'last-change - (match-beginning 0) - (match-end 0)))))))) + (buffer-file-name) + (line-number-at-pos nil t)))))))) ;;;###autoload (defun package-vc-install (name-or-url &optional name rev backend) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index cd62effd08..376892c720 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1632,17 +1632,13 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (expand-file-name fname (vc-git-root default-directory)))) revision))))) -(defun vc-git-last-change (from to) +(defun vc-git-last-change (file line) (vc-buffer-sync) - (let ((file (file-relative-name - (buffer-file-name) - (vc-git-root (buffer-file-name)))) - (start (line-number-at-pos from t)) - (end (line-number-at-pos to t))) + (let ((file (file-relative-name file (vc-git-root (buffer-file-name))))) (with-temp-buffer (when (vc-git--out-ok "blame" "--porcelain" - (format "-L%d,%d" start end) + (format "-L%d,+1" line) file) (goto-char (point-min)) (save-match-data diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index c8d28c144b..d655a1c625 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -449,10 +449,10 @@ ;; ;; Return the common ancestor between REV1 and REV2 revisions. ;; -;; - last-change (from to) +;; - last-change (file line) ;; -;; Return the most recent revision that made a change between FROM -;; and TO. +;; Return the most recent revision of FILE that made a change +;; on LINE. ;; TAG/BRANCH SYSTEM ;; @@ -3590,17 +3590,20 @@ it indicates a specific revision to check out." (throw 'ok res))))))) (declare-function log-view-current-tag "log-view" (&optional pos)) -(defun vc-default-last-change (_backend from to) +(defun vc-default-last-change (_backend file line) "Default `last-change' implementation. -FROM and TO are used as region markers" - (save-window-excursion - (let* ((buf (window-buffer (vc-region-history from to))) - (proc (get-buffer-process buf))) - (cl-assert (processp proc)) - (while (accept-process-output proc)) - (with-current-buffer buf - (prog1 (log-view-current-tag) - (kill-buffer)))))) +It returns the last revision that changed LINE number in FILE." + (unless (file-exists-p file) + (signal 'file-error "File doesn't exist")) + (with-temp-buffer + (vc-call-backend (vc-backend file) 'annotate-command + file (current-buffer)) + (goto-char (point-min)) + (forward-line (1- line)) + (let ((rev (vc-call-backend + (vc-backend file) + 'annotate-extract-revision-at-line))) + (if (consp rev) (car rev) rev)))) commit bb86ed20e16358b39288010d41d911f732f88372 Author: Philip Kaludercic Date: Sun Oct 30 14:50:09 2022 +0100 Display a message after installing source packages * lisp/emacs-lisp/package-vc.el (package-vc-unpack-1): Print message and return t. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 608d06d426..c3f54c1be8 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -381,7 +381,18 @@ The output is written out into PKG-FILE." ;; Mark package as selected (package--save-selected-packages (cons (package-desc-name pkg-desc) - package-selected-packages))) + package-selected-packages)) + + ;; Confirm that the installation was successful + (let ((main-file (package-vc-main-file pkg-desc))) + (message "Source package `%s' installed (Version %s, Revision %S)." + (package-desc-name pkg-desc) + (lm-with-file main-file + (package-strip-rcs-id + (or (lm-header "package-version") + (lm-header "version")))) + (vc-working-revision main-file))) + t) (defun package-vc-guess-backend (url) "Guess the VC backend for URL. commit ec3f102b8cc6f7010a13f247d1eca2178ba04987 Author: Philip Kaludercic Date: Sun Oct 30 14:43:10 2022 +0100 Prefer "Package-Version" over "Version" if available * lisp/emacs-lisp/package-vc.el (package-vc-release-rev): Search for both in sequence. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index ab1bffdd21..608d06d426 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -486,8 +486,13 @@ If no such revision can be found, return nil." (save-excursion (goto-char (point-min)) (let ((case-fold-search t)) - (when (re-search-forward (concat (lm-get-header-re "version") ".*$") - (lm-code-start) t) + (when (cond + ((re-search-forward + (concat (lm-get-header-re "package-version") ".*$") + (lm-code-start) t)) + ((re-search-forward + (concat (lm-get-header-re "version") ".*$") + (lm-code-start) t))) (ignore-error vc-not-supported (vc-call-backend (vc-backend (buffer-file-name)) 'last-change commit 8b49d553b655ea589c80ac1de955e9c4d65627d3 Author: Philip Kaludercic Date: Sun Oct 30 14:07:56 2022 +0100 ; Avoid a type error on malformed "elpa-packages.eld" input * lisp/emacs-lisp/package-vc.el: Use 'eq' instead of '=' diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 6597989777..ab1bffdd21 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -203,8 +203,8 @@ This function is meant to be used as a hook for ;; :version 1 ;; :default-vc Git) (let ((spec (read (current-buffer)))) - (when (= package-vc-elpa-packages-version - (plist-get (cdr spec) :version)) + (when (eq package-vc-elpa-packages-version + (plist-get (cdr spec) :version)) (setf (alist-get (intern archive) package-vc-archive-spec-alist) (car spec))) (setf (alist-get (intern archive) package-vc-archive-data-alist) commit 30f1e7c1e93dda496412f76f70b2f49b30407b11 Author: Philip Kaludercic Date: Sun Oct 30 11:43:11 2022 +0100 Extract last source package release from local VCS data * lisp/emacs-lisp/package-vc.el (package-vc-archive-spec-alist): Unmention :release-rev (package-vc-desc->spec): Fall back on other archives if a specification is missing. (package-vc-main-file): Add new function, copying the behaviour of elpa-admin.el. (package-vc-generate-description-file): Use 'package-vc-main-file'. (package-vc-unpack): Handle special value ':last-release'. (package-vc-release-rev): Add new function using 'last-change'. (package-vc-install): Pass ':last-release' as REV instead of a release. * lisp/vc/vc-git.el (vc-git-last-change): Add Git 'last-change' implementation. * lisp/vc/vc.el (vc-default-last-change): Add default 'last-change' implementation. This attempts to replicate the behaviour of elpa-admin.el's "elpaa--get-last-release-commit". diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 3816c6152d..6597989777 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -139,12 +139,6 @@ The main file of the project, relevant to gather package metadata. If not given, the assumed default is the package named with \".el\" concatenated to the end. - `:release-rev' (string) - -A revision string indicating the revision used for the current -release in the package archive. If missing or nil, no release -was made. - `:vc-backend' (symbol) A symbol indicating what the VC backend to use for cloning a @@ -179,8 +173,10 @@ The optional argument NAME can be used to override the default name for PKG-DESC." (alist-get (or name (package-desc-name pkg-desc)) - (alist-get (intern (package-desc-archive pkg-desc)) - package-vc-archive-spec-alist) + (if (package-desc-archive pkg-desc) + (alist-get (intern (package-desc-archive pkg-desc)) + package-vc-archive-spec-alist) + (mapcan #'append (mapcar #'cdr package-vc-archive-spec-alist))) nil nil #'string=)) (define-inline package-vc-query-spec (pkg-desc prop) @@ -258,6 +254,20 @@ asynchronously." return it finally return "0")) +(defun package-vc-main-file (pkg-desc) + "Return the main file for PKG-DESC." + (cl-assert (package-vc-p pkg-desc)) + (let ((pkg-spec (package-vc-desc->spec pkg-desc))) + (or (plist-get pkg-spec :main-file) + (expand-file-name + (format "%s.el" (package-desc-name pkg-desc)) + (file-name-concat + (or (package-desc-dir pkg-desc) + (expand-file-name + (package-desc-name pkg-desc) + package-user-dir)) + (plist-get pkg-spec :lisp-dir)))))) + (defun package-vc-generate-description-file (pkg-desc pkg-file) "Generate a package description file for PKG-DESC. The output is written out into PKG-FILE." @@ -265,18 +275,13 @@ The output is written out into PKG-FILE." ;; Infer the subject if missing. (unless (package-desc-summary pkg-desc) (setf (package-desc-summary pkg-desc) - (or (package-desc-summary pkg-desc) - (and-let* ((pkg (cadr (assq name package-archive-contents)))) - (package-desc-summary pkg)) - (and-let* ((pkg-spec (package-vc-desc->spec pkg-desc)) - (main-file (plist-get pkg-spec :main-file))) - (lm-summary main-file)) - (and-let* ((main-file (expand-file-name - (format "%s.el" name) - (package-desc-dir pkg-desc))) - ((file-exists-p main-file))) - (lm-summary main-file)) - package--default-summary))) + (let ((main-file (package-vc-main-file pkg-desc))) + (or (package-desc-summary pkg-desc) + (and-let* ((pkg (cadr (assq name package-archive-contents)))) + (package-desc-summary pkg)) + (and main-file (file-exists-p main-file) + (lm-summary main-file)) + package--default-summary)))) (let ((print-level nil) (print-quoted t) (print-length nil)) @@ -424,9 +429,16 @@ the `:brach' attribute in PKG-SPEC." nil nil #'string=) :vc-backend) package-vc-default-backend))) - (unless (vc-clone url backend repo-dir (or rev branch)) + (unless (vc-clone url backend repo-dir + (or (and (not (eq rev :last-release)) rev) branch)) (error "Failed to clone %s from %s" name url)))) + ;; Check out the latest release if requested + (when (eq rev :last-release) + (if-let ((release-rev (package-vc-release-rev pkg-desc))) + (vc-retrieve-tag pkg-dir release-rev) + (message "No release revision was found, continuing..."))) + (unless (eq pkg-dir repo-dir) ;; Link from the right position in `repo-dir' to the package ;; directory in the ELPA store. @@ -466,6 +478,22 @@ the `:brach' attribute in PKG-SPEC." (unless package-vc-archive-data-alist (package-vc--download-and-read-archives))) +(defun package-vc-release-rev (pkg-desc) + "Find the latest revision that bumps the \"Version\" tag for PKG-DESC. +If no such revision can be found, return nil." + (with-current-buffer (find-file-noselect (package-vc-main-file pkg-desc)) + (vc-buffer-sync) + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t)) + (when (re-search-forward (concat (lm-get-header-re "version") ".*$") + (lm-code-start) t) + (ignore-error vc-not-supported + (vc-call-backend (vc-backend (buffer-file-name)) + 'last-change + (match-beginning 0) + (match-end 0)))))))) + ;;;###autoload (defun package-vc-install (name-or-url &optional name rev backend) "Fetch the source of NAME-OR-URL. @@ -477,9 +505,11 @@ NAME-OR-URL is taken to be a package name, and the package metadata will be consulted for the URL. An explicit revision can be requested using REV. If the command is invoked with a prefix argument, the revision used for the last release in the package -archive is used. If a NAME-OR-URL is a URL, that is to say a -string, the VC backend used to clone the repository can be set by -BACKEND. If missing, `package-vc-guess-backend' will be used." +archive is used. This can also be reproduced by passing the +special value `:last-release' as REV. If a NAME-OR-URL is a URL, +that is to say a string, the VC backend used to clone the +repository can be set by BACKEND. If missing, +`package-vc-guess-backend' will be used." (interactive (progn ;; Initialize the package system to get the list of package @@ -490,11 +520,7 @@ BACKEND. If missing, `package-vc-guess-backend' will be used." "Fetch package source (name or URL): " packages)) (name (file-name-base input))) (list input (intern (string-remove-prefix "emacs-" name)) - (and current-prefix-arg - (or (package-vc-query-spec - (cadr (assoc input package-archive-contents #'string=)) - :release-rev) - (user-error "No release revision was found"))))))) + (and current-prefix-arg :last-release))))) (package-vc--archives-initialize) (cond ((and-let* ((stringp name-or-url) @@ -511,6 +537,10 @@ BACKEND. If missing, `package-vc-guess-backend' will be used." (setf (package-desc-kind copy) 'vc) copy) (or (package-vc-desc->spec (cadr desc)) + (and-let* ((extras (package-desc-extras (cadr desc))) + (url (alist-get :url extras)) + (backend (package-vc-guess-backend url))) + (list :vc-backend backend :url url)) (user-error "Package has no VC data")) rev))) ((user-error "Unknown package to fetch: %s" name-or-url)))) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 6137ce75ce..cd62effd08 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1632,6 +1632,23 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (expand-file-name fname (vc-git-root default-directory)))) revision))))) +(defun vc-git-last-change (from to) + (vc-buffer-sync) + (let ((file (file-relative-name + (buffer-file-name) + (vc-git-root (buffer-file-name)))) + (start (line-number-at-pos from t)) + (end (line-number-at-pos to t))) + (with-temp-buffer + (when (vc-git--out-ok + "blame" "--porcelain" + (format "-L%d,%d" start end) + file) + (goto-char (point-min)) + (save-match-data + (when (looking-at "\\`\\([[:alnum:]]+\\)[[:space:]]+") + (match-string 1))))))) + ;;; TAG/BRANCH SYSTEM (declare-function vc-read-revision "vc" diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 38209ef39e..c8d28c144b 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -448,6 +448,11 @@ ;; - mergebase (rev1 &optional rev2) ;; ;; Return the common ancestor between REV1 and REV2 revisions. +;; +;; - last-change (from to) +;; +;; Return the most recent revision that made a change between FROM +;; and TO. ;; TAG/BRANCH SYSTEM ;; @@ -3584,6 +3589,19 @@ it indicates a specific revision to check out." remote directory rev))) (throw 'ok res))))))) +(declare-function log-view-current-tag "log-view" (&optional pos)) +(defun vc-default-last-change (_backend from to) + "Default `last-change' implementation. +FROM and TO are used as region markers" + (save-window-excursion + (let* ((buf (window-buffer (vc-region-history from to))) + (proc (get-buffer-process buf))) + (cl-assert (processp proc)) + (while (accept-process-output proc)) + (with-current-buffer buf + (prog1 (log-view-current-tag) + (kill-buffer)))))) + ;; These things should probably be generally available commit a52cec7b6b89785ee5321ed67d096db7ce42ce9c Author: Philip Kaludercic Date: Fri Oct 28 20:13:28 2022 +0200 Explicitly handle :vc-backend in a package specification * lisp/emacs-lisp/package-vc.el (package-vc-archive-spec-alist): Document the feature. (package-vc-unpack): Check for :vc-backend in both PKG-SPEC and the archive specification data. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 5d8b2be8e9..3816c6152d 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -145,6 +145,13 @@ A revision string indicating the revision used for the current release in the package archive. If missing or nil, no release was made. + `:vc-backend' (symbol) + +A symbol indicating what the VC backend to use for cloning a +package. The value ought to be a member of +`vc-handled-backends'. If missing, `vc-clone' will fall back +onto the archive default or `package-vc-default-backend'. + All other values are ignored.") (defvar package-vc-archive-data-alist nil @@ -409,7 +416,9 @@ the `:brach' attribute in PKG-SPEC." ;; Clone the repository into `repo-dir' if necessary (unless (file-exists-p repo-dir) (make-directory (file-name-directory repo-dir) t) - (let ((backend (or (package-vc-guess-backend url) + (let ((backend (or (plist-get pkg-spec :vc-backend) + (package-vc-query-spec pkg-desc :vc-backend) + (package-vc-guess-backend url) (plist-get (alist-get (package-desc-archive pkg-desc) package-vc-archive-data-alist nil nil #'string=) commit 40977816550276aac0de75b6740fb4856e9a438b Author: Philip Kaludercic Date: Fri Oct 28 20:10:30 2022 +0200 Ensure that package specifications are always fetched * lisp/emacs-lisp/package-vc.el (package-vc--archives-initialize): Add new function, extending 'package--archives-initialize'. (package-vc-install): Use new function. (package-vc-link-directory): Use new function. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index a3e7e68d5b..5d8b2be8e9 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -451,6 +451,12 @@ the `:brach' attribute in PKG-SPEC." (package-vc-unpack-1 pkg-desc default-directory))) (package-vc-unpack-1 pkg-desc default-directory)))) +(defun package-vc--archives-initialize () + "Initialise package.el and fetch package specifications." + (package--archives-initialize) + (unless package-vc-archive-data-alist + (package-vc--download-and-read-archives))) + ;;;###autoload (defun package-vc-install (name-or-url &optional name rev backend) "Fetch the source of NAME-OR-URL. @@ -469,7 +475,7 @@ BACKEND. If missing, `package-vc-guess-backend' will be used." (progn ;; Initialize the package system to get the list of package ;; symbols for completion. - (package--archives-initialize) + (package-vc--archives-initialize) (let* ((packages (package-vc-sourced-packages-list)) (input (completing-read "Fetch package source (name or URL): " packages)) @@ -480,7 +486,7 @@ BACKEND. If missing, `package-vc-guess-backend' will be used." (cadr (assoc input package-archive-contents #'string=)) :release-rev) (user-error "No release revision was found"))))))) - (package--archives-initialize) + (package-vc--archives-initialize) (cond ((and-let* ((stringp name-or-url) (backend (or backend (package-vc-guess-backend name-or-url)))) @@ -512,7 +518,7 @@ from the base name of DIR." (file-name-base (directory-file-name dir)))))) (unless (vc-responsible-backend dir) (user-error "Directory %S is not under version control" dir)) - (package--archives-initialize) + (package-vc--archives-initialize) (let* ((name (or name (file-name-base (directory-file-name dir)))) (pkg-dir (expand-file-name name package-user-dir))) (make-symbolic-link dir pkg-dir) commit 60b3eb07542ce7b9f094b40d174c07b1393d2835 Author: Philip Kaludercic Date: Fri Oct 28 20:01:48 2022 +0200 Allow specifying the VC backend used by 'package-vc-install' * lisp/emacs-lisp/package-vc.el (package-vc-install): Add argument BACKEND. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 23249fd59c..a3e7e68d5b 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -452,7 +452,7 @@ the `:brach' attribute in PKG-SPEC." (package-vc-unpack-1 pkg-desc default-directory)))) ;;;###autoload -(defun package-vc-install (name-or-url &optional name rev) +(defun package-vc-install (name-or-url &optional name rev backend) "Fetch the source of NAME-OR-URL. If NAME-OR-URL is a URL, then the package will be downloaded from the repository indicated by the URL. The function will try to @@ -462,7 +462,9 @@ NAME-OR-URL is taken to be a package name, and the package metadata will be consulted for the URL. An explicit revision can be requested using REV. If the command is invoked with a prefix argument, the revision used for the last release in the package -archive is used." +archive is used. If a NAME-OR-URL is a URL, that is to say a +string, the VC backend used to clone the repository can be set by +BACKEND. If missing, `package-vc-guess-backend' will be used." (interactive (progn ;; Initialize the package system to get the list of package @@ -481,7 +483,7 @@ archive is used." (package--archives-initialize) (cond ((and-let* ((stringp name-or-url) - (backend (package-vc-guess-backend name-or-url))) + (backend (or backend (package-vc-guess-backend name-or-url)))) (package-vc-unpack (package-desc-create :name (or name (intern (file-name-base name-or-url))) commit a00ec87c0b1cdc2b156b2a36ad3c9908b7fbe5c6 Author: Philip Kaludercic Date: Fri Oct 28 19:58:05 2022 +0200 Update handling for new elpa-packages.eld format * lisp/emacs-lisp/package-vc.el (package-vc-elpa-packages-version): Add constant. (package-vc-archive-data-alist): Add variable. (package-vc--read-archive-data): Separate package specifications from metadata. (package-vc-unpack): Check archive metadata. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 8e4f2819db..23249fd59c 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -56,6 +56,9 @@ :group 'package :version "29.1") +(defconst package-vc-elpa-packages-version 1 + "Version number of the package specification format understood by package-vc.") + (defcustom package-vc-heuristic-alist `((,(rx bos "http" (? "s") "://" (or (: (? "www.") "github.com" @@ -144,6 +147,25 @@ was made. All other values are ignored.") +(defvar package-vc-archive-data-alist nil + "List of package specification archive metadata. +Each element of the list has the form (ARCHIVE . PLIST), where +PLIST keys are one of: + + `:version' (integer) + +Indicating the version of the file formatting, to be compared +with `package-vc-elpa-packages-version'. + + `:vc-backend' (symbol) + +A symbol indicating what the default VC backend to use if a +package specification does not indicate anything. The value +ought to be a member of `vc-handled-backends'. If missing, +`vc-clone' will fall back onto `package-vc-default-backend'. + +All other values are ignored.") + (defun package-vc-desc->spec (pkg-desc &optional name) "Retrieve the package specification for PKG-DESC. The optional argument NAME can be used to override the default @@ -171,9 +193,23 @@ This function is meant to be used as a hook for (when (file-exists-p contents-file) (with-temp-buffer (let ((coding-system-for-read 'utf-8)) - (insert-file-contents contents-file)) - (setf (alist-get (intern archive) package-vc-archive-spec-alist) - (read (current-buffer))))))) + (insert-file-contents contents-file) + ;; The response from the server is expected to have the form + ;; + ;; ((("foo" :url "..." ...) ...) + ;; :version 1 + ;; :default-vc Git) + (let ((spec (read (current-buffer)))) + (when (= package-vc-elpa-packages-version + (plist-get (cdr spec) :version)) + (setf (alist-get (intern archive) package-vc-archive-spec-alist) + (car spec))) + (setf (alist-get (intern archive) package-vc-archive-data-alist) + (cdr spec)) + (when-let ((default-vc (plist-get (cdr spec) :default-vc)) + ((not (memq default-vc vc-handled-backends)))) + (warn "Archive `%S' expects missing VC backend %S" + archive (plist-get (cdr spec) :default-vc))))))))) (defun package-vc--download-and-read-archives (&optional async) "Download specifications of all `package-archives' and read them. @@ -374,6 +410,10 @@ the `:brach' attribute in PKG-SPEC." (unless (file-exists-p repo-dir) (make-directory (file-name-directory repo-dir) t) (let ((backend (or (package-vc-guess-backend url) + (plist-get (alist-get (package-desc-archive pkg-desc) + package-vc-archive-data-alist + nil nil #'string=) + :vc-backend) package-vc-default-backend))) (unless (vc-clone url backend repo-dir (or rev branch)) (error "Failed to clone %s from %s" name url)))) commit eaafc10f673960e1cb971ed0cddd6e366daa9b1d Author: Philip Kaludercic Date: Wed Oct 26 10:36:20 2022 +0200 Add support for :release-rev in 'package-vc-archive-spec-alist' * lisp/emacs-lisp/package-vc.el (package-vc-archive-spec-alist): Update docstring. (package-vc-install): Use :release-rev if invoked with a prefix argument. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 5dc9086eae..8e4f2819db 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -136,6 +136,12 @@ The main file of the project, relevant to gather package metadata. If not given, the assumed default is the package named with \".el\" concatenated to the end. + `:release-rev' (string) + +A revision string indicating the revision used for the current +release in the package archive. If missing or nil, no release +was made. + All other values are ignored.") (defun package-vc-desc->spec (pkg-desc &optional name) @@ -414,7 +420,9 @@ guess the name of the package using `file-name-base'. This can be overridden by manually passing the optional NAME. Otherwise NAME-OR-URL is taken to be a package name, and the package metadata will be consulted for the URL. An explicit revision can -be requested using REV." +be requested using REV. If the command is invoked with a prefix +argument, the revision used for the last release in the package +archive is used." (interactive (progn ;; Initialize the package system to get the list of package @@ -424,7 +432,12 @@ be requested using REV." (input (completing-read "Fetch package source (name or URL): " packages)) (name (file-name-base input))) - (list input (intern (string-remove-prefix "emacs-" name)))))) + (list input (intern (string-remove-prefix "emacs-" name)) + (and current-prefix-arg + (or (package-vc-query-spec + (cadr (assoc input package-archive-contents #'string=)) + :release-rev) + (user-error "No release revision was found"))))))) (package--archives-initialize) (cond ((and-let* ((stringp name-or-url) commit 222b863884f07b38c0e75ba77db3ba4191b1d668 Author: Philip Kaludercic Date: Sun Oct 23 19:03:28 2022 +0200 * doc/emacs/package.texi (Package from Source): Clarify prose diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index f5301b7306..db9705aaca 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -549,28 +549,29 @@ bugs. One way to do this is to use @code{package-vc-install}, to fetch the source code for a package directly from source. The command will also automatically ensure that all files are byte-compiled and auto-loaded, -just like with a regular package. From this point on the package can -be regarded just like any other package, that can be updated (using -@code{package-update}), deleted (using @code{package-delete}) and -viewed in the package listing. +just like with a regular package. Packages installed this way behave +just like any other package. You can update them using +@code{package-update} or @code{package-update-all} and delete them +again using @code{package-delete}. They are even displayed in the +regular package listing. @findex package-report-bug @findex package-vc-prepare-patch With the source checkout, you might want to reproduce a bug against the current development head or implement a new feature to scratch an -itch. If the package metadata indicates that a maintainer can be -contacted via Email, you can use the command @code{package-report-bug} -to report a bug that will include all the user options that you have -customised. Patches can be sent out using -@code{package-vc-prepare-patch}, that makes use of -@code{vc-prepare-patch} under the hold (@pxref{Preparing Patches}). +itch. If the package metadata indicates how to contact the +maintainer, you can use the command @code{package-report-bug} to +report a bug via Email. This report will include all the user options +that you have customised. If you have made a change you wish to share +with the maintainers, first commit your changes then use the command +@code{package-vc-prepare-patch} to share it. @xref{Preparing Patches}. @findex package-vc-link-directory @findex package-vc-refresh If you maintain your own packages you might want to use a local -checkout instead of cloning a remote repository. This can be done -using @code{package-vc-link-directory}, that creates a symbolic link +checkout instead of cloning a remote repository. You can do this by +using @code{package-vc-link-directory}, which creates a symbolic link from the package directory (@pxref{Package Files}) to your checkout -and initialises the code. Note that if changes are made such as -adding autoloads, you should use @code{package-vc-refresh} to repeat -the initialisation. +and initialises the code. Note that you might have to use +@code{package-vc-refresh} to repeat the initialisation and update the +autoloads. commit 8149fdd820a632346593cb37a7a2f1d4d929f434 Author: Philip Kaludercic Date: Sun Oct 23 18:46:25 2022 +0200 ;Fix typo "pacakge" -> "package" diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 0de452d135..5dc9086eae 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -138,7 +138,7 @@ with \".el\" concatenated to the end. All other values are ignored.") -(defun pacakge-vc-desc->spec (pkg-desc &optional name) +(defun package-vc-desc->spec (pkg-desc &optional name) "Retrieve the package specification for PKG-DESC. The optional argument NAME can be used to override the default name for PKG-DESC." @@ -153,7 +153,7 @@ name for PKG-DESC." If no package specification can be determined, the function will return nil." (inline-letevals (pkg-desc prop) - (inline-quote (plist-get (pacakge-vc-desc->spec ,pkg-desc) ,prop)))) + (inline-quote (plist-get (package-vc-desc->spec ,pkg-desc) ,prop)))) (defun package-vc--read-archive-data (archive) "Update `package-vc-archive-spec-alist' with the contents of ARCHIVE. @@ -219,7 +219,7 @@ The output is written out into PKG-FILE." (or (package-desc-summary pkg-desc) (and-let* ((pkg (cadr (assq name package-archive-contents)))) (package-desc-summary pkg)) - (and-let* ((pkg-spec (pacakge-vc-desc->spec pkg-desc)) + (and-let* ((pkg-spec (package-vc-desc->spec pkg-desc)) (main-file (plist-get pkg-spec :main-file))) (lm-summary main-file)) (and-let* ((main-file (expand-file-name @@ -303,7 +303,7 @@ The output is written out into PKG-FILE." (package-vc-generate-description-file pkg-desc pkg-file) ;; Detect a manual - (when-let ((pkg-spec (pacakge-vc-desc->spec pkg-desc)) + (when-let ((pkg-spec (package-vc-desc->spec pkg-desc)) ((executable-find "install-info"))) (dolist (doc-file (ensure-list (plist-get pkg-spec :doc))) (package-vc-build-documentation pkg-desc doc-file)))) @@ -382,7 +382,7 @@ the `:brach' attribute in PKG-SPEC." "Generate a list of packages with VC data." (seq-filter (lambda (pkg) - (or (pacakge-vc-desc->spec (cadr pkg)) + (or (package-vc-desc->spec (cadr pkg)) ;; If we have no explicit VC data, we can try a kind of ;; heuristic and use the URL header, that might already be ;; pointing towards a repository, and use that as a backup @@ -440,7 +440,7 @@ be requested using REV." (let ((copy (copy-package-desc (cadr desc)))) (setf (package-desc-kind copy) 'vc) copy) - (or (pacakge-vc-desc->spec (cadr desc)) + (or (package-vc-desc->spec (cadr desc)) (user-error "Package has no VC data")) rev))) ((user-error "Unknown package to fetch: %s" name-or-url)))) commit e31c84f4e7bca94e25845c28d2fb762a1d0ec316 Author: Philip Kaludercic Date: Sun Oct 23 18:41:36 2022 +0200 Extract separate function 'package-vc-guess-backend' * lisp/emacs-lisp/package-vc.el (package-vc-guess-backend): New function. (package-vc-unpack): Use it. (package-vc-sourced-packages-list): Use it. (package-vc-install): Use it. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index c667219921..0de452d135 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -329,6 +329,13 @@ The output is written out into PKG-FILE." (cons (package-desc-name pkg-desc) package-selected-packages))) +(defun package-vc-guess-backend (url) + "Guess the VC backend for URL. +This function will internally query `package-vc-heuristic-alist' +and return nil if no reasonable guess can be made." + (and url (alist-get url package-vc-heuristic-alist + nil nil #'string-match-p))) + (defun package-vc-unpack (pkg-desc pkg-spec &optional rev) "Install the package described by PKG-DESC. PKG-SPEC is a package specification is a property list describing @@ -360,8 +367,7 @@ the `:brach' attribute in PKG-SPEC." ;; Clone the repository into `repo-dir' if necessary (unless (file-exists-p repo-dir) (make-directory (file-name-directory repo-dir) t) - (let ((backend (or (and url (alist-get url package-vc-heuristic-alist - nil nil #'string-match-p)) + (let ((backend (or (package-vc-guess-backend url) package-vc-default-backend))) (unless (vc-clone url backend repo-dir (or rev branch)) (error "Failed to clone %s from %s" name url)))) @@ -382,8 +388,7 @@ the `:brach' attribute in PKG-SPEC." ;; pointing towards a repository, and use that as a backup (and-let* ((extras (package-desc-extras (cadr pkg))) (url (alist-get :url extras)) - (backend (alist-get url package-vc-heuristic-alist - nil nil #'string-match-p)))))) + ((package-vc-guess-backend url)))))) package-archive-contents)) (defun package-vc-update (pkg-desc) @@ -423,9 +428,7 @@ be requested using REV." (package--archives-initialize) (cond ((and-let* ((stringp name-or-url) - (backend (alist-get name-or-url - package-vc-heuristic-alist - nil nil #'string-match-p))) + (backend (package-vc-guess-backend name-or-url))) (package-vc-unpack (package-desc-create :name (or name (intern (file-name-base name-or-url))) commit a3cd8d43aefb1ad53efb076f3f6cb45d7b914d5a Author: Philip Kaludercic Date: Sun Oct 23 18:38:12 2022 +0200 ;Fix typo "heusitic" -> "heuristic" diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index dd451e80f4..c667219921 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -56,7 +56,7 @@ :group 'package :version "29.1") -(defcustom package-vc-heusitic-alist +(defcustom package-vc-heuristic-alist `((,(rx bos "http" (? "s") "://" (or (: (? "www.") "github.com" "/" (+ (or alnum "-" "." "_")) @@ -104,7 +104,7 @@ (defcustom package-vc-default-backend 'Git "Default VC backend used when cloning a package repository. If no repository type was specified or could be guessed by -`package-vc-heusitic-alist', the VC backend denoted by this +`package-vc-heuristic-alist', the VC backend denoted by this symbol is used. The value must be a member of `vc-handled-backends' that implements the `clone' function." :type `(choice ,@(mapcar (lambda (b) (list 'const b)) @@ -360,7 +360,7 @@ the `:brach' attribute in PKG-SPEC." ;; Clone the repository into `repo-dir' if necessary (unless (file-exists-p repo-dir) (make-directory (file-name-directory repo-dir) t) - (let ((backend (or (and url (alist-get url package-vc-heusitic-alist + (let ((backend (or (and url (alist-get url package-vc-heuristic-alist nil nil #'string-match-p)) package-vc-default-backend))) (unless (vc-clone url backend repo-dir (or rev branch)) @@ -382,7 +382,7 @@ the `:brach' attribute in PKG-SPEC." ;; pointing towards a repository, and use that as a backup (and-let* ((extras (package-desc-extras (cadr pkg))) (url (alist-get :url extras)) - (backend (alist-get url package-vc-heusitic-alist + (backend (alist-get url package-vc-heuristic-alist nil nil #'string-match-p)))))) package-archive-contents)) @@ -424,7 +424,7 @@ be requested using REV." (cond ((and-let* ((stringp name-or-url) (backend (alist-get name-or-url - package-vc-heusitic-alist + package-vc-heuristic-alist nil nil #'string-match-p))) (package-vc-unpack (package-desc-create commit ca61e768d0d599657b4f8e998fb74eccee58c8f6 Author: Philip Kaludercic Date: Sun Oct 23 18:27:07 2022 +0200 Use user option 'package-vc-default-backend' when cloning * lisp/emacs-lisp/package-vc.el (package-vc-unpack): Respect 'package-vc-default-backend'. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 082e8f17f6..dd451e80f4 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -102,10 +102,13 @@ :version "29.1") (defcustom package-vc-default-backend 'Git - "VC backend to use as a fallback." - :type `(choice - ,@(mapcar (lambda (b) (list 'const b)) - vc-handled-backends)) + "Default VC backend used when cloning a package repository. +If no repository type was specified or could be guessed by +`package-vc-heusitic-alist', the VC backend denoted by this +symbol is used. The value must be a member of +`vc-handled-backends' that implements the `clone' function." + :type `(choice ,@(mapcar (lambda (b) (list 'const b)) + vc-handled-backends)) :version "29.1") (defvar package-vc-archive-spec-alist nil @@ -357,8 +360,9 @@ the `:brach' attribute in PKG-SPEC." ;; Clone the repository into `repo-dir' if necessary (unless (file-exists-p repo-dir) (make-directory (file-name-directory repo-dir) t) - (let ((backend (and url (alist-get url package-vc-heusitic-alist - nil nil #'string-match-p)))) + (let ((backend (or (and url (alist-get url package-vc-heusitic-alist + nil nil #'string-match-p)) + package-vc-default-backend))) (unless (vc-clone url backend repo-dir (or rev branch)) (error "Failed to clone %s from %s" name url)))) commit dbcd66371577efacef62419d1efa39494f4cd778 Author: Philip Kaludercic Date: Sun Oct 23 18:26:17 2022 +0200 ; Update 'clone' documentation in header diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index a0a3ce2e6f..38209ef39e 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -585,11 +585,14 @@ ;; properties are omitted, `point-min' and `point-max' will ;; respectively be used instead. ;; -;; - clone (remote directory) +;; - clone (remote directory rev) ;; ;; Attempt to clone a REMOTE repository, into a local DIRECTORY. ;; Returns a string with the directory with the contents of the -;; repository if successful, otherwise nil. +;; repository if successful, otherwise nil. With a non-nil value +;; for REV the backend will attempt to check out a specific +;; revision, if possible without first checking out the default +;; branch. ;;; Changes from the pre-25.1 API: ;; commit 85555ad3b79806f662819c74810d9db26108ef9f Author: Philip Kaludercic Date: Sun Oct 23 18:20:30 2022 +0200 ; Require map only during compilation As map is only used by 'pcase' during macro-expansion, it is not necessary to load it all the time. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index d53329a736..082e8f17f6 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -44,11 +44,11 @@ (eval-when-compile (require 'rx)) (eval-when-compile (require 'inline)) +(eval-when-compile (require 'map)) (require 'package) (require 'lisp-mnt) (require 'vc) (require 'seq) -(require 'map) (require 'xdg) (defgroup package-vc nil commit 0e6452ccd7df10966c5812d4663dbd52594b4b4b Author: Philip Kaludercic Date: Sun Oct 23 18:18:37 2022 +0200 ; Update TODO list diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 61f8fb86ee..d53329a736 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -34,6 +34,11 @@ ;; of the package if already installed. ;; - Allow for ELPA specifications to be respected without ;; endangering the user with arbitrary code execution +;; - Allow maintaining patches that are ported back onto regular +;; packages and maintained between versions. +;; - Allow locking the specific revisions of sourced packages +;; (comparable to `package-selected-packages') so that specific +;; revisions can be re-installed. ;;; Code: commit 2154219059a21d6aad2e7e390187d78029fff3d0 Author: Philip Kaludercic Date: Sun Oct 23 18:04:55 2022 +0200 Immediately check out the right branch or revision * lisp/emacs-lisp/package-vc.el (package-vc-unpack) Use REV to avoid checking out the wrong branch/revision first. * lisp/vc/vc-bzr.el: Handle REV. * lisp/vc/vc-git.el: Handle REV. * lisp/vc/vc-hg.el: Handle REV. * lisp/vc/vc-svn.el: Handle REV. * lisp/vc/vc.el: Make BACKEND optional and add REV. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 25ac10bd08..61f8fb86ee 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -336,8 +336,7 @@ the `:brach' attribute in PKG-SPEC." (if (yes-or-no-p "Overwrite previous checkout?") (package--delete-directory pkg-dir pkg-desc) (error "There already exists a checkout for %s" name))) - (pcase-let* ((extras (package-desc-extras pkg-desc)) - ((map :url :branch :lisp-dir) pkg-spec) + (pcase-let* (((map :url :branch :lisp-dir) pkg-spec) (repo-dir (if (null lisp-dir) pkg-dir @@ -353,18 +352,15 @@ the `:brach' attribute in PKG-SPEC." ;; Clone the repository into `repo-dir' if necessary (unless (file-exists-p repo-dir) (make-directory (file-name-directory repo-dir) t) - (unless (vc-clone (or (alist-get :vc-backend extras) - package-vc-default-backend) - url repo-dir) - (error "Failed to clone %s from %s" name url))) + (let ((backend (and url (alist-get url package-vc-heusitic-alist + nil nil #'string-match-p)))) + (unless (vc-clone url backend repo-dir (or rev branch)) + (error "Failed to clone %s from %s" name url)))) (unless (eq pkg-dir repo-dir) ;; Link from the right position in `repo-dir' to the package ;; directory in the ELPA store. - (make-symbolic-link (file-name-concat repo-dir lisp-dir) pkg-dir)) - (when-let* ((default-directory repo-dir) (rev (or rev branch))) - (vc-retrieve-tag pkg-dir rev))) - + (make-symbolic-link (file-name-concat repo-dir lisp-dir) pkg-dir))) (package-vc-unpack-1 pkg-desc pkg-dir))) (defun package-vc-sourced-packages-list () diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el index 5e826b9a28..8f00441e81 100644 --- a/lisp/vc/vc-bzr.el +++ b/lisp/vc/vc-bzr.el @@ -532,8 +532,10 @@ in the branch repository (or whose status not be determined)." (add-hook 'after-save-hook #'vc-bzr-resolve-when-done nil t) (vc-message-unresolved-conflicts buffer-file-name))) -(defun vc-bzr-clone (remote directory) - (vc-bzr-command nil 0 '() "branch" remote directory) +(defun vc-bzr-clone (remote directory rev) + (if rev + (vc-bzr-command nil 0 '() "branch" "-r" rev remote directory) + (vc-bzr-command nil 0 '() "branch" remote directory)) directory) (defun vc-bzr-version-dirstate (dir) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 366ab9a4f7..6137ce75ce 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1268,8 +1268,10 @@ This prompts for a branch to merge from." (add-hook 'after-save-hook #'vc-git-resolve-when-done nil 'local)) (vc-message-unresolved-conflicts buffer-file-name))) -(defun vc-git-clone (remote directory) - (vc-git--out-ok "clone" remote directory) +(defun vc-git-clone (remote directory rev) + (if rev + (vc-git--out-ok "clone" "--branch" rev remote directory) + (vc-git--out-ok "clone" remote directory)) directory) ;;; HISTORY FUNCTIONS diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 3ea4c5d32c..1fb91c6452 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -1250,8 +1250,11 @@ REV is the revision to check out into WORKFILE." (add-hook 'after-save-hook #'vc-hg-resolve-when-done nil t) (vc-message-unresolved-conflicts buffer-file-name))) -(defun vc-hg-clone (remote directory) - (vc-hg-command nil 0 '() "clone" remote directory) +(defun vc-hg-clone (remote directory rev) + (if rev + (vc-hg-command nil 0 '() "clone" "--rev" rev remote directory) + (vc-hg-command nil 0 '() "clone" remote directory)) + directory) ;; Modeled after the similar function in vc-bzr.el diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el index ae6884bbae..dfc84ba4d3 100644 --- a/lisp/vc/vc-svn.el +++ b/lisp/vc/vc-svn.el @@ -817,8 +817,11 @@ Set file properties accordingly. If FILENAME is non-nil, return its status." "info" "--show-item" "repos-root-url") (buffer-substring-no-properties (point-min) (1- (point-max)))))) -(defun vc-svn-clone (remote directory) - (vc-svn-command nil 0 '() "checkout" remote directory) +(defun vc-svn-clone (remote directory rev) + (if rev + (vc-svn-command nil 0 '() "checkout" "--revision" rev remote directory) + (vc-svn-command nil 0 '() "checkout" remote directory)) + (file-name-concat directory "trunk")) (provide 'vc-svn) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 7f603093e1..a0a3ce2e6f 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -3560,24 +3560,25 @@ to provide the `find-revision' operation instead." (interactive) (vc-call-backend (vc-backend buffer-file-name) 'check-headers)) -(defun vc-clone (backend remote &optional directory) +(defun vc-clone (remote &optional backend directory rev) "Use BACKEND to clone REMOTE into DIRECTORY. If successful, returns the a string with the directory of the checkout. If BACKEND is nil, iterate through every known backend -in `vc-handled-backends' until one succeeds." +in `vc-handled-backends' until one succeeds. If REV is non-nil, +it indicates a specific revision to check out." (unless directory (setq directory default-directory)) (if backend (progn (unless (memq backend vc-handled-backends) (error "Unknown VC backend %s" backend)) - (vc-call-backend backend 'clone remote directory)) + (vc-call-backend backend 'clone remote directory rev)) (catch 'ok (dolist (backend vc-handled-backends) (ignore-error vc-not-supported (when-let ((res (vc-call-backend backend 'clone - remote directory))) + remote directory rev))) (throw 'ok res))))))) commit a0532e148cca6fc9ede11fda2c9dda20cac4eca5 Author: Philip Kaludercic Date: Sun Oct 23 13:15:28 2022 +0200 ; Remove unnecessary "TODO"s from the package header diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index ba0f626e3e..25ac10bd08 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -26,13 +26,13 @@ ;;; TODO: -;; - Allow for automatic updating TODO -;; * Detect merge conflicts TODO -;; * Check if there are upstream changes TODO -;; - Allow finding revisions that bump the version tag TODO +;; - Allow for automatic updating +;; * Detect merge conflicts +;; * Check if there are upstream changes +;; - Allow finding revisions that bump the version tag ;; * Allow for `package-vc-install' to use the version ;; of the package if already installed. -;; - Allow for ELPA specifications to be respected without TODO +;; - Allow for ELPA specifications to be respected without ;; endangering the user with arbitrary code execution ;;; Code: commit ab46a0df7b88c9c2d2af8dc528e775083bcbc936 Author: Philip Kaludercic Date: Sun Oct 23 13:07:43 2022 +0200 ; Remove unnecessary 'let' binding * lisp/emacs-lisp/package-vc.el (pacakge-vc-desc->spec): Simplify function. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 769f9ac5dc..ba0f626e3e 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -134,12 +134,11 @@ All other values are ignored.") "Retrieve the package specification for PKG-DESC. The optional argument NAME can be used to override the default name for PKG-DESC." - (let ((spec (alist-get - (or name (package-desc-name pkg-desc)) - (alist-get (intern (package-desc-archive pkg-desc)) - package-vc-archive-spec-alist) - nil nil #'string=))) - spec)) + (alist-get + (or name (package-desc-name pkg-desc)) + (alist-get (intern (package-desc-archive pkg-desc)) + package-vc-archive-spec-alist) + nil nil #'string=)) (define-inline package-vc-query-spec (pkg-desc prop) "Query the property PROP for the package specification for PKG-DESC. commit 7640b0751ba1065f43ff93ed7ad2cc0d9dff9a97 Author: Philip Kaludercic Date: Sun Oct 23 13:02:25 2022 +0200 Add auxiliary function to query package specifications * lisp/emacs-lisp/package-vc.el (package-vc-query-spec): Add inline function. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 562c534002..769f9ac5dc 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -38,6 +38,7 @@ ;;; Code: (eval-when-compile (require 'rx)) +(eval-when-compile (require 'inline)) (require 'package) (require 'lisp-mnt) (require 'vc) @@ -140,6 +141,13 @@ name for PKG-DESC." nil nil #'string=))) spec)) +(define-inline package-vc-query-spec (pkg-desc prop) + "Query the property PROP for the package specification for PKG-DESC. +If no package specification can be determined, the function will +return nil." + (inline-letevals (pkg-desc prop) + (inline-quote (plist-get (pacakge-vc-desc->spec ,pkg-desc) ,prop)))) + (defun package-vc--read-archive-data (archive) "Update `package-vc-archive-spec-alist' with the contents of ARCHIVE. This function is meant to be used as a hook for commit aaa5ae90a90ba45c81bc7036ceedf5f15038c47e Author: Philip Kaludercic Date: Sat Oct 22 00:14:15 2022 +0200 Rephrase initial paragraph in "Package from Source" section * doc/emacs/package.texi (Package from Source): Clarify motivation. diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index 584f85567f..f5301b7306 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -534,15 +534,16 @@ system-wide package directory, the deletion command signals an error. @node Package from Source @section Package from Source -@cindex package source vcs git @c "git" is not technically correct - @c but it is a popular term - - By default @code{package-install} will download a Tarball from a -package archive and install the files therein contained. Most of the -time this is just what you want. One exception is when you decide to -hack on the source code of a package, and would like to share these -changes with other users. In that case you usually want to fetch and -work on the upstream source, so that you can prepare a usable patch. +@cindex package development source +@cindex upstream source, for packages +@cindex git source of package @c "git" is not technically correct + + By default @code{package-install} downloads a Tarball from a package +archive and installs its files. This might be inadequate if you wish +to hack on the package sources and share your changes with others. In +that case, you may prefer to directly fetch and work on the upstream +source. This often makes it easier to develop patches and report +bugs. @findex package-vc-install One way to do this is to use @code{package-vc-install}, to fetch the commit ab283bddb2505e767bdf08b063c648b87d71d33a Author: Philip Kaludercic Date: Sat Oct 22 00:06:02 2022 +0200 Request "elpa-packages.eld" instead of "elpa-packages" * lisp/emacs-lisp/package-vc.el (package-vc--read-archive-data): Apply change. (package-vc--download-and-read-archives): Apply change. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 8f42767a6f..562c534002 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -145,7 +145,7 @@ name for PKG-DESC." This function is meant to be used as a hook for `package--read-archive-hook'." (let* ((contents-file (expand-file-name - (format "archives/%s/elpa-packages" archive) + (format "archives/%s/elpa-packages.eld" archive) package-user-dir))) (when (file-exists-p contents-file) (with-temp-buffer @@ -162,7 +162,7 @@ If optional argument ASYNC is non-nil, perform the downloads asynchronously." (dolist (archive package-archives) (condition-case-unless-debug nil - (package--download-one-archive archive "elpa-packages" async) + (package--download-one-archive archive "elpa-packages.eld" async) (error (message "Failed to download `%s' archive." (car archive)))))) (add-hook 'package-read-archive-hook #'package-vc--read-archive-data 20) commit 5694278af37c77e3999cc39231c218f786ee7c86 Author: Philip Kaludercic Date: Fri Oct 21 20:39:33 2022 +0200 Remove 'package-vc-install' alias 'package-checkout' * lisp/emacs-lisp/package-vc.el (package-checkout): Remove it. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 360a5ebf9d..8f42767a6f 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -430,9 +430,6 @@ be requested using REV." rev))) ((user-error "Unknown package to fetch: %s" name-or-url)))) -;;;###autoload -(defalias 'package-checkout #'package-vc-install) - (defun package-vc-link-directory (dir name) "Install the package NAME in DIR by linking it into the ELPA directory. If invoked interactively with a prefix argument, the user will be commit faeb66ae42d2617371eb3780adc379eb40877d38 Author: Philip Kaludercic Date: Thu Oct 20 21:45:17 2022 +0200 Have 'package-vc-link-directory' use name if given * lisp/emacs-lisp/package-vc.el (package-vc-link-directory): Use the NAME argument. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index e9f5f254d0..360a5ebf9d 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -446,7 +446,7 @@ from the base name of DIR." (unless (vc-responsible-backend dir) (user-error "Directory %S is not under version control" dir)) (package--archives-initialize) - (let* ((name (file-name-base (directory-file-name dir))) + (let* ((name (or name (file-name-base (directory-file-name dir)))) (pkg-dir (expand-file-name name package-user-dir))) (make-symbolic-link dir pkg-dir) (package-vc-unpack-1 (package-desc-create commit 2dabcba1489aefe1c309bb1385ffc959e767f0c5 Author: Philip Kaludercic Date: Thu Oct 20 21:34:48 2022 +0200 Build documentation like elpa-admin.el * lisp/emacs-lisp/package-vc.el (package-vc-build-documentation): Add function to build a documentation file. (package-vc-unpack-1): Use 'package-vc-build-documentation'. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 8303841852..e9f5f254d0 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -242,6 +242,21 @@ The output is written out into PKG-FILE." "\n") nil pkg-file nil 'silent)))) +(declare-function org-export-to-file "ox" (backend file)) + +(defun package-vc-build-documentation (pkg-desc file) + "Build documentation FILE for PKG-DESC." + (let ((pkg-dir (package-desc-dir pkg-desc))) + (when (string-match-p "\\.org\\'" file) + (require 'ox) + (require 'ox-texinfo) + (with-temp-buffer + (insert-file-contents file) + (setq file (make-temp-file "ox-texinfo-")) + (org-export-to-file 'texinfo file))) + (call-process "install-info" nil nil nil + file pkg-dir))) + (defun package-vc-unpack-1 (pkg-desc pkg-dir) "Install PKG-DESC that is already located in PKG-DIR." ;; In case the package was installed directly from source, the @@ -273,14 +288,10 @@ The output is written out into PKG-FILE." (package-vc-generate-description-file pkg-desc pkg-file) ;; Detect a manual - (when (executable-find "install-info") - ;; Only proceed if we can find an unambiguous TeXinfo file - (let ((texi-files (directory-files pkg-dir t "\\.texi\\'")) - (dir-file (expand-file-name "dir" pkg-dir))) - (when (length= texi-files 1) - (call-process "install-info" nil nil nil - (concat "--dir=" dir-file) - (car texi-files)))))) + (when-let ((pkg-spec (pacakge-vc-desc->spec pkg-desc)) + ((executable-find "install-info"))) + (dolist (doc-file (ensure-list (plist-get pkg-spec :doc))) + (package-vc-build-documentation pkg-desc doc-file)))) ;; Update package-alist. (let ((new-desc (package-load-descriptor pkg-dir))) commit 37bfb623e4b253443e8280c3de4ff91f8db5f51b Merge: e08e9bc40f 937ae0cf55 Author: Philip Kaludercic Date: Thu Oct 20 20:00:32 2022 +0200 Merge remote-tracking branch 'origin/master' into feature/package+vc commit e08e9bc40f2c309bf119659a6496759493bd35e1 Author: Philip Kaludercic Date: Tue Oct 18 22:44:35 2022 +0200 Remove modifications to the list of ignored files in source packages * lisp/emacs-lisp/package-vc.el (package-vc-unpack-1): Remove 'vc-ignore' calls. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index c420c5f87a..8303841852 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -268,13 +268,9 @@ The output is written out into PKG-FILE." (pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir))) ;; Generate autoloads (package-generate-autoloads name pkg-dir) - (vc-ignore (concat "/" (file-relative-name - (expand-file-name (format "%s-autoloads.el" name)) - default-directory))) ;; Generate package file (package-vc-generate-description-file pkg-desc pkg-file) - (vc-ignore (concat "/" (file-relative-name pkg-file default-directory))) ;; Detect a manual (when (executable-find "install-info") @@ -284,8 +280,7 @@ The output is written out into PKG-FILE." (when (length= texi-files 1) (call-process "install-info" nil nil nil (concat "--dir=" dir-file) - (car texi-files))) - (vc-ignore "/dir")))) + (car texi-files)))))) ;; Update package-alist. (let ((new-desc (package-load-descriptor pkg-dir))) commit 5d60ea47f6625dc7da6ceb475dc624e33deb198f Author: Philip Kaludercic Date: Tue Oct 18 22:34:11 2022 +0200 Use 'elpa-packages' files for VC metadata * lisp/emacs-lisp/package-vc.el (package-vc-default-backend): Add new option. (package-vc-archive-spec-alist): Add new variable to store the contents of 'elpa-packages' for each archive. (pacakge-vc-desc->spec): Add function to query package specifications. (package-vc--read-archive-data): Add a 'package-read-archive-hook' implementation. (package-vc--download-and-read-archives): Add a 'package-refresh-contents-hook' implementation. (package-vc-main-file): Remove function. (package-vc-generate-description-file): Use package specifications. (package-vc-unpack-1): Adapt to previous changes. (package-vc-unpack): Adapt to previous changes. (package-vc-sourced-packages-list): Adapt to previous changes. (package-vc-install): Adapt to previous changes. * lisp/emacs-lisp/package.el (package-read-archive-hook): Allow extending 'package-read-all-archive-contents' using a hook. (package-read-all-archive-contents): Use 'package-read-archive-hook'. (package-refresh-contents-hook): Allow extending 'package-refresh-contents' using a hook. (package-refresh-contents): Use 'package-refresh-contents-hook'. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 7098de2ece..c420c5f87a 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -42,6 +42,7 @@ (require 'lisp-mnt) (require 'vc) (require 'seq) +(require 'map) (require 'xdg) (defgroup package-vc nil @@ -94,6 +95,79 @@ :type 'directory :version "29.1") +(defcustom package-vc-default-backend 'Git + "VC backend to use as a fallback." + :type `(choice + ,@(mapcar (lambda (b) (list 'const b)) + vc-handled-backends)) + :version "29.1") + +(defvar package-vc-archive-spec-alist nil + "List of package specifications for each archive. +The list maps package names as string to plist. Valid keys +include + + `:url' (string) + +The URL of the repository used to fetch the package source. + + `:branch' (string) + +If given, the branch to check out after cloning the directory. + + `:lisp-dir' (string) + +The repository-relative directory to use for loading the Lisp +sources. If not given, the value defaults to the root directory +of the repository. + + `:main-file' (string) + +The main file of the project, relevant to gather package +metadata. If not given, the assumed default is the package named +with \".el\" concatenated to the end. + +All other values are ignored.") + +(defun pacakge-vc-desc->spec (pkg-desc &optional name) + "Retrieve the package specification for PKG-DESC. +The optional argument NAME can be used to override the default +name for PKG-DESC." + (let ((spec (alist-get + (or name (package-desc-name pkg-desc)) + (alist-get (intern (package-desc-archive pkg-desc)) + package-vc-archive-spec-alist) + nil nil #'string=))) + spec)) + +(defun package-vc--read-archive-data (archive) + "Update `package-vc-archive-spec-alist' with the contents of ARCHIVE. +This function is meant to be used as a hook for +`package--read-archive-hook'." + (let* ((contents-file (expand-file-name + (format "archives/%s/elpa-packages" archive) + package-user-dir))) + (when (file-exists-p contents-file) + (with-temp-buffer + (let ((coding-system-for-read 'utf-8)) + (insert-file-contents contents-file)) + (setf (alist-get (intern archive) package-vc-archive-spec-alist) + (read (current-buffer))))))) + +(defun package-vc--download-and-read-archives (&optional async) + "Download specifications of all `package-archives' and read them. +Populate `package-vc-archive-spec-alist' with the result. + +If optional argument ASYNC is non-nil, perform the downloads +asynchronously." + (dolist (archive package-archives) + (condition-case-unless-debug nil + (package--download-one-archive archive "elpa-packages" async) + (error (message "Failed to download `%s' archive." (car archive)))))) + +(add-hook 'package-read-archive-hook #'package-vc--read-archive-data 20) +(add-hook 'package-refresh-contents-hook #'package-vc--download-and-read-archives 20) + (defun package-vc-commit (pkg) "Extract the commit of a development package PKG." (cl-assert (package-vc-p pkg)) @@ -120,21 +194,6 @@ return it finally return "0")) -(defun package-vc-main-file (pkg-desc) - "Return the main file of the package PKG-DESC. -If no file can be found that appends \".el\" to the end of the -package name, the file with the closest file name is chosen." - (let* ((default-directory (package-desc-dir pkg-desc)) - (best (format "%s.el" (package-desc-name pkg-desc))) - (distance most-positive-fixnum) next-best) - (if (file-exists-p best) - (expand-file-name best) - (dolist (file (directory-files default-directory nil "\\.el\\'")) - (let ((distance* (string-distance best file))) - (when (< distance* distance) - (setq distance distance* next-best file)))) - next-best))) - (defun package-vc-generate-description-file (pkg-desc pkg-file) "Generate a package description file for PKG-DESC. The output is written out into PKG-FILE." @@ -142,9 +201,17 @@ The output is written out into PKG-FILE." ;; Infer the subject if missing. (unless (package-desc-summary pkg-desc) (setf (package-desc-summary pkg-desc) - (or (and-let* ((pkg (cadr (assq name package-archive-contents)))) + (or (package-desc-summary pkg-desc) + (and-let* ((pkg (cadr (assq name package-archive-contents)))) (package-desc-summary pkg)) - (lm-summary (package-vc-main-file pkg-desc)) + (and-let* ((pkg-spec (pacakge-vc-desc->spec pkg-desc)) + (main-file (plist-get pkg-spec :main-file))) + (lm-summary main-file)) + (and-let* ((main-file (expand-file-name + (format "%s.el" name) + (package-desc-dir pkg-desc))) + ((file-exists-p main-file))) + (lm-summary main-file)) package--default-summary))) (let ((print-level nil) (print-quoted t) @@ -241,8 +308,13 @@ The output is written out into PKG-FILE." (cons (package-desc-name pkg-desc) package-selected-packages))) -(defun package-vc-unpack (pkg-desc) - "Install the package described by PKG-DESC." +(defun package-vc-unpack (pkg-desc pkg-spec &optional rev) + "Install the package described by PKG-DESC. +PKG-SPEC is a package specification is a property list describing +how to fetch and build the package PKG-DESC. See +`package-vc-archive-spec-alist' for details. The optional argument +REV specifies a specific revision to checkout. This overrides +the `:brach' attribute in PKG-SPEC." (let* ((name (package-desc-name pkg-desc)) (dirname (package-desc-full-name pkg-desc)) (pkg-dir (expand-file-name dirname package-user-dir))) @@ -251,12 +323,10 @@ The output is written out into PKG-FILE." (if (yes-or-no-p "Overwrite previous checkout?") (package--delete-directory pkg-dir pkg-desc) (error "There already exists a checkout for %s" name))) - (pcase-let* ((attr (package-desc-extras pkg-desc)) - (`(,backend ,repo ,dir ,branch) - (or (alist-get :upstream attr) - (error "Source package has no repository"))) + (pcase-let* ((extras (package-desc-extras pkg-desc)) + ((map :url :branch :lisp-dir) pkg-spec) (repo-dir - (if (null dir) + (if (null lisp-dir) pkg-dir (unless (file-exists-p package-vc-repository-store) (make-directory package-vc-repository-store t)) @@ -265,21 +335,21 @@ The output is written out into PKG-FILE." ;; FIXME: We aren't sure this directory ;; will be unique, but we can try other ;; names to avoid an unnecessary error. - (file-name-base repo))))) + (file-name-base url))))) ;; Clone the repository into `repo-dir' if necessary (unless (file-exists-p repo-dir) (make-directory (file-name-directory repo-dir) t) - (unless (setf (car (alist-get :upstream attr)) - (vc-clone backend repo repo-dir)) - (error "Failed to clone %s from %s" name repo))) + (unless (vc-clone (or (alist-get :vc-backend extras) + package-vc-default-backend) + url repo-dir) + (error "Failed to clone %s from %s" name url))) (unless (eq pkg-dir repo-dir) ;; Link from the right position in `repo-dir' to the package ;; directory in the ELPA store. - (make-symbolic-link (file-name-concat repo-dir dir) pkg-dir)) - (when-let ((default-directory repo-dir) - (rev (or (alist-get :rev attr) branch))) + (make-symbolic-link (file-name-concat repo-dir lisp-dir) pkg-dir)) + (when-let* ((default-directory repo-dir) (rev (or rev branch))) (vc-retrieve-tag pkg-dir rev))) (package-vc-unpack-1 pkg-desc pkg-dir))) @@ -288,17 +358,14 @@ The output is written out into PKG-FILE." "Generate a list of packages with VC data." (seq-filter (lambda (pkg) - (let ((extras (package-desc-extras (cadr pkg)))) - (or (alist-get :vc extras) - ;; If we have no explicit VC data, we can try a kind of - ;; heuristic and use the URL header, that might already be - ;; pointing towards a repository, and use that as a backup - (and-let* ((url (alist-get :url extras)) - (backend (alist-get url package-vc-heusitic-alist - nil nil #'string-match-p))) - (setf (alist-get :vc (package-desc-extras (cadr pkg))) - (list backend url)) - t)))) + (or (pacakge-vc-desc->spec (cadr pkg)) + ;; If we have no explicit VC data, we can try a kind of + ;; heuristic and use the URL header, that might already be + ;; pointing towards a repository, and use that as a backup + (and-let* ((extras (package-desc-extras (cadr pkg))) + (url (alist-get :url extras)) + (backend (alist-get url package-vc-heusitic-alist + nil nil #'string-match-p)))))) package-archive-contents)) (defun package-vc-update (pkg-desc) @@ -315,7 +382,6 @@ The output is written out into PKG-FILE." (package-vc-unpack-1 pkg-desc default-directory))) (package-vc-unpack-1 pkg-desc default-directory)))) - ;;;###autoload (defun package-vc-install (name-or-url &optional name rev) "Fetch the source of NAME-OR-URL. @@ -337,27 +403,26 @@ be requested using REV." (name (file-name-base input))) (list input (intern (string-remove-prefix "emacs-" name)))))) (package--archives-initialize) - (package-vc-unpack - (cond - ((and (stringp name-or-url) - (url-type (url-generic-parse-url name-or-url))) - (package-desc-create - :name (or name (intern (file-name-base name-or-url))) - :kind 'vc - :extras `((:upstream . ,(list nil name-or-url nil nil)) - (:rev . ,rev)))) - ((when-let* ((desc (cadr (assoc name-or-url package-archive-contents - #'string=))) - (upstream (or (alist-get :vc (package-desc-extras desc)) - (user-error "Package has no VC data")))) + (cond + ((and-let* ((stringp name-or-url) + (backend (alist-get name-or-url + package-vc-heusitic-alist + nil nil #'string-match-p))) + (package-vc-unpack (package-desc-create - :name (if (stringp name-or-url) - (intern name-or-url) - name-or-url) - :kind 'vc - :extras `((:upstream . ,upstream) - (:rev . ,rev))))) - ((user-error "Unknown package to fetch: %s" name-or-url))))) + :name (or name (intern (file-name-base name-or-url))) + :kind 'vc) + (list :vc-backend backend :url name-or-url) + rev))) + ((and-let* ((desc (assoc name-or-url package-archive-contents #'string=))) + (package-vc-unpack + (let ((copy (copy-package-desc (cadr desc)))) + (setf (package-desc-kind copy) 'vc) + copy) + (or (pacakge-vc-desc->spec (cadr desc)) + (user-error "Package has no VC data")) + rev))) + ((user-error "Unknown package to fetch: %s" name-or-url)))) ;;;###autoload (defalias 'package-checkout #'package-vc-install) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 245e41ee74..425abfeea5 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1650,13 +1650,19 @@ This is the value of `package-archive-priorities' last time by arbitrary functions to decide whether it is necessary to call it again.") +(defvar package-read-archive-hook (list #'package-read-archive-contents) + "List of functions to call to read the archive contents. +Each function must take an optional argument, a symbol indicating +what archive to read in. The symbol ought to be a key in +`package-archives'.") + (defun package-read-all-archive-contents () "Read cached archive file for all archives in `package-archives'. If successful, set or update `package-archive-contents'." (setq package-archive-contents nil) (setq package--old-archive-priorities package-archive-priorities) (dolist (archive package-archives) - (package-read-archive-contents (car archive)))) + (run-hook-with-args 'package-read-archive-hook (car archive)))) ;;;; Package Initialize @@ -1832,6 +1838,11 @@ asynchronously." (error (message "Failed to download `%s' archive." (car archive)))))) +(defvar package-refresh-contents-hook (list #'package--download-and-read-archives) + "List of functions to call to refresh the package archive. +Each function may take an optional argument indicating that the +operation ought to be executed asynchronously.") + ;;;###autoload (defun package-refresh-contents (&optional async) "Download descriptions of all configured ELPA packages. @@ -1850,7 +1861,7 @@ downloads in the background." (condition-case-unless-debug error (package-import-keyring default-keyring) (error (message "Cannot import default keyring: %S" (cdr error)))))) - (package--download-and-read-archives async)) + (run-hook-with-args 'package-refresh-contents-hook async)) ;;; Dependency Management commit 65fa87329ce577d1ee907c0716b48aac8c0d7d27 Merge: 5ceb88e6eb ab1b491f83 Author: Philip Kaludercic Date: Tue Oct 18 21:53:25 2022 +0200 Merge remote-tracking branch 'origin/master' into feature/package+vc commit 5ceb88e6ebf14cee3f97b0c7b8557e4b1e23de5b Author: Philip Kaludercic Date: Tue Oct 18 21:21:49 2022 +0200 Have 'vc-clone' return a directory * lisp/vc/vc-bzr.el (vc-bzr-clone): Return directory. * lisp/vc/vc-git.el (vc-git-clone): Return directory. * lisp/vc/vc-hg.el (vc-hg-clone): Return directory. * lisp/vc/vc-svn.el (vc-svn-clone): Return directory. * lisp/vc/vc.el (vc-clone): Ensure the backend returns directory. diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el index 307c5fa500..5e826b9a28 100644 --- a/lisp/vc/vc-bzr.el +++ b/lisp/vc/vc-bzr.el @@ -533,7 +533,8 @@ in the branch repository (or whose status not be determined)." (vc-message-unresolved-conflicts buffer-file-name))) (defun vc-bzr-clone (remote directory) - (vc-bzr-command nil 0 '() "branch" remote directory)) + (vc-bzr-command nil 0 '() "branch" remote directory) + directory) (defun vc-bzr-version-dirstate (dir) "Try to return as a string the bzr revision ID of directory DIR. diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index d63d755a28..366ab9a4f7 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1269,7 +1269,8 @@ This prompts for a branch to merge from." (vc-message-unresolved-conflicts buffer-file-name))) (defun vc-git-clone (remote directory) - (vc-git--out-ok "clone" remote directory)) + (vc-git--out-ok "clone" remote directory) + directory) ;;; HISTORY FUNCTIONS diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index ee54f34201..3ea4c5d32c 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -1251,7 +1251,8 @@ REV is the revision to check out into WORKFILE." (vc-message-unresolved-conflicts buffer-file-name))) (defun vc-hg-clone (remote directory) - (vc-hg-command nil 0 '() "clone" remote directory)) + (vc-hg-command nil 0 '() "clone" remote directory) + directory) ;; Modeled after the similar function in vc-bzr.el (defun vc-hg-revert (file &optional contents-done) diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el index 1aebf30c2a..ae6884bbae 100644 --- a/lisp/vc/vc-svn.el +++ b/lisp/vc/vc-svn.el @@ -818,7 +818,8 @@ Set file properties accordingly. If FILENAME is non-nil, return its status." (buffer-substring-no-properties (point-min) (1- (point-max)))))) (defun vc-svn-clone (remote directory) - (vc-svn-command nil 0 '() "checkout" remote directory)) + (vc-svn-command nil 0 '() "checkout" remote directory) + (file-name-concat directory "trunk")) (provide 'vc-svn) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 49bb7a27aa..76b8970b5b 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -588,7 +588,8 @@ ;; - clone (remote directory) ;; ;; Attempt to clone a REMOTE repository, into a local DIRECTORY. -;; Returns the symbol of the backend used if successful. +;; Returns a string with the directory with the contents of the +;; repository if successful, otherwise nil. ;;; Changes from the pre-25.1 API: ;; @@ -3517,24 +3518,23 @@ to provide the `find-revision' operation instead." (defun vc-clone (backend remote &optional directory) "Use BACKEND to clone REMOTE into DIRECTORY. -If successful, returns the symbol of the backed used to clone. -If BACKEND is nil, iterate through every known backend in -`vc-handled-backends' until one succeeds." +If successful, returns the a string with the directory of the +checkout. If BACKEND is nil, iterate through every known backend +in `vc-handled-backends' until one succeeds." (unless directory (setq directory default-directory)) (if backend (progn (unless (memq backend vc-handled-backends) (error "Unknown VC backend %s" backend)) - (vc-call-backend backend 'clone remote directory) - backend) + (vc-call-backend backend 'clone remote directory)) (catch 'ok (dolist (backend vc-handled-backends) (ignore-error vc-not-supported - (when-let (res (vc-call-backend - backend 'clone - remote directory)) - (throw 'ok backend))))))) + (when-let ((res (vc-call-backend + backend 'clone + remote directory))) + (throw 'ok res))))))) commit c25e78d8020364e1ecae795ffb79b1612bdc0d0b Author: Philip Kaludercic Date: Mon Oct 17 00:36:06 2022 +0200 * src/keyboard.c (echo_add_key): Mention quick-help diff --git a/src/keyboard.c b/src/keyboard.c index 8ab4a451b4..224512bfc9 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -503,9 +503,11 @@ echo_add_key (Lisp_Object c) if ((NILP (echo_string) || SCHARS (echo_string) == 0) && help_char_p (c)) { - AUTO_STRING (str, " (Type ? for further options)"); + AUTO_STRING (str, " (Type ? for further options, q for quick help)"); AUTO_LIST2 (props, Qface, Qhelp_key_binding); Fadd_text_properties (make_fixnum (7), make_fixnum (8), props, str); + Fadd_text_properties (make_fixnum (30), make_fixnum (31), props, +str); new_string = concat2 (new_string, str); } commit 39c9b6751ed0621dbb68b721ae48c685c18cee87 Author: Philip Kaludercic Date: Mon Oct 17 00:13:06 2022 +0200 Only clone packages if necessary * lisp/emacs-lisp/package-vc.el (package-vc-unpack): Check if directory exists before cloning. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index e146d89171..7098de2ece 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -267,11 +267,12 @@ The output is written out into PKG-FILE." ;; names to avoid an unnecessary error. (file-name-base repo))))) - ;; Clone the repository into `repo-dir'. - (make-directory (file-name-directory repo-dir) t) - (unless (setf (car (alist-get :upstream attr)) - (vc-clone backend repo repo-dir)) - (error "Failed to clone %s from %s" name repo)) + ;; Clone the repository into `repo-dir' if necessary + (unless (file-exists-p repo-dir) + (make-directory (file-name-directory repo-dir) t) + (unless (setf (car (alist-get :upstream attr)) + (vc-clone backend repo repo-dir)) + (error "Failed to clone %s from %s" name repo))) (unless (eq pkg-dir repo-dir) ;; Link from the right position in `repo-dir' to the package commit b4e833b2f8fa6962b66eddff420b366b07c48cf0 Author: Philip Kaludercic Date: Sun Oct 16 17:18:06 2022 +0200 Attempt to infer the package subject if missing * lisp/emacs-lisp/package-vc.el (package-vc-main-file): Add function. (package-vc-generate-description-file): Infer the subject. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index dfa8094e61..e146d89171 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -120,10 +120,32 @@ return it finally return "0")) +(defun package-vc-main-file (pkg-desc) + "Return the main file of the package PKG-DESC. +If no file can be found that appends \".el\" to the end of the +package name, the file with the closest file name is chosen." + (let* ((default-directory (package-desc-dir pkg-desc)) + (best (format "%s.el" (package-desc-name pkg-desc))) + (distance most-positive-fixnum) next-best) + (if (file-exists-p best) + (expand-file-name best) + (dolist (file (directory-files default-directory nil "\\.el\\'")) + (let ((distance* (string-distance best file))) + (when (< distance* distance) + (setq distance distance* next-best file)))) + next-best))) + (defun package-vc-generate-description-file (pkg-desc pkg-file) "Generate a package description file for PKG-DESC. The output is written out into PKG-FILE." - (let* ((name (package-desc-name pkg-desc))) + (let ((name (package-desc-name pkg-desc))) + ;; Infer the subject if missing. + (unless (package-desc-summary pkg-desc) + (setf (package-desc-summary pkg-desc) + (or (and-let* ((pkg (cadr (assq name package-archive-contents)))) + (package-desc-summary pkg)) + (lm-summary (package-vc-main-file pkg-desc)) + package--default-summary))) (let ((print-level nil) (print-quoted t) (print-length nil)) commit 5134eb02cf5cda16455e1b59b29ec82d491b115e Author: Philip Kaludercic Date: Sun Oct 16 13:37:29 2022 +0200 Mark source packages as always updatable * lisp/emacs-lisp/package.el (package--updateable-packages): Add check for source packages. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 6c92ff0ba7..245e41ee74 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2249,12 +2249,13 @@ to install it but still mark it as selected." #'car (seq-filter (lambda (elt) - (let ((available - (assq (car elt) package-archive-contents))) - (and available - (version-list-< - (package-desc-version (cadr elt)) - (package-desc-version (cadr available)))))) + (or (let ((available + (assq (car elt) package-archive-contents))) + (and available + (version-list-< + (package-desc-version (cadr elt)) + (package-desc-version (cadr available))))) + (package-vc-p (cadr (assq (car elt) package-alist))))) package-alist))) ;;;###autoload commit 3f7e746b514759b66c28d30ead24be08f0e01717 Author: Philip Kaludercic Date: Sun Oct 16 12:57:51 2022 +0200 Delete 'package-contact-maintainer' * doc/emacs/package.texi: Remove mention. * etc/NEWS: Remove mention. * lisp/emacs-lisp/package.el: Remove the command. diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index 087e506d6c..584f85567f 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -553,16 +553,14 @@ be regarded just like any other package, that can be updated (using @code{package-update}), deleted (using @code{package-delete}) and viewed in the package listing. -@findex package-contact-maintainer @findex package-report-bug @findex package-vc-prepare-patch With the source checkout, you might want to reproduce a bug against the current development head or implement a new feature to scratch an itch. If the package metadata indicates that a maintainer can be -contacted via Email, you can use the commands -@code{package-contact-maintainer} to send them a message, or -@code{package-report-bug} to report a bug that will include all the -user options that you have customised. Patches can be sent out using +contacted via Email, you can use the command @code{package-report-bug} +to report a bug that will include all the user options that you have +customised. Patches can be sent out using @code{package-vc-prepare-patch}, that makes use of @code{vc-prepare-patch} under the hold (@pxref{Preparing Patches}). diff --git a/etc/NEWS b/etc/NEWS index 965d2689b2..0b33718135 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1577,11 +1577,6 @@ symbolic link from the usual package directory to the checkout. This command allows you to send patches to package maintainers, for packages checked out using 'package-vc-install'. -+++ -*** New command 'package-contact-maintainer' -This command gives you a generic way to send messages to package -maintainers. - +++ *** New command 'package-report-bug' This command helps you compose an email for sending bug reports to diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 92f1533767..6c92ff0ba7 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2997,7 +2997,6 @@ either a full name or nil, and EMAIL is a valid email address." "r" #'revert-buffer "~" #'package-menu-mark-obsolete-for-deletion "w" #'package-browse-url - "m" #'package-contact-maintainer "b" #'package-report-bug "x" #'package-menu-execute "h" #'package-menu-quick-help @@ -4551,19 +4550,6 @@ will be signalled in that case." (package--print-email-button maint) (string-trim (substring-no-properties (buffer-string)))))))) -;; TODO: Allow attaching a patch to send directly to the maintainer. -;; Ideally this should be able to detect the local changes, convert -;; these into patches. -(defun package-contact-maintainer (desc) - "Prepare a message to send to the maintainers of a package. -DESC must be a `package-desc' object." - (interactive (list (package--query-desc package-archive-contents)) - package-menu-mode) - (let ((maint (package-maintainers desc)) - (name (package-desc-name desc)) - (subject (read-string "Subject: "))) - (compose-mail maint (format "[%s] %s" name subject)))) - (defun package-report-bug (desc) "Prepare a message to send to the maintainers of a package. DESC must be a `package-desc' object." commit 01e45efcd44e92dd259283df0e62653c7c20e9cc Merge: 982c0e6c15 5933055a3e Author: Philip Kaludercic Date: Sat Oct 15 17:38:30 2022 +0200 Merge branch 'master' into feature/package+vc commit 982c0e6c15535defcf6ac3c4d4169708c60efc18 Author: Philip Kaludercic Date: Wed Oct 12 21:31:20 2022 +0200 * etc/NEWS: Mention package-vc additions diff --git a/etc/NEWS b/etc/NEWS index ca857056fd..ab7145b0d9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1551,6 +1551,31 @@ These commands can be useful if the ".elc" files are out of date If no packages are marked, 'x' will install the package under point if it isn't already, and remove it if it is installed. ++++ +*** New command 'package-vc-install' +Packages can now be installed directly from source by cloning from a +repository. + ++++ +*** New command 'package-vc-link-directory' +An existing checkout can now be loaded via package.el, by creating a +symbolic link from the usual package directory to the checkout. + ++++ +*** New command 'package-vc-prepare-patch' +This command allows you to send patches to package maintainers, for +packages checked out using 'package-vc-install'. + ++++ +*** New command 'package-contact-maintainer' +This command gives you a generic way to send messages to package +maintainers. + ++++ +*** New command 'package-report-bug' +This command helps you compose an email for sending bug reports to +package maintainers. + ** Miscellaneous +++ commit 7cdc11ee990f7d22bc89994af092f991924cc50c Author: Philip Kaludercic Date: Wed Oct 12 21:30:57 2022 +0200 Document package-vc * doc/emacs/package.texi (Package Files): Add new node. diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index 420da09097..087e506d6c 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -49,6 +49,7 @@ Manual}. * Package Statuses:: Which statuses a package can have. * Package Installation:: Options for package installation. * Package Files:: Where packages are installed. +* Package from Source:: Managing packages directly from source. @end menu @node Package Menu @@ -530,3 +531,47 @@ are laid out in the same way as in @code{package-user-dir}. corresponding package subdirectory. This only works for packages installed in @code{package-user-dir}; if told to act on a package in a system-wide package directory, the deletion command signals an error. + +@node Package from Source +@section Package from Source +@cindex package source vcs git @c "git" is not technically correct + @c but it is a popular term + + By default @code{package-install} will download a Tarball from a +package archive and install the files therein contained. Most of the +time this is just what you want. One exception is when you decide to +hack on the source code of a package, and would like to share these +changes with other users. In that case you usually want to fetch and +work on the upstream source, so that you can prepare a usable patch. + +@findex package-vc-install + One way to do this is to use @code{package-vc-install}, to fetch the +source code for a package directly from source. The command will also +automatically ensure that all files are byte-compiled and auto-loaded, +just like with a regular package. From this point on the package can +be regarded just like any other package, that can be updated (using +@code{package-update}), deleted (using @code{package-delete}) and +viewed in the package listing. + +@findex package-contact-maintainer +@findex package-report-bug +@findex package-vc-prepare-patch + With the source checkout, you might want to reproduce a bug against +the current development head or implement a new feature to scratch an +itch. If the package metadata indicates that a maintainer can be +contacted via Email, you can use the commands +@code{package-contact-maintainer} to send them a message, or +@code{package-report-bug} to report a bug that will include all the +user options that you have customised. Patches can be sent out using +@code{package-vc-prepare-patch}, that makes use of +@code{vc-prepare-patch} under the hold (@pxref{Preparing Patches}). + +@findex package-vc-link-directory +@findex package-vc-refresh + If you maintain your own packages you might want to use a local +checkout instead of cloning a remote repository. This can be done +using @code{package-vc-link-directory}, that creates a symbolic link +from the package directory (@pxref{Package Files}) to your checkout +and initialises the code. Note that if changes are made such as +adding autoloads, you should use @code{package-vc-refresh} to repeat +the initialisation. commit 73669f73e65a038a6717377cf8308eba9b7ce2af Author: Philip Kaludercic Date: Wed Oct 12 21:25:54 2022 +0200 Allow specifying a package name for 'package-vc-link-directory' * lisp/emacs-lisp/package-vc.el (package-vc-link-directory): Add argument NAME diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index d513e9a733..dfa8094e61 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -339,9 +339,16 @@ be requested using REV." ;;;###autoload (defalias 'package-checkout #'package-vc-install) -(defun package-vc-link-directory (dir) - "Install the package in DIR by linking it into the ELPA directory." - (interactive (list (read-directory-name "Directory: "))) +(defun package-vc-link-directory (dir name) + "Install the package NAME in DIR by linking it into the ELPA directory. +If invoked interactively with a prefix argument, the user will be +prompted for the package NAME. Otherwise it will be inferred +from the base name of DIR." + (interactive (let ((dir (read-directory-name "Directory: "))) + (list dir + (if current-prefix-arg + (read-string "Package name: ") + (file-name-base (directory-file-name dir)))))) (unless (vc-responsible-backend dir) (user-error "Directory %S is not under version control" dir)) (package--archives-initialize) commit 0e3b67e3a37c01b71e6b97cd9b16ee28452a9f72 Author: Philip Kaludercic Date: Wed Oct 12 21:21:38 2022 +0200 * lisp/emacs-lisp/package-vc.el (package-vc-refresh): Add function. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 1ce43044d4..d513e9a733 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -353,6 +353,11 @@ be requested using REV." :kind 'vc) pkg-dir))) +(defun package-vc-refresh (pkg-desc) + "Refresh the installation for PKG-DESC." + (interactive (package-vc-read-pkg "Refresh package: ")) + (package-vc-unpack-1 pkg-desc (package-desc-dir pkg-desc))) + (defun package-vc-read-pkg (prompt) "Query for a source package description with PROMPT." (cadr (assoc (completing-read commit 0610e6f9f1f3b7aeafe4fff93188608827339532 Author: Philip Kaludercic Date: Wed Oct 12 20:42:19 2022 +0200 Rename 'package-vc-link-project' to 'package-vc-link-directory' * lisp/emacs-lisp/package-vc.el (package-vc-link-project): Rename it. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 3a1c89f73e..1ce43044d4 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -43,7 +43,6 @@ (require 'vc) (require 'seq) (require 'xdg) -(require 'project) (defgroup package-vc nil "Manage packages from VC checkouts." @@ -340,9 +339,9 @@ be requested using REV." ;;;###autoload (defalias 'package-checkout #'package-vc-install) -(defun package-vc-link-project (dir) +(defun package-vc-link-directory (dir) "Install the package in DIR by linking it into the ELPA directory." - (interactive (list (project-prompt-project-dir))) + (interactive (list (read-directory-name "Directory: "))) (unless (vc-responsible-backend dir) (user-error "Directory %S is not under version control" dir)) (package--archives-initialize) commit 22d768a29de0d3e768ab259f46e4152780258713 Author: Philip Kaludercic Date: Wed Oct 12 20:26:17 2022 +0200 Run 'package-vc-unpack-1' after updating source packages * lisp/emacs-lisp/package-vc.el (package-vc-update): Call 'package-vc-unpack-1'. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index a9aa685402..3a1c89f73e 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -281,9 +281,18 @@ The output is written out into PKG-FILE." (defun package-vc-update (pkg-desc) "Attempt to update the packager PKG-DESC." - (let ((default-directory (package-desc-dir pkg-desc))) - (with-demoted-errors "Error during package update: %S" - (vc-pull)))) + (let* ((default-directory (package-desc-dir pkg-desc)) + (ret (with-demoted-errors "Error during package update: %S" + (vc-pull))) + (buf (cond + ((processp ret) (process-buffer ret)) + ((bufferp ret) ret)))) + (if buf + (with-current-buffer buf + (vc-run-delayed + (package-vc-unpack-1 pkg-desc default-directory))) + (package-vc-unpack-1 pkg-desc default-directory)))) + ;;;###autoload (defun package-vc-install (name-or-url &optional name rev) commit 1a5e705dda54b74686cdc31543e4783a1f3337e1 Author: Philip Kaludercic Date: Wed Oct 12 16:30:01 2022 +0200 ; * lisp/vc/vc-cvs.el (vc-cvs-clone): Remove function diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index 0ebc258b5b..2dd3d416ac 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -1258,9 +1258,6 @@ ignore file." (if sort (sort-lines nil (point-min) (point-max))) (save-buffer))))) -(defun vc-cvs-clone (remote directory) - (vc-cvs-command nil 0 '() "checkout" "-d" directory remote)) - (defvar-keymap vc-cvs-log-view-mode-map "N" #'log-view-file-next "P" #'log-view-file-prev commit 576593a2b284e199c11394398a44ca28a4473cff Author: Philip Kaludercic Date: Wed Oct 12 16:09:25 2022 +0200 Add new command to install a package via symbolic linking * lisp/emacs-lisp/package-vc.el (package-vc-unpack-1): Add new function. (package-vc-unpack): Use 'package-vc-unpack-1'. (package-vc-link-project): Add new command. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index fd8639e4c5..a9aa685402 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -43,6 +43,7 @@ (require 'vc) (require 'seq) (require 'xdg) +(require 'project) (defgroup package-vc nil "Manage packages from VC checkouts." @@ -153,6 +154,72 @@ The output is written out into PKG-FILE." "\n") nil pkg-file nil 'silent)))) +(defun package-vc-unpack-1 (pkg-desc pkg-dir) + "Install PKG-DESC that is already located in PKG-DIR." + ;; In case the package was installed directly from source, the + ;; dependency list wasn't know beforehand, and they might have + ;; to be installed explicitly. + (let (deps) + (dolist (file (directory-files pkg-dir t "\\.el\\'" t)) + (with-temp-buffer + (insert-file-contents file) + (when-let* ((require-lines (lm-header-multiline "package-requires"))) + (thread-last + (mapconcat #'identity require-lines " ") + package-read-from-string + package--prepare-dependencies + (nconc deps) + (setq deps))))) + (dolist (dep deps) + (cl-callf version-to-list (cadr dep))) + (package-download-transaction + (package-compute-transaction nil (delete-dups deps)))) + + (let ((default-directory (file-name-as-directory pkg-dir)) + (name (package-desc-name pkg-desc)) + (pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir))) + ;; Generate autoloads + (package-generate-autoloads name pkg-dir) + (vc-ignore (concat "/" (file-relative-name + (expand-file-name (format "%s-autoloads.el" name)) + default-directory))) + + ;; Generate package file + (package-vc-generate-description-file pkg-desc pkg-file) + (vc-ignore (concat "/" (file-relative-name pkg-file default-directory))) + + ;; Detect a manual + (when (executable-find "install-info") + ;; Only proceed if we can find an unambiguous TeXinfo file + (let ((texi-files (directory-files pkg-dir t "\\.texi\\'")) + (dir-file (expand-file-name "dir" pkg-dir))) + (when (length= texi-files 1) + (call-process "install-info" nil nil nil + (concat "--dir=" dir-file) + (car texi-files))) + (vc-ignore "/dir")))) + + ;; Update package-alist. + (let ((new-desc (package-load-descriptor pkg-dir))) + ;; Activation has to be done before compilation, so that if we're + ;; upgrading and macros have changed we load the new definitions + ;; before compiling. + (when (package-activate-1 new-desc :reload :deps) + ;; FIXME: Compilation should be done as a separate, optional, step. + ;; E.g. for multi-package installs, we should first install all packages + ;; and then compile them. + (package--compile new-desc) + (when package-native-compile + (package--native-compile-async new-desc)) + ;; After compilation, load again any files loaded by + ;; `activate-1', so that we use the byte-compiled definitions. + (package--reload-previously-loaded new-desc))) + + ;; Mark package as selected + (package--save-selected-packages + (cons (package-desc-name pkg-desc) + package-selected-packages))) + (defun package-vc-unpack (pkg-desc) "Install the package described by PKG-DESC." (let* ((name (package-desc-name pkg-desc)) @@ -191,70 +258,9 @@ The output is written out into PKG-FILE." (make-symbolic-link (file-name-concat repo-dir dir) pkg-dir)) (when-let ((default-directory repo-dir) (rev (or (alist-get :rev attr) branch))) - (vc-retrieve-tag pkg-dir rev)) - - ;; In case the package was installed directly from source, the - ;; dependency list wasn't know beforehand, and they might have - ;; to be installed explicitly. - (let (deps) - (dolist (file (directory-files pkg-dir t "\\.el\\'" t)) - (with-temp-buffer - (insert-file-contents file) - (when-let* ((require-lines (lm-header-multiline "package-requires"))) - (thread-last - (mapconcat #'identity require-lines " ") - package-read-from-string - package--prepare-dependencies - (nconc deps) - (setq deps))))) - (dolist (dep deps) - (cl-callf version-to-list (cadr dep))) - (package-download-transaction - (package-compute-transaction nil (delete-dups deps))))) - - (let ((default-directory (file-name-as-directory pkg-dir)) - (name (package-desc-name pkg-desc)) - (pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir))) - ;; Generate autoloads - (package-generate-autoloads name pkg-dir) - (vc-ignore (concat "/" (file-relative-name - (expand-file-name (format "%s-autoloads.el" name)) - default-directory))) - - ;; Generate package file - (package-vc-generate-description-file pkg-desc pkg-file) - (vc-ignore (concat "/" (file-relative-name pkg-file default-directory))) - - ;; Detect a manual - (when (executable-find "install-info") - ;; Only proceed if we can find an unambiguous TeXinfo file - (let ((texi-files (directory-files pkg-dir t "\\.texi\\'")) - (dir-file (expand-file-name "dir" pkg-dir))) - (when (length= texi-files 1) - (call-process "install-info" nil nil nil - (concat "--dir=" dir-file) - (car texi-files))) - (vc-ignore "/dir")))) - - ;; Update package-alist. - (let ((new-desc (package-load-descriptor pkg-dir))) - ;; Activation has to be done before compilation, so that if we're - ;; upgrading and macros have changed we load the new definitions - ;; before compiling. - (when (package-activate-1 new-desc :reload :deps) - ;; FIXME: Compilation should be done as a separate, optional, step. - ;; E.g. for multi-package installs, we should first install all packages - ;; and then compile them. - (package--compile new-desc) - (when package-native-compile - (package--native-compile-async new-desc)) - ;; After compilation, load again any files loaded by - ;; `activate-1', so that we use the byte-compiled definitions. - (package--reload-previously-loaded new-desc))) - - ;; Mark package as selected - (package--save-selected-packages - (cons name package-selected-packages)))) + (vc-retrieve-tag pkg-dir rev))) + + (package-vc-unpack-1 pkg-desc pkg-dir))) (defun package-vc-sourced-packages-list () "Generate a list of packages with VC data." @@ -325,6 +331,20 @@ be requested using REV." ;;;###autoload (defalias 'package-checkout #'package-vc-install) +(defun package-vc-link-project (dir) + "Install the package in DIR by linking it into the ELPA directory." + (interactive (list (project-prompt-project-dir))) + (unless (vc-responsible-backend dir) + (user-error "Directory %S is not under version control" dir)) + (package--archives-initialize) + (let* ((name (file-name-base (directory-file-name dir))) + (pkg-dir (expand-file-name name package-user-dir))) + (make-symbolic-link dir pkg-dir) + (package-vc-unpack-1 (package-desc-create + :name (intern name) + :kind 'vc) + pkg-dir))) + (defun package-vc-read-pkg (prompt) "Query for a source package description with PROMPT." (cadr (assoc (completing-read commit 4a25205ec121926ffdbe2beee64dc10241b4cc6c Author: Philip Kaludercic Date: Wed Oct 12 14:49:23 2022 +0200 Only use 'package-vc-repository-store' if necessary * lisp/emacs-lisp/package-vc.el (package-vc-unpack): Check if the upstream data indicates a custom lisp directory. * lisp/emacs-lisp/package.el (package--delete-directory): Adapt accordingly. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index f5cf90963f..fd8639e4c5 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -155,8 +155,6 @@ The output is written out into PKG-FILE." (defun package-vc-unpack (pkg-desc) "Install the package described by PKG-DESC." - (unless (file-exists-p package-vc-repository-store) - (make-directory package-vc-repository-store t)) (let* ((name (package-desc-name pkg-desc)) (dirname (package-desc-full-name pkg-desc)) (pkg-dir (expand-file-name dirname package-user-dir))) @@ -169,12 +167,17 @@ The output is written out into PKG-FILE." (`(,backend ,repo ,dir ,branch) (or (alist-get :upstream attr) (error "Source package has no repository"))) - (repo-dir (file-name-concat - package-vc-repository-store - ;; FIXME: We aren't sure this directory - ;; will be unique, but we can try other - ;; names to avoid an unnecessary error. - (file-name-base repo)))) + (repo-dir + (if (null dir) + pkg-dir + (unless (file-exists-p package-vc-repository-store) + (make-directory package-vc-repository-store t)) + (file-name-concat + package-vc-repository-store + ;; FIXME: We aren't sure this directory + ;; will be unique, but we can try other + ;; names to avoid an unnecessary error. + (file-name-base repo))))) ;; Clone the repository into `repo-dir'. (make-directory (file-name-directory repo-dir) t) @@ -182,9 +185,10 @@ The output is written out into PKG-FILE." (vc-clone backend repo repo-dir)) (error "Failed to clone %s from %s" name repo)) - ;; Link from the right position in `repo-dir' to the package - ;; directory in the ELPA store. - (make-symbolic-link (file-name-concat repo-dir dir) pkg-dir) + (unless (eq pkg-dir repo-dir) + ;; Link from the right position in `repo-dir' to the package + ;; directory in the ELPA store. + (make-symbolic-link (file-name-concat repo-dir dir) pkg-dir)) (when-let ((default-directory repo-dir) (rev (or (alist-get :rev attr) branch))) (vc-retrieve-tag pkg-dir rev)) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 2748adddfb..106b7d5a8d 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2416,19 +2416,19 @@ compiled." (cl-loop for file in (directory-files-recursively dir "\\.el\\'") do (comp-clean-up-stale-eln (comp-el-to-eln-filename file)))) - (cond - ((not (package-vc-p pkg-desc)) - (delete-directory dir t)) - ((progn - (require 'package-vc) ;load `package-vc-repository-store' - (file-in-directory-p dir package-vc-repository-store)) - (delete-directory - (expand-file-name - (car (file-name-split - (file-relative-name dir package-vc-repository-store))) - package-vc-repository-store) - t) - (delete-file (directory-file-name dir))))) + (if (and (package-vc-p pkg-desc) + (require 'package-vc) ;load `package-vc-repository-store' + (file-in-directory-p dir package-vc-repository-store)) + (progn + (delete-directory + (expand-file-name + (car (file-name-split + (file-relative-name dir package-vc-repository-store))) + package-vc-repository-store) + t) + (delete-file (directory-file-name dir))) + (delete-directory dir t))) + (defun package-delete (pkg-desc &optional force nosave) "Delete package PKG-DESC. commit 8e6e6e6de511ea5cf664a17761e879077aa07e0d Author: Philip Kaludercic Date: Sun Oct 9 23:37:29 2022 +0200 Rename 'package-vc-fetch' to 'package-vc-install' * lisp/emacs-lisp/package-vc.el (package-vc-fetch): Rename to preserve symmetry with 'package-install'. (package-checkout): Follow the previous rename. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index e02213ed3f..f5cf90963f 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -30,7 +30,7 @@ ;; * Detect merge conflicts TODO ;; * Check if there are upstream changes TODO ;; - Allow finding revisions that bump the version tag TODO -;; * Allow for `package-vc-fetch' to use the version +;; * Allow for `package-vc-install' to use the version ;; of the package if already installed. ;; - Allow for ELPA specifications to be respected without TODO ;; endangering the user with arbitrary code execution @@ -276,7 +276,7 @@ The output is written out into PKG-FILE." (vc-pull)))) ;;;###autoload -(defun package-vc-fetch (name-or-url &optional name rev) +(defun package-vc-install (name-or-url &optional name rev) "Fetch the source of NAME-OR-URL. If NAME-OR-URL is a URL, then the package will be downloaded from the repository indicated by the URL. The function will try to @@ -319,7 +319,7 @@ be requested using REV." ((user-error "Unknown package to fetch: %s" name-or-url))))) ;;;###autoload -(defalias 'package-checkout #'package-vc-fetch) +(defalias 'package-checkout #'package-vc-install) (defun package-vc-read-pkg (prompt) "Query for a source package description with PROMPT." commit f74d52954bd5c5c9cfde01001a31bb300271ecd0 Author: Philip Kaludercic Date: Sat Oct 8 18:22:03 2022 +0200 * lisp/emacs-lisp/package-vc.el: Autoload 'package-vc-prepare-patch' diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 678b4f7a95..e02213ed3f 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -34,8 +34,6 @@ ;; of the package if already installed. ;; - Allow for ELPA specifications to be respected without TODO ;; endangering the user with arbitrary code execution -;; - Allow sending patches to package maintainers TODO -;; * Add `vc-send-patch' to vc.el TODO ;;; Code: @@ -333,6 +331,7 @@ be requested using REV." package-alist #'string=))) +;;;###autoload (defun package-vc-prepare-patch (pkg subject revisions) "Send a patch to the maintainer of a package PKG. SUBJECT and REVISIONS are used passed on to `vc-prepare-patch'. commit a4a825df829670f824de9b15583972f6898e0e18 Author: Philip Kaludercic Date: Sat Oct 8 00:13:55 2022 +0200 Clone packages into a separate directory * lisp/emacs-lisp/package-vc.el (package-vc-repository-store): Add new user option. (package-vc-unpack): Use 'package-vc-repository-store'. * lisp/emacs-lisp/package.el (package--delete-directory): Check and handle source packages. (package-delete): Invoke 'package--delete-directory' with an additional argument. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index d9903b3ca3..678b4f7a95 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -44,6 +44,7 @@ (require 'lisp-mnt) (require 'vc) (require 'seq) +(require 'xdg) (defgroup package-vc nil "Manage packages from VC checkouts." @@ -89,6 +90,12 @@ vc-handled-backends))) :version "29.1") +(defcustom package-vc-repository-store + (expand-file-name "emacs/vc-packages" (xdg-data-home)) + "Directory used by `package-vc-unpack' to store repositories." + :type 'directory + :version "29.1") + (defun package-vc-commit (pkg) "Extract the commit of a development package PKG." (cl-assert (package-vc-p pkg)) @@ -150,25 +157,39 @@ The output is written out into PKG-FILE." (defun package-vc-unpack (pkg-desc) "Install the package described by PKG-DESC." + (unless (file-exists-p package-vc-repository-store) + (make-directory package-vc-repository-store t)) (let* ((name (package-desc-name pkg-desc)) (dirname (package-desc-full-name pkg-desc)) (pkg-dir (expand-file-name dirname package-user-dir))) (setf (package-desc-dir pkg-desc) pkg-dir) (when (file-exists-p pkg-dir) (if (yes-or-no-p "Overwrite previous checkout?") - (package--delete-directory pkg-dir) + (package--delete-directory pkg-dir pkg-desc) (error "There already exists a checkout for %s" name))) (pcase-let* ((attr (package-desc-extras pkg-desc)) (`(,backend ,repo ,dir ,branch) (or (alist-get :upstream attr) - (error "Source package has no repository")))) - (make-directory (file-name-directory pkg-dir) t) + (error "Source package has no repository"))) + (repo-dir (file-name-concat + package-vc-repository-store + ;; FIXME: We aren't sure this directory + ;; will be unique, but we can try other + ;; names to avoid an unnecessary error. + (file-name-base repo)))) + + ;; Clone the repository into `repo-dir'. + (make-directory (file-name-directory repo-dir) t) (unless (setf (car (alist-get :upstream attr)) - (vc-clone backend repo pkg-dir)) + (vc-clone backend repo repo-dir)) (error "Failed to clone %s from %s" name repo)) - (when-let ((rev (or (alist-get :rev attr) branch))) + + ;; Link from the right position in `repo-dir' to the package + ;; directory in the ELPA store. + (make-symbolic-link (file-name-concat repo-dir dir) pkg-dir) + (when-let ((default-directory repo-dir) + (rev (or (alist-get :rev attr) branch))) (vc-retrieve-tag pkg-dir rev)) - (when dir (setq pkg-dir (file-name-concat pkg-dir dir))) ;; In case the package was installed directly from source, the ;; dependency list wasn't know beforehand, and they might have diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index ad01dbc197..2748adddfb 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2407,15 +2407,28 @@ installed), maybe you need to \\[package-refresh-contents]") pkg)) (declare-function comp-el-to-eln-filename "comp.c") -(defun package--delete-directory (dir) - "Delete DIR recursively. +(defvar package-vc-repository-store) +(defun package--delete-directory (dir pkg-desc) + "Delete PKG-DESC directory DIR recursively. Clean-up the corresponding .eln files if Emacs is native compiled." (when (featurep 'native-compile) (cl-loop for file in (directory-files-recursively dir "\\.el\\'") do (comp-clean-up-stale-eln (comp-el-to-eln-filename file)))) - (delete-directory dir t)) + (cond + ((not (package-vc-p pkg-desc)) + (delete-directory dir t)) + ((progn + (require 'package-vc) ;load `package-vc-repository-store' + (file-in-directory-p dir package-vc-repository-store)) + (delete-directory + (expand-file-name + (car (file-name-split + (file-relative-name dir package-vc-repository-store))) + package-vc-repository-store) + t) + (delete-file (directory-file-name dir))))) (defun package-delete (pkg-desc &optional force nosave) "Delete package PKG-DESC. @@ -2469,7 +2482,7 @@ If NOSAVE is non-nil, the package is not removed from (package-desc-name pkg-used-elsewhere-by))) (t (add-hook 'post-command-hook #'package-menu--post-refresh) - (package--delete-directory dir) + (package--delete-directory dir pkg-desc) ;; Remove NAME-VERSION.signed and NAME-readme.txt files. ;; ;; NAME-readme.txt files are no longer created, but they commit 7c66223dfba64c29afddf2f13cbf322d4cc4d12a Author: Philip Kaludercic Date: Fri Oct 7 22:36:12 2022 +0200 * lisp/emacs-lisp/package.el (package-report-bug): Use 'file-in-directory-p' diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 6e891fede1..ad01dbc197 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4555,16 +4555,15 @@ DESC must be a `package-desc' object." (let ((maint (package-maintainers desc)) (name (symbol-name (package-desc-name desc))) vars) - (let ((check (apply-partially #'file-equal-p (package-desc-dir desc)))) - (dolist-with-progress-reporter (group custom-current-group-alist) - "Scanning for modified user options..." - (dolist (ent (get (cdr group) 'custom-group)) - (when (and (custom-variable-p (car ent)) - (boundp (car ent)) - (not (eq (custom--standard-value (car ent)) - (default-toplevel-value (car ent)))) - (locate-dominating-file (car group) check)) - (push (car ent) vars))))) + (dolist-with-progress-reporter (group custom-current-group-alist) + "Scanning for modified user options..." + (dolist (ent (get (cdr group) 'custom-group)) + (when (and (custom-variable-p (car ent)) + (boundp (car ent)) + (not (eq (custom--standard-value (car ent)) + (default-toplevel-value (car ent)))) + (file-in-directory-p (car group) (package-desc-dir desc))) + (push (car ent) vars)))) (dlet ((reporter-prompt-for-summary-p t)) (reporter-submit-bug-report maint name vars)))) commit 432252c23f9855d9f43dabd600415305ab0c8b91 Author: Philip Kaludercic Date: Fri Oct 7 19:19:44 2022 +0200 Extend package-vc heuristics to multiple source forges * package-vc.el (package-vc-probable-repository-regexp): Rename to 'package-vc-heusitic-alist'. (package-vc-heusitic-alist): Add support for multiple VC backends. (package-vc-sourced-packages-list): Use 'package-vc-heusitic-alist' diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 2d3769448d..d9903b3ca3 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -50,24 +50,44 @@ :group 'package :version "29.1") -(defcustom package-vc-probable-repository-regexp - (rx bos "http" (? "s") "://" - (or (: (? "www.") "github.com" - "/" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "codeberg.org" - "/" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: (? "www.") "gitlab" (+ "." (+ alnum)) - "/" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "git.sr.ht" - "/~" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_")))) - (or (? "/") ".git") eos) - "Regular expression matching URLs that are repositories." - :version "29.1" - :type 'regex) +(defcustom package-vc-heusitic-alist + `((,(rx bos "http" (? "s") "://" + (or (: (? "www.") "github.com" + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "codeberg.org" + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: (? "www.") "gitlab" (+ "." (+ alnum)) + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "git.sr.ht" + "/~" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "git." (or "savannah" "sv") "." (? "non") "gnu.org/" + (or "r" "git") "/" + (+ (or alnum "-" "." "_")) (? "/"))) + (or (? "/") ".git") eos) + . Git) + (,(rx bos "http" (? "s") "://" + (or (: "hg.sr.ht" + "/~" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/" + (+ (or alnum "-" "." "_")) (? "/"))) + eos) + . Hg) + (,(rx bos "http" (? "s") "://" + (or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/" + (+ (or alnum "-" "." "_")) (? "/"))) + eos) + . Bzr)) + "Heuristic mapping URL regular expressions to VC backends." + :type `(alist :key-type (regexp :tag "Regular expression matching URLs") + :value-type (choice :tag "VC Backend" + ,@(mapcar (lambda (b) `(const ,b)) + vc-handled-backends))) + :version "29.1") (defun package-vc-commit (pkg) "Extract the commit of a development package PKG." @@ -223,14 +243,10 @@ The output is written out into PKG-FILE." ;; heuristic and use the URL header, that might already be ;; pointing towards a repository, and use that as a backup (and-let* ((url (alist-get :url extras)) - ((string-match-p package-vc-probable-repository-regexp - url))) - ;; XXX: Currently `package-vc-probable-repository-regexp' - ;; only contains Git repositories, so we can infer the - ;; repository type. This might work for now, but is not a - ;; particularly resilient approach. + (backend (alist-get url package-vc-heusitic-alist + nil nil #'string-match-p))) (setf (alist-get :vc (package-desc-extras (cadr pkg))) - (list 'Git url)) + (list backend url)) t)))) package-archive-contents)) commit 077c1533dffc4d1fbd05c8ec29e47bef09934bb8 Author: Philip Kaludercic Date: Fri Oct 7 18:59:42 2022 +0200 ; * package-vc.el (package-vc-read-pkg): Return package description diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index e03a5f73b4..2d3769448d 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -288,11 +288,13 @@ be requested using REV." (defun package-vc-read-pkg (prompt) "Query for a source package description with PROMPT." - (completing-read - prompt - package-alist - (lambda (pkg) (package-vc-p (cadr pkg))) - t)) + (cadr (assoc (completing-read + prompt + package-alist + (lambda (pkg) (package-vc-p (cadr pkg))) + t) + package-alist + #'string=))) (defun package-vc-prepare-patch (pkg subject revisions) "Send a patch to the maintainer of a package PKG. commit f9065c7951bd31b3475e2c425cd2b6c08e51b7e1 Author: Philip Kaludercic Date: Fri Oct 7 18:58:02 2022 +0200 Use 'package-vc-p' in package-vc.el * package-vc.el (package-vc-commit): Use it instead of 'eq'. (package-vc-version): Use it instead of 'eq'. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index d3850a5e2c..e03a5f73b4 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -71,7 +71,7 @@ (defun package-vc-commit (pkg) "Extract the commit of a development package PKG." - (cl-assert (eq (package-desc-kind pkg) 'vc)) + (cl-assert (package-vc-p pkg)) ;; FIXME: vc should be extended to allow querying the commit of a ;; directory (as is possible when dealing with git repositores). ;; This should be a fallback option. @@ -82,7 +82,7 @@ (defun package-vc-version (pkg) "Extract the commit of a development package PKG." - (cl-assert (eq (package-desc-kind pkg) 'vc)) + (cl-assert (package-vc-p pkg)) (cl-loop with dir = (package-desc-dir pkg) ;FIXME: dir is nil for file in (sort (directory-files dir t "\\.el\\'") (lambda (s1 s2) commit e092e60f1539898a42ed157b87bdd32f512109e0 Author: Philip Kaludercic Date: Fri Oct 7 18:57:00 2022 +0200 Add a package-vc command for submitting ptches * lisp/emacs-lisp/package-vc.el (package-vc-read-pkg): Add auxiliary command for querying source packages. (package-vc-prepare-patch): Add it. * lisp/emacs-lisp/package.el (package-maintainers): Add an optional NO-ERROR argument. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 2a45bacf6e..d3850a5e2c 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -286,5 +286,26 @@ be requested using REV." ;;;###autoload (defalias 'package-checkout #'package-vc-fetch) +(defun package-vc-read-pkg (prompt) + "Query for a source package description with PROMPT." + (completing-read + prompt + package-alist + (lambda (pkg) (package-vc-p (cadr pkg))) + t)) + +(defun package-vc-prepare-patch (pkg subject revisions) + "Send a patch to the maintainer of a package PKG. +SUBJECT and REVISIONS are used passed on to `vc-prepare-patch'. +PKG must be a package description." + (interactive + (list (package-vc-read-pkg "Package to prepare a patch for: ") + (and (not vc-prepare-patches-separately) + (read-string "Subject: " "[PATCH] " nil nil t)) + (or (log-view-get-marked) + (vc-read-multiple-revisions "Revisions: ")))) + (vc-prepare-patch (package-maintainers pkg t) + subject revisions)) + (provide 'package-vc) ;;; package-vc.el ends here diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 9ac94fa6bc..6e891fede1 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4516,20 +4516,23 @@ DESC must be a `package-desc' object." (funcall browse-url-secondary-browser-function url) (browse-url url)))) -(defun package-maintainers (pkg-desc) +(defun package-maintainers (pkg-desc &optional no-error) "Return an email address for the maintainers of PKG-DESC. The email address may contain commas, if there are multiple maintainers. If no maintainers are found, an error will be -thrown." +signalled. If the optional argument NO-ERROR is non-nil no error +will be signalled in that case." (unless pkg-desc - (user-error "Invalid package description")) + (error "Invalid package description")) (let* ((extras (package-desc-extras pkg-desc)) (maint (alist-get :maintainer extras))) - (unless maint + (cond + ((and (null maint) (null no-error)) (user-error "Package has no explicit maintainer")) - (with-temp-buffer - (package--print-email-button maint) - (string-trim (substring-no-properties (buffer-string)))))) + ((not (null maint)) + (with-temp-buffer + (package--print-email-button maint) + (string-trim (substring-no-properties (buffer-string)))))))) ;; TODO: Allow attaching a patch to send directly to the maintainer. ;; Ideally this should be able to detect the local changes, convert commit effe1f20f58bd92443e28cda2f0f65c681f1b387 Author: Philip Kaludercic Date: Fri Oct 7 18:52:17 2022 +0200 Extract package maintainer guessing code into a separate function * package.el (package-maintainers): Add new function. (package-contact-maintainer): Use it. (package-report-bug): Use it. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 48d78fab83..9ac94fa6bc 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4516,6 +4516,21 @@ DESC must be a `package-desc' object." (funcall browse-url-secondary-browser-function url) (browse-url url)))) +(defun package-maintainers (pkg-desc) + "Return an email address for the maintainers of PKG-DESC. +The email address may contain commas, if there are multiple +maintainers. If no maintainers are found, an error will be +thrown." + (unless pkg-desc + (user-error "Invalid package description")) + (let* ((extras (package-desc-extras pkg-desc)) + (maint (alist-get :maintainer extras))) + (unless maint + (user-error "Package has no explicit maintainer")) + (with-temp-buffer + (package--print-email-button maint) + (string-trim (substring-no-properties (buffer-string)))))) + ;; TODO: Allow attaching a patch to send directly to the maintainer. ;; Ideally this should be able to detect the local changes, convert ;; these into patches. @@ -4524,33 +4539,19 @@ DESC must be a `package-desc' object." DESC must be a `package-desc' object." (interactive (list (package--query-desc package-archive-contents)) package-menu-mode) - (unless desc - (user-error "No package here")) - (let* ((extras (package-desc-extras desc)) - (maint (alist-get :maintainer extras)) - (name (package-desc-name desc)) - (subject (read-string "Subject: "))) - (unless maint - (user-error "Package has no explicit maintainer")) - (compose-mail - (with-temp-buffer - (package--print-email-button maint) - (string-trim (substring-no-properties (buffer-string)))) - (format "[%s] %s" name subject)))) + (let ((maint (package-maintainers desc)) + (name (package-desc-name desc)) + (subject (read-string "Subject: "))) + (compose-mail maint (format "[%s] %s" name subject)))) (defun package-report-bug (desc) "Prepare a message to send to the maintainers of a package. DESC must be a `package-desc' object." (interactive (list (package--query-desc package-alist)) package-menu-mode) - (unless desc - (user-error "Package must be non-nil")) - (let* ((extras (package-desc-extras desc)) - (maint (alist-get :maintainer extras)) - vars) - (unless maint - (user-error "Package %s has no explicit maintainer" - (package-desc-name desc))) + (let ((maint (package-maintainers desc)) + (name (symbol-name (package-desc-name desc))) + vars) (let ((check (apply-partially #'file-equal-p (package-desc-dir desc)))) (dolist-with-progress-reporter (group custom-current-group-alist) "Scanning for modified user options..." @@ -4562,12 +4563,7 @@ DESC must be a `package-desc' object." (locate-dominating-file (car group) check)) (push (car ent) vars))))) (dlet ((reporter-prompt-for-summary-p t)) - (reporter-submit-bug-report - (with-temp-buffer - (package--print-email-button maint) - (string-trim (substring-no-properties (buffer-string)))) - (symbol-name (package-desc-name desc)) - vars)))) + (reporter-submit-bug-report maint name vars)))) ;;;; Introspection commit e75994f2ff0fb863cb978e354926d0d138d5b362 Author: Philip Kaludercic Date: Fri Oct 7 18:41:24 2022 +0200 Add an inline procedure for checking for source packages * package.el (eval-when-compile): Require 'inline during compilation. (package-vc-p): Add inline function. (package-desc-full-name): Use it. (package-load-descriptor): Use it. (package--get-activatable-pkg): Use it. (package-install-from-archive): Use it. (package-update): Use it. (package-desc-status): Use it. (package--remove-hidden): Use it. (package-menu--print-info-simple): Use it. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index b0659cd585..48d78fab83 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -146,6 +146,7 @@ (require 'cl-lib) (eval-when-compile (require 'subr-x)) (eval-when-compile (require 'epg)) ;For setf accessors. +(eval-when-compile (require 'inline)) ;For `define-inline' (require 'seq) (require 'tabulated-list) @@ -456,6 +457,11 @@ synchronously." (defvar package--default-summary "No description available.") +(define-inline package-vc-p (pkg-desc) + "Return non-nil if PKG-DESC is a source package." + (inline-letevals (pkg-desc) + (inline-quote (eq (package-desc-kind ,pkg-desc) 'vc)))) + (cl-defstruct (package-desc ;; Rename the default constructor from `make-package-desc'. (:constructor package-desc-create) @@ -571,7 +577,7 @@ This is, approximately, the inverse of `version-to-list'. (defun package-desc-full-name (pkg-desc) "Return full name of package-desc object PKG-DESC. This is the name of the package with its version appended." - (if (eq (package-desc-kind pkg-desc) 'vc) + (if (package-vc-p pkg-desc) (symbol-name (package-desc-name pkg-desc)) (format "%s-%s" (package-desc-name pkg-desc) @@ -720,7 +726,7 @@ return it." (read (current-buffer))) (error "Can't find define-package in %s" pkg-file)))) (setf (package-desc-dir pkg-desc) pkg-dir) - (when (eq (package-desc-kind pkg-desc) 'vc) + (when (package-vc-p pkg-desc) (require 'package-vc) (push (cons :commit (package-vc-commit pkg-desc)) (package-desc-extras pkg-desc))) @@ -911,8 +917,8 @@ correspond to previously loaded files (those returned by (v2 (package-desc-version p2))) (or ;; Prefer source packages. - (eq (package-desc-kind p1) 'vc) - (not (eq (package-desc-kind p2) 'vc)) + (package-vc-p p1) + (package-vc-p p2) ;; Prefer builtin packages. (package-disabled-p p1 v1) (not (package-disabled-p p2 v2)))))))) @@ -2076,7 +2082,7 @@ if all the in-between dependencies are also in PACKAGE-LIST." (defun package-install-from-archive (pkg-desc) "Download and install a package defined by PKG-DESC." ;; This won't happen, unless the archive is doing something wrong. - (when (eq (package-desc-kind pkg-desc) 'dir) + (when (package-vc-p pkg-desc) (error "Can't install directory package from archive")) (let* ((location (package-archive-base pkg-desc)) (file (concat (package-desc-full-name pkg-desc) @@ -2226,7 +2232,7 @@ to install it but still mark it as selected." name (intern name))) (pkg-desc (cadr (assq package package-alist)))) - (if (eq (package-desc-kind pkg-desc) 'vc) + (if (package-vc-p pkg-desc) (package-vc-update pkg-desc) (package-delete pkg-desc 'force) (package-install package 'dont-select)))) @@ -3134,7 +3140,7 @@ of these dependencies, similar to the list returned by (signed (or (not package-list-unsigned) (package-desc-signed pkg-desc)))) (cond - ((eq (package-desc-kind pkg-desc) 'vc) "source") + ((package-vc-p pkg-desc) "source") ((eq dir 'builtin) "built-in") ((and lle (null held)) "disabled") ((stringp held) @@ -3225,7 +3231,7 @@ to their archives." (let ((ins-version (package-desc-version installed))) (cl-remove-if (lambda (p) (or (version-list-= (package-desc-version p) ins-version) - (eq (package-desc-kind installed) 'vc))) + (package-vc-p installed))) filtered-by-priority)))))))) (defcustom package-hidden-regexps nil @@ -3482,7 +3488,7 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." package-desc ,pkg action package-menu-describe-package) ,(propertize - (if (eq (package-desc-kind pkg) 'vc) + (if (package-vc-p pkg) (progn (require 'package-vc) (package-vc-commit pkg)) commit 8cfeb8a9e0f69e3cd11aebe03da876e1c713a85f Merge: bb2bd2ed91 59df0a7bd9 Author: Philip Kaludercic Date: Sat Oct 8 11:56:23 2022 +0200 Merge branch 'master' into feature/package+vc commit bb2bd2ed91e123d66dfdf296a14e4cdd6739e2b6 Author: Philip Kaludercic Date: Fri Oct 7 16:44:28 2022 +0200 ; * vc-svn.el (vc-svn-clone): Fix typo diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el index cb50a37e09..6a6e586e17 100644 --- a/lisp/vc/vc-svn.el +++ b/lisp/vc/vc-svn.el @@ -818,7 +818,7 @@ Set file properties accordingly. If FILENAME is non-nil, return its status." (buffer-substring-no-properties (point-min) (1- (point-max)))))) (defun vc-svn-clone (remote directory) - (vc-svn-command nil 0 '() "checkout" remove directory)) + (vc-svn-command nil 0 '() "checkout" remote directory)) (provide 'vc-svn) commit 7c11398ca0a77eaf97448f0760800d6ec05fe22c Author: Philip Kaludercic Date: Thu Oct 6 21:45:36 2022 +0200 Add a generic bug reporting command for packages * lisp/emacs-lisp/package.el (package-menu-mode-map): Bind 'package-report-bug'. (package-report-bug): Add new command. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 2de5056475..e0fb4b0572 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2964,6 +2964,7 @@ either a full name or nil, and EMAIL is a valid email address." "~" #'package-menu-mark-obsolete-for-deletion "w" #'package-browse-url "m" #'package-contact-maintainer + "b" #'package-report-bug "x" #'package-menu-execute "h" #'package-menu-quick-help "H" #'package-menu-hide-package @@ -4516,6 +4517,37 @@ DESC must be a `package-desc' object." (string-trim (substring-no-properties (buffer-string)))) (format "[%s] %s" name subject)))) +(defun package-report-bug (desc) + "Prepare a message to send to the maintainers of a package. +DESC must be a `package-desc' object." + (interactive (list (package--query-desc package-alist)) + package-menu-mode) + (unless desc + (user-error "Package must be non-nil")) + (let* ((extras (package-desc-extras desc)) + (maint (alist-get :maintainer extras)) + vars) + (unless maint + (user-error "Package %s has no explicit maintainer" + (package-desc-name desc))) + (let ((check (apply-partially #'file-equal-p (package-desc-dir desc)))) + (dolist-with-progress-reporter (group custom-current-group-alist) + "Scanning for modified user options..." + (dolist (ent (get (cdr group) 'custom-group)) + (when (and (custom-variable-p (car ent)) + (boundp (car ent)) + (not (eq (custom--standard-value (car ent)) + (default-toplevel-value (car ent)))) + (locate-dominating-file (car group) check)) + (push (car ent) vars))))) + (dlet ((reporter-prompt-for-summary-p t)) + (reporter-submit-bug-report + (with-temp-buffer + (package--print-email-button maint) + (string-trim (substring-no-properties (buffer-string)))) + (symbol-name (package-desc-name desc)) + vars)))) + ;;;; Introspection (defun package-get-descriptor (pkg-name) commit b6132d84e94e317a8eea13a7a71a1b2d6f94153e Author: Philip Kaludercic Date: Thu Oct 6 17:04:31 2022 +0200 * lisp/vc/vc-svn.el (vc-svn-clone): Add 'clone' implementation diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el index 08b53a7169..cb50a37e09 100644 --- a/lisp/vc/vc-svn.el +++ b/lisp/vc/vc-svn.el @@ -817,6 +817,9 @@ Set file properties accordingly. If FILENAME is non-nil, return its status." "info" "--show-item" "repos-root-url") (buffer-substring-no-properties (point-min) (1- (point-max)))))) +(defun vc-svn-clone (remote directory) + (vc-svn-command nil 0 '() "checkout" remove directory)) + (provide 'vc-svn) ;;; vc-svn.el ends here commit 132e4fbbcb0d92ac1667a670adf05b7475fc6b13 Author: Philip Kaludercic Date: Thu Oct 6 17:02:00 2022 +0200 * lisp/vc/vc-cvs.el (vc-cvs-clone): Add 'clone' implementation diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index 52cc42791f..7d348240ba 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -1258,6 +1258,9 @@ ignore file." (if sort (sort-lines nil (point-min) (point-max))) (save-buffer))))) +(defun vc-cvs-clone (remote directory) + (vc-cvs-command nil 0 '() "checkout" "-d" directory remote)) + (defvar-keymap vc-cvs-log-view-mode-map "N" #'log-view-file-next "P" #'log-view-file-prev commit 3d0ab51826b077ae13a022c9d80df606f1a03454 Author: Philip Kaludercic Date: Thu Oct 6 16:54:02 2022 +0200 * lisp/vc/vc-bzr.el (vc-bzr-clone): Add 'clone' implementation diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el index f6b17d4ce0..743ee237a0 100644 --- a/lisp/vc/vc-bzr.el +++ b/lisp/vc/vc-bzr.el @@ -532,6 +532,9 @@ in the branch repository (or whose status not be determined)." (add-hook 'after-save-hook #'vc-bzr-resolve-when-done nil t) (vc-message-unresolved-conflicts buffer-file-name))) +(defun vc-bzr-clone (remote directory) + (vc-bzr-command nil 0 '() "branch" remote directory)) + (defun vc-bzr-version-dirstate (dir) "Try to return as a string the bzr revision ID of directory DIR. This uses the dirstate file's parent revision entry. commit daab6c16aa25f81f76bf89860872b9e3b36ca852 Author: Philip Kaludercic Date: Thu Oct 6 16:49:10 2022 +0200 * lisp/vc/vc-hg.el (vc-hg-clone): Add 'clone' implementation diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 61976288e3..a4ef7f3550 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -1249,6 +1249,8 @@ REV is the revision to check out into WORKFILE." (add-hook 'after-save-hook #'vc-hg-resolve-when-done nil t) (vc-message-unresolved-conflicts buffer-file-name))) +(defun vc-hg-clone (remote directory) + (vc-hg-command nil 0 '() "clone" remote directory)) ;; Modeled after the similar function in vc-bzr.el (defun vc-hg-revert (file &optional contents-done) commit d5dbf0804c5a3025f7946991a39ec26c01f76212 Author: Philip Kaludercic Date: Tue Aug 30 11:28:50 2022 +0200 * package-vc.el (package-vc-unpack): Fix 'vc-ignore' call When generating the manual node (/dir), we need to ensure that the default-directory is set to the package root, otherwise the file is ignored in some other repository, that probably doesn't exist. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index ee6a3e79dd..2a45bacf6e 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -169,7 +169,7 @@ The output is written out into PKG-FILE." (package-download-transaction (package-compute-transaction nil (delete-dups deps))))) - (let ((default-directory pkg-dir) + (let ((default-directory (file-name-as-directory pkg-dir)) (name (package-desc-name pkg-desc)) (pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir))) ;; Generate autoloads @@ -180,7 +180,18 @@ The output is written out into PKG-FILE." ;; Generate package file (package-vc-generate-description-file pkg-desc pkg-file) - (vc-ignore (concat "/" (file-relative-name pkg-file default-directory)))) + (vc-ignore (concat "/" (file-relative-name pkg-file default-directory))) + + ;; Detect a manual + (when (executable-find "install-info") + ;; Only proceed if we can find an unambiguous TeXinfo file + (let ((texi-files (directory-files pkg-dir t "\\.texi\\'")) + (dir-file (expand-file-name "dir" pkg-dir))) + (when (length= texi-files 1) + (call-process "install-info" nil nil nil + (concat "--dir=" dir-file) + (car texi-files))) + (vc-ignore "/dir")))) ;; Update package-alist. (let ((new-desc (package-load-descriptor pkg-dir))) @@ -198,17 +209,6 @@ The output is written out into PKG-FILE." ;; `activate-1', so that we use the byte-compiled definitions. (package--reload-previously-loaded new-desc))) - ;; Detect a manual - (when (executable-find "install-info") - ;; Only proceed if we can find an unambiguous TeXinfo file - (let ((texi-files (directory-files pkg-dir t "\\.texi\\'")) - (dir-file (expand-file-name "dir" pkg-dir))) - (when (length= texi-files 1) - (call-process "install-info" nil nil nil - (concat "--dir=" dir-file) - (car texi-files))) - (vc-ignore "/dir"))) - ;; Mark package as selected (package--save-selected-packages (cons name package-selected-packages)))) commit 54dbd7d55c3705c00482eed9272e70df259d7147 Author: Philip Kaludercic Date: Sat Aug 20 17:07:23 2022 +0200 * package-vc.el (package-vc-unpack): Ignore dir files diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index fb0d452450..ee6a3e79dd 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -206,7 +206,8 @@ The output is written out into PKG-FILE." (when (length= texi-files 1) (call-process "install-info" nil nil nil (concat "--dir=" dir-file) - (car texi-files))))) + (car texi-files))) + (vc-ignore "/dir"))) ;; Mark package as selected (package--save-selected-packages commit 820036dafe642f3319312c38ef442168aff17e84 Author: Philip Kaludercic Date: Fri Aug 19 20:37:09 2022 +0200 * package-vc.el (package-vc-unpack): Mark packages as selected diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index a3de07e503..fb0d452450 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -206,7 +206,11 @@ The output is written out into PKG-FILE." (when (length= texi-files 1) (call-process "install-info" nil nil nil (concat "--dir=" dir-file) - (car texi-files))))))) + (car texi-files))))) + + ;; Mark package as selected + (package--save-selected-packages + (cons name package-selected-packages)))) (defun package-vc-sourced-packages-list () "Generate a list of packages with VC data." commit d3f03666bbd6c506d65650c33413df826f502065 Merge: 57e16b316d 9f26a8d31b Author: Philip Kaludercic Date: Thu Aug 18 09:23:45 2022 +0200 Merge remote-tracking branch 'origin/master' into feature/package+vc commit 57e16b316d76b77de4252b7923eab8199b8c3fd5 Author: Philip Kaludercic Date: Fri Aug 12 17:02:20 2022 +0200 * package-vc.el (package-vc-fetch): Autoload it diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 27f1c7c3b7..a3de07e503 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -235,6 +235,7 @@ The output is written out into PKG-FILE." (with-demoted-errors "Error during package update: %S" (vc-pull)))) +;;;###autoload (defun package-vc-fetch (name-or-url &optional name rev) "Fetch the source of NAME-OR-URL. If NAME-OR-URL is a URL, then the package will be downloaded from commit 1823349e6a61b2997b27cdb1ff42c69739693455 Merge: faa7f03b0c 829b131e5b Author: Philip Kaludercic Date: Fri Aug 12 16:05:05 2022 +0200 Merge remote-tracking branch 'origin/master' into feature/package+vc commit faa7f03b0c5b6d2c51bb185cf5a0f422ba0fb956 Author: Philip Kaludercic Date: Thu Aug 11 14:19:26 2022 +0200 Add "send patches" note to package-vc TODO section diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 04821d43c4..27f1c7c3b7 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -34,6 +34,8 @@ ;; of the package if already installed. ;; - Allow for ELPA specifications to be respected without TODO ;; endangering the user with arbitrary code execution +;; - Allow sending patches to package maintainers TODO +;; * Add `vc-send-patch' to vc.el TODO ;;; Code: commit dd98fedd0c7f27bfba046d761042c19181cb461d Author: Philip Kaludercic Date: Thu Aug 11 14:05:01 2022 +0200 * package.el (describe-package-1): Add news if avaliable diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 0145306dc4..ab1a652188 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2658,7 +2658,10 @@ Helper function for `describe-package'." (incompatible-reason (package--incompatible-p desc)) (signed (if desc (package-desc-signed desc))) (maintainer (cdr (assoc :maintainer extras))) - (authors (cdr (assoc :authors extras)))) + (authors (cdr (assoc :authors extras))) + (news (and-let* ((file (expand-file-name "news" pkg-dir)) + ((file-readable-p file))) + file))) (when (string= status "avail-obso") (setq status "available obsolete")) (when incompatible-reason @@ -2857,6 +2860,14 @@ Helper function for `describe-package'." t) (insert (or readme-string "This package does not provide a description."))))) + + ;; Insert news if available. + (when news + (insert "\n" (make-separator-line) "\n" + (propertize "* News" 'face 'package-help-section-name) + "\n\n") + (insert-file-contents news)) + ;; Make library descriptions into links. (goto-char start-of-description) (package--describe-add-library-links) commit fb87d5008e21d1bc03547c1edf2280fb4cb8311e Author: Philip Kaludercic Date: Thu Aug 11 13:35:47 2022 +0200 * package.el (package--get-activatable-pkg): Prefer source packages diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 1ee39f8752..0145306dc4 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -898,14 +898,22 @@ correspond to previously loaded files (those returned by (defun package--get-activatable-pkg (pkg-name) ;; Is "activatable" a word? - (let ((pkg-descs (cdr (assq pkg-name package-alist)))) + (let ((pkg-descs (sort (cdr (assq pkg-name package-alist)) + (lambda (p1 p2) + (let ((v1 (package-desc-version p1)) + (v2 (package-desc-version p2))) + (or + ;; Prefer source packages. + (eq (package-desc-kind p1) 'vc) + (not (eq (package-desc-kind p2) 'vc)) + ;; Prefer builtin packages. + (package-disabled-p p1 v1) + (not (package-disabled-p p2 v2)))))))) ;; Check if PACKAGE is available in `package-alist'. (while (when pkg-descs (let ((available-version (package-desc-version (car pkg-descs)))) - (or (package-disabled-p pkg-name available-version) - ;; Prefer a builtin package. - (package-built-in-p pkg-name available-version)))) + (package-disabled-p pkg-name available-version))) (setq pkg-descs (cdr pkg-descs))) (car pkg-descs))) commit f5bb6b01318fe3a21493992e94908cf685e9b26b Author: Philip Kaludercic Date: Thu Aug 11 13:23:51 2022 +0200 Allow updating source packages * lisp/emacs-lisp/package-vc.el (package-vc-update): Add new function. * lisp/emacs-lisp/package.el (package-update): Use 'package-vc-update'. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 0f5ee4305a..04821d43c4 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -227,6 +227,12 @@ The output is written out into PKG-FILE." t)))) package-archive-contents)) +(defun package-vc-update (pkg-desc) + "Attempt to update the packager PKG-DESC." + (let ((default-directory (package-desc-dir pkg-desc))) + (with-demoted-errors "Error during package update: %S" + (vc-pull)))) + (defun package-vc-fetch (name-or-url &optional name rev) "Fetch the source of NAME-OR-URL. If NAME-OR-URL is a URL, then the package will be downloaded from diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 1321c3728e..1ee39f8752 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2194,17 +2194,22 @@ to install it but still mark it as selected." (message "Package `%s' installed." name)) (message "`%s' is already installed" name)))) +(declare-function package-vc-update "package-vc" (pkg)) + ;;;###autoload (defun package-update (name) "Update package NAME if a newer version exists." (interactive (list (completing-read "Update package: " (package--updateable-packages) nil t))) - (let ((package (if (symbolp name) - name - (intern name)))) - (package-delete (cadr (assq package package-alist)) 'force) - (package-install package 'dont-select))) + (let* ((package (if (symbolp name) + name + (intern name))) + (pkg-desc (cadr (assq package package-alist)))) + (if (eq (package-desc-kind pkg-desc) 'vc) + (package-vc-update pkg-desc) + (package-delete pkg-desc 'force) + (package-install package 'dont-select)))) (defun package--updateable-packages () ;; Initialize the package system to get the list of package commit 9ddc23cd3438cba85b8a41e78d335c0d5071a212 Author: Philip Kaludercic Date: Thu Aug 11 12:42:37 2022 +0200 Ignore files in .elpaignore during byte compilation * package.el (package--parse-elpaignore): Add new function. (package--compile): Bind 'byte-compile-ignore-files' to the result of 'package--parse-elpaignore'. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 5a707e1a60..0f5ee4305a 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -29,7 +29,6 @@ ;; - Allow for automatic updating TODO ;; * Detect merge conflicts TODO ;; * Check if there are upstream changes TODO -;; - Respect the .elpaignore file TODO ;; - Allow finding revisions that bump the version tag TODO ;; * Allow for `package-vc-fetch' to use the version ;; of the package if already installed. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index a582148640..1321c3728e 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -599,6 +599,25 @@ package." "Return the priority of the archive of package-desc object PKG-DESC." (package-archive-priority (package-desc-archive pkg-desc))) +(defun package--parse-elpaignore (pkg-desc) + "Return the of regular expression to match files ignored by PKG-DESC." + (let* ((pkg-dir (file-name-as-directory (package-desc-dir pkg-desc))) + (ignore (expand-file-name ".elpaignore" pkg-dir)) + files) + (when (file-exists-p ignore) + (with-temp-buffer + (insert-file-contents ignore) + (goto-char (point-min)) + (while (not (eobp)) + (push (wildcard-to-regexp + (let ((line (buffer-substring + (line-beginning-position) + (line-end-position)))) + (file-name-concat pkg-dir (string-trim-left line "/")))) + files) + (forward-line))) + files))) + (cl-defstruct (package--bi-desc (:constructor package-make-builtin (version summary)) (:type vector)) @@ -1073,11 +1092,13 @@ untar into a directory named DIR; otherwise, signal an error." ;;;; Compilation (defvar warning-minimum-level) +(defvar byte-compile-ignore-files) (defun package--compile (pkg-desc) "Byte-compile installed package PKG-DESC. This assumes that `pkg-desc' has already been activated with `package-activate-1'." - (let ((warning-minimum-level :error) + (let ((byte-compile-ignore-files (package--parse-elpaignore pkg-desc)) + (warning-minimum-level :error) (load-path load-path)) (byte-recompile-directory (package-desc-dir pkg-desc) 0 t))) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 2dcf8f5654..290054d523 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -573,6 +573,11 @@ ;; ;; Attempt to clone a REMOTE repository, into a local DIRECTORY. ;; Returns the symbol of the backend used if successful. +;; +;; - send-patch (addr &optional rev-list) +;; +;; Send a patch to ADDR + ;;; Changes from the pre-25.1 API: ;; commit 878cacc7127426a51feff28dd323674a7e62a5e0 Author: Philip Kaludercic Date: Thu Aug 11 12:40:17 2022 +0200 * package-vc.el (package-vc-unpack): Detect TeXinfo manuals diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 0776d2c0a8..5a707e1a60 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -195,7 +195,17 @@ The output is written out into PKG-FILE." (package--native-compile-async new-desc)) ;; After compilation, load again any files loaded by ;; `activate-1', so that we use the byte-compiled definitions. - (package--reload-previously-loaded new-desc))))) + (package--reload-previously-loaded new-desc))) + + ;; Detect a manual + (when (executable-find "install-info") + ;; Only proceed if we can find an unambiguous TeXinfo file + (let ((texi-files (directory-files pkg-dir t "\\.texi\\'")) + (dir-file (expand-file-name "dir" pkg-dir))) + (when (length= texi-files 1) + (call-process "install-info" nil nil nil + (concat "--dir=" dir-file) + (car texi-files))))))) (defun package-vc-sourced-packages-list () "Generate a list of packages with VC data." commit 8638aace3fbe01529f33870f469fa60bf5e43ee7 Author: Philip Kaludercic Date: Thu Aug 11 11:26:45 2022 +0200 Allow ignoring files during byte compilation * bytecomp.el (byte-compile-ignore-files): Add new variable. (byte-recompile-directory): Respect 'byte-compile-ignore-files'. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 1ecd77f751..b0ace9dae6 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1876,6 +1876,9 @@ Files in subdirectories of DIRECTORY are processed also." (interactive "DByte force recompile (directory): ") (byte-recompile-directory directory nil t)) +(defvar byte-compile-ignore-files nil + "List of regexps for files to ignore during byte compilation.") + ;;;###autoload (defun byte-recompile-directory (directory &optional arg force follow-symlinks) "Recompile every `.el' file in DIRECTORY that needs recompilation. @@ -1932,14 +1935,23 @@ also be compiled." ;; This file is a subdirectory. Handle them differently. (or (null arg) (eq 0 arg) (y-or-n-p (concat "Check " source "? "))) - (setq directories (nconc directories (list source)))) + (setq directories (nconc directories (list source))) + ;; Directory is requested to be ignored + (string-match-p + (regexp-opt byte-compile-ignore-files) + source) + (setq directories (nconc directories (list source)))) ;; It is an ordinary file. Decide whether to compile it. (if (and (string-match emacs-lisp-file-regexp source) ;; The next 2 tests avoid compiling lock files (file-readable-p source) (not (string-match "\\`\\.#" file)) (not (auto-save-file-name-p source)) - (not (member source (dir-locals--all-files directory)))) + (not (member source (dir-locals--all-files directory))) + ;; File is requested to be ignored + (string-match-p + (regexp-opt byte-compile-ignore-files) + source)) (progn (cl-incf (pcase (byte-recompile-file source force arg) ('no-byte-compile skip-count) commit 5fe97dd9dd8b0312541d8583b8cb3e36087beae5 Author: Philip Kaludercic Date: Thu Aug 11 10:55:43 2022 +0200 ; Require rx during byte compilation diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index bd02dcb072..0776d2c0a8 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -38,6 +38,7 @@ ;;; Code: +(eval-when-compile (require 'rx)) (require 'package) (require 'lisp-mnt) (require 'vc) commit 98381366b5fce7f54cd10545f051906fe9240f10 Author: Philip Kaludercic Date: Thu Aug 11 10:53:11 2022 +0200 Guess Git repositories from the URL header * package-vc.el (package-vc-probable-repository-regexp): Add new user option. (package-vc-sourced-packages-list): Add new function using 'package-vc-probable-repository-regexp'. (package-vc-fetch): Use 'package-vc-sourced-packages-list'. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index a6694edc9f..bd02dcb072 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -48,6 +48,25 @@ :group 'package :version "29.1") +(defcustom package-vc-probable-repository-regexp + (rx bos "http" (? "s") "://" + (or (: (? "www.") "github.com" + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "codeberg.org" + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: (? "www.") "gitlab" (+ "." (+ alnum)) + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "git.sr.ht" + "/~" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_")))) + (or (? "/") ".git") eos) + "Regular expression matching URLs that are repositories." + :version "29.1" + :type 'regex) + (defun package-vc-commit (pkg) "Extract the commit of a development package PKG." (cl-assert (eq (package-desc-kind pkg) 'vc)) @@ -177,6 +196,27 @@ The output is written out into PKG-FILE." ;; `activate-1', so that we use the byte-compiled definitions. (package--reload-previously-loaded new-desc))))) +(defun package-vc-sourced-packages-list () + "Generate a list of packages with VC data." + (seq-filter + (lambda (pkg) + (let ((extras (package-desc-extras (cadr pkg)))) + (or (alist-get :vc extras) + ;; If we have no explicit VC data, we can try a kind of + ;; heuristic and use the URL header, that might already be + ;; pointing towards a repository, and use that as a backup + (and-let* ((url (alist-get :url extras)) + ((string-match-p package-vc-probable-repository-regexp + url))) + ;; XXX: Currently `package-vc-probable-repository-regexp' + ;; only contains Git repositories, so we can infer the + ;; repository type. This might work for now, but is not a + ;; particularly resilient approach. + (setf (alist-get :vc (package-desc-extras (cadr pkg))) + (list 'Git url)) + t)))) + package-archive-contents)) + (defun package-vc-fetch (name-or-url &optional name rev) "Fetch the source of NAME-OR-URL. If NAME-OR-URL is a URL, then the package will be downloaded from @@ -191,10 +231,7 @@ be requested using REV." ;; Initialize the package system to get the list of package ;; symbols for completion. (package--archives-initialize) - (let* ((packages (seq-filter - (lambda (pkg) - (alist-get :vc (package-desc-extras (cadr pkg)))) - package-archive-contents)) + (let* ((packages (package-vc-sourced-packages-list)) (input (completing-read "Fetch package source (name or URL): " packages)) (name (file-name-base input))) commit d01445716d6e24548548ce7bffe3562b3427a602 Author: Philip Kaludercic Date: Wed Aug 3 20:25:17 2022 +0200 Only suggest packages with VC metadata * package-vc.el (package-vc-fetch): Filter out packages without :vc information in the interactive specification. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index f2bd507247..a6694edc9f 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -41,6 +41,7 @@ (require 'package) (require 'lisp-mnt) (require 'vc) +(require 'seq) (defgroup package-vc nil "Manage packages from VC checkouts." @@ -190,9 +191,12 @@ be requested using REV." ;; Initialize the package system to get the list of package ;; symbols for completion. (package--archives-initialize) - (let* ((input (completing-read - "Fetch package source (name or URL): " - package-archive-contents)) + (let* ((packages (seq-filter + (lambda (pkg) + (alist-get :vc (package-desc-extras (cadr pkg)))) + package-archive-contents)) + (input (completing-read + "Fetch package source (name or URL): " packages)) (name (file-name-base input))) (list input (intern (string-remove-prefix "emacs-" name)))))) (package--archives-initialize) commit 1b722606cad8899ac53e9c4effba4249f64a6a4b Author: Philip Kaludercic Date: Wed Aug 3 14:43:34 2022 +0200 * package-vc.el (package-vc-unpack): Delete using package--delete-directory diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index b54108a619..f2bd507247 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -114,7 +114,7 @@ The output is written out into PKG-FILE." (setf (package-desc-dir pkg-desc) pkg-dir) (when (file-exists-p pkg-dir) (if (yes-or-no-p "Overwrite previous checkout?") - (delete-directory pkg-dir t) + (package--delete-directory pkg-dir) (error "There already exists a checkout for %s" name))) (pcase-let* ((attr (package-desc-extras pkg-desc)) (`(,backend ,repo ,dir ,branch) commit e7ebdc29cecbd694d3ee1e081bef46155e707e10 Author: Philip Kaludercic Date: Wed Aug 3 13:47:54 2022 +0200 Add TODO section for package-vc diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 8b2b2f707d..b54108a619 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -24,6 +24,18 @@ ;; the source code, this extension allows for packages to be fetched ;; and updated directly from a version control system. +;;; TODO: + +;; - Allow for automatic updating TODO +;; * Detect merge conflicts TODO +;; * Check if there are upstream changes TODO +;; - Respect the .elpaignore file TODO +;; - Allow finding revisions that bump the version tag TODO +;; * Allow for `package-vc-fetch' to use the version +;; of the package if already installed. +;; - Allow for ELPA specifications to be respected without TODO +;; endangering the user with arbitrary code execution + ;;; Code: (require 'package) commit e9504782fe0cb9c64348b0466dba67cad0547460 Author: Philip Kaludercic Date: Tue Aug 2 17:34:14 2022 +0200 Have VC ignore auto generated files * package-vc.el (package-vc-unpack): Generate autoloads and ignore have the VCS ignore them (along with package description file). diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index f5263d08b9..8b2b2f707d 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -135,8 +135,19 @@ The output is written out into PKG-FILE." (package-download-transaction (package-compute-transaction nil (delete-dups deps))))) - (package-vc-generate-description-file - pkg-desc (file-name-concat pkg-dir (package--description-file pkg-dir))) + (let ((default-directory pkg-dir) + (name (package-desc-name pkg-desc)) + (pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir))) + ;; Generate autoloads + (package-generate-autoloads name pkg-dir) + (vc-ignore (concat "/" (file-relative-name + (expand-file-name (format "%s-autoloads.el" name)) + default-directory))) + + ;; Generate package file + (package-vc-generate-description-file pkg-desc pkg-file) + (vc-ignore (concat "/" (file-relative-name pkg-file default-directory)))) + ;; Update package-alist. (let ((new-desc (package-load-descriptor pkg-dir))) ;; Activation has to be done before compilation, so that if we're commit ffb06d910043bcbfad939e43442f81fe3421f0d5 Author: Philip Kaludercic Date: Tue Aug 2 17:12:45 2022 +0200 Assume VC data is directly usable in 'package-archive-contents' * package-vc.el (package-vc-fetch): Remove string parsing and translation code. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 7e76725a05..f5263d08b9 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -184,26 +184,14 @@ be requested using REV." (:rev . ,rev)))) ((when-let* ((desc (cadr (assoc name-or-url package-archive-contents #'string=))) - (spec (or (alist-get :vc (package-desc-extras desc)) - (user-error "Package has no VC header")))) - (unless (string-match - (rx bos - (group (+ alnum)) - (+ blank) (group (+ (not blank))) - (? (+ blank) (group (+ (not blank))) - (? (+ blank) (group (+ (not blank))))) - eos) - spec) - (user-error "Invalid repository specification %S" spec)) + (upstream (or (alist-get :vc (package-desc-extras desc)) + (user-error "Package has no VC data")))) (package-desc-create :name (if (stringp name-or-url) (intern name-or-url) name-or-url) :kind 'vc - :extras `((:upstream . ,(list (intern (match-string 1 spec)) - (match-string 2 spec) - (match-string 3 spec) - (match-string 4 spec))) + :extras `((:upstream . ,upstream) (:rev . ,rev))))) ((user-error "Unknown package to fetch: %s" name-or-url))))) commit 168929cf0d722a2fb52d3442b030b755d5e9c1b3 Author: Philip Kaludercic Date: Tue Aug 2 17:04:31 2022 +0200 * package-vc.el (vc-clone): Remove superfluous declaration diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index f95c79ccf2..7e76725a05 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -35,8 +35,6 @@ :group 'package :version "29.1") -(declare-function vc-clone "vc" (backend remote &optional directory)) - (defun package-vc-commit (pkg) "Extract the commit of a development package PKG." (cl-assert (eq (package-desc-kind pkg) 'vc)) commit f3e7820b480b4aa7a70f3ae6b2d775eba468a472 Author: Philip Kaludercic Date: Sun Jul 31 21:32:38 2022 +0200 Extract package-fetch and related functionality Note that the "package kind" was renamed from "source" to "vc". * package-vc.el: (package-vc-commit): Copy from package.el (package-vc-version): Add new function (package-vc-generate-description-file): Add new function. (package-vc-unpack): Add new function. (package-vc-fetch): Copy from package.el (package-checkout): Add alias for package-vc-fetch * package.el (package-devel-dir): Remove option. The checkouts are stored in package-user-dir (package-desc): Handle (vc . VERS) version strings (package-desc-full-name): Return the plain name for vc packages (package-devel-commit): Move function to package-vc (package-load-descriptor): Refactor according to other changes (package-load-all-descriptors): Remove package-devel-dir (package-unpack): Remove vc package handling (package-generate-description-file): Remove special handling for vc packages (package-install-from-archive): Remove special handling for vc packages (package-fetch): Move function to package-vc (package-desc-status): Use "vc" instead of "source" (package--remove-hidden): Use "vc" instead of "source" (package-menu--print-info-simple): Refactor according to other changes diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el new file mode 100644 index 0000000000..f95c79ccf2 --- /dev/null +++ b/lisp/emacs-lisp/package-vc.el @@ -0,0 +1,216 @@ +;;; package-vc.el --- Manage packages from VC checkouts -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: Philip Kaludercic +;; Keywords: tools + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; While packages managed by package.el use tarballs for distributing +;; the source code, this extension allows for packages to be fetched +;; and updated directly from a version control system. + +;;; Code: + +(require 'package) +(require 'lisp-mnt) +(require 'vc) + +(defgroup package-vc nil + "Manage packages from VC checkouts." + :group 'package + :version "29.1") + +(declare-function vc-clone "vc" (backend remote &optional directory)) + +(defun package-vc-commit (pkg) + "Extract the commit of a development package PKG." + (cl-assert (eq (package-desc-kind pkg) 'vc)) + ;; FIXME: vc should be extended to allow querying the commit of a + ;; directory (as is possible when dealing with git repositores). + ;; This should be a fallback option. + (cl-loop with dir = (package-desc-dir pkg) + for file in (directory-files dir t "\\.el\\'" t) + when (vc-working-revision file) return it + finally return "unknown")) + +(defun package-vc-version (pkg) + "Extract the commit of a development package PKG." + (cl-assert (eq (package-desc-kind pkg) 'vc)) + (cl-loop with dir = (package-desc-dir pkg) ;FIXME: dir is nil + for file in (sort (directory-files dir t "\\.el\\'") + (lambda (s1 s2) + (< (length s1) (length s2)))) + when (with-temp-buffer + (insert-file-contents file) + (package-strip-rcs-id + (or (lm-header "package-version") + (lm-header "version")))) + return it + finally return "0")) + +(defun package-vc-generate-description-file (pkg-desc pkg-file) + "Generate a package description file for PKG-DESC. +The output is written out into PKG-FILE." + (let* ((name (package-desc-name pkg-desc))) + (let ((print-level nil) + (print-quoted t) + (print-length nil)) + (write-region + (concat + ";;; Generated package description from " + (replace-regexp-in-string + "-pkg\\.el\\'" ".el" + (file-name-nondirectory pkg-file)) + " -*- no-byte-compile: t -*-\n" + (prin1-to-string + (nconc + (list 'define-package + (symbol-name name) + (cons 'vc (package-vc-version pkg-desc)) + (package-desc-summary pkg-desc) + (let ((requires (package-desc-reqs pkg-desc))) + (list 'quote + ;; Turn version lists into string form. + (mapcar + (lambda (elt) + (list (car elt) + (package-version-join (cadr elt)))) + requires)))) + (package--alist-to-plist-args + (package-desc-extras pkg-desc)))) + "\n") + nil pkg-file nil 'silent)))) + +(defun package-vc-unpack (pkg-desc) + "Install the package described by PKG-DESC." + (let* ((name (package-desc-name pkg-desc)) + (dirname (package-desc-full-name pkg-desc)) + (pkg-dir (expand-file-name dirname package-user-dir))) + (setf (package-desc-dir pkg-desc) pkg-dir) + (when (file-exists-p pkg-dir) + (if (yes-or-no-p "Overwrite previous checkout?") + (delete-directory pkg-dir t) + (error "There already exists a checkout for %s" name))) + (pcase-let* ((attr (package-desc-extras pkg-desc)) + (`(,backend ,repo ,dir ,branch) + (or (alist-get :upstream attr) + (error "Source package has no repository")))) + (make-directory (file-name-directory pkg-dir) t) + (unless (setf (car (alist-get :upstream attr)) + (vc-clone backend repo pkg-dir)) + (error "Failed to clone %s from %s" name repo)) + (when-let ((rev (or (alist-get :rev attr) branch))) + (vc-retrieve-tag pkg-dir rev)) + (when dir (setq pkg-dir (file-name-concat pkg-dir dir))) + + ;; In case the package was installed directly from source, the + ;; dependency list wasn't know beforehand, and they might have + ;; to be installed explicitly. + (let (deps) + (dolist (file (directory-files pkg-dir t "\\.el\\'" t)) + (with-temp-buffer + (insert-file-contents file) + (when-let* ((require-lines (lm-header-multiline "package-requires"))) + (thread-last + (mapconcat #'identity require-lines " ") + package-read-from-string + package--prepare-dependencies + (nconc deps) + (setq deps))))) + (dolist (dep deps) + (cl-callf version-to-list (cadr dep))) + (package-download-transaction + (package-compute-transaction nil (delete-dups deps))))) + + (package-vc-generate-description-file + pkg-desc (file-name-concat pkg-dir (package--description-file pkg-dir))) + ;; Update package-alist. + (let ((new-desc (package-load-descriptor pkg-dir))) + ;; Activation has to be done before compilation, so that if we're + ;; upgrading and macros have changed we load the new definitions + ;; before compiling. + (when (package-activate-1 new-desc :reload :deps) + ;; FIXME: Compilation should be done as a separate, optional, step. + ;; E.g. for multi-package installs, we should first install all packages + ;; and then compile them. + (package--compile new-desc) + (when package-native-compile + (package--native-compile-async new-desc)) + ;; After compilation, load again any files loaded by + ;; `activate-1', so that we use the byte-compiled definitions. + (package--reload-previously-loaded new-desc))))) + +(defun package-vc-fetch (name-or-url &optional name rev) + "Fetch the source of NAME-OR-URL. +If NAME-OR-URL is a URL, then the package will be downloaded from +the repository indicated by the URL. The function will try to +guess the name of the package using `file-name-base'. This can +be overridden by manually passing the optional NAME. Otherwise +NAME-OR-URL is taken to be a package name, and the package +metadata will be consulted for the URL. An explicit revision can +be requested using REV." + (interactive + (progn + ;; Initialize the package system to get the list of package + ;; symbols for completion. + (package--archives-initialize) + (let* ((input (completing-read + "Fetch package source (name or URL): " + package-archive-contents)) + (name (file-name-base input))) + (list input (intern (string-remove-prefix "emacs-" name)))))) + (package--archives-initialize) + (package-vc-unpack + (cond + ((and (stringp name-or-url) + (url-type (url-generic-parse-url name-or-url))) + (package-desc-create + :name (or name (intern (file-name-base name-or-url))) + :kind 'vc + :extras `((:upstream . ,(list nil name-or-url nil nil)) + (:rev . ,rev)))) + ((when-let* ((desc (cadr (assoc name-or-url package-archive-contents + #'string=))) + (spec (or (alist-get :vc (package-desc-extras desc)) + (user-error "Package has no VC header")))) + (unless (string-match + (rx bos + (group (+ alnum)) + (+ blank) (group (+ (not blank))) + (? (+ blank) (group (+ (not blank))) + (? (+ blank) (group (+ (not blank))))) + eos) + spec) + (user-error "Invalid repository specification %S" spec)) + (package-desc-create + :name (if (stringp name-or-url) + (intern name-or-url) + name-or-url) + :kind 'vc + :extras `((:upstream . ,(list (intern (match-string 1 spec)) + (match-string 2 spec) + (match-string 3 spec) + (match-string 4 spec))) + (:rev . ,rev))))) + ((user-error "Unknown package to fetch: %s" name-or-url))))) + +;;;###autoload +(defalias 'package-checkout #'package-vc-fetch) + +(provide 'package-vc) +;;; package-vc.el ends here diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 858214611f..a582148640 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -304,17 +304,6 @@ packages in `package-directory-list'." :group 'applications :version "24.1") -(defcustom package-devel-dir (expand-file-name "devel" package-user-dir) - "Directory containing the user's Emacs Lisp package checkouts. -The directory name should be absolute. -Apart from this directory, Emacs also looks for system-wide -packages in `package-directory-list'." - :type 'directory - :initialize #'custom-initialize-delay - :set-after '(package-user-dir) - :risky t - :version "29.1") - ;;;###autoload (defcustom package-directory-list ;; Defaults are subdirs named "elpa" in the site-lisp dirs. @@ -472,14 +461,18 @@ synchronously." &rest rest-plist &aux (name (intern name-string)) - (version (and version-string (version-to-list version-string))) + (version (if (eq (car-safe version-string) 'vc) + (version-to-list (cdr version-string)) + (version-to-list version-string))) (reqs (mapcar (lambda (elt) (list (car elt) (version-to-list (cadr elt)))) (if (eq 'quote (car requirements)) (nth 1 requirements) requirements))) - (kind (plist-get rest-plist :kind)) + (kind (if (eq (car-safe version-string) 'vc) + 'vc + (plist-get rest-plist :kind))) (archive (plist-get rest-plist :archive)) (extras (let (alist) (while rest-plist @@ -571,10 +564,10 @@ This is, approximately, the inverse of `version-to-list'. (defun package-desc-full-name (pkg-desc) "Return full name of package-desc object PKG-DESC. This is the name of the package with its version appended." - (format "%s-%s" - (package-desc-name pkg-desc) - (if (eq (package-desc-kind pkg-desc) 'source) - "devel" + (if (eq (package-desc-kind pkg-desc) 'vc) + (symbol-name (package-desc-name pkg-desc)) + (format "%s-%s" + (package-desc-name pkg-desc) (package-version-join (package-desc-version pkg-desc))))) (defun package-desc-suffix (pkg-desc) @@ -654,6 +647,8 @@ loaded and/or activated, customize `package-load-list'.") ;; `package-load-all-descriptors', which ultimately populates the ;; `package-alist' variable. +(declare-function package-vc-version "package-vc" (pkg)) + (defun package-process-define-package (exp) "Process define-package expression EXP and push it to `package-alist'. EXP should be a form read from a foo-pkg.el file. @@ -682,15 +677,7 @@ are sorted with the highest version first." nil))) new-pkg-desc))) -(declare-function vc-working-revision "vc" (file &optional backend)) -(defun package-devel-commit (pkg) - "Extract the commit of a development package PKG." - (cl-assert (eq (package-desc-kind pkg) 'source)) - (require 'vc) - (cl-loop with dir = (package-desc-dir pkg) - for file in (directory-files dir t "\\.el\\'" t) - when (vc-working-revision file) return it - finally return "unknown")) +(declare-function package-vc-commit "package-vc" (pkg)) (defun package-load-descriptor (pkg-dir) "Load the package description file in directory PKG-DIR. @@ -707,13 +694,9 @@ return it." (read (current-buffer))) (error "Can't find define-package in %s" pkg-file)))) (setf (package-desc-dir pkg-desc) pkg-dir) - (when (file-exists-p (expand-file-name - (symbol-name (package-desc-name pkg-desc)) - package-devel-dir)) - ;; XXX: This check seems dirty, there should be a better - ;; way to deduce if a package is in the devel directory. - (setf (package-desc-kind pkg-desc) 'source) - (push (cons :commit (package-devel-commit pkg-desc)) + (when (eq (package-desc-kind pkg-desc) 'vc) + (require 'package-vc) + (push (cons :commit (package-vc-commit pkg-desc)) (package-desc-extras pkg-desc))) (if (file-exists-p signed-file) (setf (package-desc-signed pkg-desc) t)) @@ -728,9 +711,7 @@ controls which package subdirectories may be loaded. In each valid package subdirectory, this function loads the description file containing a call to `define-package', which updates `package-alist'." - (dolist (dir (cl-list* package-user-dir - package-devel-dir - package-directory-list)) + (dolist (dir (cons package-user-dir package-directory-list)) (when (file-directory-p dir) (dolist (pkg-dir (directory-files dir t "^[^.]" t)) (when (file-directory-p pkg-dir) @@ -964,51 +945,12 @@ untar into a directory named DIR; otherwise, signal an error." (apply #'nconc (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist)))) -(declare-function vc-clone "vc" (backend remote &optional directory)) - (defun package-unpack (pkg-desc) "Install the contents of the current buffer as a package." (let* ((name (package-desc-name pkg-desc)) (dirname (package-desc-full-name pkg-desc)) (pkg-dir (expand-file-name dirname package-user-dir))) (pcase (package-desc-kind pkg-desc) - ('source - (setq pkg-dir (expand-file-name (symbol-name name) package-devel-dir)) - (when (file-exists-p pkg-dir) - (if (and (called-interactively-p 'interactive) - (yes-or-no-p "Overwrite previous checkout?")) - (delete-directory pkg-dir t) - (error "There already exists a checkout for %s" name))) - (pcase-let* ((attr (package-desc-extras pkg-desc)) - (`(,backend ,repo ,dir ,branch) - (or (alist-get :upstream attr) - (error "Source package has no repository")))) - (require 'vc) - (make-directory (file-name-directory (file-name-directory pkg-dir)) t) - (unless (setf (car (alist-get :upstream attr)) - (vc-clone backend repo pkg-dir)) - (error "Failed to clone %s from %s" name repo)) - (when-let ((rev (or (alist-get :rev attr) branch))) - (vc-retrieve-tag pkg-dir rev)) - (when dir (setq pkg-dir (file-name-concat pkg-dir dir))) - ;; In case the package was installed directly from source, the - ;; dependency list wasn't know beforehand, and they might have - ;; to be installed explicitly. - (let (deps) - (dolist (file (directory-files pkg-dir t "\\.el\\'" t)) - (with-temp-buffer - (insert-file-contents file) - (when-let* ((require-lines (lm-header-multiline "package-requires"))) - (thread-last - (mapconcat #'identity require-lines " ") - package-read-from-string - package--prepare-dependencies - (nconc deps) - (setq deps))))) - (dolist (dep deps) - (cl-callf version-to-list (cadr dep))) - (package-download-transaction - (package-compute-transaction nil (delete-dups deps)))))) ('dir (make-directory pkg-dir t) (let ((file-list @@ -1035,9 +977,8 @@ untar into a directory named DIR; otherwise, signal an error." (package--make-autoloads-and-stuff pkg-desc pkg-dir) ;; Update package-alist. (let ((new-desc (package-load-descriptor pkg-dir))) - (unless (or (equal (package-desc-full-name new-desc) - (package-desc-full-name pkg-desc)) - (eq (package-desc-kind pkg-desc) 'source)) + (unless (equal (package-desc-full-name new-desc) + (package-desc-full-name pkg-desc)) (error "The retrieved package (`%s') doesn't match what the archive offered (`%s')" (package-desc-full-name new-desc) (package-desc-full-name pkg-desc))) ;; Activation has to be done before compilation, so that if we're @@ -1071,8 +1012,7 @@ untar into a directory named DIR; otherwise, signal an error." (nconc (list 'define-package (symbol-name name) - (and (not (eq (package-desc-kind pkg-desc) 'source)) - (package-version-join (package-desc-version pkg-desc))) + (package-version-join (package-desc-version pkg-desc)) (package-desc-summary pkg-desc) (let ((requires (package-desc-reqs pkg-desc))) (list 'quote @@ -1087,6 +1027,7 @@ untar into a directory named DIR; otherwise, signal an error." "\n") nil pkg-file nil 'silent)))) + ;;;; Autoload (declare-function autoload-rubric "autoload" (file &optional type feature)) @@ -2099,48 +2040,46 @@ if all the in-between dependencies are also in PACKAGE-LIST." ;; This won't happen, unless the archive is doing something wrong. (when (eq (package-desc-kind pkg-desc) 'dir) (error "Can't install directory package from archive")) - (if (eq (package-desc-kind pkg-desc) 'source) - (package-unpack pkg-desc) - (let* ((location (package-archive-base pkg-desc)) - (file (concat (package-desc-full-name pkg-desc) - (package-desc-suffix pkg-desc)))) - (package--with-response-buffer location :file file - (if (or (not (package-check-signature)) - (member (package-desc-archive pkg-desc) - package-unsigned-archives)) - ;; If we don't care about the signature, unpack and we're - ;; done. - (let ((save-silently t)) - (package-unpack pkg-desc)) - ;; If we care, check it and *then* write the file. - (let ((content (buffer-string))) - (package--check-signature - location file content nil - ;; This function will be called after signature checking. - (lambda (&optional good-sigs) - ;; Signature checked, unpack now. - (with-temp-buffer ;FIXME: Just use the previous current-buffer. - (set-buffer-multibyte nil) - (cl-assert (not (multibyte-string-p content))) - (insert content) - (let ((save-silently t)) - (package-unpack pkg-desc))) - ;; Here the package has been installed successfully, mark it as - ;; signed if appropriate. - (when good-sigs - ;; Write out good signatures into NAME-VERSION.signed file. - (write-region (mapconcat #'epg-signature-to-string good-sigs "\n") - nil - (expand-file-name - (concat (package-desc-full-name pkg-desc) ".signed") - package-user-dir) - nil 'silent) - ;; Update the old pkg-desc which will be shown on the description buffer. - (setf (package-desc-signed pkg-desc) t) - ;; Update the new (activated) pkg-desc as well. - (when-let* ((pkg-descs (cdr (assq (package-desc-name pkg-desc) - package-alist)))) - (setf (package-desc-signed (car pkg-descs)) t))))))))))) + (let* ((location (package-archive-base pkg-desc)) + (file (concat (package-desc-full-name pkg-desc) + (package-desc-suffix pkg-desc)))) + (package--with-response-buffer location :file file + (if (or (not (package-check-signature)) + (member (package-desc-archive pkg-desc) + package-unsigned-archives)) + ;; If we don't care about the signature, unpack and we're + ;; done. + (let ((save-silently t)) + (package-unpack pkg-desc)) + ;; If we care, check it and *then* write the file. + (let ((content (buffer-string))) + (package--check-signature + location file content nil + ;; This function will be called after signature checking. + (lambda (&optional good-sigs) + ;; Signature checked, unpack now. + (with-temp-buffer ;FIXME: Just use the previous current-buffer. + (set-buffer-multibyte nil) + (cl-assert (not (multibyte-string-p content))) + (insert content) + (let ((save-silently t)) + (package-unpack pkg-desc))) + ;; Here the package has been installed successfully, mark it as + ;; signed if appropriate. + (when good-sigs + ;; Write out good signatures into NAME-VERSION.signed file. + (write-region (mapconcat #'epg-signature-to-string good-sigs "\n") + nil + (expand-file-name + (concat (package-desc-full-name pkg-desc) ".signed") + package-user-dir) + nil 'silent) + ;; Update the old pkg-desc which will be shown on the description buffer. + (setf (package-desc-signed pkg-desc) t) + ;; Update the new (activated) pkg-desc as well. + (when-let* ((pkg-descs (cdr (assq (package-desc-name pkg-desc) + package-alist)))) + (setf (package-desc-signed (car pkg-descs)) t)))))))))) ;;;###autoload (defun package-installed-p (package &optional min-version) @@ -2234,61 +2173,6 @@ to install it but still mark it as selected." (message "Package `%s' installed." name)) (message "`%s' is already installed" name)))) -;;;###autoload -(defun package-fetch (name-or-url &optional name rev) - "Fetch the source of NAME-OR-URL. -If NAME-OR-URL is a URL, then the package will be downloaded from -the repository indicated by the URL. The function will try to -guess the name of the package using `file-name-base'. This can -be overridden by manually passing the optional NAME. Otherwise -NAME-OR-URL is taken to be a package name, and the package -metadata will be consulted for the URL. An explicit revision can -be requested using REV." - (interactive - (progn - ;; Initialize the package system to get the list of package - ;; symbols for completion. - (package--archives-initialize) - (let* ((input (completing-read - "Fetch package source (name or URL): " - package-archive-contents)) - (name (file-name-base input))) - (list input (intern (string-remove-prefix "emacs-" name)))))) - (package--archives-initialize) - (package-install - (cond - ((and (stringp name-or-url) - (url-type (url-generic-parse-url name-or-url))) - (package-desc-create - :name (or name (intern (file-name-base name-or-url))) - :kind 'source - :extras `((:upstream . ,(list nil name-or-url nil nil)) - (:rev . ,rev)))) - ((when-let* ((desc (cadr (assoc name-or-url package-archive-contents - #'string=))) - (spec (or (alist-get :vc (package-desc-extras desc)) - (user-error "Package has no VC header")))) - (unless (string-match - (rx bos - (group (+ alnum)) - (+ blank) (group (+ (not blank))) - (? (+ blank) (group (+ (not blank))) - (? (+ blank) (group (+ (not blank))))) - eos) - spec) - (user-error "Invalid repository specification %S" spec)) - (package-desc-create - :name (if (stringp name-or-url) - (intern name-or-url) - name-or-url) - :kind 'source - :extras `((:upstream . ,(list (intern (match-string 1 spec)) - (match-string 2 spec) - (match-string 3 spec) - (match-string 4 spec))) - (:rev . ,rev))))) - ((user-error "Unknown package to fetch: %s" name-or-url))))) - ;;;###autoload (defun package-update (name) "Update package NAME if a newer version exists." @@ -3188,7 +3072,7 @@ of these dependencies, similar to the list returned by (signed (or (not package-list-unsigned) (package-desc-signed pkg-desc)))) (cond - ((eq (package-desc-kind pkg-desc) 'source) "source") + ((eq (package-desc-kind pkg-desc) 'vc) "source") ((eq dir 'builtin) "built-in") ((and lle (null held)) "disabled") ((stringp held) @@ -3279,7 +3163,7 @@ to their archives." (let ((ins-version (package-desc-version installed))) (cl-remove-if (lambda (p) (or (version-list-= (package-desc-version p) ins-version) - (eq (package-desc-kind installed) 'source))) + (eq (package-desc-kind installed) 'vc))) filtered-by-priority)))))))) (defcustom package-hidden-regexps nil @@ -3536,8 +3420,10 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." package-desc ,pkg action package-menu-describe-package) ,(propertize - (if (eq (package-desc-kind pkg) 'source) - (package-devel-commit pkg) + (if (eq (package-desc-kind pkg) 'vc) + (progn + (require 'package-vc) + (package-vc-commit pkg)) (package-version-join (package-desc-version pkg))) 'font-lock-face face) @@ -4334,22 +4220,22 @@ Unlike other filters, this leaves the marks intact." (while (not (eobp)) (setq mark (char-after)) (unless (eq mark ?\s) - (setq pkg-id (tabulated-list-get-id)) + (setq pkg-id (tabulated-list-get-id)) (setq entry (package-menu--print-info-simple pkg-id)) - (push entry found-entries) - ;; remember the mark - (push (cons pkg-id mark) marks)) + (push entry found-entries) + ;; remember the mark + (push (cons pkg-id mark) marks)) (forward-line)) (if found-entries (progn (setq tabulated-list-entries found-entries) (package-menu--display t nil) - ;; redo the marks, but we must remember the marks!! - (goto-char (point-min)) - (while (not (eobp)) - (setq mark (cdr (assq (tabulated-list-get-id) marks))) - (tabulated-list-put-tag (char-to-string mark) t))) - (user-error "No packages found"))))) + ;; redo the marks, but we must remember the marks!! + (goto-char (point-min)) + (while (not (eobp)) + (setq mark (cdr (assq (tabulated-list-get-id) marks))) + (tabulated-list-put-tag (char-to-string mark) t))) + (user-error "No packages found"))))) (defun package-menu-filter-upgradable () "Filter \"*Packages*\" buffer to show only upgradable packages." @@ -4555,7 +4441,7 @@ DESC must be a `package-desc' object." (unless url (user-error "No website for %s" (package-desc-name desc))) (if secondary - (funcall browse-url-secondary-browser-function url) + (funcall browse-url-secondary-browser-function url) (browse-url url)))) ;; TODO: Allow attaching a patch to send directly to the maintainer. commit 118033294136a8fb3a14347ce190b447dd2ff2fe Merge: edd73bd0d5 ac237334c7 Author: Philip Kaludercic Date: Sun Jul 31 14:27:28 2022 +0200 Merge remote-tracking branch 'origin/master' into feature/package+vc commit edd73bd0d5474b71cbd4261c6a722be8f652bb9a Author: Philip Kaludercic Date: Mon Feb 14 13:47:31 2022 +0100 Add command to contact maintainer * package.el (package-menu-mode-map): Add package-contact-maintainer. (package--query-desc): Extract a common utility function. (package-browse-url): Use package--query-desc. (package-contact-maintainer): Add command. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index c3f6174c19..58fc55da12 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2917,6 +2917,7 @@ either a full name or nil, and EMAIL is a valid email address." "r" #'revert-buffer "~" #'package-menu-mark-obsolete-for-deletion "w" #'package-browse-url + "m" #'package-contact-maintainer "x" #'package-menu-execute "h" #'package-menu-quick-help "H" #'package-menu-hide-package @@ -4378,11 +4379,22 @@ beginning of the line." (package-version-join (package-desc-version package-desc)) (package-desc-summary package-desc)))) +(defun package--query-desc (&optional alist) + "Query the user for a package or return the package at point. +The optional argument ALIST must consist of elements with the +form (PKG-NAME PKG-DESC). If not specified, it will default to +`package-alist'." + (or (tabulated-list-get-id) + (let ((alist (or alist package-alist))) + (cadr (assoc (completing-read "Package: " alist nil t) + alist #'string=))))) + (defun package-browse-url (desc &optional secondary) "Open the website of the package under point in a browser. -`browse-url' is used to determine the browser to be used. -If SECONDARY (interactively, the prefix), use the secondary browser." - (interactive (list (tabulated-list-get-id) +`browse-url' is used to determine the browser to be used. If +SECONDARY (interactively, the prefix), use the secondary browser. +DESC must be a `package-desc' object." + (interactive (list (package--query-desc) current-prefix-arg) package-menu-mode) (unless desc @@ -4394,6 +4406,28 @@ If SECONDARY (interactively, the prefix), use the secondary browser." (funcall browse-url-secondary-browser-function url) (browse-url url)))) +;; TODO: Allow attaching a patch to send directly to the maintainer. +;; Ideally this should be able to detect the local changes, convert +;; these into patches. +(defun package-contact-maintainer (desc) + "Prepare a message to send to the maintainers of a package. +DESC must be a `package-desc' object." + (interactive (list (package--query-desc package-archive-contents)) + package-menu-mode) + (unless desc + (user-error "No package here")) + (let* ((extras (package-desc-extras desc)) + (maint (alist-get :maintainer extras)) + (name (package-desc-name desc)) + (subject (read-string "Subject: "))) + (unless maint + (user-error "Package has no explicit maintainer")) + (compose-mail + (with-temp-buffer + (package--print-email-button maint) + (string-trim (substring-no-properties (buffer-string)))) + (format "[%s] %s" name subject)))) + ;;;; Introspection (defun package-get-descriptor (pkg-name) commit 04c4c578c71cae77b3b782497808bb2321da3be1 Author: Philip Kaludercic Date: Mon Feb 14 12:45:17 2022 +0100 Allow for packages to be installed directly from VCS Packages installed via package-fetch are of the kind 'source, and their extra properties may include a :upstream key (a list consisting of the VC backend, a remote repository, a branch and a path within the repository) and :rev key (indicating a specific revision to checkout). * package.el (package-devel-dir): Add new option. (package-desc): Allow an empty version string to be passed to package-desc-from-define. (package-desc-full-name): Handle source packages. (vc-working-revision): Declare function for package-devel-commit. (package-devel-commit): Add function. (package-load-descriptor): Detect and handle source packages. (package-load-all-descriptors): Use package-devel-dir. (vc-clone): Declare function for package-unpack. (package-unpack): Handle source packages. (package-generate-description-file): Handle source packages by ommiting a version number. (package-install-from-archive): Check if a package is a source package. (package-fetch): Add new command (package-desc-status): Check for source packages. (package--remove-hidden): Hide regular packages from the package list if a source package was installed. (package-status-from-source): Add new face. (package-menu--print-info-simple): Handle source packages. (package-menu-mark-delete): Allow deleting source packages. (package-menu--status-predicate): Sort source packages after dependencies but before unsigned packages. (package-menu-filter-by-status): Allow filtering by source packages. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 6aa82e576d..c3f6174c19 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -303,6 +303,17 @@ packages in `package-directory-list'." :risky t :version "24.1") +(defcustom package-devel-dir (expand-file-name "devel" package-user-dir) + "Directory containing the user's Emacs Lisp package checkouts. +The directory name should be absolute. +Apart from this directory, Emacs also looks for system-wide +packages in `package-directory-list'." + :type 'directory + :initialize #'custom-initialize-delay + :set-after '(package-user-dir) + :risky t + :version "29.1") + ;;;###autoload (defcustom package-directory-list ;; Defaults are subdirs named "elpa" in the site-lisp dirs. @@ -459,7 +470,7 @@ synchronously." &rest rest-plist &aux (name (intern name-string)) - (version (version-to-list version-string)) + (version (and version-string (version-to-list version-string))) (reqs (mapcar (lambda (elt) (list (car elt) (version-to-list (cadr elt)))) @@ -560,7 +571,9 @@ This is, approximately, the inverse of `version-to-list'. This is the name of the package with its version appended." (format "%s-%s" (package-desc-name pkg-desc) - (package-version-join (package-desc-version pkg-desc)))) + (if (eq (package-desc-kind pkg-desc) 'source) + "devel" + (package-version-join (package-desc-version pkg-desc))))) (defun package-desc-suffix (pkg-desc) "Return file-name extension of package-desc object PKG-DESC. @@ -666,6 +679,16 @@ are sorted with the highest version first." nil))) new-pkg-desc))) +(declare-function vc-working-revision "vc" (file &optional backend)) +(defun package-devel-commit (pkg) + "Extract the commit of a development package PKG." + (cl-assert (eq (package-desc-kind pkg) 'source)) + (require 'vc) + (cl-loop with dir = (package-desc-dir pkg) + for file in (directory-files dir t "\\.el\\'" t) + when (vc-working-revision file) return it + finally return "unknown")) + (defun package-load-descriptor (pkg-dir) "Load the package description file in directory PKG-DIR. Create a new `package-desc' object, add it to `package-alist' and @@ -681,6 +704,14 @@ return it." (read (current-buffer))) (error "Can't find define-package in %s" pkg-file)))) (setf (package-desc-dir pkg-desc) pkg-dir) + (when (file-exists-p (expand-file-name + (symbol-name (package-desc-name pkg-desc)) + package-devel-dir)) + ;; XXX: This check seems dirty, there should be a better + ;; way to deduce if a package is in the devel directory. + (setf (package-desc-kind pkg-desc) 'source) + (push (cons :commit (package-devel-commit pkg-desc)) + (package-desc-extras pkg-desc))) (if (file-exists-p signed-file) (setf (package-desc-signed pkg-desc) t)) pkg-desc))))) @@ -694,13 +725,13 @@ controls which package subdirectories may be loaded. In each valid package subdirectory, this function loads the description file containing a call to `define-package', which updates `package-alist'." - (dolist (dir (cons package-user-dir package-directory-list)) + (dolist (dir (cl-list* package-user-dir + package-devel-dir + package-directory-list)) (when (file-directory-p dir) - (dolist (subdir (directory-files dir)) - (unless (equal subdir "..") - (let ((pkg-dir (expand-file-name subdir dir))) - (when (file-directory-p pkg-dir) - (package-load-descriptor pkg-dir)))))))) + (dolist (pkg-dir (directory-files dir t "^[^.]" t)) + (when (file-directory-p pkg-dir) + (package-load-descriptor pkg-dir)))))) (defun package--alist () "Return `package-alist', after computing it if needed." @@ -916,12 +947,51 @@ untar into a directory named DIR; otherwise, signal an error." (apply #'nconc (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist)))) +(declare-function vc-clone "vc" (backend remote &optional directory)) + (defun package-unpack (pkg-desc) "Install the contents of the current buffer as a package." (let* ((name (package-desc-name pkg-desc)) (dirname (package-desc-full-name pkg-desc)) (pkg-dir (expand-file-name dirname package-user-dir))) (pcase (package-desc-kind pkg-desc) + ('source + (setq pkg-dir (expand-file-name (symbol-name name) package-devel-dir)) + (when (file-exists-p pkg-dir) + (if (and (called-interactively-p 'interactive) + (yes-or-no-p "Overwrite previous checkout?")) + (delete-directory pkg-dir t) + (error "There already exists a checkout for %s" name))) + (pcase-let* ((attr (package-desc-extras pkg-desc)) + (`(,backend ,repo ,dir ,branch) + (or (alist-get :upstream attr) + (error "Source package has no repository")))) + (require 'vc) + (make-directory (file-name-directory (file-name-directory pkg-dir)) t) + (unless (setf (car (alist-get :upstream attr)) + (vc-clone backend repo pkg-dir)) + (error "Failed to clone %s from %s" name repo)) + (when-let ((rev (or (alist-get :rev attr) branch))) + (vc-retrieve-tag pkg-dir rev)) + (when dir (setq pkg-dir (file-name-concat pkg-dir dir))) + ;; In case the package was installed directly from source, the + ;; dependency list wasn't know beforehand, and they might have + ;; to be installed explicitly. + (let (deps) + (dolist (file (directory-files pkg-dir t "\\.el\\'" t)) + (with-temp-buffer + (insert-file-contents file) + (when-let* ((require-lines (lm-header-multiline "package-requires"))) + (thread-last + (mapconcat #'identity require-lines " ") + package-read-from-string + package--prepare-dependencies + (nconc deps) + (setq deps))))) + (dolist (dep deps) + (cl-callf version-to-list (cadr dep))) + (package-download-transaction + (package-compute-transaction nil (delete-dups deps)))))) ('dir (make-directory pkg-dir t) (let ((file-list @@ -935,7 +1005,7 @@ untar into a directory named DIR; otherwise, signal an error." ;; indistinguishable from a `tar' or a `single'. Let's make ;; things simple by ensuring we're one of them. (setf (package-desc-kind pkg-desc) - (if (> (length file-list) 1) 'tar 'single)))) + (if (length> file-list 1) 'tar 'single)))) ('tar (make-directory package-user-dir t) (let* ((default-directory (file-name-as-directory package-user-dir))) @@ -948,8 +1018,9 @@ untar into a directory named DIR; otherwise, signal an error." (package--make-autoloads-and-stuff pkg-desc pkg-dir) ;; Update package-alist. (let ((new-desc (package-load-descriptor pkg-dir))) - (unless (equal (package-desc-full-name new-desc) - (package-desc-full-name pkg-desc)) + (unless (or (equal (package-desc-full-name new-desc) + (package-desc-full-name pkg-desc)) + (eq (package-desc-kind pkg-desc) 'source)) (error "The retrieved package (`%s') doesn't match what the archive offered (`%s')" (package-desc-full-name new-desc) (package-desc-full-name pkg-desc))) ;; Activation has to be done before compilation, so that if we're @@ -983,7 +1054,8 @@ untar into a directory named DIR; otherwise, signal an error." (nconc (list 'define-package (symbol-name name) - (package-version-join (package-desc-version pkg-desc)) + (and (not (eq (package-desc-kind pkg-desc) 'source)) + (package-version-join (package-desc-version pkg-desc))) (package-desc-summary pkg-desc) (let ((requires (package-desc-reqs pkg-desc))) (list 'quote @@ -1995,50 +2067,52 @@ if all the in-between dependencies are also in PACKAGE-LIST." (cdr (assoc (package-desc-archive desc) package-archives))) (defun package-install-from-archive (pkg-desc) - "Download and install a tar package defined by PKG-DESC." + "Download and install a package defined by PKG-DESC." ;; This won't happen, unless the archive is doing something wrong. (when (eq (package-desc-kind pkg-desc) 'dir) (error "Can't install directory package from archive")) - (let* ((location (package-archive-base pkg-desc)) - (file (concat (package-desc-full-name pkg-desc) - (package-desc-suffix pkg-desc)))) - (package--with-response-buffer location :file file - (if (or (not (package-check-signature)) - (member (package-desc-archive pkg-desc) - package-unsigned-archives)) - ;; If we don't care about the signature, unpack and we're - ;; done. - (let ((save-silently t)) - (package-unpack pkg-desc)) - ;; If we care, check it and *then* write the file. - (let ((content (buffer-string))) - (package--check-signature - location file content nil - ;; This function will be called after signature checking. - (lambda (&optional good-sigs) - ;; Signature checked, unpack now. - (with-temp-buffer ;FIXME: Just use the previous current-buffer. - (set-buffer-multibyte nil) - (cl-assert (not (multibyte-string-p content))) - (insert content) - (let ((save-silently t)) - (package-unpack pkg-desc))) - ;; Here the package has been installed successfully, mark it as - ;; signed if appropriate. - (when good-sigs - ;; Write out good signatures into NAME-VERSION.signed file. - (write-region (mapconcat #'epg-signature-to-string good-sigs "\n") - nil - (expand-file-name - (concat (package-desc-full-name pkg-desc) ".signed") - package-user-dir) - nil 'silent) - ;; Update the old pkg-desc which will be shown on the description buffer. - (setf (package-desc-signed pkg-desc) t) - ;; Update the new (activated) pkg-desc as well. - (when-let* ((pkg-descs (cdr (assq (package-desc-name pkg-desc) - package-alist)))) - (setf (package-desc-signed (car pkg-descs)) t)))))))))) + (if (eq (package-desc-kind pkg-desc) 'source) + (package-unpack pkg-desc) + (let* ((location (package-archive-base pkg-desc)) + (file (concat (package-desc-full-name pkg-desc) + (package-desc-suffix pkg-desc)))) + (package--with-response-buffer location :file file + (if (or (not (package-check-signature)) + (member (package-desc-archive pkg-desc) + package-unsigned-archives)) + ;; If we don't care about the signature, unpack and we're + ;; done. + (let ((save-silently t)) + (package-unpack pkg-desc)) + ;; If we care, check it and *then* write the file. + (let ((content (buffer-string))) + (package--check-signature + location file content nil + ;; This function will be called after signature checking. + (lambda (&optional good-sigs) + ;; Signature checked, unpack now. + (with-temp-buffer ;FIXME: Just use the previous current-buffer. + (set-buffer-multibyte nil) + (cl-assert (not (multibyte-string-p content))) + (insert content) + (let ((save-silently t)) + (package-unpack pkg-desc))) + ;; Here the package has been installed successfully, mark it as + ;; signed if appropriate. + (when good-sigs + ;; Write out good signatures into NAME-VERSION.signed file. + (write-region (mapconcat #'epg-signature-to-string good-sigs "\n") + nil + (expand-file-name + (concat (package-desc-full-name pkg-desc) ".signed") + package-user-dir) + nil 'silent) + ;; Update the old pkg-desc which will be shown on the description buffer. + (setf (package-desc-signed pkg-desc) t) + ;; Update the new (activated) pkg-desc as well. + (when-let* ((pkg-descs (cdr (assq (package-desc-name pkg-desc) + package-alist)))) + (setf (package-desc-signed (car pkg-descs)) t))))))))))) ;;;###autoload (defun package-installed-p (package &optional min-version) @@ -2132,6 +2206,61 @@ to install it but still mark it as selected." (message "Package `%s' installed." name)) (message "`%s' is already installed" name)))) +;;;###autoload +(defun package-fetch (name-or-url &optional name rev) + "Fetch the source of NAME-OR-URL. +If NAME-OR-URL is a URL, then the package will be downloaded from +the repository indicated by the URL. The function will try to +guess the name of the package using `file-name-base'. This can +be overridden by manually passing the optional NAME. Otherwise +NAME-OR-URL is taken to be a package name, and the package +metadata will be consulted for the URL. An explicit revision can +be requested using REV." + (interactive + (progn + ;; Initialize the package system to get the list of package + ;; symbols for completion. + (package--archives-initialize) + (let* ((input (completing-read + "Fetch package source (name or URL): " + package-archive-contents)) + (name (file-name-base input))) + (list input (intern (string-remove-prefix "emacs-" name)))))) + (package--archives-initialize) + (package-install + (cond + ((and (stringp name-or-url) + (url-type (url-generic-parse-url name-or-url))) + (package-desc-create + :name (or name (intern (file-name-base name-or-url))) + :kind 'source + :extras `((:upstream . ,(list nil name-or-url nil nil)) + (:rev . ,rev)))) + ((when-let* ((desc (cadr (assoc name-or-url package-archive-contents + #'string=))) + (spec (or (alist-get :vc (package-desc-extras desc)) + (user-error "Package has no VC header")))) + (unless (string-match + (rx bos + (group (+ alnum)) + (+ blank) (group (+ (not blank))) + (? (+ blank) (group (+ (not blank))) + (? (+ blank) (group (+ (not blank))))) + eos) + spec) + (user-error "Invalid repository specification %S" spec)) + (package-desc-create + :name (if (stringp name-or-url) + (intern name-or-url) + name-or-url) + :kind 'source + :extras `((:upstream . ,(list (intern (match-string 1 spec)) + (match-string 2 spec) + (match-string 3 spec) + (match-string 4 spec))) + (:rev . ,rev))))) + ((user-error "Unknown package to fetch: %s" name-or-url))))) + (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. If the result looks like a dotted numeric version, return it. @@ -2940,6 +3069,7 @@ of these dependencies, similar to the list returned by (signed (or (not package-list-unsigned) (package-desc-signed pkg-desc)))) (cond + ((eq (package-desc-kind pkg-desc) 'source) "source") ((eq dir 'builtin) "built-in") ((and lle (null held)) "disabled") ((stringp held) @@ -3028,8 +3158,9 @@ to their archives." (if (not installed) filtered-by-priority (let ((ins-version (package-desc-version installed))) - (cl-remove-if (lambda (p) (version-list-= (package-desc-version p) - ins-version)) + (cl-remove-if (lambda (p) (or (version-list-= (package-desc-version p) + ins-version) + (eq (package-desc-kind installed) 'source))) filtered-by-priority)))))))) (defcustom package-hidden-regexps nil @@ -3231,6 +3362,11 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." "Face used on the status and version of installed packages." :version "25.1") +(defface package-status-from-source + '((t :inherit font-lock-negation-char-face)) + "Face used on the status and version of installed packages." + :version "29.1") + (defface package-status-dependency '((t :inherit package-status-installed)) "Face used on the status and version of dependency packages." @@ -3268,6 +3404,7 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." ("held" 'package-status-held) ("disabled" 'package-status-disabled) ("installed" 'package-status-installed) + ("source" 'package-status-from-source) ("dependency" 'package-status-dependency) ("unsigned" 'package-status-unsigned) ("incompat" 'package-status-incompat) @@ -3279,9 +3416,12 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." follow-link t package-desc ,pkg action package-menu-describe-package) - ,(propertize (package-version-join - (package-desc-version pkg)) - 'font-lock-face face) + ,(propertize + (if (eq (package-desc-kind pkg) 'source) + (package-devel-commit pkg) + (package-version-join + (package-desc-version pkg))) + 'font-lock-face face) ,(propertize status 'font-lock-face face) ,@(if (cdr package-archives) (list (propertize (or (package-desc-archive pkg) "") @@ -3356,7 +3496,7 @@ If optional arg BUTTON is non-nil, describe its associated package." (interactive "p" package-menu-mode) (package--ensure-package-menu-mode) (if (member (package-menu-get-status) - '("installed" "dependency" "obsolete" "unsigned")) + '("installed" "source" "dependency" "obsolete" "unsigned")) (tabulated-list-put-tag "D" t) (forward-line))) @@ -3674,6 +3814,8 @@ This is used for `tabulated-list-format' in `package-menu-mode'." ((string= sB "installed") nil) ((string= sA "dependency") t) ((string= sB "dependency") nil) + ((string= sA "source") t) + ((string= sB "source") nil) ((string= sA "unsigned") t) ((string= sB "unsigned") nil) ((string= sA "held") t) @@ -3969,6 +4111,7 @@ packages." "held" "incompat" "installed" + "source" "new" "unsigned"))) package-menu-mode) commit ccecc87d5880a322fa6f25cfe3697af7797bfadd Author: Philip Kaludercic Date: Mon Feb 14 12:33:34 2022 +0100 Implement vc-clone for git * vc-git.el (vc-git-clone): Add Git implementation diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index ad39dc604a..adf1340633 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1136,6 +1136,9 @@ This prompts for a branch to merge from." (add-hook 'after-save-hook #'vc-git-resolve-when-done nil 'local)) (vc-message-unresolved-conflicts buffer-file-name))) +(defun vc-git-clone (remote directory) + (vc-git--out-ok "clone" remote directory)) + ;;; HISTORY FUNCTIONS (autoload 'vc-setup-buffer "vc-dispatcher") commit 077c9badf9322845a8d2911e48392fa8f4c5939c Author: Philip Kaludercic Date: Mon Feb 14 12:33:11 2022 +0100 Add new command to clone a repository * vc.el (vc-clone): Add command diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index a6124acadd..fd0192fad2 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -568,6 +568,11 @@ ;; containing FILE-OR-DIR. The optional REMOTE-NAME specifies the ;; remote (in Git parlance) whose URL is to be returned. It has ;; only a meaning for distributed VCS and is ignored otherwise. +;; +;; - clone (remote directory) +;; +;; Attempt to clone a REMOTE repository, into a local DIRECTORY. +;; Returns the symbol of the backend used if successful. ;;; Changes from the pre-25.1 API: ;; @@ -3233,6 +3238,27 @@ to provide the `find-revision' operation instead." (interactive) (vc-call-backend (vc-backend buffer-file-name) 'check-headers)) +(defun vc-clone (backend remote &optional directory) + "Use BACKEND to clone REMOTE into DIRECTORY. +If successful, returns the symbol of the backed used to clone. +If BACKEND is nil, iterate through every known backend in +`vc-handled-backends' until one succeeds." + (unless directory + (setq directory default-directory)) + (if backend + (progn + (unless (memq backend vc-handled-backends) + (error "Unknown VC backend %s" backend)) + (vc-call-backend backend 'clone remote directory) + backend) + (catch 'ok + (dolist (backend vc-handled-backends) + (ignore-error vc-not-supported + (when-let (res (vc-call-backend + backend 'clone + remote directory)) + (throw 'ok backend))))))) + ;; These things should probably be generally available