commit 23dd27a97953bab3ffab86dcc83b4e3b139657aa (HEAD, refs/remotes/origin/master) Author: Matt Armstrong Date: Sat Nov 5 16:31:19 2022 -0700 itree.c and buffer-tests.el: Incorporate code review feedback * src/itree.c: Improve wording in `itree_insert_gap` comment. * test/src/buffer-tests.el (test-overlay-insert-before-markers-at-start): Don't rely on (point-min) being 1. (test-overlay-insert-before-markers-at-end): ditto. (test-overlay-insert-before-markers-empty): ditto. diff --git a/src/itree.c b/src/itree.c index 989f452cb9..d73fbffd2b 100644 --- a/src/itree.c +++ b/src/itree.c @@ -1193,8 +1193,8 @@ itree_iterator_finish (struct itree_iterator *iter) intersecting it, while respecting their rear_advance and front_advance setting. - When BEFORE_MARKERS, all overlays beginning/ending at POS are - treated as if their front_advance/rear_advance was true. */ + If BEFORE_MARKERS is non-zero, all overlays beginning/ending at POS + are treated as if their front_advance/rear_advance was true. */ void itree_insert_gap (struct itree_tree *tree, diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index b11243e021..26a649e133 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -1339,11 +1339,13 @@ Test both front-advance and non-front-advance overlays." (ert-info ((format "front-advance %S" front-advance)) (with-temp-buffer (insert "1234") - (let ((overlay (make-overlay 2 3 nil front-advance nil))) - (goto-char 2) + (let* ((beg (1+ (point-min))) + (end (1+ beg)) + (overlay (make-overlay beg end nil front-advance nil))) + (goto-char beg) (insert-before-markers "x") - (should (equal 3 (overlay-start overlay))) - (should (equal 4 (overlay-end overlay)))))))) + (should (equal (1+ beg) (overlay-start overlay))) + (should (equal (1+ end) (overlay-end overlay)))))))) (ert-deftest test-overlay-insert-before-markers-at-end () "`insert-before-markers' always advances an overlay's end. @@ -1352,22 +1354,25 @@ Test both rear-advance and non-rear-advance overlays." (ert-info ((format "rear-advance %S" rear-advance)) (with-temp-buffer (insert "1234") - (let ((overlay (make-overlay 2 3 nil nil rear-advance))) - (goto-char 3) + (let* ((beg (1+ (point-min))) + (end (1+ beg)) + (overlay (make-overlay beg end nil nil rear-advance))) + (goto-char end) (insert-before-markers "x") - (should (equal 2 (overlay-start overlay))) - (should (equal 4 (overlay-end overlay)))))))) + (should (equal beg (overlay-start overlay))) + (should (equal (1+ end) (overlay-end overlay)))))))) (ert-deftest test-overlay-insert-before-markers-empty () (dolist (advance-args '((nil nil) (t nil) (nil t) (t t))) (ert-info ((format "advance args %S" advance-args)) (with-temp-buffer (insert "1234") - (let ((overlay (apply #'make-overlay 2 2 nil advance-args))) - (goto-char 2) + (let* ((pos (1+ (point-min))) + (overlay (apply #'make-overlay pos pos nil advance-args))) + (goto-char pos) (insert-before-markers "x") - (should (equal 3 (overlay-start overlay))) - (should (equal 3 (overlay-end overlay)))))))) + (should (equal (1+ pos) (overlay-start overlay))) + (should (equal (1+ pos) (overlay-end overlay)))))))) ;; +==========================================================================+ ;; | Moving by deletions commit 6e5ec085510ccf52ac6cb07c3a1a2778324a1d89 Author: Stefan Monnier Date: Sat Nov 5 17:22:37 2022 -0400 buffer.c: evaporate overlays in all indirect buffers This fixes bug#58928. The patch works by moving the `evaporate_overlays` check closer to `itree_delete_gap`. * src/buffer.c (adjust_overlays_for_delete_in_buffer): New function, integrating the functionality of `evaporate_overlays`. (adjust_overlays_for_delete): Use it. (evaporate_overlays): Delete function. * src/buffer.h (evaporate_overlays): Delete declaration. * src/insdel.c (adjust_markers_for_replace): Minor optimization. (adjust_after_replace, replace_range, replace_range_2, del_range_2): Don't call `evaporate_overlays`. * test/src/buffer-tests.el (buffer-tests--overlays-indirect-evaporate): Remove the `:expected-result :failed` attribute. diff --git a/src/buffer.c b/src/buffer.c index 390ccff5c8..ec2d34daf8 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -3472,21 +3472,47 @@ adjust_overlays_for_insert (ptrdiff_t pos, ptrdiff_t length, bool before_markers } } +static void +adjust_overlays_for_delete_in_buffer (struct buffer * buf, + ptrdiff_t pos, ptrdiff_t length) +{ + Lisp_Object hit_list = Qnil; + struct itree_node *node; + + /* Ideally, the evaporate check would be done directly within + `itree_delete_gap`, but that code isn't supposed to know about overlays, + only about `itree_node`s, so it would break an abstraction boundary. */ + itree_delete_gap (buf->overlays, pos, length); + + /* Delete any zero-sized overlays at position POS, if the `evaporate' + property is set. */ + + ITREE_FOREACH (node, buf->overlays, pos, pos, ASCENDING) + { + if (node->end == pos && node->begin == pos + && ! NILP (Foverlay_get (node->data, Qevaporate))) + hit_list = Fcons (node->data, hit_list); + } + + for (; CONSP (hit_list); hit_list = XCDR (hit_list)) + Fdelete_overlay (XCAR (hit_list)); +} + void adjust_overlays_for_delete (ptrdiff_t pos, ptrdiff_t length) { if (!current_buffer->indirections) - itree_delete_gap (current_buffer->overlays, pos, length); + adjust_overlays_for_delete_in_buffer (current_buffer, pos, length); else { struct buffer *base = current_buffer->base_buffer ? current_buffer->base_buffer : current_buffer; Lisp_Object tail, other; - itree_delete_gap (base->overlays, pos, length); + adjust_overlays_for_delete_in_buffer (base, pos, length); FOR_EACH_LIVE_BUFFER (tail, other) if (XBUFFER (other)->base_buffer == base) - itree_delete_gap (XBUFFER (other)->overlays, pos, length); + adjust_overlays_for_delete_in_buffer (XBUFFER (other), pos, length); } } @@ -4099,25 +4125,6 @@ call_overlay_mod_hooks (Lisp_Object list, Lisp_Object overlay, bool after, } } -/* Delete any zero-sized overlays at position POS, if the `evaporate' - property is set. */ -void -evaporate_overlays (ptrdiff_t pos) -{ - Lisp_Object hit_list = Qnil; - struct itree_node *node; - - ITREE_FOREACH (node, current_buffer->overlays, pos, pos, ASCENDING) - { - if (node->end == pos - && ! NILP (Foverlay_get (node->data, Qevaporate))) - hit_list = Fcons (node->data, hit_list); - } - - for (; CONSP (hit_list); hit_list = XCDR (hit_list)) - Fdelete_overlay (XCAR (hit_list)); -} - /*********************************************************************** Allocation with mmap ***********************************************************************/ diff --git a/src/buffer.h b/src/buffer.h index 3ea4125645..2e80c8a7b0 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -1170,7 +1170,6 @@ extern EMACS_INT fix_position (Lisp_Object); extern void delete_all_overlays (struct buffer *); extern void reset_buffer (struct buffer *); extern void compact_buffer (struct buffer *); -extern void evaporate_overlays (ptrdiff_t); extern ptrdiff_t overlays_at (ptrdiff_t, bool, Lisp_Object **, ptrdiff_t *, ptrdiff_t *); extern ptrdiff_t overlays_in (ptrdiff_t, ptrdiff_t, bool, Lisp_Object **, ptrdiff_t *, bool, bool, ptrdiff_t *); diff --git a/src/insdel.c b/src/insdel.c index ef17f99d21..03ce59b340 100644 --- a/src/insdel.c +++ b/src/insdel.c @@ -345,6 +345,11 @@ adjust_markers_for_replace (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t diff_bytes = new_bytes - old_bytes; adjust_suspend_auto_hscroll (from, from + old_chars); + + /* FIXME: When OLD_CHARS is 0, this "replacement" is really just an + insertion, but the behavior we provide here in that case is that of + `insert-before-markers` rather than that of `insert`. + Maybe not a bug, but not a feature either. */ for (m = BUF_MARKERS (current_buffer); m; m = m->next) { if (m->bytepos >= prev_to_byte) @@ -362,7 +367,8 @@ adjust_markers_for_replace (ptrdiff_t from, ptrdiff_t from_byte, check_markers (); adjust_overlays_for_insert (from + old_chars, new_chars, true); - adjust_overlays_for_delete (from, old_chars); + if (old_chars) + adjust_overlays_for_delete (from, old_chars); } /* Starting at POS (BYTEPOS), find the byte position corresponding to @@ -1334,8 +1340,6 @@ adjust_after_replace (ptrdiff_t from, ptrdiff_t from_byte, check_markers (); - if (len == 0) - evaporate_overlays (from); modiff_incr (&MODIFF, nchars_del + len); CHARS_MODIFF = MODIFF; } @@ -1521,9 +1525,6 @@ replace_range (ptrdiff_t from, ptrdiff_t to, Lisp_Object new, (from_byte + outgoing_insbytes - (PT_BYTE < to_byte ? PT_BYTE : to_byte))); - if (outgoing_insbytes == 0) - evaporate_overlays (from); - check_markers (); modiff_incr (&MODIFF, nchars_del + inschars); @@ -1647,9 +1648,6 @@ replace_range_2 (ptrdiff_t from, ptrdiff_t from_byte, adjust_point (inschars - nchars_del, insbytes - nbytes_del); } - if (insbytes == 0) - evaporate_overlays (from); - check_markers (); modiff_incr (&MODIFF, nchars_del + inschars); @@ -1858,8 +1856,6 @@ del_range_2 (ptrdiff_t from, ptrdiff_t from_byte, check_markers (); - evaporate_overlays (from); - return deletion; } diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 3c37176095..b11243e021 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -301,7 +301,6 @@ with parameters from the *Messages* buffer modification." Deleting characters from either a base or an indirect buffer should evaporate overlays in both." - :expected-result :failed ;; Loop twice, erasing from the base buffer the first time and the ;; indirect buffer the second. (dolist (erase-where '(base indirect)) commit 5c9895fffe4e34b7a31b0a8e4bce0b59a4bc0326 Author: Matt Armstrong Date: Tue Nov 1 19:40:20 2022 -0700 Add a test for overlay evaporation across indirect buffers * test/src/buffer-tests.el (buffer-tests--overlays-indirect-evaporate): Test evaporation of overlays triggered by deleting text in base and in indirect buffers. Test doesn't pass at the moment. diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 0e9e84ef7a..3c37176095 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -296,6 +296,42 @@ with parameters from the *Messages* buffer modification." (should (equal (overlay-start ol1) (overlay-start ol2))) (should (equal (overlay-end ol1) (overlay-end ol2)))))) +(ert-deftest buffer-tests--overlays-indirect-evaporate () + "Verify that deleting text evaporates overlays in every related buffer. + +Deleting characters from either a base or an indirect buffer +should evaporate overlays in both." + :expected-result :failed + ;; Loop twice, erasing from the base buffer the first time and the + ;; indirect buffer the second. + (dolist (erase-where '(base indirect)) + (ert-info ((format "erase-where %S" erase-where)) + (with-temp-buffer + (insert "xxx") + (let* ((beg 2) + (end 3) + (base (current-buffer)) + (base-overlay (make-overlay beg end base)) + (indirect (make-indirect-buffer + base + (generate-new-buffer-name + (concat (buffer-name base) "-indirect")))) + (indirect-overlay (make-overlay beg end indirect))) + (overlay-put base-overlay 'evaporate t) + (overlay-put indirect-overlay 'evaporate t) + (with-current-buffer (pcase-exhaustive erase-where + (`base base) + (`indirect indirect)) + (delete-region beg end)) + (ert-info ((prin1-to-string + `(,base ,base-overlay ,indirect ,indirect-overlay))) + (should (not (buffer-live-p (overlay-buffer base-overlay)))) + (should (not (buffer-live-p (overlay-buffer indirect-overlay)))) + (should (equal nil (with-current-buffer base + (overlays-in (point-min) (point-max))))) + (should (equal nil (with-current-buffer indirect + (overlays-in (point-min) (point-max))))))))))) + (ert-deftest overlay-evaporation-after-killed-buffer () (let* ((ols (with-temp-buffer (insert "toto") commit 26d2ac38e9a7486aa56acb6bb0162c8ee091aaca Author: Matt Armstrong Date: Fri Nov 4 15:24:40 2022 -0700 Minor tweaks to the fix for `insert-before-markers' overlay fix (bug#58928) * src/buffer.c (adjust_overlays_for_insert): wrap to less than 80 chars. * src/itree.c: document BEFORE_MARKERS. diff --git a/src/buffer.c b/src/buffer.c index 745e62f53f..390ccff5c8 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -3467,7 +3467,8 @@ adjust_overlays_for_insert (ptrdiff_t pos, ptrdiff_t length, bool before_markers itree_insert_gap (base->overlays, pos, length, before_markers); FOR_EACH_LIVE_BUFFER (tail, other) if (XBUFFER (other)->base_buffer == base) - itree_insert_gap (XBUFFER (other)->overlays, pos, length, before_markers); + itree_insert_gap (XBUFFER (other)->overlays, pos, length, + before_markers); } } diff --git a/src/itree.c b/src/itree.c index c5e43bb028..989f452cb9 100644 --- a/src/itree.c +++ b/src/itree.c @@ -1191,7 +1191,10 @@ itree_iterator_finish (struct itree_iterator *iter) /* Insert a gap at POS of length LENGTH expanding all intervals intersecting it, while respecting their rear_advance and - front_advance setting. */ + front_advance setting. + + When BEFORE_MARKERS, all overlays beginning/ending at POS are + treated as if their front_advance/rear_advance was true. */ void itree_insert_gap (struct itree_tree *tree, commit 2fc6e715a2931523a52d541d5b9868ca6cb144ff Author: Matt Armstrong Date: Fri Nov 4 15:02:17 2022 -0700 Tweak the overlay related `insert-before-markers' tests * test/src/buffer-tests.el (test-overlay-insert-before-markers-empty): Move code down to the other tests related to insertion. Test all front/rear insert combinations. To make the test more clear, at least to me, hard code all character positions. (test-overlay-insert-before-markers-at-start): For both front-advance modes verify that `insert-before-markers' at and overlay's start advances it. (test-overlay-insert-before-markers-at-end): For both rear-advance modes test that `insert-before-markers' at an overlay's end advances it. (test-overlay-insert-before-markers-non-empty): Delete, replaced by the two tests above. diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index a39d7d51de..0e9e84ef7a 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -528,28 +528,6 @@ with parameters from the *Messages* buffer modification." (deftest-overlay-start/end-1 L (1 0) (1 1)) (deftest-overlay-start/end-1 M (0 0) (1 1)) -(ert-deftest test-overlay-insert-before-markers-empty () - (with-temp-buffer - (insert "1234") - (goto-char (1+ (point-min))) - (let ((overlay (make-overlay (point) (point)))) - (insert-before-markers "x") - (should (equal (point) (overlay-end overlay))) - (should (equal (point) (overlay-start overlay)))))) - -(ert-deftest test-overlay-insert-before-markers-non-empty () - (with-temp-buffer - (insert "1234") - (goto-char (+ 2 (point))) - (let ((overlay (make-overlay (1- (point)) (point)))) - (insert-before-markers "x") - (should (equal (point) (overlay-end overlay))) - (should (equal (- (point) 2) (overlay-start overlay))) - (forward-char -2) - (insert-before-markers "y") - (should (equal (+ 2 (point)) (overlay-end overlay))) - (should (equal (point) (overlay-start overlay)))))) - (ert-deftest test-overlay-start/end-2 () (should-not (overlay-start (with-temp-buffer (make-overlay 1 1)))) (should-not (overlay-end (with-temp-buffer (make-overlay 1 1))))) @@ -1315,7 +1293,46 @@ Regression test for bug#58706." (delete-overlay left) (should (= 2 (length (overlays-in 1 (point-max)))))))) +;; +==========================================================================+ +;; | Moving overlays with insert-before-markers +;; +==========================================================================+ +(ert-deftest test-overlay-insert-before-markers-at-start () + "`insert-before-markers' always advances an overlay's start. +Test both front-advance and non-front-advance overlays." + (dolist (front-advance '(nil t)) + (ert-info ((format "front-advance %S" front-advance)) + (with-temp-buffer + (insert "1234") + (let ((overlay (make-overlay 2 3 nil front-advance nil))) + (goto-char 2) + (insert-before-markers "x") + (should (equal 3 (overlay-start overlay))) + (should (equal 4 (overlay-end overlay)))))))) + +(ert-deftest test-overlay-insert-before-markers-at-end () + "`insert-before-markers' always advances an overlay's end. +Test both rear-advance and non-rear-advance overlays." + (dolist (rear-advance '(nil t)) + (ert-info ((format "rear-advance %S" rear-advance)) + (with-temp-buffer + (insert "1234") + (let ((overlay (make-overlay 2 3 nil nil rear-advance))) + (goto-char 3) + (insert-before-markers "x") + (should (equal 2 (overlay-start overlay))) + (should (equal 4 (overlay-end overlay)))))))) + +(ert-deftest test-overlay-insert-before-markers-empty () + (dolist (advance-args '((nil nil) (t nil) (nil t) (t t))) + (ert-info ((format "advance args %S" advance-args)) + (with-temp-buffer + (insert "1234") + (let ((overlay (apply #'make-overlay 2 2 nil advance-args))) + (goto-char 2) + (insert-before-markers "x") + (should (equal 3 (overlay-start overlay))) + (should (equal 3 (overlay-end overlay)))))))) ;; +==========================================================================+ ;; | Moving by deletions commit 4e108213341c99193d73133bb9d2cfbf31e6d8c9 Author: Brian Cully Date: Mon Oct 31 11:55:45 2022 -0400 lisp/eshell/em-tramp.el: Rename 'TRAMP' to 'Tramp'. diff --git a/lisp/eshell/em-tramp.el b/lisp/eshell/em-tramp.el index 3daac1db3b..499deaa7fc 100644 --- a/lisp/eshell/em-tramp.el +++ b/lisp/eshell/em-tramp.el @@ -1,4 +1,4 @@ -;;; em-tramp.el --- Eshell features that require TRAMP -*- lexical-binding:t -*- +;;; em-tramp.el --- Eshell features that require Tramp -*- lexical-binding:t -*- ;; Copyright (C) 1999-2022 Free Software Foundation, Inc. @@ -21,7 +21,7 @@ ;;; Commentary: -;; Eshell features that require TRAMP. +;; Eshell features that require Tramp. ;;; Code: @@ -38,17 +38,17 @@ ;;;###autoload (progn (defgroup eshell-tramp nil - "This module defines commands that use TRAMP in a way that is + "This module defines commands that use Tramp in a way that is not transparent to the user. So far, this includes only the built-in su, sudo and doas commands, which are not compatible with the full, external su, sudo, and doas commands, and - require the user to understand how to use the TRAMP sudo + require the user to understand how to use the Tramp sudo method." - :tag "TRAMP Eshell features" + :tag "Tramp Eshell features" :group 'eshell-module)) (defun eshell-tramp-initialize () ;Called from `eshell-mode' via intern-soft! - "Initialize the TRAMP-using commands code." + "Initialize the Tramp-using commands code." (when (eshell-using-module 'eshell-cmpl) (add-hook 'pcomplete-try-first-hook 'eshell-complete-host-reference nil t)) @@ -59,9 +59,9 @@ (autoload 'eshell-parse-command "esh-cmd") (defun eshell/su (&rest args) - "Alias \"su\" to call TRAMP. + "Alias \"su\" to call Tramp. -Uses the system su through TRAMP's su method." +Uses the system su through Tramp's su method." (eshell-eval-using-options "su" args '((?h "help" nil nil "show this usage screen") @@ -110,7 +110,7 @@ Become another USER during a login session.") (defun eshell/sudo (&rest args) "Alias \"sudo\" to call Tramp. -Uses the system sudo through TRAMP's sudo method." +Uses the system sudo through Tramp's sudo method." (eshell-eval-using-options "sudo" args '((?h "help" nil nil "show this usage screen") commit 062d16c3ebed270aa1cb64b6b6cd09c36002d4a5 Author: Brian Cully Date: Wed Oct 26 21:10:21 2022 -0400 Add the "doas" alias to eshell. * lisp/eshell/em-tramp.el (eshell/doas): new function. (eshell--method-wrap-directory): new function. (eshell/sudo): accept '-s'/'--shell' for interactive use. * test/lisp/eshell/em-tramp-tests.el (em-tramp-test/sudo-shell) (em-tramp-test/sudo-user-shell) (em-tramp-test/doas-basic) (em-tramp-test/doas-user) (em-tramp-test/doas-shell) (em-tramp-test/doas-user-shell): new tests. * etc/NEWS: mention new 'doas' eshell command. * doc/misc/eshell.texi: add 'doas' command documentation. diff --git a/doc/misc/eshell.texi b/doc/misc/eshell.texi index ff368c9dc4..96873a3f9a 100644 --- a/doc/misc/eshell.texi +++ b/doc/misc/eshell.texi @@ -717,9 +717,12 @@ current environment. @cmindex su @itemx sudo @cmindex sudo -Uses TRAMP's @command{su} or @command{sudo} method @pxref{Inline methods, , , tramp} -to run a command via @command{su} or @command{sudo}. These commands -are in the eshell-tramp module, which is disabled by default. +@itemx doas +@cmindex doas +Uses TRAMP's @command{su}, @command{sudo}, or @command{doas} method +@pxref{Inline methods, , , tramp} to run a command via @command{su}, +@command{sudo}, or @command{doas}. These commands are in the +eshell-tramp module, which is disabled by default. @item substitute diff --git a/etc/NEWS b/etc/NEWS index df755c6ed1..89da8aa63f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -370,6 +370,11 @@ node in the Eshell manual for more details. *** Eshell pipelines now only pipe stdout by default. To pipe both stdout and stderr, use the '|&' operator instead of '|'. +*** New eshell built-in command 'doas'. +The privilege-escalation program 'doas' has been added to the existing +'su' and 'sudo' commands from the 'eshell-tramp' module. The external +command may still be accessed by using '*doas'. + --- ** The 'delete-forward-char' command now deletes by grapheme clusters. This command is by default bound to the function key diff --git a/lisp/eshell/em-tramp.el b/lisp/eshell/em-tramp.el index aebbc36e71..3daac1db3b 100644 --- a/lisp/eshell/em-tramp.el +++ b/lisp/eshell/em-tramp.el @@ -40,9 +40,10 @@ (defgroup eshell-tramp nil "This module defines commands that use TRAMP in a way that is not transparent to the user. So far, this includes only the - built-in su and sudo commands, which are not compatible with - the full, external su and sudo commands, and require the user - to understand how to use the TRAMP sudo method." + built-in su, sudo and doas commands, which are not compatible + with the full, external su, sudo, and doas commands, and + require the user to understand how to use the TRAMP sudo + method." :tag "TRAMP Eshell features" :group 'eshell-module)) @@ -52,7 +53,7 @@ (add-hook 'pcomplete-try-first-hook 'eshell-complete-host-reference nil t)) (setq-local eshell-complex-commands - (append '("su" "sudo") + (append '("su" "sudo" "doas") eshell-complex-commands))) (autoload 'eshell-parse-command "esh-cmd") @@ -91,6 +92,21 @@ Become another USER during a login session.") (put 'eshell/su 'eshell-no-numeric-conversions t) +(defun eshell--method-wrap-directory (directory method &optional user) + "Return DIRECTORY as accessed by a Tramp METHOD for USER." + (let ((user (or user "root")) + (dir (file-local-name (expand-file-name directory))) + (prefix (file-remote-p directory)) + (host (or (file-remote-p directory 'host) + tramp-default-host)) + (rmethod (file-remote-p directory 'method)) + (ruser (file-remote-p directory 'user))) + (if (and prefix (or (not (string-equal rmethod method)) + (not (string-equal ruser user)))) + (format "%s|%s:%s@%s:%s" + (substring prefix 0 -1) method user host dir) + (format "/%s:%s@%s:%s" method user host dir)))) + (defun eshell/sudo (&rest args) "Alias \"sudo\" to call Tramp. @@ -99,34 +115,44 @@ Uses the system sudo through TRAMP's sudo method." "sudo" args '((?h "help" nil nil "show this usage screen") (?u "user" t user "execute a command as another USER") + (?s "shell" nil shell "start a shell instead of executing COMMAND") :show-usage :parse-leading-options-only - :usage "[(-u | --user) USER] COMMAND + :usage "[(-u | --user) USER] (-s | --shell) | COMMAND Execute a COMMAND as the superuser or another USER.") - (throw 'eshell-external - (let* ((user (or user "root")) - (host (or (file-remote-p default-directory 'host) - tramp-default-host)) - (dir (file-local-name (expand-file-name default-directory))) - (prefix (file-remote-p default-directory)) - (default-directory - (if (and prefix - (or - (not - (string-equal - "sudo" - (file-remote-p default-directory 'method))) - (not - (string-equal - user - (file-remote-p default-directory 'user))))) - (format "%s|sudo:%s@%s:%s" - (substring prefix 0 -1) user host dir) - (format "/sudo:%s@%s:%s" user host dir)))) - (eshell-named-command (car args) (cdr args)))))) + (let ((dir (eshell--method-wrap-directory default-directory "sudo" user))) + (if shell + (throw 'eshell-replace-command + (eshell-parse-command "cd" (list dir))) + (throw 'eshell-external + (let ((default-directory dir)) + (eshell-named-command (car args) (cdr args)))))))) (put 'eshell/sudo 'eshell-no-numeric-conversions t) +(defun eshell/doas (&rest args) + "Call Tramp's doas method with ARGS. + +Uses the system doas through Tramp's doas method." + (eshell-eval-using-options + "doas" args + '((?h "help" nil nil "show this usage screen") + (?u "user" t user "execute a command as another USER") + (?s "shell" nil shell "start a shell instead of executing COMMAND") + :show-usage + :parse-leading-options-only + :usage "[(-u | --user) USER] (-s | --shell) | COMMAND +Execute a COMMAND as the superuser or another USER.") + (let ((dir (eshell--method-wrap-directory default-directory "doas" user))) + (if shell + (throw 'eshell-replace-command + (eshell-parse-command "cd" (list dir))) + (throw 'eshell-external + (let ((default-directory dir)) + (eshell-named-command (car args) (cdr args)))))))) + +(put 'eshell/doas 'eshell-no-numeric-conversions t) + (provide 'em-tramp) ;; Local Variables: diff --git a/test/lisp/eshell/em-tramp-tests.el b/test/lisp/eshell/em-tramp-tests.el index 8969c1e229..6cc35ecdb1 100644 --- a/test/lisp/eshell/em-tramp-tests.el +++ b/test/lisp/eshell/em-tramp-tests.el @@ -85,4 +85,79 @@ `(,(format "/sudo:USER@%s:%s" tramp-default-host default-directory) ("echo" ("-u" "hi"))))))) +(ert-deftest em-tramp-test/sudo-shell () + "Test Eshell `sudo' command with -s/--shell option." + (dolist (args '(("--shell") + ("-s"))) + (should (equal + (catch 'eshell-replace-command (apply #'eshell/sudo args)) + `(eshell-trap-errors + (eshell-named-command + "cd" + (list ,(format "/sudo:root@%s:%s" + tramp-default-host default-directory)))))))) + +(ert-deftest em-tramp-test/sudo-user-shell () + "Test Eshell `sudo' command with -s and -u options." + (should (equal + (catch 'eshell-replace-command (eshell/sudo "-u" "USER" "-s")) + `(eshell-trap-errors + (eshell-named-command + "cd" + (list ,(format "/sudo:USER@%s:%s" + tramp-default-host default-directory))))))) + +(ert-deftest em-tramp-test/doas-basic () + "Test Eshell `doas' command with default user." + (cl-letf (((symbol-function 'eshell-named-command) + #'mock-eshell-named-command)) + (should (equal + (catch 'eshell-external (eshell/doas "echo" "hi")) + `(,(format "/doas:root@%s:%s" + tramp-default-host default-directory) + ("echo" ("hi"))))) + (should (equal + (catch 'eshell-external (eshell/doas "echo" "-u" "hi")) + `(,(format "/doas:root@%s:%s" + tramp-default-host default-directory) + ("echo" ("-u" "hi"))))))) + +(ert-deftest em-tramp-test/doas-user () + "Test Eshell `doas' command with specified user." + (cl-letf (((symbol-function 'eshell-named-command) + #'mock-eshell-named-command)) + (should (equal + (catch 'eshell-external (eshell/doas "-u" "USER" "echo" "hi")) + `(,(format "/doas:USER@%s:%s" + tramp-default-host default-directory) + ("echo" ("hi"))))) + (should (equal + (catch 'eshell-external + (eshell/doas "-u" "USER" "echo" "-u" "hi")) + `(,(format "/doas:USER@%s:%s" + tramp-default-host default-directory) + ("echo" ("-u" "hi"))))))) + +(ert-deftest em-tramp-test/doas-shell () + "Test Eshell `doas' command with -s/--shell option." + (dolist (args '(("--shell") + ("-s"))) + (should (equal + (catch 'eshell-replace-command (apply #'eshell/doas args)) + `(eshell-trap-errors + (eshell-named-command + "cd" + (list ,(format "/doas:root@%s:%s" + tramp-default-host default-directory)))))))) + +(ert-deftest em-tramp-test/doas-user-shell () + "Test Eshell `doas' command with -s and -u options." + (should (equal + (catch 'eshell-replace-command (eshell/doas "-u" "USER" "-s")) + `(eshell-trap-errors + (eshell-named-command + "cd" + (list ,(format "/doas:USER@%s:%s" + tramp-default-host default-directory))))))) + ;;; em-tramp-tests.el ends here commit 8a49a888532c955ae81855636a65b446508cb361 Author: Juri Linkov Date: Sat Nov 5 19:45:57 2022 +0200 ; * lisp/progmodes/project.el (project-kill-buffer-conditions): Fix typo. diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 3f3015b78d..fc035675ce 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) - "\\[^ ]") + "\\`[^ ]") ;; non-text buffer such as xref, occur, vc, log, ... (and (derived-mode . special-mode) (not (major-mode . help-mode)) commit 9828b596e57824a71f93a658fbf42b11e69cdf20 Author: Juri Linkov Date: Sat Nov 5 19:40:48 2022 +0200 * etc/NEWS: Remove remark implemented by 'vc-default-checkin-patch'. diff --git a/etc/NEWS b/etc/NEWS index 559704312d..df755c6ed1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1893,8 +1893,6 @@ with the changes against the last commit, e.g. with 'C-x v D' want to commit. Finally, type 'C-x v v' in that diff buffer to commit only part of your changes, those whose hunks were left in the buffer. -Currently this feature works only with the Git as 'vc-backend'. - --- *** 'C-x v v' on an unregistered file will now use the most specific backend. Previously, if you had an SVN-covered "~/" directory, and a Git-covered commit 7926cf73414d93700119f6138429a1347bb797fa Author: Juri Linkov Date: Sat Nov 5 19:34:47 2022 +0200 * lisp/net/dictionary.el (dictionary-search): Use format-prompt. diff --git a/lisp/net/dictionary.el b/lisp/net/dictionary.el index b8f5018005..d381750eb0 100644 --- a/lisp/net/dictionary.el +++ b/lisp/net/dictionary.el @@ -1150,9 +1150,7 @@ It presents the selection or word at point as default input and allows editing it." (interactive (list (let ((default (dictionary-search-default))) - (read-string (if default - (format "Search word (%s): " default) - "Search word: ") + (read-string (format-prompt "Search word" default) nil 'dictionary-word-history default)) (if current-prefix-arg (read-string (if dictionary-default-dictionary commit 2637ef8f48a9f1bd26575731465b9ce0e75d4653 Author: Juri Linkov Date: Sat Nov 5 19:15:42 2022 +0200 * lisp/tab-bar.el (tab-bar-fixed-width): Improve width calculations. diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 810cb4edd7..2150fa1506 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -1055,9 +1055,10 @@ tab bar might wrap to the second line.") (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) + (let* ((space (apply 'propertize " " (text-properties-at 0 name))) + (space-width (string-pixel-width (propertize space 'face 'tab-bar))) + (ins-pos (- len (if close-p 1 0)))) + (while (<= (+ pixel-width space-width) width) (setf (substring name ins-pos ins-pos) space) (setq pixel-width (string-pixel-width (propertize name 'face 'tab-bar-tab)))))) commit 270020a4b45edb0484a9e7b40ec2fbd894cb430d Author: Philip Kaludercic Date: Sat Nov 5 16:43:05 2022 +0100 Rephrase 'package-vc-ensure-packages' docstring * lisp/emacs-lisp/package-vc.el (package-vc-ensure-packages): Make it easier to read. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index ae0f7e0ee1..a0b4b03118 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -119,7 +119,7 @@ the `clone' function." (defvar package-vc-selected-packages) ; pacify byte-compiler (defun package-vc-ensure-packages () - "Ensure source packages specified in `package-vc-selected-packages'." + "Ensure packages specified in `package-vc-selected-packages' are installed." (pcase-dolist (`(,(and (pred symbolp) name) . ,spec) package-vc-selected-packages) (let ((pkg-desc (cadr (assoc name package-alist #'string=)))) commit 1557bb9d8f1f2f99aa5a594bdb1c7aa1c7546b97 Author: Philip Kaludercic Date: Sat Nov 5 16:31:16 2022 +0100 ; Rename 'package-vc-link-directory' to '-install-from-checkout' * doc/emacs/package.texi (Fetching Package Sources): Rename instances * etc/NEWS: Rename instances. * lisp/emacs-lisp/package-vc.el (package-vc-link-directory): Rename to 'package-vc-install-from-checkout'. diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index bd11648e57..e8af35e2e3 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -592,11 +592,11 @@ 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-install-from-checkout @findex package-vc-refresh If you maintain your own packages you might want to use a local checkout instead of cloning a remote repository. You can do this by -using @code{package-vc-link-directory}, which creates a symbolic link +using @code{package-vc-install-from-checkout}, which creates a symbolic link from the package directory (@pxref{Package Files}) to your checkout and initialises the code. Note that you might have to use @code{package-vc-refresh} to repeat the initialisation and update the diff --git a/etc/NEWS b/etc/NEWS index edeb8fc3d0..559704312d 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1559,7 +1559,7 @@ Packages can now be installed directly from source by cloning from a repository. +++ -*** New command 'package-vc-link-directory' +*** New command 'package-vc-install-from-checkout' An existing checkout can now be loaded via package.el, by creating a symbolic link from the usual package directory to the checkout. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 96cf7bb466..ae0f7e0ee1 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -28,8 +28,8 @@ ;; 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. +;; `package-vc-install-from-checkout' 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 @@ -665,7 +665,7 @@ for the last released version of the package." (find-file directory))) ;;;###autoload -(defun package-vc-link-directory (dir name) +(defun package-vc-install-from-checkout (dir name) "Set up the package NAME in DIR by linking it into the ELPA directory. Interactively, prompt the user for DIR, which should be a directory under version control, typically one created by `package-vc-checkout'. commit 22e8c679ee6e09a864725e42ffd4df014fbdca31 Author: Michael Albinus Date: Sat Nov 5 17:39:17 2022 +0100 * lisp/jka-compr.el (jka-compr-load): Add MUST-SUFFIX argument. diff --git a/lisp/jka-compr.el b/lisp/jka-compr.el index 8db78ebcda..420d83ab1f 100644 --- a/lisp/jka-compr.el +++ b/lisp/jka-compr.el @@ -598,7 +598,7 @@ There should be no more than seven characters after the final `/'." ;; Support for loading compressed files. -(defun jka-compr-load (file &optional noerror nomessage _nosuffix) +(defun jka-compr-load (file &optional noerror nomessage _nosuffix _must-suffix) "Documented as original." (let* ((local-copy (jka-compr-file-local-copy file)) commit 26460328bc92605f5c3a41dc1963519299c6e266 Author: Eli Zaretskii Date: Sat Nov 5 15:19:42 2022 +0200 Fix the unexec build * src/itree.c (forget_itree): New function. * src/emacs.c (Fdump_emacs): Call 'forget_itree'. diff --git a/src/emacs.c b/src/emacs.c index 40ba0db340..1b2aa9442b 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -3105,6 +3105,8 @@ You must run Emacs in batch mode in order to dump it. */) gflags.will_dump_with_unexec_ = false; gflags.dumped_with_unexec_ = true; + forget_itree (); + alloc_unexec_pre (); unexec (SSDATA (filename), !NILP (symfile) ? SSDATA (symfile) : 0); diff --git a/src/itree.c b/src/itree.c index cd37da18b8..c5e43bb028 100644 --- a/src/itree.c +++ b/src/itree.c @@ -294,6 +294,14 @@ init_itree (void) iter = itree_iterator_create (NULL); } +#ifdef HAVE_UNEXEC +void +forget_itree (void) +{ + iter = NULL; +} +#endif + struct check_subtree_result { /* Node count of the tree. */ diff --git a/src/itree.h b/src/itree.h index d05bc7789a..436fcfc7a0 100644 --- a/src/itree.h +++ b/src/itree.h @@ -107,6 +107,7 @@ enum itree_order }; extern void init_itree (void); +extern void forget_itree (void); extern void itree_node_init (struct itree_node *, bool, bool, Lisp_Object); extern ptrdiff_t itree_node_begin (struct itree_tree *, struct itree_node *); extern ptrdiff_t itree_node_end (struct itree_tree *, struct itree_node *); commit ae497d75f74f7ef0830f6cb760fa786a589e290d Author: Eli Zaretskii Date: Sat Nov 5 14:28:53 2022 +0200 Fix warnings in sqlite.c in the MS-Windows build * src/sqlite.c (sqlite3_errstr) [WINDOWSNT]: Define and load from the DLL only if the SQLite3 version is at least 3.7.15. (sqlite_prepare_errdata) [SQLITE_VERSION_NUMBER >= 3007015]: Use the original code if sqlite3_errstr is available. diff --git a/src/sqlite.c b/src/sqlite.c index 906d064000..ac860f55bc 100644 --- a/src/sqlite.c +++ b/src/sqlite.c @@ -52,7 +52,9 @@ DEF_DLL_FN (SQLITE_API int, sqlite3_bind_null, (sqlite3_stmt*, int)); DEF_DLL_FN (SQLITE_API int, sqlite3_bind_int, (sqlite3_stmt*, int, int)); DEF_DLL_FN (SQLITE_API int, sqlite3_extended_errcode, (sqlite3*)); DEF_DLL_FN (SQLITE_API const char*, sqlite3_errmsg, (sqlite3*)); +#if SQLITE_VERSION_NUMBER >= 3007015 DEF_DLL_FN (SQLITE_API const char*, sqlite3_errstr, (int)); +#endif DEF_DLL_FN (SQLITE_API int, sqlite3_step, (sqlite3_stmt*)); DEF_DLL_FN (SQLITE_API int, sqlite3_changes, (sqlite3*)); DEF_DLL_FN (SQLITE_API int, sqlite3_column_count, (sqlite3_stmt*)); @@ -91,7 +93,9 @@ DEF_DLL_FN (SQLITE_API int, sqlite3_load_extension, # undef sqlite3_bind_int # undef sqlite3_extended_errcode # undef sqlite3_errmsg -# undef sqlite3_errstr +# if SQLITE_VERSION_NUMBER >= 3007015 +# undef sqlite3_errstr +# endif # undef sqlite3_step # undef sqlite3_changes # undef sqlite3_column_count @@ -117,7 +121,9 @@ DEF_DLL_FN (SQLITE_API int, sqlite3_load_extension, # define sqlite3_bind_int fn_sqlite3_bind_int # define sqlite3_extended_errcode fn_sqlite3_extended_errcode # define sqlite3_errmsg fn_sqlite3_errmsg -# define sqlite3_errstr fn_sqlite3_errstr +# if SQLITE_VERSION_NUMBER >= 3007015 +# define sqlite3_errstr fn_sqlite3_errstr +# endif # define sqlite3_step fn_sqlite3_step # define sqlite3_changes fn_sqlite3_changes # define sqlite3_column_count fn_sqlite3_column_count @@ -146,7 +152,9 @@ load_dll_functions (HMODULE library) LOAD_DLL_FN (library, sqlite3_bind_int); LOAD_DLL_FN (library, sqlite3_extended_errcode); LOAD_DLL_FN (library, sqlite3_errmsg); +#if SQLITE_VERSION_NUMBER >= 3007015 LOAD_DLL_FN (library, sqlite3_errstr); +#endif LOAD_DLL_FN (library, sqlite3_step); LOAD_DLL_FN (library, sqlite3_changes); LOAD_DLL_FN (library, sqlite3_column_count); @@ -428,14 +436,17 @@ row_to_value (sqlite3_stmt *stmt) static Lisp_Object sqlite_prepare_errdata (int code, sqlite3 *sdb) { - Lisp_Object errstr, errcode, ext_errcode; - const char *errmsg; + Lisp_Object errcode = make_fixnum (code); + const char *errmsg = sqlite3_errmsg (sdb); + Lisp_Object lerrmsg = errmsg ? build_string (errmsg) : Qnil; + Lisp_Object errstr, ext_errcode; - /* The internet says this is identical to sqlite3_errstr (code), - which is too new to exist on Fedora 9. */ - errmsg = sqlite3_errmsg (sdb); - errstr = errmsg ? build_string (errmsg) : Qnil; - errcode = make_fixnum (code); +#if SQLITE_VERSION_NUMBER >= 3007015 + errstr = build_string (sqlite3_errstr (code)); +#else + /* The internet says this is identical to sqlite3_errstr (code). */ + errstr = lerrmsg; +#endif /* More details about what went wrong. */ #if SQLITE_VERSION_NUMBER >= 3006005 @@ -445,8 +456,7 @@ sqlite_prepare_errdata (int code, sqlite3 *sdb) ext_errcode = make_fixnum (0); #endif - return list4 (errstr, errmsg ? build_string (errmsg) : Qnil, - errcode, ext_errcode); + return list4 (errstr, lerrmsg, errcode, ext_errcode); } DEFUN ("sqlite-execute", Fsqlite_execute, Ssqlite_execute, 2, 3, 0, commit e275dd289437547414b22cda3227305fb6a85854 Author: Nicolas Graner Date: Thu Nov 3 22:49:43 2022 +0100 Avoid error when forwarding messages from Rmail * lisp/gnus/message.el (message-mail): Verify that In-Reply-To has a string value before matching it with a regexp. (Bug#59007) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 24cba97718..3bbd68bdcd 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -7034,6 +7034,7 @@ is a function used to switch to and display the mail buffer." ;; Firefox sends us In-Reply-To headers that are Message-IDs ;; without <> around them. Fix that. (when (and (eq (car h) 'In-Reply-To) + (stringp (cdr h)) ;; Looks like a Message-ID. (string-match-p "\\`[^ @]+@[^ @]+\\'" (cdr h)) (not (string-match-p "\\`<.*>\\'" (cdr h)))) commit ae7dcba6c5d9c2c19f4ee67793e164af3723f69f Author: Po Lu Date: Sat Nov 5 19:43:12 2022 +0800 Make sqlite.c build with SQlite in Fedora 9 * src/sqlite.c (sqlite_prepare_errdata): Use sqlite3_errmsg instead of sqlite3_errstr. diff --git a/src/sqlite.c b/src/sqlite.c index 08bf696b8c..906d064000 100644 --- a/src/sqlite.c +++ b/src/sqlite.c @@ -428,11 +428,23 @@ row_to_value (sqlite3_stmt *stmt) static Lisp_Object sqlite_prepare_errdata (int code, sqlite3 *sdb) { - Lisp_Object errstr = build_string (sqlite3_errstr (code)); - Lisp_Object errcode = make_fixnum (code); + Lisp_Object errstr, errcode, ext_errcode; + const char *errmsg; + + /* The internet says this is identical to sqlite3_errstr (code), + which is too new to exist on Fedora 9. */ + errmsg = sqlite3_errmsg (sdb); + errstr = errmsg ? build_string (errmsg) : Qnil; + errcode = make_fixnum (code); + /* More details about what went wrong. */ - Lisp_Object ext_errcode = make_fixnum (sqlite3_extended_errcode (sdb)); - const char *errmsg = sqlite3_errmsg (sdb); +#if SQLITE_VERSION_NUMBER >= 3006005 + ext_errcode = make_fixnum (sqlite3_extended_errcode (sdb)); +#else + /* What value to use here? */ + ext_errcode = make_fixnum (0); +#endif + return list4 (errstr, errmsg ? build_string (errmsg) : Qnil, errcode, ext_errcode); } commit 656cc127f2e16fd40585ddc9646b1cb8d552d9dd Merge: 22fb5397de 154ecf6197 Author: Eli Zaretskii Date: Sat Nov 5 13:12:32 2022 +0200 Merge branch 'master' of git.savannah.gnu.org:/srv/git/emacs commit 154ecf61972fa7277bf9412f2bf34b496338b57d Author: Po Lu Date: Sat Nov 5 19:09:42 2022 +0800 Simplify XI scroll class reporting code * src/xterm.c (xi_populate_device_from_info): Use xnmalloc. Avoid reading classes at all when the XI library only supports 2.0. (xi_handle_new_classes): New function. (xi_handle_device_changed): Move class parsing logic there to avoid duplicating code. diff --git a/src/xterm.c b/src/xterm.c index 4178526c31..545a95f7b2 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -5301,6 +5301,7 @@ x_free_xi_devices (struct x_display_info *dpyinfo) } #ifdef HAVE_XINPUT2_1 + struct xi_known_valuator { /* The current value of this valuator. */ @@ -5312,6 +5313,7 @@ struct xi_known_valuator /* The next valuator whose value we already know. */ struct xi_known_valuator *next; }; + #endif static void @@ -5321,11 +5323,10 @@ xi_populate_device_from_info (struct xi_device_t *xi_device, #ifdef HAVE_XINPUT2_1 struct xi_scroll_valuator_t *valuator; struct xi_known_valuator *values, *tem; - int actual_valuator_count; + int actual_valuator_count, c; XIScrollClassInfo *info; XIValuatorClassInfo *val_info; #endif - int c; #ifdef HAVE_XINPUT2_2 XITouchClassInfo *touch_info; #endif @@ -5339,8 +5340,8 @@ xi_populate_device_from_info (struct xi_device_t *xi_device, #ifdef HAVE_XINPUT2_1 actual_valuator_count = 0; - xi_device->valuators = xmalloc (sizeof *xi_device->valuators - * device->num_classes); + xi_device->valuators = xnmalloc (device->num_classes, + sizeof *xi_device->valuators); values = NULL; #endif @@ -5353,11 +5354,11 @@ xi_populate_device_from_info (struct xi_device_t *xi_device, xi_device->direct_p = false; #endif +#ifdef HAVE_XINPUT2_1 for (c = 0; c < device->num_classes; ++c) { switch (device->classes[c]->type) { -#ifdef HAVE_XINPUT2_1 case XIScrollClass: { info = (XIScrollClassInfo *) device->classes[c]; @@ -5385,7 +5386,6 @@ xi_populate_device_from_info (struct xi_device_t *xi_device, values = tem; break; } -#endif #ifdef HAVE_XINPUT2_2 case XITouchClass: @@ -5399,7 +5399,6 @@ xi_populate_device_from_info (struct xi_device_t *xi_device, } } -#ifdef HAVE_XINPUT2_1 xi_device->scroll_valuator_count = actual_valuator_count; /* Now look through all the valuators whose values are already known @@ -13043,97 +13042,117 @@ xi_has_scroll_valuators (XIDeviceChangedEvent *event) return false; } -#endif +/* Repopulate the information (touchpoint tracking information, scroll + valuators, etc) in DEVICE with the device classes provided in + CLASSES. This is called upon receiving a DeviceChanged event. -/* Handle EVENT, a DeviceChanged event. Look up the device that - changed, and update its information with the data in EVENT. */ + This function is not present on XI 2.0 as there are no worthwhile + classes there. */ static void -xi_handle_device_changed (struct x_display_info *dpyinfo, - struct xi_device_t *device, - XIDeviceChangedEvent *event) +xi_handle_new_classes (struct x_display_info *dpyinfo, struct xi_device_t *device, + XIAnyClassInfo **classes, int num_classes) { -#ifdef HAVE_XINPUT2_1 - XIDeviceInfo *info; XIScrollClassInfo *scroll; - int i, ndevices; struct xi_scroll_valuator_t *valuator; XIValuatorClassInfo *valuator_info; -#endif + int i; #ifdef HAVE_XINPUT2_2 - struct xi_touch_point_t *tem, *last; XITouchClassInfo *touch; #endif -#ifdef HAVE_XINPUT2_1 - 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) */ - - device->valuators = xrealloc (device->valuators, - (event->num_classes - * sizeof *device->valuators)); - device->scroll_valuator_count = 0; + if (dpyinfo->xi2_version < 1) + /* Emacs is connected to an XI 2.0 server, which reports no + classes of interest. */ + return; + + device->valuators = xnmalloc (num_classes, + sizeof *device->valuators); + device->scroll_valuator_count = 0; #ifdef HAVE_XINPUT2_2 - device->direct_p = false; + device->direct_p = false; #endif - for (i = 0; i < event->num_classes; ++i) + for (i = 0; i < num_classes; ++i) + { + switch (classes[i]->type) { - 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; + case XIScrollClass: + scroll = (XIScrollClassInfo *) 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]; + case XITouchClass: + touch = (XITouchClassInfo *) classes[i]; - if (touch->mode == XIDirectTouch) - device->direct_p = true; - break; + if (touch->mode == XIDirectTouch) + device->direct_p = true; + break; #endif - } } + } - /* Restore the values of any scroll valuators that we already - know about. */ + /* Restore the values of any scroll valuators that we already + know about. */ - for (i = 0; i < event->num_classes; ++i) + for (i = 0; i < num_classes; ++i) + { + switch (classes[i]->type) { - 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; - } + case XIValuatorClass: + valuator_info = (XIValuatorClassInfo *) classes[i]; - break; + 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; } + + break; } } +} + +#endif + +/* Handle EVENT, a DeviceChanged event. Look up the device that + changed, and update its information with the data in EVENT. */ + +static void +xi_handle_device_changed (struct x_display_info *dpyinfo, + struct xi_device_t *device, + XIDeviceChangedEvent *event) +{ +#ifdef HAVE_XINPUT2_1 + int ndevices; + XIDeviceInfo *info; +#endif +#ifdef HAVE_XINPUT2_2 + struct xi_touch_point_t *tem, *last; +#endif + +#ifdef HAVE_XINPUT2_1 + 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: if this event is a SlaveSwitch event caused by + wheel movement, then querying for the device info will probably + return the value after the wheel movement, leading to a delta + of 0 being computed upon handling the subsequent XI_Motion + event. (bug#58980) */ + xi_handle_new_classes (dpyinfo, device, event->classes, + event->num_classes); else { /* When a DeviceChange event is received for a master device, @@ -13153,65 +13172,10 @@ xi_handle_device_changed (struct x_display_info *dpyinfo, if (!info) return; - device->valuators = xrealloc (device->valuators, - (info->num_classes - * sizeof *device->valuators)); - device->scroll_valuator_count = 0; -#ifdef HAVE_XINPUT2_2 - device->direct_p = false; -#endif - - for (i = 0; i < info->num_classes; ++i) - { - switch (info->classes[i]->type) - { - case XIScrollClass: - scroll = (XIScrollClassInfo *) info->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 *) info->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 < info->num_classes; ++i) - { - switch (info->classes[i]->type) - { - case XIValuatorClass: - valuator_info = (XIValuatorClassInfo *) info->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; - } - - break; - } - } - - XIFreeDeviceInfo (info); + /* info contains the classes currently associated with the + event. Apply them. */ + xi_handle_new_classes (dpyinfo, device, info->classes, + info->num_classes); } #endif commit 22fb5397defc14c3dbdb48ba7f2f06cb7329be9d Author: Eli Zaretskii Date: Sat Nov 5 13:11:28 2022 +0200 ; Fix documentation of package-vc.el * lisp/emacs-lisp/package-vc.el (package-vc-default-backend) (package-vc-selected-packages, package-vc--archive-spec-alist) (package-vc--archive-data-alist, package-vc--query-spec) (package-vc--read-archive-data, package-vc-commit) (package-vc--main-file, package-vc--generate-description-file) (package-vc--build-documentation, package-vc--unpack-1) (package-vc--guess-backend, package-vc--clone) (package-vc--unpack, package-vc-update, package-vc--release-rev) (package-vc-install, package-vc-checkout) (package-vc-link-directory, package-vc-refresh) (package-vc-prepare-patch, package-vc--archives-initialize): Doc fixes. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index aae33096c9..96cf7bb466 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -109,9 +109,10 @@ (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-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." +`package-vc-heuristic-alist', this is the default VC backend +used as fallback. The value must be a member of +`vc-handled-backends' and the named backend must implement +the `clone' function." :type `(choice ,@(mapcar (lambda (b) (list 'const b)) vc-handled-backends)) :version "29.1") @@ -135,13 +136,12 @@ symbol is used. The value must be a member of ;;;###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 + "List of packages that must be installed. +Each member 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, +- nil, if any package version can be installed; +- a version string, if that specific revision is to be installed; - a property list of the form described in `package-vc-archive-spec-alist', giving a package specification. @@ -149,7 +149,7 @@ is a symbol designating the package and SPEC is one of: This user option differs from `package-selected-packages' in that 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" + :type '(alist :tag "List of packages you want to be installed" :key-type (symbol :tag "Package") :value-type (choice (const :tag "Any revision" nil) @@ -166,54 +166,47 @@ function `package-vc-selected-packages' to apply the changes." (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 +The list maps each package name, as a string, to a plist. +Valid keys and the corresponding value types are: - `:url' (string) + `:url' (string) + The URL of the repository used to fetch the package source. -The URL of the repository used to fetch the package source. + `:branch' (string) + If given, the name of the branch to checkout after cloning the directory. - `:branch' (string) + `:lisp-dir' (string) + The repository-relative name of the directory to use for loading the Lisp + sources. If not given, the value defaults to the root directory + of the repository. -If given, the branch to check out after cloning the directory. + `:main-file' (string) + The main file of the project, relevant to gather package metadata. + If not given, the assumed default is the package name with \".el\" + appended to it. - `: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. - - `: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'. + `:vc-backend' (symbol) + A symbol of the VC backend to use for cloning the package. The + value ought to be a member of `vc-handled-backends'. If omitted, + `vc-clone' will fall back onto the archive default or on + `package-vc-default-backend'. All other values are ignored.") (defvar package-vc--archive-data-alist nil - "List of package specification archive metadata. + "List of package specification metadata for archives. 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'. + `:version' (integer) + Indicates 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'. + `:vc-backend' (symbol) + A symbol of the default VC backend to use if a package specification + does not indicate a backend. The value ought to be a member of + `vc-handled-backends'. If omitted, `vc-clone' will fall back on + `package-vc-default-backend'. All other values are ignored.") @@ -230,16 +223,15 @@ name for PKG-DESC." nil nil #'string=)) (define-inline package-vc--query-spec (pkg-desc prop) - "Query the property PROP for the package specification for PKG-DESC. + "Query the property PROP for the package specification of 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)))) (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'." + "Update `package-vc--archive-spec-alist' for 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))) @@ -279,10 +271,10 @@ asynchronously." (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." + "Return the last commit of a development package PKG." (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). + ;; directory (as is possible when dealing with git repositories). ;; This should be a fallback option. (cl-loop with dir = (package-desc-dir pkg) for file in (directory-files dir t "\\.el\\'" t) @@ -301,7 +293,7 @@ asynchronously." "0")) (defun package-vc--main-file (pkg-desc) - "Return the main file for PKG-DESC." + "Return the name of 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) @@ -315,8 +307,7 @@ asynchronously." (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." + "Generate a package description file for PKG-DESC and write it to PKG-FILE." (let ((name (package-desc-name pkg-desc))) ;; Infer the subject if missing. (unless (package-desc-summary pkg-desc) @@ -360,7 +351,9 @@ 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) - "Build documentation FILE for PKG-DESC." + "Build documentation FILE for PKG-DESC. +FILE can be an Org file, indicated by its \".org\" extension, +otherwise it's assumed to be an Info file." (let ((pkg-dir (package-desc-dir pkg-desc))) (when (string-match-p "\\.org\\'" file) (require 'ox) @@ -373,7 +366,7 @@ The output is written out into PKG-FILE." file pkg-dir))) (defun package-vc--unpack-1 (pkg-desc pkg-dir) - "Install PKG-DESC that is already located in PKG-DIR." + "Install PKG-DESC that is already checked-out 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. @@ -443,14 +436,14 @@ The output is written out into PKG-FILE." (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 return nil if it cannot reasonably guess." (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." + "Clone the package PKG-DESC whose spec is PKG-SPEC into the directory DIR. +REV specifies a specific revision to checkout. This overrides the `:branch' +attribute in PKG-SPEC." (pcase-let* ((name (package-desc-name pkg-desc)) ((map :url :branch) pkg-spec)) @@ -477,11 +470,10 @@ package specification PKG-SPEC." (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." +PKG-SPEC is a package specification, a property list describing +how to fetch and build the package. See `package-vc--archive-spec-alist' +for details. The optional argument REV specifies a specific revision to +checkout. This overrides the `:branch' attribute in PKG-SPEC." (pcase-let* (((map :url :lisp-dir) pkg-spec) (name (package-desc-name pkg-desc)) (dirname (package-desc-full-name pkg-desc)) @@ -523,7 +515,7 @@ the `:brach' attribute in PKG-SPEC." package-archive-contents)) (defun package-vc-update (pkg-desc) - "Attempt to update the packager PKG-DESC." + "Attempt to update the package PKG-DESC." ;; 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 @@ -558,13 +550,13 @@ the `:brach' attribute in PKG-SPEC." (vc-pull)))) (defun package-vc--archives-initialize () - "Initialise package.el and fetch package specifications." + "Initialize package.el and fetch package specifications." (package--archives-initialize) (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. + "Return 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) @@ -586,20 +578,23 @@ If no such revision can be found, return nil." ;;;###autoload (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 -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. 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. 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." + "Fetch a package NAME-OR-URL and set it up for using with Emacs. +If NAME-OR-URL is a URL, download the package from the repository +at that URL; the function will try to guess the name of the package +from the URL. Otherwise NAME-OR-URL should be a symbol whose name +is the package name, and the URL for the package will be taken from +the package's metadata. +By default, this function installs the last version of the package +available from its repository, but if REV is given and non-nil, it +specifies the revision to install. If REV has the special value +`:last-release' (interactively, the prefix argument), that stands +for the last released version of the package. +When calling from Lisp, optional argument NAME overrides the package +name as deduced from NAME-OR-URL. +Optional argument BACKEND specifies the VC backend to use for cloning +the package's repository; this is only possible if NAME-OR-URL is a URL, +a string. If BACKEND is omitted or nil, the function +uses `package-vc--guess-backend' to guess the backend." (interactive (progn ;; Initialize the package system to get the list of package @@ -637,12 +632,15 @@ repository can be set by BACKEND. If missing, ;;;###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 -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." + "Clone the sources for PKG-DESC into DIRECTORY and visit that directory. +Unlike `package-vc-install', this does not yet set up the package +for use with Emacs; use `package-vc-link-directory' for setting +the package up after this function finishes. +Optional argument REV means to clone a specific version of the +package; it defaults to the last version available from the +package's repository. If REV has the special value +`:last-release' (interactively, the prefix argument), that stands +for the last released version of the package." (interactive (progn ;; Initialize the package system to get the list of package @@ -668,10 +666,12 @@ special value `:last-release' as REV." ;;;###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 -prompted for the package NAME. Otherwise it will be inferred -from the base name of DIR." + "Set up the package NAME in DIR by linking it into the ELPA directory. +Interactively, prompt the user for DIR, which should be a directory +under version control, typically one created by `package-vc-checkout'. +If invoked interactively with a prefix argument, prompt the user +for the NAME of the package to set up. Otherwise infer the package +name from the base name of DIR." (interactive (let ((dir (read-directory-name "Directory: "))) (list dir (if current-prefix-arg @@ -690,7 +690,8 @@ from the base name of DIR." ;;;###autoload (defun package-vc-refresh (pkg-desc) - "Refresh the installation for PKG-DESC." + "Refresh the installation for package given by PKG-DESC. +Interactively, prompt for the name of the package to refresh." (interactive (package-vc--read-pkg "Refresh package: ")) (package-vc--unpack-1 pkg-desc (package-desc-dir pkg-desc))) @@ -706,9 +707,12 @@ from the base name of DIR." ;;;###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'. -PKG must be a package description." + "Send patch for REVISIONS to maintainer of the package PKG using SUBJECT. +SUBJECT and REVISIONS are passed on to `vc-prepare-patch', which see. +PKG must be a package description. +Interactively, prompt for PKG, SUBJECT, and REVISIONS. However, +if the current buffer has marked commit log entries, REVISIONS +are the tags of the marked entries, see `log-view-get-marked'." (interactive (list (package-vc--read-pkg "Package to prepare a patch for: ") (and (not vc-prepare-patches-separately)