commit 74100997b3853a6c00c60e1998ed5a86a9a01bc3 (HEAD, refs/remotes/origin/master) Author: Stefan Monnier Date: Mon Apr 4 15:11:46 2022 -0400 * lisp/progmodes/cc-cmds.el (indent-new-comment-line): Delete advice This piece of advice was effective only for Emacs<20.1 and old XEmacs (at least older than Aug 2007). diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index e9237bb01e..f1f61f7e08 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -5026,18 +5026,6 @@ If a fill prefix is specified, it overrides all the above." (defalias 'c-comment-line-break-function 'c-indent-new-comment-line) (make-obsolete 'c-comment-line-break-function 'c-indent-new-comment-line "21.1") -;; Advice for Emacsen older than 21.1 (!), released 2001/10 -(unless (boundp 'comment-line-break-function) - (defvar c-inside-line-break-advice nil) - (defadvice indent-new-comment-line (around c-line-break-advice - activate preactivate) - "Call `c-indent-new-comment-line' if in CC Mode." - (if (or c-inside-line-break-advice - (not c-buffer-is-cc-mode)) - ad-do-it - (let ((c-inside-line-break-advice t)) - (c-indent-new-comment-line (ad-get-arg 0)))))) - (defun c-context-line-break () "Do a line break suitable to the context. commit 1f4f6b956bee611ffa406b3851e5264ee74e3bfb Author: Stefan Monnier Date: Mon Apr 4 15:06:47 2022 -0400 OClosure: add support for `slot-value` * lisp/emacs-lisp/oclosure.el (oclosure--slot-index) (oclosure--slot-value, oclosure--set-slot-value): New functions. * lisp/emacs-lisp/eieio-core.el (eieio-oset, eieio-oref): Consolidate the type test. Use `oclosure--(set-)slot-value`. (eieio--validate-slot-value, eieio--validate-class-slot-value): Don't presume `class` is an EIEIO class. (eieio--class): Fix bogus `:type` info. (eieio--object-class): Simplify. (eieio--known-slot-name-p): New function. (eieio-oref, eieio-oref-default, eieio-oset-default): Use it. * test/lisp/emacs-lisp/oclosure-tests.el: Require `eieio`. (oclosure-test): Make `name` field mutable. (oclosure-test-slot-value): New test. diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index ed1a28a24f..d687289b22 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -92,7 +92,7 @@ Currently under control of this var: (:copier nil)) children initarg-tuples ;; initarg tuples list - (class-slots nil :type eieio--slot) + (class-slots nil :type (vector-of eieio--slot)) class-allocation-values ;; class allocated value vector default-object-cache ;; what a newly created object would look like. ; This will speed up instantiation time as @@ -130,10 +130,7 @@ Currently under control of this var: class)) (defsubst eieio--object-class (obj) - (let ((tag (eieio--object-class-tag obj))) - (if eieio-backward-compatibility - (eieio--class-object tag) - tag))) + (eieio--class-object (eieio--object-class-tag obj))) (defun class-p (x) "Return non-nil if X is a valid class vector. @@ -265,6 +262,10 @@ use '%s or turn off `eieio-backward-compatibility' instead" cname) (defvar eieio--known-slot-names nil) (defvar eieio--known-class-slot-names nil) +(defun eieio--known-slot-name-p (name) + (or (memq name eieio--known-slot-names) + (get name 'slot-name))) + (defun eieio-defclass-internal (cname superclasses slots options) "Define CNAME as a new subclass of SUPERCLASSES. SLOTS are the slots residing in that class definition, and OPTIONS @@ -704,13 +705,13 @@ an error." nil ;; Trim off object IDX junk added in for the object index. (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots))) - (let* ((sd (aref (cl--class-slots class) + (let* ((sd (aref (eieio--class-slots class) slot-idx)) (st (cl--slot-descriptor-type sd))) (cond ((not (eieio--perform-slot-validation st value)) (signal 'invalid-slot-type - (list (eieio--class-name class) slot st value))) + (list (cl--class-name class) slot st value))) ((alist-get :read-only (cl--slot-descriptor-props sd)) (signal 'eieio-read-only (list (cl--class-name class) slot))))))) @@ -725,7 +726,7 @@ an error." slot-idx)))) (if (not (eieio--perform-slot-validation st value)) (signal 'invalid-slot-type - (list (eieio--class-name class) slot st value)))))) + (list (cl--class-name class) slot st value)))))) (defun eieio-barf-if-slot-unbound (value instance slotname fn) "Throw a signal if VALUE is a representation of an UNBOUND slot. @@ -746,31 +747,35 @@ Argument FN is the function calling this verifier." (ignore obj) (pcase slot ((and (or `',name (and name (pred keywordp))) - (guard (not (memq name eieio--known-slot-names)))) + (guard (not (eieio--known-slot-name-p name)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) exp nil 'compile-only name)) (_ exp)))) + ;; FIXME: Make it a gv-expander such that the hash-table lookup is + ;; only performed once when used in `push' and friends? (gv-setter eieio-oset)) (cl-check-type slot symbol) - (cl-check-type obj (or eieio-object class cl-structure-object)) - (let* ((class (cond ((symbolp obj) - (error "eieio-oref called on a class: %s" obj) - (eieio--full-class-object obj)) - (t (eieio--object-class obj)))) - (c (eieio--slot-name-index class slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c (eieio--class-slot-name-index class slot)) - ;; Oref that slot. - (aref (eieio--class-class-allocation-values class) c) - ;; The slot-missing method is a cool way of allowing an object author - ;; to intercept missing slot definitions. Since it is also the LAST - ;; thing called in this fn, its return value would be retrieved. - (slot-missing obj slot 'oref)) - (cl-check-type obj (or eieio-object cl-structure-object)) - (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) + (cond + ((cl-typep obj '(or eieio-object cl-structure-object)) + (let* ((class (eieio--object-class obj)) + (c (eieio--slot-name-index class slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c (eieio--class-slot-name-index class slot)) + ;; Oref that slot. + (aref (eieio--class-class-allocation-values class) c) + ;; The slot-missing method is a cool way of allowing an object author + ;; to intercept missing slot definitions. Since it is also the LAST + ;; thing called in this fn, its return value would be retrieved. + (slot-missing obj slot 'oref)) + (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) + ((cl-typep obj 'oclosure) (oclosure--slot-value obj slot)) + (t + (signal 'wrong-type-argument + (list '(or eieio-object cl-structure-object oclosure) obj))))) + (defun eieio-oref-default (class slot) @@ -782,7 +787,7 @@ Fills in CLASS's SLOT with its default value." (ignore class) (pcase slot ((and (or `',name (and name (pred keywordp))) - (guard (not (memq name eieio--known-slot-names)))) + (guard (not (eieio--known-slot-name-p name)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) exp nil 'compile-only name)) @@ -817,24 +822,29 @@ Fills in CLASS's SLOT with its default value." (defun eieio-oset (obj slot value) "Do the work for the macro `oset'. Fills in OBJ's SLOT with VALUE." - (cl-check-type obj (or eieio-object cl-structure-object)) (cl-check-type slot symbol) - (let* ((class (eieio--object-class obj)) - (c (eieio--slot-name-index class slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c - (eieio--class-slot-name-index class slot)) - ;; Oset that slot. - (progn - (eieio--validate-class-slot-value class c value slot) - (aset (eieio--class-class-allocation-values class) - c value)) - ;; See oref for comment on `slot-missing' - (slot-missing obj slot 'oset value)) - (eieio--validate-slot-value class c value slot) - (aset obj c value)))) + (cond + ((cl-typep obj '(or eieio-object cl-structure-object)) + (let* ((class (eieio--object-class obj)) + (c (eieio--slot-name-index class slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c + (eieio--class-slot-name-index class slot)) + ;; Oset that slot. + (progn + (eieio--validate-class-slot-value class c value slot) + (aset (eieio--class-class-allocation-values class) + c value)) + ;; See oref for comment on `slot-missing' + (slot-missing obj slot 'oset value)) + (eieio--validate-slot-value class c value slot) + (aset obj c value)))) + ((cl-typep obj 'oclosure) (oclosure--set-slot-value obj slot value)) + (t + (signal 'wrong-type-argument + (list '(or eieio-object cl-structure-object oclosure) obj))))) (defun eieio-oset-default (class slot value) "Do the work for the macro `oset-default'. @@ -844,7 +854,7 @@ Fills in the default value in CLASS' in SLOT with VALUE." (ignore class value) (pcase slot ((and (or `',name (and name (pred keywordp))) - (guard (not (memq name eieio--known-slot-names)))) + (guard (not (eieio--known-slot-name-p name)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) exp nil 'compile-only name)) @@ -867,7 +877,7 @@ Fills in the default value in CLASS' in SLOT with VALUE." (eieio--validate-class-slot-value class c value slot) (aset (eieio--class-class-allocation-values class) c value)) - (signal 'invalid-slot-name (list (eieio--class-name class) slot))) + (signal 'invalid-slot-name (list (cl--class-name class) slot))) ;; `oset-default' on an instance-allocated slot is allowed by EIEIO but ;; not by CLOS and is mildly inconsistent with the :initform thingy, so ;; it'd be nice to get rid of it. diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index c37a5352a3..3df64ad280 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -511,6 +511,26 @@ This has 2 uses: "OClosure function to access a specific slot of an OClosure function." index) +(defun oclosure--slot-index (oclosure slotname) + (gethash slotname + (oclosure--class-index-table + (cl--find-class (oclosure-type oclosure))))) + +(defun oclosure--slot-value (oclosure slotname) + (let ((class (cl--find-class (oclosure-type oclosure))) + (index (oclosure--slot-index oclosure slotname))) + (oclosure--get oclosure index + (oclosure--slot-mutable-p + (nth index (oclosure--class-slots class)))))) + +(defun oclosure--set-slot-value (oclosure slotname value) + (let ((class (cl--find-class (oclosure-type oclosure))) + (index (oclosure--slot-index oclosure slotname))) + (unless (oclosure--slot-mutable-p + (nth index (oclosure--class-slots class))) + (signal 'setting-constant (list oclosure slotname))) + (oclosure--set value oclosure index))) + (defconst oclosure--mut-getter-prototype (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (oclosure) (oclosure--get oclosure index t))) diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el index c72a9dbd7a..d3e2b3870a 100644 --- a/test/lisp/emacs-lisp/oclosure-tests.el +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -22,12 +22,13 @@ (require 'ert) (require 'oclosure) (require 'cl-lib) +(require 'eieio) (oclosure-define (oclosure-test (:copier oclosure-test-copy) (:copier oclosure-test-copy1 (fst))) "Simple OClosure." - fst snd name) + fst snd (name :mutable t)) (cl-defmethod oclosure-test-gen ((_x compiled-function)) "#") @@ -123,4 +124,20 @@ (should (equal (funcall f 5) 15)) (should (equal (funcall f2 15) 68)))) +(ert-deftest oclosure-test-slot-value () + (require 'eieio) + (let ((ocl (oclosure-lambda + (oclosure-test (fst 'fst1) (snd 'snd1) (name 'name1)) + (x) + (list name fst snd x)))) + (should (equal 'fst1 (slot-value ocl 'fst))) + (should (equal 'snd1 (slot-value ocl 'snd))) + (should (equal 'name1 (slot-value ocl 'name))) + (setf (slot-value ocl 'name) 'new-name) + (should (equal 'new-name (slot-value ocl 'name))) + (should (equal '(new-name fst1 snd1 arg) (funcall ocl 'arg))) + (should-error (setf (slot-value ocl 'fst) 'new-fst) :type 'setting-constant) + (should (equal 'fst1 (slot-value ocl 'fst))) + )) + ;;; oclosure-tests.el ends here. commit 6c4a4cc94e9fea809b518da9fe9e581a6031a6df Author: Eli Zaretskii Date: Mon Apr 4 21:09:43 2022 +0300 ; * src/alloc.c (grow_mark_stack): Remove unused variable. diff --git a/src/alloc.c b/src/alloc.c index 71f2c199b2..6d91ec3358 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6677,7 +6677,6 @@ grow_mark_stack (void) struct mark_stack *ms = &mark_stk; eassert (ms->sp == ms->size); ptrdiff_t min_incr = ms->sp == 0 ? 8192 : 1; - ptrdiff_t oldsize = ms->size; ms->stack = xpalloc (ms->stack, &ms->size, min_incr, -1, sizeof *ms->stack); eassert (ms->sp < ms->size); } commit f4b649ad0b1bcd347432928d967d49fab24a4c91 Author: Vincent Belaïche Date: Mon Apr 4 19:42:07 2022 +0200 SES with case insensitive cell names for jumping. * doc/misc/ses.texi (The Basics): Document that ses-jump may be customized. (Customizing @acronym{SES}): Document new customisations for ses-jump. * lisp/ses.el (ses-jump-cell-name-function) (ses-jump-prefix-function): New defcustoms. (ses-jump-prefix): New defun. (ses-jump): Make ses-jump use the new defcustoms. * test/lisp/ses-tests.el (ses-jump-B2-prefix-arg) (ses-jump-B2-lowcase, ses-jump-B2-lowcase-keys) (ses-jump-B2-symbol, ses-jump-B2-renamed): New tests. diff --git a/doc/misc/ses.texi b/doc/misc/ses.texi index 0acb7bf3f1..6d0415cdbb 100644 --- a/doc/misc/ses.texi +++ b/doc/misc/ses.texi @@ -220,7 +220,14 @@ You move around with the regular Emacs movement commands. @table @kbd @item j -Moves point to cell, specified by identifier (@code{ses-jump}). +Moves point to cell, specified by identifier (@code{ses-jump}). Unless +the cell is a renamed cell, the identifier is case-insensitive. A +prefix argument @math{n} move to cell with coordinates @math{(n\div R, +n \% C)} for a spreadsheet of @math{R} rows and @math{C} columns, and +A1 being of coordinates @math{(0,0)}. The way the identifier or the +command prefix argument are interpreted can be customized through +variables @code{ses-jump-cell-name-function} and +@code{ses-jump-prefix-function}. @end table Point is always at the left edge of a cell, or at the empty endline. @@ -726,10 +733,6 @@ yank. This doesn't make any difference? @section Customizing @acronym{SES} @cindex customizing @vindex enable-local-eval -@vindex ses-mode-hook -@vindex safe-functions -@vindex enable-local-eval - By default, a newly-created spreadsheet has 1 row and 1 column. The column width is 7 and the default printer is @samp{"%.7g"}. Each of these @@ -740,9 +743,34 @@ cell. You can customize @code{ses-after-entry-functions} to move left or up or down. For diagonal movement, select two functions from the list. +@vindex ses-jump-cell-name-function +@code{ses-jump-cell-name-function} is a customizable variable by +default set to the @code{upcase} function. This function is called +when you pass a cell name to the @command{ses-jump} command (@kbd{j}), +it changes the entered cell name to that where to jump. The default +setting @code{upcase} allows you to enter the cell name in low +case. Another use of @code{ses-jump-cell-name-function} could be some +internationalisation to convert non latin characters into latin +equivalents to name the cell. Instead of a cell name, the function may +return cell coordinates in the form of a cons, for instance @code{(0 +. 0)} for cell @code{A1}, @code{(1 . 0)} for cell @code{A2}, etc. + +@vindex ses-jump-prefix-function +@code{ses-jump-prefix-function} is a customisable variable by default +set to the @code{ses-jump-prefix} function. This function is called +when you give a prefix argument to the @command{ses-jump} command +(@kbd{j}). It returns a cell name or cell coordinates corresponding to +the prefix argument. Cell coordinates are in the form of a cons, for +instance @code{(1 . 0)} for cell @code{A2}. The default setting +@code{ses-jump-prefix} will number cells left to right and then top +down, so assuming a 4x3 spreadsheet prefix argument 0 jumps to cell +A1, prefix argument 2 jumps to C1, prefix argument 3 jumps to A2, etc. + +@vindex ses-mode-hook @code{ses-mode-hook} is a normal mode hook (list of functions to execute when starting @acronym{SES} mode for a buffer). +@vindex safe-functions The variable @code{safe-functions} is a list of possibly-unsafe functions to be treated as safe when analyzing formulas and printers. @xref{Virus protection}. Before customizing @code{safe-functions}, diff --git a/lisp/ses.el b/lisp/ses.el index 45e323e805..e3b3a45776 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -112,6 +112,24 @@ Each function is called with ARG=1." :group 'ses :type 'hook) +(defcustom ses-jump-cell-name-function 'upcase + "Function to process the string passed to function ‘ses-jump’. Set it to 'identity to make no change. +Set it to 'upcase to make cell name change case isensitive. + + May return + +* a string, in this case this must be a cell name. +* a (row . col) cons cell, in this case that must be valid cell coordinate." + :group 'ses + :type 'function) + +(defcustom ses-jump-prefix-function 'ses-jump-prefix + "Function that takes the prefix argument passed to function ‘ses-jump’. It may return the same +sort of thing as ‘ses-jump-cell-name-function’." + :group 'ses + :type 'function) + + ;;---------------------------------------------------------------------------- ;; Global variables and constants @@ -2233,24 +2251,41 @@ Based on the current set of columns and `window-hscroll' position." ;;---------------------------------------------------------------------------- ;; Redisplay and recalculation ;;---------------------------------------------------------------------------- +(defun ses-jump-prefix (prefix-int) + "Convert an integer into a (ROW . COL), by numbering cells starting from 0 from top left to bottom right, going row by row." + (and (>= prefix-int 0) + (< prefix-int (* ses--numcols ses--numrows)) + (cons (/ prefix-int ses--numcols) (% prefix-int ses--numcols)))) -(defun ses-jump (sym) + +(defun ses-jump (&optional sym) "Move point to cell SYM." - (interactive (let* (names - (s (completing-read - "Jump to cell: " - (and ses--named-cell-hashmap - (progn (maphash (lambda (key _val) - (push (symbol-name key) names)) - ses--named-cell-hashmap) - names))))) - (if (string= s "") - (user-error "Invalid cell name") - (list (intern s))))) - (let ((rowcol (ses-sym-rowcol sym))) + (interactive "P") + (setq sym + (if current-prefix-arg + (funcall ses-jump-prefix-function (prefix-numeric-value sym)) + (or sym + (completing-read + "Jump to cell: " + (and ses--named-cell-hashmap + (let (names) + (maphash (lambda (key _val) + (push (symbol-name key) names)) + ses--named-cell-hashmap) + names)))))) + (and (stringp sym) + (not (and ses--named-cell-hashmap (gethash (intern sym) ses--named-cell-hashmap))) + (setq sym (funcall ses-jump-cell-name-function sym))) + (if (stringp sym) + (if (string= sym "") + (user-error "Empty cell name") + (setq sym (intern sym)))) + (let ((rowcol (if (consp sym) + (prog1 sym (setq sym (ses-cell-symbol (car sym) (cdr sym)))) + (ses-sym-rowcol sym)))) (or rowcol (error "Invalid cell name")) (if (eq (symbol-value sym) '*skip*) - (error "Cell is covered by preceding cell")) + (error "Cell is covered by preceding cell")) (ses-goto-print (car rowcol) (cdr rowcol)))) (defun ses-jump-safe (cell) diff --git a/test/lisp/ses-tests.el b/test/lisp/ses-tests.el index cd524cbf6e..b60ddeea78 100644 --- a/test/lisp/ses-tests.el +++ b/test/lisp/ses-tests.el @@ -178,6 +178,61 @@ to `ses--bar' and inserting a row, makes A2 value empty, and `ses--bar' equal to (should (eq ses--bar 2))))) +;; JUMP tests +;; ====================================================================== +(ert-deftest ses-jump-B2-prefix-arg () + "Test jumping to cell B2 by use of prefix argument" + (let ((ses-initial-size '(3 . 3)) + ses-after-entry-functions) + (with-temp-buffer + (ses-mode) + ;; C-u 4 M-x ses-jump + (let ((current-prefix-arg 4)) + (call-interactively 'ses-jump)) + (should (eq (ses--cell-at-pos (point)) 'B2))))) + + +(ert-deftest ses-jump-B2-lowcase () + "Test jumping to cell B2 by use of lowcase cell name string" + (let ((ses-initial-size '(3 . 3)) + ses-after-entry-functions) + (with-temp-buffer + (ses-mode) + (funcall-interactively 'ses-jump "b2") + (ses-command-hook) + (should (eq (ses--cell-at-pos (point)) 'B2))))) + +(ert-deftest ses-jump-B2-lowcase-keys () + "Test jumping to cell B2 by use of lowcase cell name string with simulating keys" + (let ((ses-initial-size '(3 . 3)) + ses-after-entry-functions) + (with-temp-buffer + (ses-mode) + (ert-simulate-keys [ ?b ?2 return] (ses-jump)) + (ses-command-hook) + (should (eq (ses--cell-at-pos (point)) 'B2))))) + +(ert-deftest ses-jump-B2-symbol () + "Test jumping to cell B2 by use of cell name symbol" + (let ((ses-initial-size '(3 . 3)) + ses-after-entry-functions) + (with-temp-buffer + (ses-mode) + (funcall-interactively 'ses-jump 'B2) + (ses-command-hook) + (should (eq (ses--cell-at-pos (point)) 'B2))))) + +(ert-deftest ses-jump-B2-renamed () + "Test jumping to cell B2 after renaming it `ses--toto'." + (let ((ses-initial-size '(3 . 3)) + ses-after-entry-functions) + (with-temp-buffer + (ses-mode) + (ses-rename-cell 'ses--toto (ses-get-cell 1 1)) + (ses-jump 'ses--toto) + (ses-command-hook) + (should (eq (ses--cell-at-pos (point)) 'ses--toto))))) + (provide 'ses-tests) ;;; ses-tests.el ends here commit 7a8798de95a57c8ff85f070075e0a0176b458578 Author: Mattias Engdegård Date: Sat Apr 2 16:02:09 2022 +0200 Reduce GC mark-phase recursion by using explicit stack (bug#54698) An explict stack of objects to be traversed for marking replaces recursion for most common object types: conses, vectors, records, hash tables, symbols, functions etc. Recursion is still used for other types but those are less common and thus not as likely to cause a problem. The stack grows dynamically as required which eliminates almost all C stack overflow crashes in the GC. There is also a nontrivial GC performance improvement. * src/alloc.c (GC_REMEMBER_LAST_MARKED, GC_CDR_COUNT): New. (mark_char_table, struct mark_entry): Remove (subsumed into process_mark_stack). (struct mark_entry, struct mark_stack, mark_stk) (mark_stack_empty_p, mark_stack_pop, grow_mark_stack) (mark_stack_push_value, mark_stack_push_values) (process_mark_stack): New. (mark_object, mark_objects): Just push the object(s) and let process_mark_stack do the work. diff --git a/src/alloc.c b/src/alloc.c index b06dd943ba..71f2c199b2 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6085,6 +6085,8 @@ maybe_garbage_collect (void) garbage_collect (); } +static inline bool mark_stack_empty_p (void); + /* Subroutine of Fgarbage_collect that does most of the work. */ void garbage_collect (void) @@ -6100,6 +6102,8 @@ garbage_collect (void) if (garbage_collection_inhibited) return; + eassert(mark_stack_empty_p ()); + /* Record this function, so it appears on the profiler's backtraces. */ record_in_backtrace (QAutomatic_GC, 0, 0); @@ -6222,6 +6226,8 @@ garbage_collect (void) mark_and_sweep_weak_table_contents (); eassert (weak_hash_tables == NULL); + eassert (mark_stack_empty_p ()); + gc_sweep (); unmark_main_thread (); @@ -6395,15 +6401,25 @@ mark_glyph_matrix (struct glyph_matrix *matrix) } } +/* Whether to remember a few of the last marked values for debugging. */ +#define GC_REMEMBER_LAST_MARKED 0 + +#if GC_REMEMBER_LAST_MARKED enum { LAST_MARKED_SIZE = 1 << 9 }; /* Must be a power of 2. */ Lisp_Object last_marked[LAST_MARKED_SIZE] EXTERNALLY_VISIBLE; static int last_marked_index; +#endif +/* Whether to enable the mark_object_loop_halt debugging feature. */ +#define GC_CDR_COUNT 0 + +#if GC_CDR_COUNT /* For debugging--call abort when we cdr down this many links of a list, in mark_object. In debugging, the call to abort will hit a breakpoint. Normally this is zero and the check never goes off. */ ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE; +#endif static void mark_vectorlike (union vectorlike_header *header) @@ -6457,19 +6473,6 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype) } } -NO_INLINE /* To reduce stack depth in mark_object. */ -static Lisp_Object -mark_compiled (struct Lisp_Vector *ptr) -{ - int i, size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK; - - set_vector_marked (ptr); - for (i = 0; i < size; i++) - if (i != COMPILED_CONSTANTS) - mark_object (ptr->contents[i]); - return size > COMPILED_CONSTANTS ? ptr->contents[COMPILED_CONSTANTS] : Qnil; -} - /* Mark the chain of overlays starting at PTR. */ static void @@ -6622,110 +6625,161 @@ mark_window (struct Lisp_Vector *ptr) (w, mark_discard_killed_buffers (w->next_buffers)); } -static void -mark_hash_table (struct Lisp_Vector *ptr) -{ - struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr; - - mark_vectorlike (&h->header); - mark_object (h->test.name); - mark_object (h->test.user_hash_function); - mark_object (h->test.user_cmp_function); - /* If hash table is not weak, mark all keys and values. For weak - tables, mark only the vector and not its contents --- that's what - makes it weak. */ - if (NILP (h->weak)) - mark_object (h->key_and_value); - else +/* Entry of the mark stack. */ +struct mark_entry +{ + ptrdiff_t n; /* number of values, or 0 if a single value */ + union { + Lisp_Object value; /* when n = 0 */ + Lisp_Object *values; /* when n > 0 */ + } u; +}; + +/* This stack is used during marking for traversing data structures without + using C recursion. */ +struct mark_stack +{ + struct mark_entry *stack; /* base of stack */ + ptrdiff_t size; /* allocated size in entries */ + ptrdiff_t sp; /* current number of entries */ +}; + +static struct mark_stack mark_stk = {NULL, 0, 0}; + +static inline bool +mark_stack_empty_p (void) +{ + return mark_stk.sp <= 0; +} + +/* Pop and return a value from the mark stack (which must be nonempty). */ +static inline Lisp_Object +mark_stack_pop (void) +{ + eassume (!mark_stack_empty_p ()); + struct mark_entry *e = &mark_stk.stack[mark_stk.sp - 1]; + if (e->n == 0) /* single value */ { - eassert (h->next_weak == NULL); - h->next_weak = weak_hash_tables; - weak_hash_tables = h; - set_vector_marked (XVECTOR (h->key_and_value)); + --mark_stk.sp; + return e->u.value; } + /* Array of values: pop them left to right, which seems to be slightly + faster than right to left. */ + e->n--; + if (e->n == 0) + --mark_stk.sp; /* last value consumed */ + return (++e->u.values)[-1]; } -void -mark_objects (Lisp_Object *obj, ptrdiff_t n) +NO_INLINE static void +grow_mark_stack (void) { - for (ptrdiff_t i = 0; i < n; i++) - mark_object (obj[i]); + struct mark_stack *ms = &mark_stk; + eassert (ms->sp == ms->size); + ptrdiff_t min_incr = ms->sp == 0 ? 8192 : 1; + ptrdiff_t oldsize = ms->size; + ms->stack = xpalloc (ms->stack, &ms->size, min_incr, -1, sizeof *ms->stack); + eassert (ms->sp < ms->size); } -/* Determine type of generic Lisp_Object and mark it accordingly. +/* Push VALUE onto the mark stack. */ +static inline void +mark_stack_push_value (Lisp_Object value) +{ + if (mark_stk.sp >= mark_stk.size) + grow_mark_stack (); + mark_stk.stack[mark_stk.sp++] = (struct mark_entry){.n = 0, .u.value = value}; +} - This function implements a straightforward depth-first marking - algorithm and so the recursion depth may be very high (a few - tens of thousands is not uncommon). To minimize stack usage, - a few cold paths are moved out to NO_INLINE functions above. - In general, inlining them doesn't help you to gain more speed. */ +/* Push the N values at VALUES onto the mark stack. */ +static inline void +mark_stack_push_values (Lisp_Object *values, ptrdiff_t n) +{ + eassume (n >= 0); + if (n == 0) + return; + if (mark_stk.sp >= mark_stk.size) + grow_mark_stack (); + mark_stk.stack[mark_stk.sp++] = (struct mark_entry){.n = n, + .u.values = values}; +} -void -mark_object (Lisp_Object arg) +/* Traverse and mark objects on the mark stack above BASE_SP. + + Traversal is depth-first using the mark stack for most common + object types. Recursion is used for other types, in the hope that + they are rare enough that C stack usage is kept low. */ +static void +process_mark_stack (ptrdiff_t base_sp) { - register Lisp_Object obj; - void *po; #if GC_CHECK_MARKED_OBJECTS struct mem_node *m = NULL; #endif +#if GC_CDR_COUNT ptrdiff_t cdr_count = 0; +#endif - obj = arg; - loop: + eassume (mark_stk.sp >= base_sp && base_sp >= 0); - po = XPNTR (obj); - if (PURE_P (po)) - return; + while (mark_stk.sp > base_sp) + { + Lisp_Object obj = mark_stack_pop (); + mark_obj: ; + void *po = XPNTR (obj); + if (PURE_P (po)) + continue; - last_marked[last_marked_index++] = obj; - last_marked_index &= LAST_MARKED_SIZE - 1; +#if GC_REMEMBER_LAST_MARKED + last_marked[last_marked_index++] = obj; + last_marked_index &= LAST_MARKED_SIZE - 1; +#endif - /* Perform some sanity checks on the objects marked here. Abort if - we encounter an object we know is bogus. This increases GC time - by ~80%. */ + /* Perform some sanity checks on the objects marked here. Abort if + we encounter an object we know is bogus. This increases GC time + by ~80%. */ #if GC_CHECK_MARKED_OBJECTS - /* Check that the object pointed to by PO is known to be a Lisp - structure allocated from the heap. */ + /* Check that the object pointed to by PO is known to be a Lisp + structure allocated from the heap. */ #define CHECK_ALLOCATED() \ - do { \ - if (pdumper_object_p (po)) \ - { \ - if (!pdumper_object_p_precise (po)) \ - emacs_abort (); \ - break; \ - } \ - m = mem_find (po); \ - if (m == MEM_NIL) \ - emacs_abort (); \ - } while (0) - - /* Check that the object pointed to by PO is live, using predicate - function LIVEP. */ -#define CHECK_LIVE(LIVEP, MEM_TYPE) \ - do { \ - if (pdumper_object_p (po)) \ - break; \ - if (! (m->type == MEM_TYPE && LIVEP (m, po))) \ - emacs_abort (); \ - } while (0) - - /* Check both of the above conditions, for non-symbols. */ -#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) \ - do { \ - CHECK_ALLOCATED (); \ - CHECK_LIVE (LIVEP, MEM_TYPE); \ - } while (false) - - /* Check both of the above conditions, for symbols. */ -#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \ - do { \ - if (!c_symbol_p (ptr)) \ - { \ - CHECK_ALLOCATED (); \ - CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL); \ - } \ - } while (false) + do { \ + if (pdumper_object_p (po)) \ + { \ + if (!pdumper_object_p_precise (po)) \ + emacs_abort (); \ + break; \ + } \ + m = mem_find (po); \ + if (m == MEM_NIL) \ + emacs_abort (); \ + } while (0) + + /* Check that the object pointed to by PO is live, using predicate + function LIVEP. */ +#define CHECK_LIVE(LIVEP, MEM_TYPE) \ + do { \ + if (pdumper_object_p (po)) \ + break; \ + if (! (m->type == MEM_TYPE && LIVEP (m, po))) \ + emacs_abort (); \ + } while (0) + + /* Check both of the above conditions, for non-symbols. */ +#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) \ + do { \ + CHECK_ALLOCATED (); \ + CHECK_LIVE (LIVEP, MEM_TYPE); \ + } while (false) + + /* Check both of the above conditions, for symbols. */ +#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \ + do { \ + if (!c_symbol_p (ptr)) \ + { \ + CHECK_ALLOCATED (); \ + CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL); \ + } \ + } while (false) #else /* not GC_CHECK_MARKED_OBJECTS */ @@ -6734,200 +6788,220 @@ mark_object (Lisp_Object arg) #endif /* not GC_CHECK_MARKED_OBJECTS */ - switch (XTYPE (obj)) - { - case Lisp_String: - { - register struct Lisp_String *ptr = XSTRING (obj); - if (string_marked_p (ptr)) - break; - CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING); - set_string_marked (ptr); - mark_interval_tree (ptr->u.s.intervals); + switch (XTYPE (obj)) + { + case Lisp_String: + { + register struct Lisp_String *ptr = XSTRING (obj); + if (string_marked_p (ptr)) + break; + CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING); + set_string_marked (ptr); + mark_interval_tree (ptr->u.s.intervals); #ifdef GC_CHECK_STRING_BYTES - /* Check that the string size recorded in the string is the - same as the one recorded in the sdata structure. */ - string_bytes (ptr); + /* Check that the string size recorded in the string is the + same as the one recorded in the sdata structure. */ + string_bytes (ptr); #endif /* GC_CHECK_STRING_BYTES */ - } - break; + } + break; - case Lisp_Vectorlike: - { - register struct Lisp_Vector *ptr = XVECTOR (obj); + case Lisp_Vectorlike: + { + register struct Lisp_Vector *ptr = XVECTOR (obj); - if (vector_marked_p (ptr)) - break; + if (vector_marked_p (ptr)) + break; - enum pvec_type pvectype - = PSEUDOVECTOR_TYPE (ptr); + enum pvec_type pvectype + = PSEUDOVECTOR_TYPE (ptr); #ifdef GC_CHECK_MARKED_OBJECTS - if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po)) - { - m = mem_find (po); - if (m == MEM_NIL) - emacs_abort (); - if (m->type == MEM_TYPE_VECTORLIKE) - CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE); - else - CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK); - } + if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po)) + { + m = mem_find (po); + if (m == MEM_NIL) + emacs_abort (); + if (m->type == MEM_TYPE_VECTORLIKE) + CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE); + else + CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK); + } #endif - switch (pvectype) - { - case PVEC_BUFFER: - mark_buffer ((struct buffer *) ptr); - break; - - case PVEC_COMPILED: - /* Although we could treat this just like a vector, mark_compiled - returns the COMPILED_CONSTANTS element, which is marked at the - next iteration of goto-loop here. This is done to avoid a few - recursive calls to mark_object. */ - obj = mark_compiled (ptr); - if (!NILP (obj)) - goto loop; - break; - - case PVEC_FRAME: - mark_frame (ptr); - break; - - case PVEC_WINDOW: - mark_window (ptr); - break; - - case PVEC_HASH_TABLE: - mark_hash_table (ptr); - break; - - case PVEC_CHAR_TABLE: - case PVEC_SUB_CHAR_TABLE: - mark_char_table (ptr, (enum pvec_type) pvectype); - break; - - case PVEC_BOOL_VECTOR: - /* bool vectors in a dump are permanently "marked", since - they're in the old section and don't have mark bits. - If we're looking at a dumped bool vector, we should - have aborted above when we called vector_marked_p, so - we should never get here. */ - eassert (!pdumper_object_p (ptr)); - set_vector_marked (ptr); - break; - - case PVEC_OVERLAY: - mark_overlay (XOVERLAY (obj)); - break; - - case PVEC_SUBR: -#ifdef HAVE_NATIVE_COMP - if (SUBR_NATIVE_COMPILEDP (obj)) + switch (pvectype) { + case PVEC_BUFFER: + mark_buffer ((struct buffer *) ptr); + break; + + case PVEC_FRAME: + mark_frame (ptr); + break; + + case PVEC_WINDOW: + mark_window (ptr); + break; + + case PVEC_HASH_TABLE: + { + struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *)ptr; + ptrdiff_t size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK; + set_vector_marked (ptr); + mark_stack_push_values (ptr->contents, size); + mark_stack_push_value (h->test.name); + mark_stack_push_value (h->test.user_hash_function); + mark_stack_push_value (h->test.user_cmp_function); + if (NILP (h->weak)) + mark_stack_push_value (h->key_and_value); + else + { + /* For weak tables, mark only the vector and not its + contents --- that's what makes it weak. */ + eassert (h->next_weak == NULL); + h->next_weak = weak_hash_tables; + weak_hash_tables = h; + set_vector_marked (XVECTOR (h->key_and_value)); + } + break; + } + + case PVEC_CHAR_TABLE: + case PVEC_SUB_CHAR_TABLE: + mark_char_table (ptr, (enum pvec_type) pvectype); + break; + + case PVEC_BOOL_VECTOR: + /* bool vectors in a dump are permanently "marked", since + they're in the old section and don't have mark bits. + If we're looking at a dumped bool vector, we should + have aborted above when we called vector_marked_p, so + we should never get here. */ + eassert (!pdumper_object_p (ptr)); set_vector_marked (ptr); - struct Lisp_Subr *subr = XSUBR (obj); - mark_object (subr->native_intspec); - mark_object (subr->command_modes); - mark_object (subr->native_comp_u); - mark_object (subr->lambda_list); - mark_object (subr->type); - } + break; + + case PVEC_OVERLAY: + mark_overlay (XOVERLAY (obj)); + break; + + case PVEC_SUBR: +#ifdef HAVE_NATIVE_COMP + if (SUBR_NATIVE_COMPILEDP (obj)) + { + set_vector_marked (ptr); + struct Lisp_Subr *subr = XSUBR (obj); + mark_stack_push_value (subr->native_intspec); + mark_stack_push_value (subr->command_modes); + mark_stack_push_value (subr->native_comp_u); + mark_stack_push_value (subr->lambda_list); + mark_stack_push_value (subr->type); + } #endif - break; + break; - case PVEC_FREE: - emacs_abort (); + case PVEC_FREE: + emacs_abort (); - default: - /* A regular vector, or a pseudovector needing no special - treatment. */ - mark_vectorlike (&ptr->header); + default: + { + /* A regular vector or pseudovector needing no special + treatment. */ + ptrdiff_t size = ptr->header.size; + if (size & PSEUDOVECTOR_FLAG) + size &= PSEUDOVECTOR_SIZE_MASK; + set_vector_marked (ptr); + mark_stack_push_values (ptr->contents, size); + } + break; + } } - } - break; + break; - case Lisp_Symbol: - { - struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj); - nextsym: - if (symbol_marked_p (ptr)) - break; - CHECK_ALLOCATED_AND_LIVE_SYMBOL (); - set_symbol_marked (ptr); - /* Attempt to catch bogus objects. */ - eassert (valid_lisp_object_p (ptr->u.s.function)); - mark_object (ptr->u.s.function); - mark_object (ptr->u.s.plist); - switch (ptr->u.s.redirect) + case Lisp_Symbol: { - case SYMBOL_PLAINVAL: mark_object (SYMBOL_VAL (ptr)); break; - case SYMBOL_VARALIAS: - { - Lisp_Object tem; - XSETSYMBOL (tem, SYMBOL_ALIAS (ptr)); - mark_object (tem); + struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj); + nextsym: + if (symbol_marked_p (ptr)) break; - } - case SYMBOL_LOCALIZED: - mark_localized_symbol (ptr); - break; - case SYMBOL_FORWARDED: - /* If the value is forwarded to a buffer or keyboard field, - these are marked when we see the corresponding object. - And if it's forwarded to a C variable, either it's not - a Lisp_Object var, or it's staticpro'd already. */ - break; - default: emacs_abort (); + CHECK_ALLOCATED_AND_LIVE_SYMBOL (); + set_symbol_marked (ptr); + /* Attempt to catch bogus objects. */ + eassert (valid_lisp_object_p (ptr->u.s.function)); + mark_stack_push_value (ptr->u.s.function); + mark_stack_push_value (ptr->u.s.plist); + switch (ptr->u.s.redirect) + { + case SYMBOL_PLAINVAL: + mark_stack_push_value (SYMBOL_VAL (ptr)); + break; + case SYMBOL_VARALIAS: + { + Lisp_Object tem; + XSETSYMBOL (tem, SYMBOL_ALIAS (ptr)); + mark_stack_push_value (tem); + break; + } + case SYMBOL_LOCALIZED: + mark_localized_symbol (ptr); + break; + case SYMBOL_FORWARDED: + /* If the value is forwarded to a buffer or keyboard field, + these are marked when we see the corresponding object. + And if it's forwarded to a C variable, either it's not + a Lisp_Object var, or it's staticpro'd already. */ + break; + default: emacs_abort (); + } + if (!PURE_P (XSTRING (ptr->u.s.name))) + set_string_marked (XSTRING (ptr->u.s.name)); + mark_interval_tree (string_intervals (ptr->u.s.name)); + /* Inner loop to mark next symbol in this bucket, if any. */ + po = ptr = ptr->u.s.next; + if (ptr) + goto nextsym; } - if (!PURE_P (XSTRING (ptr->u.s.name))) - set_string_marked (XSTRING (ptr->u.s.name)); - mark_interval_tree (string_intervals (ptr->u.s.name)); - /* Inner loop to mark next symbol in this bucket, if any. */ - po = ptr = ptr->u.s.next; - if (ptr) - goto nextsym; - } - break; - - case Lisp_Cons: - { - struct Lisp_Cons *ptr = XCONS (obj); - if (cons_marked_p (ptr)) break; - CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS); - set_cons_marked (ptr); - /* If the cdr is nil, avoid recursion for the car. */ - if (NILP (ptr->u.s.u.cdr)) + + case Lisp_Cons: { + struct Lisp_Cons *ptr = XCONS (obj); + if (cons_marked_p (ptr)) + break; + CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS); + set_cons_marked (ptr); + /* Avoid growing the stack if the cdr is nil. + In any case, make sure the car is expanded first. */ + if (!NILP (ptr->u.s.u.cdr)) + { + mark_stack_push_value (ptr->u.s.u.cdr); +#if GC_CDR_COUNT + cdr_count++; + if (cdr_count == mark_object_loop_halt) + emacs_abort (); +#endif + } + /* Speedup hack for the common case (successive list elements). */ obj = ptr->u.s.car; - cdr_count = 0; - goto loop; + goto mark_obj; } - mark_object (ptr->u.s.car); - obj = ptr->u.s.u.cdr; - cdr_count++; - if (cdr_count == mark_object_loop_halt) - emacs_abort (); - goto loop; - } - case Lisp_Float: - CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT); - /* Do not mark floats stored in a dump image: these floats are - "cold" and do not have mark bits. */ - if (pdumper_object_p (XFLOAT (obj))) - eassert (pdumper_cold_object_p (XFLOAT (obj))); - else if (!XFLOAT_MARKED_P (XFLOAT (obj))) - XFLOAT_MARK (XFLOAT (obj)); - break; + case Lisp_Float: + CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT); + /* Do not mark floats stored in a dump image: these floats are + "cold" and do not have mark bits. */ + if (pdumper_object_p (XFLOAT (obj))) + eassert (pdumper_cold_object_p (XFLOAT (obj))); + else if (!XFLOAT_MARKED_P (XFLOAT (obj))) + XFLOAT_MARK (XFLOAT (obj)); + break; - case_Lisp_Int: - break; + case_Lisp_Int: + break; - default: - emacs_abort (); + default: + emacs_abort (); + } } #undef CHECK_LIVE @@ -6935,6 +7009,22 @@ mark_object (Lisp_Object arg) #undef CHECK_ALLOCATED_AND_LIVE } +void +mark_object (Lisp_Object obj) +{ + ptrdiff_t sp = mark_stk.sp; + mark_stack_push_value (obj); + process_mark_stack (sp); +} + +void +mark_objects (Lisp_Object *objs, ptrdiff_t n) +{ + ptrdiff_t sp = mark_stk.sp; + mark_stack_push_values (objs, n); + process_mark_stack (sp); +} + /* Mark the Lisp pointers in the terminal objects. Called by Fgarbage_collect. */ commit 8103b060d89ac63a12c439087bd46c30da72cd97 Author: Jürgen Hötzel Date: Fri Mar 4 10:08:14 2022 +0100 Use correct signal oldset in posix_spawn implementation posix_spawn was restoring the wrong signal set, which still had SIGCHLD and SIGINT masked, causing problems with child processes that spawned child processes. (Bug#54667) See the thread ending at https://lists.gnu.org/archive/html/emacs-devel/2022-03/msg00067.html for more details. * src/callproc.c (emacs_spawn): Pass oldset parameter. (emacs_posix_spawn_init_attributes): Use correct oldset. (emacs_posix_spawn_init): Remove intermediate function. diff --git a/src/callproc.c b/src/callproc.c index 018c9ce690..0922e10f01 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -1335,7 +1335,8 @@ emacs_posix_spawn_init_actions (posix_spawn_file_actions_t *actions, } static int -emacs_posix_spawn_init_attributes (posix_spawnattr_t *attributes) +emacs_posix_spawn_init_attributes (posix_spawnattr_t *attributes, + const sigset_t *oldset) { int error = posix_spawnattr_init (attributes); if (error != 0) @@ -1377,11 +1378,7 @@ emacs_posix_spawn_init_attributes (posix_spawnattr_t *attributes) goto out; /* Stop blocking SIGCHLD in the child. */ - sigset_t oldset; - error = pthread_sigmask (SIG_SETMASK, NULL, &oldset); - if (error != 0) - goto out; - error = posix_spawnattr_setsigmask (attributes, &oldset); + error = posix_spawnattr_setsigmask (attributes, oldset); if (error != 0) goto out; @@ -1392,23 +1389,6 @@ emacs_posix_spawn_init_attributes (posix_spawnattr_t *attributes) return error; } -static int -emacs_posix_spawn_init (posix_spawn_file_actions_t *actions, - posix_spawnattr_t *attributes, int std_in, - int std_out, int std_err, const char *cwd) -{ - int error = emacs_posix_spawn_init_actions (actions, std_in, - std_out, std_err, cwd); - if (error != 0) - return error; - - error = emacs_posix_spawn_init_attributes (attributes); - if (error != 0) - return error; - - return 0; -} - #endif /* Start a new asynchronous subprocess. If successful, return zero @@ -1443,9 +1423,12 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int std_err, if (use_posix_spawn) { /* Initialize optional attributes before blocking. */ - int error - = emacs_posix_spawn_init (&actions, &attributes, std_in, - std_out, std_err, cwd); + int error = emacs_posix_spawn_init_actions (&actions, std_in, + std_out, std_err, cwd); + if (error != 0) + return error; + + error = emacs_posix_spawn_init_attributes (&attributes, oldset); if (error != 0) return error; } commit e7cd4bae44585b4fc0d57fbb98f49930b945a817 Author: Stefan Monnier Date: Mon Apr 4 09:55:03 2022 -0400 test/lisp/edmacro-tests.el: Adjust to recent changes diff --git a/test/lisp/edmacro-tests.el b/test/lisp/edmacro-tests.el index b5809ad0b7..e386342f6e 100644 --- a/test/lisp/edmacro-tests.el +++ b/test/lisp/edmacro-tests.el @@ -25,23 +25,24 @@ (require 'edmacro) (ert-deftest edmacro-test-edmacro-parse-keys () - (should (equal (edmacro-parse-keys "") "")) - (should (equal (edmacro-parse-keys "x") "x")) - (should (equal (edmacro-parse-keys "C-a") "\C-a")) + (should (equal (edmacro-parse-keys "") [])) + (should (equal (edmacro-parse-keys "x") [?x])) + (should (equal (edmacro-parse-keys "C-a") [?\C-a])) ;; comments - (should (equal (edmacro-parse-keys ";; foobar") "")) - (should (equal (edmacro-parse-keys ";;;") "")) - (should (equal (edmacro-parse-keys "; ; ;") ";;;")) - (should (equal (edmacro-parse-keys "REM foobar") "")) - (should (equal (edmacro-parse-keys "x ;; foobar") "x")) - (should (equal (edmacro-parse-keys "x REM foobar") "x")) + (should (equal (edmacro-parse-keys ";; foobar") [])) + (should (equal (edmacro-parse-keys ";;;") [])) + (should (equal (edmacro-parse-keys "; ; ;") [?\; ?\; ?\;])) + (should (equal (edmacro-parse-keys "REM foobar") [])) + (should (equal (edmacro-parse-keys "x ;; foobar") [?x])) + (should (equal (edmacro-parse-keys "x REM foobar") [?x])) (should (equal (edmacro-parse-keys "<>") - [134217848 103 111 116 111 45 108 105 110 101 13])) + [?\M-x ?g ?o ?t ?o ?- ?l ?i ?n ?e ?\r])) ;; repetitions - (should (equal (edmacro-parse-keys "3*x") "xxx")) - (should (equal (edmacro-parse-keys "3*C-m") "\C-m\C-m\C-m")) - (should (equal (edmacro-parse-keys "10*foo") "foofoofoofoofoofoofoofoofoofoo"))) + (should (equal (edmacro-parse-keys "3*x") [?x ?x ?x])) + (should (equal (edmacro-parse-keys "3*C-m") [?\C-m ?\C-m ?\C-m])) + (should (equal (edmacro-parse-keys "10*foo") + (apply #'vconcat (make-list 10 [?f ?o ?o]))))) ;;; edmacro-tests.el ends here commit 877893303bfc7ce447f4acc33f2f9c8caf809489 Author: Stefan Monnier Date: Mon Apr 4 09:13:10 2022 -0400 edmacro.el: Silence warnings due to kmacro changes * lisp/edmacro.el (edit-kbd-macro): Use `kmacro-p` and kmacro accessors. (edmacro-finish-edit): Use `kmacro-p` and the new `kmacro` constructor. diff --git a/lisp/edmacro.el b/lisp/edmacro.el index 2561994f7b..179fea786d 100644 --- a/lisp/edmacro.el +++ b/lisp/edmacro.el @@ -99,8 +99,7 @@ With a prefix argument, format the macro in a more concise way." (when keys (let ((cmd (if (arrayp keys) (key-binding keys) keys)) (cmd-noremap (when (arrayp keys) (key-binding keys nil t))) - (mac nil) (mac-counter nil) (mac-format nil) - kmacro) + (mac nil) (mac-counter nil) (mac-format nil)) (cond (store-hook (setq mac keys) (setq cmd nil)) @@ -131,10 +130,10 @@ With a prefix argument, format the macro in a more concise way." (t (setq mac cmd) (setq cmd nil))) - (when (setq kmacro (kmacro-extract-lambda mac)) - (setq mac (car kmacro) - mac-counter (nth 1 kmacro) - mac-format (nth 2 kmacro))) + (when (kmacro-p mac) + (setq mac (kmacro--keys mac) + mac-counter (kmacro--counter mac) + mac-format (kmacro--format mac))) (unless (arrayp mac) (error "Key sequence %s is not a keyboard macro" (key-description keys))) @@ -260,7 +259,7 @@ or nil, use a compact 80-column format." (push key keys) (let ((b (key-binding key))) (and b (commandp b) (not (arrayp b)) - (not (kmacro-extract-lambda b)) + (not (kmacro-p b)) (or (not (fboundp b)) (not (or (arrayp (symbol-function b)) (get b 'kmacro)))) @@ -313,10 +312,7 @@ or nil, use a compact 80-column format." (when cmd (if (= (length mac) 0) (fmakunbound cmd) - (fset cmd - (if (and mac-counter mac-format) - (kmacro-lambda-form mac mac-counter mac-format) - mac)))) + (fset cmd (kmacro mac mac-counter mac-format)))) (if no-keys (when cmd (cl-loop for key in (where-is-internal cmd '(keymap)) do @@ -327,10 +323,8 @@ or nil, use a compact 80-column format." (cl-loop for key in keys do (global-set-key key (or cmd - (if (and mac-counter mac-format) - (kmacro-lambda-form - mac mac-counter mac-format) - mac)))))))))) + (kmacro mac mac-counter + mac-format)))))))))) (kill-buffer buf) (when (buffer-name obuf) (switch-to-buffer obuf)) @@ -645,9 +639,9 @@ This function assumes that the events can be stored in a string." ;;; Parsing a human-readable keyboard macro. -(defun edmacro-parse-keys (string &optional need-vector) +(defun edmacro-parse-keys (string &optional _need-vector) (let ((result (kbd string))) - (if (and need-vector (stringp result)) + (if (stringp result) (seq-into result 'vector) result))) commit 84cf3be6f77f61dd361acdb3683ab9d71e76c995 Author: Po Lu Date: Mon Apr 4 20:32:46 2022 +0800 Handle mouse movement correctly during DND from one of our own frames * lisp/dnd.el (dnd-handle-movement): Select the window specified in posn. * lisp/term/x-win.el (x-dnd-movement): New function. (x-dnd-movement-function): Set it as the default. * src/frame.c (delete_frame): Prevent deleting the drop source frame. * src/xterm.c (x_dnd_send_position): Set new mouse movement flags if the target window is one of our own frames. (x_dnd_begin_drag_and_drop): Call DND movement function whenever appropriate. (x_free_frame_resources): Remove useless code. (syms_of_xterm): New defvar `x-dnd-movement-function'. * src/xterm.h: Update prototypes. diff --git a/lisp/dnd.el b/lisp/dnd.el index 8b11973eb4..4f71edf1aa 100644 --- a/lisp/dnd.el +++ b/lisp/dnd.el @@ -107,31 +107,33 @@ program." (defun dnd-handle-movement (posn) "Handle mouse movement to POSN when receiving a drop from another program." - (when dnd-scroll-margin - (ignore-errors - (let* ((row (cdr (posn-col-row posn))) - (window (when (windowp (posn-window posn)) - (posn-window posn))) - (text-height (window-text-height window)) - ;; Make sure it's possible to scroll both up - ;; and down if the margin is too large for the - ;; window. - (margin (min (/ text-height 3) dnd-scroll-margin))) - ;; At 2 lines, the window becomes too small for any - ;; meaningful scrolling. - (unless (<= text-height 2) - (cond - ;; Inside the bottom scroll margin, scroll up. - ((> row (- text-height margin)) - (with-selected-window window - (scroll-up 1))) - ;; Inside the top scroll margin, scroll down. - ((< row margin) - (with-selected-window window - (scroll-down 1)))))))) - (when dnd-indicate-insertion-point - (ignore-errors - (goto-char (posn-point posn))))) + (when (windowp (posn-window posn)) + (with-selected-window (posn-window posn) + (when dnd-scroll-margin + (ignore-errors + (let* ((row (cdr (posn-col-row posn))) + (window (when (windowp (posn-window posn)) + (posn-window posn))) + (text-height (window-text-height window)) + ;; Make sure it's possible to scroll both up + ;; and down if the margin is too large for the + ;; window. + (margin (min (/ text-height 3) dnd-scroll-margin))) + ;; At 2 lines, the window becomes too small for any + ;; meaningful scrolling. + (unless (<= text-height 2) + (cond + ;; Inside the bottom scroll margin, scroll up. + ((> row (- text-height margin)) + (with-selected-window window + (scroll-up 1))) + ;; Inside the top scroll margin, scroll down. + ((< row margin) + (with-selected-window window + (scroll-down 1)))))))) + (when dnd-indicate-insertion-point + (ignore-errors + (goto-char (posn-point posn))))))) (defun dnd-handle-one-url (window action url) "Handle one dropped url by calling the appropriate handler. diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el index 9ae238661e..f0b9b27f66 100644 --- a/lisp/term/x-win.el +++ b/lisp/term/x-win.el @@ -85,6 +85,7 @@ (defvar x-selection-timeout) (defvar x-session-id) (defvar x-session-previous-id) +(defvar x-dnd-movement-function) (defun x-handle-no-bitmap-icon (_switch) (setq default-frame-alist (cons '(icon-type) default-frame-alist))) @@ -1576,6 +1577,13 @@ frames on all displays." (add-variable-watcher 'x-gtk-use-native-input #'x-gtk-use-native-input-watcher) +(defun x-dnd-movement (_frame position) + "Handle movement to POSITION during drag-and-drop." + (dnd-handle-movement position) + (redisplay)) + +(setq x-dnd-movement-function #'x-dnd-movement) + (provide 'x-win) (provide 'term/x-win) diff --git a/src/frame.c b/src/frame.c index 7a9ed3302e..05b22ac72b 100644 --- a/src/frame.c +++ b/src/frame.c @@ -1987,6 +1987,10 @@ delete_frame (Lisp_Object frame, Lisp_Object force) else error ("Attempt to delete the only frame"); } +#ifdef HAVE_X_WINDOWS + else if (x_dnd_in_progress && f == x_dnd_frame) + error ("Attempt to delete the drop source frame"); +#endif XSETFRAME (frame, f); diff --git a/src/xterm.c b/src/xterm.c index 2e4df67c76..d29a7a122a 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -846,7 +846,10 @@ static int x_filter_event (struct x_display_info *, XEvent *); /* Global state maintained during a drag-and-drop operation. */ /* Flag that indicates if a drag-and-drop operation is in progress. */ -static bool x_dnd_in_progress; +bool x_dnd_in_progress; + +/* The frame where the drag-and-drop operation originated. */ +struct frame *x_dnd_frame; /* Flag that indicates if a drag-and-drop operation is no longer in progress, but the nested event loop should continue to run, because @@ -946,9 +949,6 @@ static Atom *x_dnd_targets = NULL; /* The number of elements in that array. */ static int x_dnd_n_targets; -/* The frame where the drag-and-drop operation originated. */ -static struct frame *x_dnd_frame; - /* The old window attributes of the root window before the drag-and-drop operation started. It is used to keep the old event mask around, since that should be restored after the operation @@ -959,6 +959,13 @@ static XWindowAttributes x_dnd_old_window_attrs; up the drag and drop operation. */ static bool x_dnd_unwind_flag; +/* The frame for which `x-dnd-movement-function' should be called. */ +static struct frame *x_dnd_movement_frame; + +/* The coordinates which the movement function should be called + with. */ +static int x_dnd_movement_x, x_dnd_movement_y; + struct x_client_list_window { Window window; @@ -3137,6 +3144,23 @@ x_dnd_send_position (struct frame *f, Window target, int supported, { struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); XEvent msg; + struct frame *target_frame; + int dest_x, dest_y; + Window child_return; + + target_frame = x_top_window_to_frame (dpyinfo, target); + + if (target_frame && XTranslateCoordinates (dpyinfo->display, + dpyinfo->root_window, + FRAME_X_WINDOW (target_frame), + root_x, root_y, &dest_x, + &dest_y, &child_return)) + { + x_dnd_movement_frame = target_frame; + x_dnd_movement_x = dest_x; + x_dnd_movement_y = dest_y; + return; + } if (target == x_dnd_mouse_rect_target && x_dnd_mouse_rect.width @@ -3151,9 +3175,6 @@ x_dnd_send_position (struct frame *f, Window target, int supported, return; } - if (x_top_window_to_frame (dpyinfo, target)) - return; - msg.xclient.type = ClientMessage; msg.xclient.message_type = dpyinfo->Xatom_XdndPosition; msg.xclient.format = 32; @@ -9143,6 +9164,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, ptrdiff_t i, end, fill; XTextProperty prop; xm_drop_start_message dmsg; + Lisp_Object frame_object, x, y; if (!FRAME_VISIBLE_P (f)) error ("Frame is invisible"); @@ -9229,6 +9251,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, = x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_client_list_stacking); x_dnd_toplevels = NULL; x_dnd_allow_current_frame = allow_current_frame; + x_dnd_movement_frame = NULL; if (x_dnd_use_toplevels) { @@ -9307,6 +9330,28 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, #endif #endif + if (x_dnd_movement_frame) + { + XSETFRAME (frame_object, x_dnd_movement_frame); + XSETINT (x, x_dnd_movement_x); + XSETINT (y, x_dnd_movement_y); + x_dnd_movement_frame = NULL; + + if (!NILP (Vx_dnd_movement_function) + && !FRAME_TOOLTIP_P (XFRAME (frame_object))) + { + x_dnd_old_window_attrs = root_window_attrs; + x_dnd_unwind_flag = true; + + ref = SPECPDL_INDEX (); + record_unwind_protect_ptr (x_dnd_cleanup_drag_and_drop, f); + call2 (Vx_dnd_movement_function, frame_object, + Fposn_at_x_y (x, y, frame_object, Qnil)); + x_dnd_unwind_flag = false; + unbind_to (ref, Qnil); + } + } + if (hold_quit.kind != NO_EVENT) { if (hold_quit.kind == SELECTION_REQUEST_EVENT) @@ -20746,46 +20791,6 @@ x_free_frame_resources (struct frame *f) Lisp_Object bar; struct scroll_bar *b; #endif - xm_drop_start_message dmsg; - - if (x_dnd_in_progress && f == x_dnd_frame) - { - block_input (); - if (x_dnd_last_seen_window != None - && x_dnd_last_protocol_version != -1) - x_dnd_send_leave (f, x_dnd_last_seen_window); - else if (x_dnd_last_seen_window != None - && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style) - && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE - && x_dnd_motif_setup_p) - { - dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, - XM_DRAG_REASON_DROP_START); - dmsg.byte_order = XM_TARGETS_TABLE_CUR; - dmsg.timestamp = 0; - dmsg.side_effects - = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, - x_dnd_wanted_action), - XM_DROP_SITE_VALID, - xm_side_effect_from_action (dpyinfo, - x_dnd_wanted_action), - XM_DROP_ACTION_DROP_CANCEL); - dmsg.x = 0; - dmsg.y = 0; - dmsg.index_atom = dpyinfo->Xatom_XdndSelection; - dmsg.source_window = FRAME_X_WINDOW (f); - - xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (f), - x_dnd_last_seen_window, &dmsg); - } - unblock_input (); - - x_dnd_end_window = None; - x_dnd_last_seen_window = None; - x_dnd_in_progress = false; - x_dnd_waiting_for_finish = false; - x_dnd_frame = NULL; - } block_input (); @@ -23054,4 +23059,11 @@ coordinates to a Motif drop receiver when the mouse moves outside it during a drag-and-drop session, to work around broken implementations of Motif. */); x_dnd_fix_motif_leave = true; + + DEFVAR_LISP ("x-dnd-movement-function", Vx_dnd_movement_function, + doc: /* Function called upon mouse movement on a frame during drag-and-drop. +It should either be nil, or accept two arguments FRAME and POSITION, +where FRAME is the frame the mouse is on top of, and POSITION is a +mouse position list. */); + Vx_dnd_movement_function = Qnil; } diff --git a/src/xterm.h b/src/xterm.h index 57036af2bb..5627fd23c5 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -1548,6 +1548,9 @@ extern void x_session_close (void); extern struct input_event xg_pending_quit_event; #endif +extern bool x_dnd_in_progress; +extern struct frame *x_dnd_frame; + #ifdef HAVE_XINPUT2 struct xi_device_t *xi_device_from_id (struct x_display_info *, int); #endif commit 3d2531c12c54f9ab923603655016077450c23ab2 Author: Po Lu Date: Mon Apr 4 11:37:12 2022 +0000 Fix generation of extra DND events while dragging on Haiku * src/haiku_support.cc (be_drag_message): Set new DND flag. (be_drag_and_drop_in_progress): New function. * src/haiku_support.h: Update prototypes. * src/haikuterm.c (haiku_read_socket): Don't store DND motion events if DND is in progress. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 64556ba51b..40112e2b71 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -122,6 +122,7 @@ static int current_window_id; static void *grab_view = NULL; static BLocker grab_view_locker; +static bool drag_and_drop_in_progress; /* This could be a private API, but it's used by (at least) the Qt port, so it's probably here to stay. */ @@ -4111,6 +4112,8 @@ be_drag_message (void *view, void *message, bool allow_same_view, resume_thread (infos[1].object); unblock_input_function (); + drag_and_drop_in_progress = true; + while (true) { block_input_function (); @@ -4128,12 +4131,24 @@ be_drag_message (void *view, void *message, bool allow_same_view, process_pending_signals_function (); if (should_quit_function ()) - return true; + { + drag_and_drop_in_progress = false; + return true; + } if (infos[1].events & B_EVENT_INVALID) - return false; + { + drag_and_drop_in_progress = false; + return false; + } infos[0].events = B_EVENT_READ; infos[1].events = B_EVENT_INVALID; } } + +bool +be_drag_and_drop_in_progress (void) +{ + return drag_and_drop_in_progress; +} diff --git a/src/haiku_support.h b/src/haiku_support.h index ac3029fbf3..d0a78c693b 100644 --- a/src/haiku_support.h +++ b/src/haiku_support.h @@ -951,6 +951,9 @@ extern "C" void (*process_pending_signals_function) (void), bool (*should_quit_function) (void)); + extern bool + be_drag_and_drop_in_progress (void); + #ifdef __cplusplus extern void * find_appropriate_view_for_draw (void *vw); diff --git a/src/haikuterm.c b/src/haikuterm.c index 91e985e196..e2d6a9a467 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -3145,12 +3145,16 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) another program is dragging stuff over us. */ do_help = -1; - inev.kind = DRAG_N_DROP_EVENT; - inev.arg = Qlambda; - XSETINT (inev.x, b->x); - XSETINT (inev.y, b->y); - XSETFRAME (inev.frame_or_window, f); + if (!be_drag_and_drop_in_progress ()) + { + inev.kind = DRAG_N_DROP_EVENT; + inev.arg = Qlambda; + + XSETINT (inev.x, b->x); + XSETINT (inev.y, b->y); + XSETFRAME (inev.frame_or_window, f); + } break; } } commit 728a1c2fe080d2781ad1efebf64403764dfcd18d Author: Po Lu Date: Mon Apr 4 19:07:01 2022 +0800 * src/xterm.c: Explain meaning of drag-and-drop state variables. diff --git a/src/xterm.c b/src/xterm.c index 2918b4037f..2e4df67c76 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -843,44 +843,120 @@ static void x_scroll_bar_end_update (struct x_display_info *, struct scroll_bar static int x_filter_event (struct x_display_info *, XEvent *); #endif +/* Global state maintained during a drag-and-drop operation. */ + +/* Flag that indicates if a drag-and-drop operation is in progress. */ static bool x_dnd_in_progress; + +/* Flag that indicates if a drag-and-drop operation is no longer in + progress, but the nested event loop should continue to run, because + handle_one_xevent is waiting for the drop target to return some + important information. */ static bool x_dnd_waiting_for_finish; -/* 0 means nothing has happened. 1 means an XmDROP_START message was - sent to the target, but no response has yet been received. 2 means - a response to our XmDROP_START message was received and the target - accepted the drop, so Emacs should start waiting for the drop - target to convert one of the special selections XmTRANSFER_SUCCESS - or XmTRANSFER_FAILURE. */ + +/* State of the Motif drop operation. + + 0 means nothing has happened, i.e. the event loop should not wait + for the receiver to send any data. 1 means an XmDROP_START message + was sent to the target, but no response has yet been received. 2 + means a response to our XmDROP_START message was received and the + target accepted the drop, so Emacs should start waiting for the + drop target to convert one of the special selections + XmTRANSFER_SUCCESS or XmTRANSFER_FAILURE. */ static int x_dnd_waiting_for_motif_finish; + +/* Whether or not F1 was pressed during the drag-and-drop operation. + + Motif programs rely on this to decide whether or not help + information about the drop site should be displayed. */ static bool x_dnd_xm_use_help; + +/* Whether or not Motif drag initiator info was set up. */ static bool x_dnd_motif_setup_p; + +/* The target window we are waiting for an XdndFinished message + from. */ static Window x_dnd_pending_finish_target; + +/* The protocol version of that target window. */ static int x_dnd_waiting_for_finish_proto; + +/* Whether or not it is OK for something to be dropped on the frame + where the drag-and-drop operation originated. */ static bool x_dnd_allow_current_frame; /* Whether or not to return a frame from `x_dnd_begin_drag_and_drop'. 0 means to do nothing. 1 means to wait for the mouse to first exit `x_dnd_frame'. 2 means to wait for the mouse to move onto a frame, - and 3 means to `x_dnd_return_frame_object'. */ + and 3 means to return `x_dnd_return_frame_object'. */ static int x_dnd_return_frame; + +/* The frame that should be returned by + `x_dnd_begin_drag_and_drop'. */ static struct frame *x_dnd_return_frame_object; +/* The last toplevel window the mouse pointer moved over. */ static Window x_dnd_last_seen_window; + +/* The window where the drop happened. Normally None, but it is set + when something is actually dropped. */ static Window x_dnd_end_window; + +/* The XDND protocol version of `x_dnd_last_seen_window'. -1 means it + did not support XDND. */ static int x_dnd_last_protocol_version; + +/* The Motif drag and drop protocol style of `x_dnd_last_seen_window'. + XM_DRAG_STYLE_NONE means the window does not support the Motif drag + or drop protocol. XM_DRAG_STYLE_DROP_ONLY means the window does + not respond to any drag protocol messages, so only drops should be + sent. Any other value means that the window supports both the drag + and drop protocols. */ static int x_dnd_last_motif_style; + +/* The timestamp where Emacs last acquired ownership of the + `XdndSelection' selection. */ static Time x_dnd_selection_timestamp; +/* The drop target window to which the rectangle below applies. */ static Window x_dnd_mouse_rect_target; + +/* A rectangle where XDND position messages should not be sent to the + drop target if the mouse pointer lies within. */ static XRectangle x_dnd_mouse_rect; + +/* The action the drop target actually chose to perform. + + Under XDND, this is set upon receiving the XdndFinished or + XdndStatus messages from the drop target. + + Under Motif, this is changed upon receiving a XmDROP_START message + in reply to our own. */ static Atom x_dnd_action; + +/* The action we want the drop target to perform. The drop target may + elect to perform some different action, which is guaranteed to be + in `x_dnd_action' upon completion of a drop. */ static Atom x_dnd_wanted_action; +/* Array of selection targets available to the drop target. */ static Atom *x_dnd_targets = NULL; + +/* The number of elements in that array. */ static int x_dnd_n_targets; + +/* The frame where the drag-and-drop operation originated. */ static struct frame *x_dnd_frame; + +/* The old window attributes of the root window before the + drag-and-drop operation started. It is used to keep the old event + mask around, since that should be restored after the operation + finishes. */ static XWindowAttributes x_dnd_old_window_attrs; + +/* Whether or not `x_dnd_cleaup_drag_and_drop' should actually clean + up the drag and drop operation. */ static bool x_dnd_unwind_flag; struct x_client_list_window commit 773d4104a592fda4366d8db27d0307ee23de8bfe Author: Lars Ingebrigtsen Date: Mon Apr 4 12:48:47 2022 +0200 Further fixes for cl--generic-describe and (function ...) * lisp/emacs-lisp/cl-generic.el (cl--generic-describe): Fix the #' problem for defmethods, too (bug#54628). diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 2ca84b019f..179310c145 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1096,13 +1096,12 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (dolist (method (cl--generic-method-table generic)) (let* ((info (cl--generic-method-info method))) ;; FIXME: Add hyperlinks for the types as well. - (if (length> (nth 0 info) 0) - (insert (format "%s%S" (nth 0 info) - (let ((print-quoted nil)) - (nth 1 info)))) - ;; Make the non-":extra" bits look more like `C-h f' - ;; output. - (insert (format "%S" (cons function (nth 1 info))))) + (let ((print-quoted nil)) + (if (length> (nth 0 info) 0) + (insert (format "%s%S" (nth 0 info) (nth 1 info))) + ;; Make the non-":extra" bits look more like `C-h f' + ;; output. + (insert (format "%S" (cons function (nth 1 info)))))) (let* ((met-name (cl--generic-load-hist-format function (cl--generic-method-qualifiers method) commit f365607bc059169e5aa9f98c8418661d6fc6477d Author: Mattias Engdegård Date: Mon Mar 21 11:20:37 2022 +0100 Inline call0..8 Inlining these trivial functions gives a healthy speed boost to many common functions such as `sort`, `mapcar` etc. * src/eval.c (call0, ..., call8): Move functions... * src/lisp.h (call0, ..., call8): ...here and declare them inline. diff --git a/src/eval.c b/src/eval.c index 7269582333..a1cebcd025 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2766,76 +2766,6 @@ apply1 (Lisp_Object fn, Lisp_Object arg) return NILP (arg) ? Ffuncall (1, &fn) : CALLN (Fapply, fn, arg); } -/* Call function fn on no arguments. */ -Lisp_Object -call0 (Lisp_Object fn) -{ - return Ffuncall (1, &fn); -} - -/* Call function fn with 1 argument arg1. */ -Lisp_Object -call1 (Lisp_Object fn, Lisp_Object arg1) -{ - return CALLN (Ffuncall, fn, arg1); -} - -/* Call function fn with 2 arguments arg1, arg2. */ -Lisp_Object -call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2) -{ - return CALLN (Ffuncall, fn, arg1, arg2); -} - -/* Call function fn with 3 arguments arg1, arg2, arg3. */ -Lisp_Object -call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3); -} - -/* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */ -Lisp_Object -call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object arg4) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4); -} - -/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */ -Lisp_Object -call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object arg4, Lisp_Object arg5) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5); -} - -/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */ -Lisp_Object -call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6); -} - -/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */ -Lisp_Object -call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7); -} - -/* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5, - arg6, arg7, arg8. */ -Lisp_Object -call8 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7, - Lisp_Object arg8) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); -} - DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0, doc: /* Return t if OBJECT is a function. */) (Lisp_Object object) diff --git a/src/lisp.h b/src/lisp.h index 179c09702c..9c7dc3bc6f 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3202,6 +3202,76 @@ enum maxargs 'Finsert (1, &text);'. */ #define CALLN(f, ...) CALLMANY (f, ((Lisp_Object []) {__VA_ARGS__})) +/* Call function fn on no arguments. */ +INLINE Lisp_Object +call0 (Lisp_Object fn) +{ + return Ffuncall (1, &fn); +} + +/* Call function fn with 1 argument arg1. */ +INLINE Lisp_Object +call1 (Lisp_Object fn, Lisp_Object arg1) +{ + return CALLN (Ffuncall, fn, arg1); +} + +/* Call function fn with 2 arguments arg1, arg2. */ +INLINE Lisp_Object +call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2) +{ + return CALLN (Ffuncall, fn, arg1, arg2); +} + +/* Call function fn with 3 arguments arg1, arg2, arg3. */ +INLINE Lisp_Object +call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3) +{ + return CALLN (Ffuncall, fn, arg1, arg2, arg3); +} + +/* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */ +INLINE Lisp_Object +call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, + Lisp_Object arg4) +{ + return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4); +} + +/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */ +INLINE Lisp_Object +call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, + Lisp_Object arg4, Lisp_Object arg5) +{ + return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5); +} + +/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */ +INLINE Lisp_Object +call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, + Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6) +{ + return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6); +} + +/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */ +INLINE Lisp_Object +call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, + Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7) +{ + return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7); +} + +/* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5, + arg6, arg7, arg8. */ +INLINE Lisp_Object +call8 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, + Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7, + Lisp_Object arg8) +{ + return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); +} + extern void defvar_lisp (struct Lisp_Objfwd const *, char const *); extern void defvar_lisp_nopro (struct Lisp_Objfwd const *, char const *); extern void defvar_bool (struct Lisp_Boolfwd const *, char const *); @@ -4453,15 +4523,6 @@ extern bool FUNCTIONP (Lisp_Object); extern Lisp_Object funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *arg_vector); extern Lisp_Object eval_sub (Lisp_Object form); extern Lisp_Object apply1 (Lisp_Object, Lisp_Object); -extern Lisp_Object call0 (Lisp_Object); -extern Lisp_Object call1 (Lisp_Object, Lisp_Object); -extern Lisp_Object call2 (Lisp_Object, Lisp_Object, Lisp_Object); -extern Lisp_Object call3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); -extern Lisp_Object call4 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); -extern Lisp_Object call5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); -extern Lisp_Object call6 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); -extern Lisp_Object call7 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); -extern Lisp_Object call8 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); extern Lisp_Object internal_catch (Lisp_Object, Lisp_Object (*) (Lisp_Object), Lisp_Object); extern Lisp_Object internal_lisp_condition_case (Lisp_Object, Lisp_Object, Lisp_Object); extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object)); commit 530f163a7f4f1f0ead119b8d3c3dd9fa882af9b2 Author: Mattias Engdegård Date: Wed Mar 16 17:01:57 2022 +0100 Speed up comparisons between 2 fixnums Since <, <=, > and >= have their own byte-ops, the corresponding functions are mostly used as arguments to higher-order functions. This optimisation is particularly beneficial for sorting, where the comparison function is time-critical. * src/data.c (Flss, Fgtr, Fleq, Fgeq): * src/fileio.c (Fcar_less_than_car): Fast path for calls with 2 fixnum arguments. diff --git a/src/data.c b/src/data.c index 5894340aba..f06b561dcc 100644 --- a/src/data.c +++ b/src/data.c @@ -2817,6 +2817,9 @@ DEFUN ("<", Flss, Slss, 1, MANY, 0, usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { + if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1])) + return XFIXNUM (args[0]) < XFIXNUM (args[1]) ? Qt : Qnil; + return arithcompare_driver (nargs, args, ARITH_LESS); } @@ -2825,6 +2828,9 @@ DEFUN (">", Fgtr, Sgtr, 1, MANY, 0, usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { + if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1])) + return XFIXNUM (args[0]) > XFIXNUM (args[1]) ? Qt : Qnil; + return arithcompare_driver (nargs, args, ARITH_GRTR); } @@ -2833,6 +2839,9 @@ DEFUN ("<=", Fleq, Sleq, 1, MANY, 0, usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { + if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1])) + return XFIXNUM (args[0]) <= XFIXNUM (args[1]) ? Qt : Qnil; + return arithcompare_driver (nargs, args, ARITH_LESS_OR_EQUAL); } @@ -2841,6 +2850,9 @@ DEFUN (">=", Fgeq, Sgeq, 1, MANY, 0, usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { + if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1])) + return XFIXNUM (args[0]) >= XFIXNUM (args[1]) ? Qt : Qnil; + return arithcompare_driver (nargs, args, ARITH_GRTR_OR_EQUAL); } diff --git a/src/fileio.c b/src/fileio.c index 5d66a93ac6..c418036fc6 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -5523,7 +5523,10 @@ DEFUN ("car-less-than-car", Fcar_less_than_car, Scar_less_than_car, 2, 2, 0, doc: /* Return t if (car A) is numerically less than (car B). */) (Lisp_Object a, Lisp_Object b) { - return arithcompare (Fcar (a), Fcar (b), ARITH_LESS); + Lisp_Object ca = Fcar (a), cb = Fcar (b); + if (FIXNUMP (ca) && FIXNUMP (cb)) + return XFIXNUM (ca) < XFIXNUM (cb) ? Qt : Qnil; + return arithcompare (ca, cb, ARITH_LESS); } /* Build the complete list of annotations appropriate for writing out commit f4833c88bbb3ca69f75e230a50bbd5edb4d5c00d Author: Mattias Engdegård Date: Wed Mar 16 16:24:24 2022 +0100 Rewrite string-greaterp and string> using string-lessp Since string-lessp has its own byte-op, using it is much faster than calling string-greaterp even with the need to bind a temporary variable. * lisp/emacs-lisp/byte-opt.el (byte-optimize-string-greaterp): New. (string-greaterp, string>): Set byte-optimizer. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 0a79bf9b79..39bb622459 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1049,6 +1049,14 @@ See Info node `(elisp) Integer Basics'." form ; No improvement. (cons 'concat (nreverse newargs))))) +(defun byte-optimize-string-greaterp (form) + ;; Rewrite in terms of `string-lessp' which has its own bytecode. + (pcase (cdr form) + (`(,a ,b) (let ((arg1 (make-symbol "arg1"))) + `(let ((,arg1 ,a)) + (string-lessp ,b ,arg1)))) + (_ form))) + (put 'identity 'byte-optimizer #'byte-optimize-identity) (put 'memq 'byte-optimizer #'byte-optimize-memq) (put 'memql 'byte-optimizer #'byte-optimize-member) @@ -1072,6 +1080,9 @@ See Info node `(elisp) Integer Basics'." (put 'string= 'byte-optimizer #'byte-optimize-binary-predicate) (put 'string-equal 'byte-optimizer #'byte-optimize-binary-predicate) +(put 'string-greaterp 'byte-optimizer #'byte-optimize-string-greaterp) +(put 'string> 'byte-optimizer #'byte-optimize-string-greaterp) + (put 'concat 'byte-optimizer #'byte-optimize-concat) ;; I'm not convinced that this is necessary. Doesn't the optimizer loop commit 16ee9fa138817c061d00cf9a59d2b3f559eebfe1 Author: Mattias Engdegård Date: Wed Mar 16 15:17:19 2022 +0100 Faster `string-lessp` for unibyte arguments Since this function is commonly used as a sorting predicate where it is time-critical, this is a useful optimisation. * src/fns.c (Fstring_lessp): Add fast path for the common case when both arguments are unibyte. * test/src/fns-tests.el (fns-tests--string-lessp-cases) (fns-tests-string-lessp): New test. diff --git a/src/fns.c b/src/fns.c index 8ec23c4e3a..ee4e80b506 100644 --- a/src/fns.c +++ b/src/fns.c @@ -441,15 +441,24 @@ Symbols are also allowed; their print names are used instead. */) { if (SYMBOLP (string1)) string1 = SYMBOL_NAME (string1); + else + CHECK_STRING (string1); if (SYMBOLP (string2)) string2 = SYMBOL_NAME (string2); - CHECK_STRING (string1); - CHECK_STRING (string2); + else + CHECK_STRING (string2); + + ptrdiff_t n = min (SCHARS (string1), SCHARS (string2)); + if (!STRING_MULTIBYTE (string1) && !STRING_MULTIBYTE (string2)) + { + /* Both arguments are unibyte (hot path). */ + int d = memcmp (SSDATA (string1), SSDATA (string2), n); + return d < 0 || (d == 0 && n < SCHARS (string2)) ? Qt : Qnil; + } ptrdiff_t i1 = 0, i1_byte = 0, i2 = 0, i2_byte = 0; - ptrdiff_t end = min (SCHARS (string1), SCHARS (string2)); - while (i1 < end) + while (i1 < n) { /* When we find a mismatch, we must compare the characters, not just the bytes. */ diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 5b252e184f..c080c48392 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -130,6 +130,49 @@ (should (equal [nil nil nil nil nil t t t t t] (vconcat A))) (should (equal [t t t t t nil nil nil nil nil] (vconcat (nreverse A)))))) +(defconst fns-tests--string-lessp-cases + '((a 97 error) + (97 "a" error) + ("abc" "abd" t) + ("abd" "abc" nil) + (abc "abd" t) + ("abd" abc nil) + (abc abd t) + (abd abc nil) + ("" "" nil) + ("" " " t) + (" " "" nil) + ("abc" "abcd" t) + ("abcd" "abc" nil) + ("abc" "abc" nil) + (abc abc nil) + ("\0" "" nil) + ("" "\0" t) + ("~" "\x80" t) + ("\x80" "\x80" nil) + ("\xfe" "\xff" t) + ("Munchen" "München" t) + ("München" "Munchen" nil) + ("München" "München" nil) + ("Ré" "Réunion" t))) + + +(ert-deftest fns-tests-string-lessp () + ;; Exercise both `string-lessp' and its alias `string<', both directly + ;; and in a function (exercising its bytecode). + (dolist (lessp (list #'string-lessp #'string< + (lambda (a b) (string-lessp a b)) + (lambda (a b) (string< a b)))) + (ert-info ((prin1-to-string lessp) :prefix "function: ") + (dolist (case fns-tests--string-lessp-cases) + (ert-info ((prin1-to-string case) :prefix "case: ") + (pcase case + (`(,x ,y error) + (should-error (funcall lessp x y))) + (`(,x ,y ,expected) + (should (equal (funcall lessp x y) expected))))))))) + + (ert-deftest fns-tests-compare-strings () (should-error (compare-strings)) (should-error (compare-strings "xyzzy" "xyzzy")) commit 85fb2341f82d2ba687cefd21ec84d46d06834f57 Author: Po Lu Date: Mon Apr 4 13:42:36 2022 +0800 Respect frame extents during drag and drop * xterm.c (struct x_client_list_window): New fields for frame extents. (x_dnd_compute_toplevels): Set window frame extents. (x_dnd_get_target_window_1): Return None if the mouse is in a frame extent. (x_dnd_get_target_window): Likewise. diff --git a/src/xterm.c b/src/xterm.c index 969be23c7a..2918b4037f 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -896,6 +896,11 @@ struct x_client_list_window struct x_client_list_window *next; uint8_t xm_protocol_style; + int frame_extents_left; + int frame_extents_right; + int frame_extents_top; + int frame_extents_bottom; + #ifdef HAVE_XSHAPE int border_width; @@ -1787,27 +1792,30 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) unsigned long nitems, bytes_after; unsigned long i; unsigned char *data = NULL; + int frame_extents[4]; #ifndef USE_XCB int dest_x, dest_y; unsigned long *wmstate; - unsigned long wmstate_items; - unsigned char *wmstate_data = NULL; + unsigned long wmstate_items, extent_items; + unsigned char *wmstate_data = NULL, *extent_data = NULL; XWindowAttributes attrs; Window child; xm_drag_receiver_info xm_info; #else - uint32_t *wmstate; + uint32_t *wmstate, *fextents; uint8_t *xmdata; xcb_get_window_attributes_cookie_t *window_attribute_cookies; xcb_translate_coordinates_cookie_t *translate_coordinate_cookies; xcb_get_property_cookie_t *get_property_cookies; xcb_get_property_cookie_t *xm_property_cookies; + xcb_get_property_cookie_t *extent_property_cookies; xcb_get_geometry_cookie_t *get_geometry_cookies; xcb_get_window_attributes_reply_t attrs, *attrs_reply; xcb_translate_coordinates_reply_t *coordinates_reply; xcb_get_property_reply_t *property_reply; xcb_get_property_reply_t *xm_property_reply; + xcb_get_property_reply_t *extent_property_reply; xcb_get_geometry_reply_t *geometry_reply; xcb_generic_error_t *error; #endif @@ -1855,6 +1863,8 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) = alloca (sizeof *get_property_cookies * nitems); xm_property_cookies = alloca (sizeof *xm_property_cookies * nitems); + extent_property_cookies + = alloca (sizeof *extent_property_cookies * nitems); get_geometry_cookies = alloca (sizeof *get_geometry_cookies * nitems); @@ -1887,6 +1897,11 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) (xcb_atom_t) dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, (xcb_atom_t) dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, 0, 4); + extent_property_cookies[i] + = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) toplevels[i], + (xcb_atom_t) dpyinfo->Xatom_net_frame_extents, + XCB_ATOM_CARDINAL, 0, 4); get_geometry_cookies[i] = xcb_get_geometry (dpyinfo->xcb_connection, (xcb_window_t) toplevels[i]); @@ -1913,6 +1928,11 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) order. */ for (i = 0; i < nitems; ++i) { + frame_extents[0] = 0; + frame_extents[1] = 0; + frame_extents[2] = 0; + frame_extents[3] = 0; + #ifndef USE_XCB x_catch_errors (dpyinfo->display); rc = (XGetWindowAttributes (dpyinfo->display, @@ -1935,6 +1955,24 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) == Success) && !x_had_errors_p (dpyinfo->display) && wmstate_data && wmstate_items == 2 && format == 32); + + if (XGetWindowProperty (dpyinfo->display, toplevels[i], + dpyinfo->Xatom_net_frame_extents, + 0, 4, False, XA_CARDINAL, &type, + &format, &extent_items, &bytes_after, + &extent_data) == Success + && !x_had_errors_p (dpyinfo->display) + && extent_data && extent_items >= 4 && format == 32) + { + frame_extents[0] = ((unsigned long *) extent_data)[0]; + frame_extents[1] = ((unsigned long *) extent_data)[1]; + frame_extents[2] = ((unsigned long *) extent_data)[2]; + frame_extents[3] = ((unsigned long *) extent_data)[3]; + } + + if (extent_data) + XFree (extent_data); + x_uncatch_errors (); #else rc = true; @@ -1971,6 +2009,9 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) free (error); } + /* These requests don't set rc on failure because they aren't + required. */ + xm_property_reply = xcb_get_property_reply (dpyinfo->xcb_connection, xm_property_cookies[i], &error); @@ -1978,6 +2019,28 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) if (!xm_property_reply) free (error); + extent_property_reply = xcb_get_property_reply (dpyinfo->xcb_connection, + extent_property_cookies[i], + &error); + + if (!extent_property_reply) + free (error); + else + { + if (xcb_get_property_value_length (extent_property_reply) == 16 + && extent_property_reply->format == 32 + && extent_property_reply->type == XCB_ATOM_CARDINAL) + { + fextents = xcb_get_property_value (extent_property_reply); + frame_extents[0] = fextents[0]; + frame_extents[1] = fextents[1]; + frame_extents[2] = fextents[2]; + frame_extents[3] = fextents[3]; + } + + free (extent_property_reply); + } + if (property_reply && (xcb_get_property_value_length (property_reply) != 8 || property_reply->format != 32)) @@ -2006,6 +2069,11 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) tem = xmalloc (sizeof *tem); tem->window = toplevels[i]; tem->dpy = dpyinfo->display; + tem->frame_extents_left = frame_extents[0]; + tem->frame_extents_right = frame_extents[1]; + tem->frame_extents_top = frame_extents[2]; + tem->frame_extents_bottom = frame_extents[3]; + #ifndef USE_XCB tem->x = dest_x; tem->y = dest_y; @@ -2387,18 +2455,55 @@ x_dnd_get_target_window_2 (XRectangle *rects, int nrects, static Window x_dnd_get_target_window_1 (struct x_display_info *dpyinfo, - int root_x, int root_y, int *motif_out) + int root_x, int root_y, int *motif_out, + bool *extents_p) { struct x_client_list_window *tem, *chosen = NULL; /* Loop through x_dnd_toplevels until we find the toplevel where root_x and root_y are. */ + *motif_out = XM_DRAG_STYLE_NONE; for (tem = x_dnd_toplevels; tem; tem = tem->next) { if (!tem->mapped_p || tem->wm_state != NormalState) continue; + /* Test if the coordinates are inside the window's frame + extents, and return None in that case. */ + + *extents_p = true; + if (root_x > tem->x - tem->frame_extents_left + && root_x < tem->x + && root_y > tem->y - tem->frame_extents_top + && root_y < (tem->y + tem->height - 1 + + tem->frame_extents_bottom)) + return None; + + if (root_x > tem->x + tem->width + && root_x < (tem->x + tem->width - 1 + + tem->frame_extents_right) + && root_y > tem->y - tem->frame_extents_top + && root_y < (tem->y + tem->height - 1 + + tem->frame_extents_bottom)) + return None; + + if (root_y > tem->y - tem->frame_extents_top + && root_y < tem->y + && root_x > tem->x - tem->frame_extents_left + && root_x < (tem->x + tem->width - 1 + + tem->frame_extents_right)) + return None; + + if (root_y > tem->y + tem->height + && root_y < (tem->y + tem->height - 1 + + tem->frame_extents_bottom) + && root_x >= tem->x - tem->frame_extents_left + && root_x < (tem->x + tem->width - 1 + + tem->frame_extents_right)) + return None; + *extents_p = false; + if (root_x >= tem->x && root_y >= tem->y && root_x < tem->x + tem->width && root_y < tem->y + tem->height) @@ -2566,6 +2671,7 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo, { Window child_return, child, dummy, proxy; int dest_x_return, dest_y_return, rc, proto, motif; + bool extents_p; #if defined HAVE_XCOMPOSITE && (XCOMPOSITE_MAJOR > 0 || XCOMPOSITE_MINOR > 2) Window overlay_window; XWindowAttributes attrs; @@ -2581,8 +2687,10 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo, if (x_dnd_use_toplevels) { + extents_p = false; child = x_dnd_get_target_window_1 (dpyinfo, root_x, - root_y, motif_out); + root_y, motif_out, + &extents_p); if (!x_dnd_allow_current_frame && FRAME_X_WINDOW (x_dnd_frame) == child) @@ -2613,6 +2721,14 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo, return child; } + if (extents_p) + { + *proto_out = -1; + *motif_out = XM_DRAG_STYLE_NONE; + + return None; + } + /* Then look at the composite overlay window. */ #if defined HAVE_XCOMPOSITE && (XCOMPOSITE_MAJOR > 0 || XCOMPOSITE_MINOR > 2) if (dpyinfo->composite_supported_p commit 4431cf604736b095aa86fd24da82930c3fc5ce19 Author: Po Lu Date: Mon Apr 4 13:17:18 2022 +0800 Don't baselessly ignore frames after passing through the root window * src/xterm.c (x_dnd_begin_drag_and_drop): (handle_one_xevent): Don't rely on target not being None to set x_dnd_return_frame to 2. diff --git a/src/xterm.c b/src/xterm.c index c70b31c5ad..969be23c7a 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -9072,11 +9072,11 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, | SubstructureNotifyMask | PropertyChangeMask); + if (EQ (return_frame, Qnow)) + x_dnd_update_state (FRAME_DISPLAY_INFO (f), CurrentTime); + while (x_dnd_in_progress || x_dnd_waiting_for_finish) { - if (EQ (return_frame, Qnow)) - x_dnd_update_state (FRAME_DISPLAY_INFO (f), CurrentTime); - hold_quit.kind = NO_EVENT; #ifdef USE_GTK current_finish = X_EVENT_NORMAL; @@ -12835,6 +12835,10 @@ x_dnd_update_state (struct x_display_info *dpyinfo, Time timestamp) if (target != x_dnd_last_seen_window) { + if (target != FRAME_OUTER_WINDOW (x_dnd_frame) + && x_dnd_return_frame == 1) + x_dnd_return_frame = 2; + if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1 && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) @@ -12858,10 +12862,6 @@ x_dnd_update_state (struct x_display_info *dpyinfo, Time timestamp) x_dnd_last_seen_window, &lmsg); } - if (target != FRAME_OUTER_WINDOW (x_dnd_frame) - && x_dnd_return_frame == 1) - x_dnd_return_frame = 2; - if (x_dnd_return_frame == 2 && x_any_window_to_frame (dpyinfo, target)) { @@ -14466,6 +14466,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (target != x_dnd_last_seen_window) { + if (target != FRAME_OUTER_WINDOW (x_dnd_frame) + && x_dnd_return_frame == 1) + x_dnd_return_frame = 2; + if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1 && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) @@ -14510,10 +14514,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, } } - if (target != FRAME_OUTER_WINDOW (x_dnd_frame) - && x_dnd_return_frame == 1) - x_dnd_return_frame = 2; - if (x_dnd_return_frame == 2 && x_any_window_to_frame (dpyinfo, target)) { @@ -15918,6 +15918,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (target != x_dnd_last_seen_window) { + if (target != FRAME_OUTER_WINDOW (x_dnd_frame) + && x_dnd_return_frame == 1) + x_dnd_return_frame = 2; + if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1 && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) @@ -15964,10 +15968,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, } } - if (target != FRAME_OUTER_WINDOW (x_dnd_frame) - && x_dnd_return_frame == 1) - x_dnd_return_frame = 2; - if (x_dnd_return_frame == 2 && x_any_window_to_frame (dpyinfo, target)) { commit aea799838b7ffd11f187c2511ecca250c8b99411 Author: Po Lu Date: Mon Apr 4 13:10:01 2022 +0800 Improve behavior of dragging text to windows on top of frames * doc/lispref/frames.texi (Drag and Drop): Document new meaning of `return-frame' in `x-begin-drag'. * lisp/mouse.el (mouse-drag-and-drop-region): Use `now' when calling `x-begin-drag'. * src/xfns.c (Fx_begin_drag): Update doc string. * src/xterm.c (x_dnd_begin_drag_and_drop): Accept return_frame as a Lisp_Object and handle Qnow correctly. (XTmouse_position): Ignore tooltip frames when processing `drag-source'. (syms_of_xterm): New defsym `now'. * src/xterm.h: Update prototypes. diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index 057f070ccc..85f92d4f62 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -4075,12 +4075,15 @@ describing the available actions, and strings that the drop target is expected to present to the user to choose between the available actions. -If @var{return-frame} is non-nil and the mouse moves over an Emacs -frame after first moving out of @var{frame}, then the frame to which -the mouse moves will be returned immediately. This is useful when you -want to treat dragging content from one frame to another specially, -while also being able to drag content to other programs, but is not -guaranteed to work on all systems and window managers. +If @var{return-frame} is non-@code{nil} and the mouse moves over an +Emacs frame after first moving out of @var{frame}, then the frame to +which the mouse moves will be returned immediately. If +@var{return-frame} is the symbol @code{now}, then any frame underneath +the mouse pointer will be returned and no further work will be done. +@var{return-frame} useful when you want to treat dragging content from +one frame to another specially, while also being able to drag content +to other programs, but it is not guaranteed to work on all systems and +window managers. If the drop was rejected or no drop target was found, this function returns @code{nil}. Otherwise, it returns a symbol describing the diff --git a/lisp/mouse.el b/lisp/mouse.el index f42492bb5d..26a17365da 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -3061,7 +3061,8 @@ is copied instead of being cut." value-selection ; This remains nil when event was "click". text-tooltip states - window-exempt) + window-exempt + drag-again-mouse-position) ;; STATES stores for each window on this frame its start and point ;; positions so we can restore them on all windows but for the one @@ -3171,7 +3172,14 @@ is copied instead of being cut." (frame-pixel-width frame)) (> (cdr location) (frame-pixel-height frame))))) - (not (posn-window (event-end event))))) + (and (or (not drag-again-mouse-position) + (let ((mouse-position (mouse-absolute-pixel-position))) + (or (< 5 (abs (- (car drag-again-mouse-position) + (car mouse-position)))) + (< 5 (abs (- (cdr drag-again-mouse-position) + (cdr mouse-position))))))) + (not (posn-window (event-end event)))))) + (setq drag-again-mouse-position nil) (mouse-drag-and-drop-region-hide-tooltip) (gui-set-selection 'XdndSelection value-selection) (let ((drag-action-or-frame @@ -3182,9 +3190,18 @@ is copied instead of being cut." (if mouse-drag-and-drop-region-cut-when-buffers-differ 'XdndActionMove 'XdndActionCopy) - (posn-window (event-end event)) t) + (posn-window (event-end event)) 'now) (quit nil)))) (when (framep drag-action-or-frame) + ;; With some window managers `x-begin-drag' + ;; returns a frame sooner than `mouse-position' + ;; will return one, due to over-wide frame windows + ;; being drawn by the window manager. To avoid + ;; that, we just require the mouse move a few + ;; pixels before beginning another cross-program + ;; drag. + (setq drag-again-mouse-position + (mouse-absolute-pixel-position)) (throw 'drag-again nil)) (let ((min-char (point))) diff --git a/src/xfns.c b/src/xfns.c index 4fa919f36a..5cf3eb4199 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -6712,7 +6712,9 @@ Emacs. For that reason, they are not mentioned here. Consult If RETURN-FRAME is non-nil, this function will return the frame if the mouse pointer moves onto an Emacs frame, after first moving out of -FRAME. (This is not guaranteed to work on some systems.) +FRAME. (This is not guaranteed to work on some systems.) If +RETURN-FRAME is the symbol `now', any frame underneath the mouse +pointer will be returned immediately. If ACTION is a list and not nil, its elements are assumed to be a cons of (ITEM . STRING), where ITEM is the name of an action, and STRING is @@ -6828,7 +6830,7 @@ mouse buttons are released on top of FRAME. */) x_set_dnd_targets (target_atoms, ntargets); lval = x_dnd_begin_drag_and_drop (f, FRAME_DISPLAY_INFO (f)->last_user_time, - xaction, !NILP (return_frame), action_list, + xaction, return_frame, action_list, (const char **) &name_list, nnames, !NILP (allow_current_frame)); diff --git a/src/xterm.c b/src/xterm.c index e3935bacb9..c70b31c5ad 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -2295,6 +2295,7 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) static int x_dnd_get_window_proto (struct x_display_info *, Window); static Window x_dnd_get_window_proxy (struct x_display_info *, Window); +static void x_dnd_update_state (struct x_display_info *, Time); #ifdef USE_XCB static void @@ -8933,9 +8934,9 @@ x_top_window_to_frame (struct x_display_info *dpyinfo, int wdesc) Lisp_Object x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, - bool return_frame_p, Atom *ask_action_list, - const char **ask_action_names, - size_t n_ask_actions, bool allow_current_frame) + Lisp_Object return_frame, Atom *ask_action_list, + const char **ask_action_names, size_t n_ask_actions, + bool allow_current_frame) { #ifndef USE_GTK XEvent next_event; @@ -9046,9 +9047,12 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, } } - if (return_frame_p) + if (!NILP (return_frame)) x_dnd_return_frame = 1; + if (EQ (return_frame, Qnow)) + x_dnd_return_frame = 2; + #ifdef USE_GTK current_count = 0; #endif @@ -9070,6 +9074,9 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, while (x_dnd_in_progress || x_dnd_waiting_for_finish) { + if (EQ (return_frame, Qnow)) + x_dnd_update_state (FRAME_DISPLAY_INFO (f), CurrentTime); + hold_quit.kind = NO_EVENT; #ifdef USE_GTK current_finish = X_EVENT_NORMAL; @@ -9951,7 +9958,9 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, /* Child of win. */ &child); - if (!EQ (track_mouse, Qdrag_source)) + if (!EQ (track_mouse, Qdrag_source) + /* Don't let tooltips interfere. */ + || (f1 && FRAME_TOOLTIP_P (f1))) f1 = dpyinfo->last_mouse_frame; else { @@ -22662,6 +22671,7 @@ syms_of_xterm (void) DEFSYM (Qvendor_specific_keysyms, "vendor-specific-keysyms"); DEFSYM (Qlatin_1, "latin-1"); + DEFSYM (Qnow, "now"); #ifdef USE_GTK xg_default_icon_file = build_pure_c_string ("icons/hicolor/scalable/apps/emacs.svg"); diff --git a/src/xterm.h b/src/xterm.h index 062b34b35c..57036af2bb 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -1389,7 +1389,7 @@ extern void x_scroll_bar_configure (GdkEvent *); #endif extern Lisp_Object x_dnd_begin_drag_and_drop (struct frame *, Time, Atom, - bool, Atom *, const char **, + Lisp_Object, Atom *, const char **, size_t, bool); extern void x_set_dnd_targets (Atom *, int); commit 9ff2f0be32be621a0a1953cac2d552afebafe226 Author: Andrew G Cohen Date: Thu Mar 10 09:30:00 2022 +0800 Replace list and vector sorting with TIMSORT algorithm * src/Makefile.in (base_obj): Add sort.o. * src/deps.mk (fns.o): Add sort.c. * src/lisp.h: Add prototypes for inorder, tim_sort. * src/sort.c: New file providing tim_sort. * src/fns.c: Remove prototypes for removed routines. (merge_vectors, sort_vector_inplace, sort_vector_copy): Remove. (sort_list, sort_vector): Use tim_sort. * test/src/fns-tests.el (fns-tests-sort): New sorting unit tests. diff --git a/src/Makefile.in b/src/Makefile.in index 69c4c44d1a..7d15b7afd5 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -434,7 +434,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ minibuf.o fileio.o dired.o \ cmds.o casetab.o casefiddle.o indent.o search.o regex-emacs.o undo.o \ alloc.o pdumper.o data.o doc.o editfns.o callint.o \ - eval.o floatfns.o fns.o font.o print.o lread.o $(MODULES_OBJ) \ + eval.o floatfns.o fns.o sort.o font.o print.o lread.o $(MODULES_OBJ) \ syntax.o $(UNEXEC_OBJ) bytecode.o comp.o $(DYNLIB_OBJ) \ process.o gnutls.o callproc.o \ region-cache.o sound.o timefns.o atimer.o \ diff --git a/src/deps.mk b/src/deps.mk index deffab93ec..39edd5c1dd 100644 --- a/src/deps.mk +++ b/src/deps.mk @@ -279,7 +279,7 @@ eval.o: eval.c commands.h keyboard.h blockinput.h atimer.h systime.h frame.h \ dispextern.h lisp.h globals.h $(config_h) coding.h composite.h xterm.h \ msdos.h floatfns.o: floatfns.c syssignal.h lisp.h globals.h $(config_h) -fns.o: fns.c commands.h lisp.h $(config_h) frame.h buffer.h character.h \ +fns.o: fns.c sort.c commands.h lisp.h $(config_h) frame.h buffer.h character.h \ keyboard.h keymap.h window.h $(INTERVALS_H) coding.h ../lib/md5.h \ ../lib/sha1.h ../lib/sha256.h ../lib/sha512.h blockinput.h atimer.h \ systime.h xterm.h ../lib/unistd.h globals.h diff --git a/src/fns.c b/src/fns.c index 0cc0c0a53d..8ec23c4e3a 100644 --- a/src/fns.c +++ b/src/fns.c @@ -39,9 +39,6 @@ along with GNU Emacs. If not, see . */ #include "puresize.h" #include "gnutls.h" -static void sort_vector_copy (Lisp_Object pred, ptrdiff_t len, - Lisp_Object src[restrict VLA_ELEMS (len)], - Lisp_Object dest[restrict VLA_ELEMS (len)]); enum equal_kind { EQUAL_NO_QUIT, EQUAL_PLAIN, EQUAL_INCLUDING_PROPERTIES }; static bool internal_equal (Lisp_Object, Lisp_Object, enum equal_kind, int, Lisp_Object); @@ -2107,8 +2104,11 @@ See also the function `nreverse', which is used more often. */) return new; } -/* Sort LIST using PREDICATE, preserving original order of elements - considered as equal. */ + +/* Stably sort LIST ordered by PREDICATE using the TIMSORT + algorithm. This converts the list to a vector, sorts the vector, + and returns the result converted back to a list. The input list is + destructively reused to hold the sorted result. */ static Lisp_Object sort_list (Lisp_Object list, Lisp_Object predicate) @@ -2116,112 +2116,43 @@ sort_list (Lisp_Object list, Lisp_Object predicate) ptrdiff_t length = list_length (list); if (length < 2) return list; - - Lisp_Object tem = Fnthcdr (make_fixnum (length / 2 - 1), list); - Lisp_Object back = Fcdr (tem); - Fsetcdr (tem, Qnil); - - return merge (Fsort (list, predicate), Fsort (back, predicate), predicate); -} - -/* Using PRED to compare, return whether A and B are in order. - Compare stably when A appeared before B in the input. */ -static bool -inorder (Lisp_Object pred, Lisp_Object a, Lisp_Object b) -{ - return NILP (call2 (pred, b, a)); -} - -/* Using PRED to compare, merge from ALEN-length A and BLEN-length B - into DEST. Argument arrays must be nonempty and must not overlap, - except that B might be the last part of DEST. */ -static void -merge_vectors (Lisp_Object pred, - ptrdiff_t alen, Lisp_Object const a[restrict VLA_ELEMS (alen)], - ptrdiff_t blen, Lisp_Object const b[VLA_ELEMS (blen)], - Lisp_Object dest[VLA_ELEMS (alen + blen)]) -{ - eassume (0 < alen && 0 < blen); - Lisp_Object const *alim = a + alen; - Lisp_Object const *blim = b + blen; - - while (true) + else { - if (inorder (pred, a[0], b[0])) + Lisp_Object *result; + USE_SAFE_ALLOCA; + SAFE_ALLOCA_LISP (result, length); + Lisp_Object tail = list; + for (ptrdiff_t i = 0; i < length; i++) { - *dest++ = *a++; - if (a == alim) - { - if (dest != b) - memcpy (dest, b, (blim - b) * sizeof *dest); - return; - } + result[i] = Fcar (tail); + tail = XCDR (tail); } - else + tim_sort (predicate, result, length); + + ptrdiff_t i = 0; + tail = list; + while (CONSP (tail)) { - *dest++ = *b++; - if (b == blim) - { - memcpy (dest, a, (alim - a) * sizeof *dest); - return; - } + XSETCAR (tail, result[i]); + tail = XCDR (tail); + i++; } + SAFE_FREE (); + return list; } } -/* Using PRED to compare, sort LEN-length VEC in place, using TMP for - temporary storage. LEN must be at least 2. */ -static void -sort_vector_inplace (Lisp_Object pred, ptrdiff_t len, - Lisp_Object vec[restrict VLA_ELEMS (len)], - Lisp_Object tmp[restrict VLA_ELEMS (len >> 1)]) -{ - eassume (2 <= len); - ptrdiff_t halflen = len >> 1; - sort_vector_copy (pred, halflen, vec, tmp); - if (1 < len - halflen) - sort_vector_inplace (pred, len - halflen, vec + halflen, vec); - merge_vectors (pred, halflen, tmp, len - halflen, vec + halflen, vec); -} - -/* Using PRED to compare, sort from LEN-length SRC into DST. - Len must be positive. */ -static void -sort_vector_copy (Lisp_Object pred, ptrdiff_t len, - Lisp_Object src[restrict VLA_ELEMS (len)], - Lisp_Object dest[restrict VLA_ELEMS (len)]) -{ - eassume (0 < len); - ptrdiff_t halflen = len >> 1; - if (halflen < 1) - dest[0] = src[0]; - else - { - if (1 < halflen) - sort_vector_inplace (pred, halflen, src, dest); - if (1 < len - halflen) - sort_vector_inplace (pred, len - halflen, src + halflen, dest); - merge_vectors (pred, halflen, src, len - halflen, src + halflen, dest); - } -} - -/* Sort VECTOR in place using PREDICATE, preserving original order of - elements considered as equal. */ +/* Stably sort VECTOR ordered by PREDICATE using the TIMSORT + algorithm. */ static void sort_vector (Lisp_Object vector, Lisp_Object predicate) { - ptrdiff_t len = ASIZE (vector); - if (len < 2) + ptrdiff_t length = ASIZE (vector); + if (length < 2) return; - ptrdiff_t halflen = len >> 1; - Lisp_Object *tmp; - USE_SAFE_ALLOCA; - SAFE_ALLOCA_LISP (tmp, halflen); - for (ptrdiff_t i = 0; i < halflen; i++) - tmp[i] = make_fixnum (0); - sort_vector_inplace (predicate, len, XVECTOR (vector)->contents, tmp); - SAFE_FREE (); + + tim_sort (predicate, XVECTOR (vector)->contents, length); } DEFUN ("sort", Fsort, Ssort, 2, 2, 0, @@ -2267,7 +2198,7 @@ merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred) } Lisp_Object tem; - if (inorder (pred, Fcar (l1), Fcar (l2))) + if (!NILP (call2 (pred, Fcar (l1), Fcar (l2)))) { tem = l1; l1 = Fcdr (l1); diff --git a/src/lisp.h b/src/lisp.h index c5a772b423..179c09702c 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3939,6 +3939,9 @@ extern Lisp_Object string_to_multibyte (Lisp_Object); extern Lisp_Object string_make_unibyte (Lisp_Object); extern void syms_of_fns (void); +/* Defined in sort.c */ +extern void tim_sort (Lisp_Object, Lisp_Object *, const ptrdiff_t); + /* Defined in floatfns.c. */ verify (FLT_RADIX == 2 || FLT_RADIX == 16); enum { LOG2_FLT_RADIX = FLT_RADIX == 2 ? 1 : 4 }; diff --git a/src/sort.c b/src/sort.c new file mode 100644 index 0000000000..c7ccfc2305 --- /dev/null +++ b/src/sort.c @@ -0,0 +1,974 @@ +/* Timsort for sequences. + +Copyright (C) 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 . */ + +/* This is a version of the cpython code implementing the TIMSORT + sorting algorithm described in + https://github.com/python/cpython/blob/main/Objects/listsort.txt. + This algorithm identifies and pushes naturally ordered sublists of + the original list, or "runs", onto a stack, and merges them + periodically according to a merge strategy called "powersort". + State is maintained during the sort in a merge_state structure, + which is passed around as an argument to all the subroutines. A + "stretch" structure includes a pointer to the run BASE of length + LEN along with its POWER (a computed integer used by the powersort + merge strategy that depends on this run and the succeeding run.) */ + + +#include +#include "lisp.h" + + +/* MAX_MERGE_PENDING is the maximum number of entries in merge_state's + pending-stretch stack. For a list with n elements, this needs at most + floor(log2(n)) + 1 entries even if we didn't force runs to a + minimal length. So the number of bits in a ptrdiff_t is plenty large + enough for all cases. */ + +#define MAX_MERGE_PENDING (sizeof (ptrdiff_t) * 8) + +/* Once we get into galloping mode, we stay there as long as both runs + win at least GALLOP_WIN_MIN consecutive times. */ + +#define GALLOP_WIN_MIN 7 + +/* A small temp array of size MERGESTATE_TEMP_SIZE is used to avoid + malloc when merging small lists. */ + +#define MERGESTATE_TEMP_SIZE 256 + +struct stretch +{ + Lisp_Object *base; + ptrdiff_t len; + int power; +}; + +struct reloc +{ + Lisp_Object **src; + Lisp_Object **dst; + ptrdiff_t *size; + int order; /* -1 while in merge_lo; +1 while in merg_hi; 0 otherwise. */ +}; + + +typedef struct +{ + Lisp_Object *listbase; + ptrdiff_t listlen; + + /* PENDING is a stack of N pending stretches yet to be merged. + Stretch #i starts at address base[i] and extends for len[i] + elements. */ + + int n; + struct stretch pending[MAX_MERGE_PENDING]; + + /* The variable MIN_GALLOP, initialized to GALLOP_WIN_MIN, controls + when we get *into* galloping mode. merge_lo and merge_hi tend to + nudge it higher for random data, and lower for highly structured + data. */ + + ptrdiff_t min_gallop; + + /* 'A' is temporary storage, able to hold ALLOCED elements, to help + with merges. 'A' initially points to TEMPARRAY, and subsequently + to newly allocated memory if needed. */ + + Lisp_Object *a; + ptrdiff_t alloced; + specpdl_ref count; + Lisp_Object temparray[MERGESTATE_TEMP_SIZE]; + + /* If an exception is thrown while merging we might have to relocate + some list elements from temporary storage back into the list. + RELOC keeps track of the information needed to do this. */ + + struct reloc reloc; + + /* PREDICATE is the lisp comparison predicate for the sort. */ + + Lisp_Object predicate; +} merge_state; + + +/* Return true iff (PREDICATE A B) is non-nil. */ + +static inline bool +inorder (const Lisp_Object predicate, const Lisp_Object a, const Lisp_Object b) +{ + return !NILP (call2 (predicate, a, b)); +} + + +/* Sort the list starting at LO and ending at HI using a stable binary + insertion sort algorithm. On entry the sublist [LO, START) (with + START between LO and HIGH) is known to be sorted (pass START == LO + if you are unsure). Even in case of error, the output will be some + permutation of the input (nothing is lost or duplicated). */ + +static void +binarysort (merge_state *ms, Lisp_Object *lo, const Lisp_Object *hi, + Lisp_Object *start) +{ + Lisp_Object pred = ms->predicate; + + eassume (lo <= start && start <= hi); + if (lo == start) + ++start; + for (; start < hi; ++start) + { + Lisp_Object *l = lo; + Lisp_Object *r = start; + Lisp_Object pivot = *r; + + eassume (l < r); + do { + Lisp_Object *p = l + ((r - l) >> 1); + if (inorder (pred, pivot, *p)) + r = p; + else + l = p + 1; + } while (l < r); + eassume (l == r); + for (Lisp_Object *p = start; p > l; --p) + p[0] = p[-1]; + *l = pivot; + } +} + + +/* Find and return the length of the "run" (the longest + non-decreasing sequence or the longest strictly decreasing + sequence, with the Boolean *DESCENDING set to 0 in the former + case, or to 1 in the latter) beginning at LO, in the slice [LO, + HI) with LO < HI. The strictness of the definition of + "descending" ensures there are no equal elements to get out of + order so the caller can safely reverse a descending sequence + without violating stability. */ + +static ptrdiff_t +count_run (merge_state *ms, Lisp_Object *lo, const Lisp_Object *hi, + bool *descending) +{ + Lisp_Object pred = ms->predicate; + + eassume (lo < hi); + *descending = 0; + ++lo; + ptrdiff_t n = 1; + if (lo == hi) + return n; + + n = 2; + if (inorder (pred, lo[0], lo[-1])) + { + *descending = 1; + for (lo = lo + 1; lo < hi; ++lo, ++n) + { + if (!inorder (pred, lo[0], lo[-1])) + break; + } + } + else + { + for (lo = lo + 1; lo < hi; ++lo, ++n) + { + if (inorder (pred, lo[0], lo[-1])) + break; + } + } + + return n; +} + + +/* Locate and return the proper insertion position of KEY in a sorted + vector: if the vector contains an element equal to KEY, return the + position immediately to the left of the leftmost equal element. + [GALLOP_RIGHT does the same except it returns the position to the + right of the rightmost equal element (if any).] + + 'A' is a sorted vector of N elements. N must be > 0. + + Elements preceding HINT, a non-negative index less than N, are + skipped. The closer HINT is to the final result, the faster this + runs. + + The return value is the int k in [0, N] such that + + A[k-1] < KEY <= a[k] + + pretending that *(A-1) precedes all values and *(A+N) succeeds all + values. In other words, the first k elements of A should precede + KEY, and the last N-k should follow KEY. */ + +static ptrdiff_t +gallop_left (merge_state *ms, const Lisp_Object key, Lisp_Object *a, + const ptrdiff_t n, const ptrdiff_t hint) +{ + Lisp_Object pred = ms->predicate; + + eassume (a && n > 0 && hint >= 0 && hint < n); + + a += hint; + ptrdiff_t lastofs = 0; + ptrdiff_t ofs = 1; + if (inorder (pred, *a, key)) + { + /* When a[hint] < key, gallop right until + a[hint + lastofs] < key <= a[hint + ofs]. */ + const ptrdiff_t maxofs = n - hint; /* This is one after the end of a. */ + while (ofs < maxofs) + { + if (inorder (pred, a[ofs], key)) + { + lastofs = ofs; + eassume (ofs <= (PTRDIFF_MAX - 1) / 2); + ofs = (ofs << 1) + 1; + } + else + break; /* Here key <= a[hint+ofs]. */ + } + if (ofs > maxofs) + ofs = maxofs; + /* Translate back to offsets relative to &a[0]. */ + lastofs += hint; + ofs += hint; + } + else + { + /* When key <= a[hint], gallop left, until + a[hint - ofs] < key <= a[hint - lastofs]. */ + const ptrdiff_t maxofs = hint + 1; /* Here &a[0] is lowest. */ + while (ofs < maxofs) + { + if (inorder (pred, a[-ofs], key)) + break; + /* Here key <= a[hint - ofs]. */ + lastofs = ofs; + eassume (ofs <= (PTRDIFF_MAX - 1) / 2); + ofs = (ofs << 1) + 1; + } + if (ofs > maxofs) + ofs = maxofs; + /* Translate back to use positive offsets relative to &a[0]. */ + ptrdiff_t k = lastofs; + lastofs = hint - ofs; + ofs = hint - k; + } + a -= hint; + + eassume (-1 <= lastofs && lastofs < ofs && ofs <= n); + /* Now a[lastofs] < key <= a[ofs], so key belongs somewhere to the + right of lastofs but no farther right than ofs. Do a binary + search, with invariant a[lastofs-1] < key <= a[ofs]. */ + ++lastofs; + while (lastofs < ofs) + { + ptrdiff_t m = lastofs + ((ofs - lastofs) >> 1); + + if (inorder (pred, a[m], key)) + lastofs = m + 1; /* Here a[m] < key. */ + else + ofs = m; /* Here key <= a[m]. */ + } + eassume (lastofs == ofs); /* Then a[ofs-1] < key <= a[ofs]. */ + return ofs; +} + + +/* Locate and return the proper position of KEY in a sorted vector + exactly like GALLOP_LEFT, except that if KEY already exists in + A[0:N] find the position immediately to the right of the rightmost + equal value. + + The return value is the int k in [0, N] such that + + A[k-1] <= KEY < A[k]. */ + +static ptrdiff_t +gallop_right (merge_state *ms, const Lisp_Object key, Lisp_Object *a, + const ptrdiff_t n, const ptrdiff_t hint) +{ + Lisp_Object pred = ms->predicate; + + eassume (a && n > 0 && hint >= 0 && hint < n); + + a += hint; + ptrdiff_t lastofs = 0; + ptrdiff_t ofs = 1; + if (inorder (pred, key, *a)) + { + /* When key < a[hint], gallop left until + a[hint - ofs] <= key < a[hint - lastofs]. */ + const ptrdiff_t maxofs = hint + 1; /* Here &a[0] is lowest. */ + while (ofs < maxofs) + { + if (inorder (pred, key, a[-ofs])) + { + lastofs = ofs; + eassume (ofs <= (PTRDIFF_MAX - 1) / 2); + ofs = (ofs << 1) + 1; + } + else /* Here a[hint - ofs] <= key. */ + break; + } + if (ofs > maxofs) + ofs = maxofs; + /* Translate back to use positive offsets relative to &a[0]. */ + ptrdiff_t k = lastofs; + lastofs = hint - ofs; + ofs = hint - k; + } + else + { + /* When a[hint] <= key, gallop right, until + a[hint + lastofs] <= key < a[hint + ofs]. */ + const ptrdiff_t maxofs = n - hint; /* Here &a[n-1] is highest. */ + while (ofs < maxofs) + { + if (inorder (pred, key, a[ofs])) + break; + /* Here a[hint + ofs] <= key. */ + lastofs = ofs; + eassume (ofs <= (PTRDIFF_MAX - 1) / 2); + ofs = (ofs << 1) + 1; + } + if (ofs > maxofs) + ofs = maxofs; + /* Translate back to use offsets relative to &a[0]. */ + lastofs += hint; + ofs += hint; + } + a -= hint; + + eassume (-1 <= lastofs && lastofs < ofs && ofs <= n); + /* Now a[lastofs] <= key < a[ofs], so key belongs somewhere to the + right of lastofs but no farther right than ofs. Do a binary + search, with invariant a[lastofs-1] <= key < a[ofs]. */ + ++lastofs; + while (lastofs < ofs) + { + ptrdiff_t m = lastofs + ((ofs - lastofs) >> 1); + + if (inorder (pred, key, a[m])) + ofs = m; /* Here key < a[m]. */ + else + lastofs = m + 1; /* Here a[m] <= key. */ + } + eassume (lastofs == ofs); /* Now a[ofs-1] <= key < a[ofs]. */ + return ofs; +} + + +static void +merge_init (merge_state *ms, const ptrdiff_t list_size, Lisp_Object *lo, + const Lisp_Object predicate) +{ + eassume (ms != NULL); + + ms->a = ms->temparray; + ms->alloced = MERGESTATE_TEMP_SIZE; + + ms->n = 0; + ms->min_gallop = GALLOP_WIN_MIN; + ms->listlen = list_size; + ms->listbase = lo; + ms->predicate = predicate; + ms->reloc = (struct reloc){NULL, NULL, NULL, 0}; +} + + +/* The dynamically allocated memory may hold lisp objects during + merging. MERGE_MARKMEM marks them so they aren't reaped during + GC. */ + +static void +merge_markmem (void *arg) +{ + merge_state *ms = arg; + eassume (ms != NULL); + + if (ms->reloc.size != NULL && *ms->reloc.size > 0) + { + eassume (ms->reloc.src != NULL); + mark_objects (*ms->reloc.src, *ms->reloc.size); + } +} + + +/* Free all temp storage. If an exception occurs while merging, + relocate any lisp elements in temp storage back to the original + array. */ + +static void +cleanup_mem (void *arg) +{ + merge_state *ms = arg; + eassume (ms != NULL); + + /* If we have an exception while merging, some of the list elements + might only live in temp storage; we copy everything remaining in + the temp storage back into the original list. This ensures that + the original list has all of the original elements, although + their order is unpredictable. */ + + if (ms->reloc.order != 0 && *ms->reloc.size > 0) + { + eassume (*ms->reloc.src != NULL && *ms->reloc.dst != NULL); + ptrdiff_t n = *ms->reloc.size; + ptrdiff_t shift = ms->reloc.order == -1 ? 0 : n - 1; + memcpy (*ms->reloc.dst - shift, *ms->reloc.src, n * word_size); + } + + /* Free any remaining temp storage. */ + xfree (ms->a); +} + + +/* Allocate enough temp memory for NEED array slots. Any previously + allocated memory is first freed, and a cleanup routine is + registered to free memory at the very end of the sort, or on + exception. */ + +static void +merge_getmem (merge_state *ms, const ptrdiff_t need) +{ + eassume (ms != NULL); + + if (ms->a == ms->temparray) + { + /* We only get here if alloc is needed and this is the first + time, so we set up the unwind protection. */ + specpdl_ref count = SPECPDL_INDEX (); + record_unwind_protect_ptr_mark (cleanup_mem, ms, merge_markmem); + ms->count = count; + } + else + { + /* We have previously alloced storage. Since we don't care + what's in the block we don't use realloc which would waste + cycles copying the old data. We just free and alloc + again. */ + xfree (ms->a); + } + ms->a = xmalloc (need * word_size); + ms->alloced = need; +} + + +static inline void +needmem (merge_state *ms, ptrdiff_t na) +{ + if (na > ms->alloced) + merge_getmem (ms, na); +} + + +/* Stably merge (in-place) the NA elements starting at SSA with the NB + elements starting at SSB = SSA + NA. NA and NB must be positive. + Require that SSA[NA-1] belongs at the end of the merge, and NA <= + NB. */ + +static void +merge_lo (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na, Lisp_Object *ssb, + ptrdiff_t nb) +{ + Lisp_Object pred = ms->predicate; + + eassume (ms && ssa && ssb && na > 0 && nb > 0); + eassume (ssa + na == ssb); + needmem (ms, na); + memcpy (ms->a, ssa, na * word_size); + Lisp_Object *dest = ssa; + ssa = ms->a; + + ms->reloc = (struct reloc){&ssa, &dest, &na, -1}; + + *dest++ = *ssb++; + --nb; + if (nb == 0) + goto Succeed; + if (na == 1) + goto CopyB; + + ptrdiff_t min_gallop = ms->min_gallop; + for (;;) + { + ptrdiff_t acount = 0; /* The # of consecutive times A won. */ + + ptrdiff_t bcount = 0; /* The # of consecutive times B won. */ + + for (;;) + { + eassume (na > 1 && nb > 0); + if (inorder (pred, *ssb, *ssa)) + { + *dest++ = *ssb++ ; + ++bcount; + acount = 0; + --nb; + if (nb == 0) + goto Succeed; + if (bcount >= min_gallop) + break; + } + else + { + *dest++ = *ssa++; + ++acount; + bcount = 0; + --na; + if (na == 1) + goto CopyB; + if (acount >= min_gallop) + break; + } + } + + /* One run is winning so consistently that galloping may be a + huge speedup. We try that, and continue galloping until (if + ever) neither run appears to be winning consistently + anymore. */ + ++min_gallop; + do { + eassume (na > 1 && nb > 0); + min_gallop -= min_gallop > 1; + ms->min_gallop = min_gallop; + ptrdiff_t k = gallop_right (ms, ssb[0], ssa, na, 0); + acount = k; + if (k) + { + memcpy (dest, ssa, k * word_size); + dest += k; + ssa += k; + na -= k; + if (na == 1) + goto CopyB; + /* While na==0 is impossible for a consistent comparison + function, we shouldn't assume that it is. */ + if (na == 0) + goto Succeed; + } + *dest++ = *ssb++ ; + --nb; + if (nb == 0) + goto Succeed; + + k = gallop_left (ms, ssa[0], ssb, nb, 0); + bcount = k; + if (k) + { + memmove (dest, ssb, k * word_size); + dest += k; + ssb += k; + nb -= k; + if (nb == 0) + goto Succeed; + } + *dest++ = *ssa++; + --na; + if (na == 1) + goto CopyB; + } while (acount >= GALLOP_WIN_MIN || bcount >= GALLOP_WIN_MIN); + ++min_gallop; /* Apply a penalty for leaving galloping mode. */ + ms->min_gallop = min_gallop; + } + Succeed: + ms->reloc = (struct reloc){NULL, NULL, NULL, 0}; + + if (na) + memcpy (dest, ssa, na * word_size); + return; + CopyB: + eassume (na == 1 && nb > 0); + ms->reloc = (struct reloc){NULL, NULL, NULL, 0}; + + /* The last element of ssa belongs at the end of the merge. */ + memmove (dest, ssb, nb * word_size); + dest[nb] = ssa[0]; +} + + +/* Stably merge (in-place) the NA elements starting at SSA with the NB + elements starting at SSB = SSA + NA. NA and NB must be positive. + Require that SSA[NA-1] belongs at the end of the merge, and NA >= + NB. */ + +static void +merge_hi (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na, + Lisp_Object *ssb, ptrdiff_t nb) +{ + Lisp_Object pred = ms->predicate; + + eassume (ms && ssa && ssb && na > 0 && nb > 0); + eassume (ssa + na == ssb); + needmem (ms, nb); + Lisp_Object *dest = ssb; + dest += nb - 1; + memcpy(ms->a, ssb, nb * word_size); + Lisp_Object *basea = ssa; + Lisp_Object *baseb = ms->a; + ssb = ms->a + nb - 1; + ssa += na - 1; + + ms->reloc = (struct reloc){&baseb, &dest, &nb, 1}; + + *dest-- = *ssa--; + --na; + if (na == 0) + goto Succeed; + if (nb == 1) + goto CopyA; + + ptrdiff_t min_gallop = ms->min_gallop; + for (;;) { + ptrdiff_t acount = 0; /* The # of consecutive times A won. */ + ptrdiff_t bcount = 0; /* The # of consecutive times B won. */ + + for (;;) { + eassume (na > 0 && nb > 1); + if (inorder (pred, *ssb, *ssa)) + { + *dest-- = *ssa--; + ++acount; + bcount = 0; + --na; + if (na == 0) + goto Succeed; + if (acount >= min_gallop) + break; + } + else + { + *dest-- = *ssb--; + ++bcount; + acount = 0; + --nb; + if (nb == 1) + goto CopyA; + if (bcount >= min_gallop) + break; + } + } + + /* One run is winning so consistently that galloping may be a huge + speedup. Try that, and continue galloping until (if ever) + neither run appears to be winning consistently anymore. */ + ++min_gallop; + do { + eassume (na > 0 && nb > 1); + min_gallop -= min_gallop > 1; + ms->min_gallop = min_gallop; + ptrdiff_t k = gallop_right (ms, ssb[0], basea, na, na - 1); + k = na - k; + acount = k; + if (k) + { + dest += -k; + ssa += -k; + memmove(dest + 1, ssa + 1, k * word_size); + na -= k; + if (na == 0) + goto Succeed; + } + *dest-- = *ssb--; + --nb; + if (nb == 1) + goto CopyA; + + k = gallop_left (ms, ssa[0], baseb, nb, nb - 1); + k = nb - k; + bcount = k; + if (k) + { + dest += -k; + ssb += -k; + memcpy(dest + 1, ssb + 1, k * word_size); + nb -= k; + if (nb == 1) + goto CopyA; + /* While nb==0 is impossible for a consistent comparison + function we shouldn't assume that it is. */ + if (nb == 0) + goto Succeed; + } + *dest-- = *ssa--; + --na; + if (na == 0) + goto Succeed; + } while (acount >= GALLOP_WIN_MIN || bcount >= GALLOP_WIN_MIN); + ++min_gallop; /* Apply a penalty for leaving galloping mode. */ + ms->min_gallop = min_gallop; + } + Succeed: + ms->reloc = (struct reloc){NULL, NULL, NULL, 0}; + if (nb) + memcpy (dest - nb + 1, baseb, nb * word_size); + return; + CopyA: + eassume (nb == 1 && na > 0); + ms->reloc = (struct reloc){NULL, NULL, NULL, 0}; + /* The first element of ssb belongs at the front of the merge. */ + memmove (dest + 1 - na, ssa + 1 - na, na * word_size); + dest += -na; + ssa += -na; + dest[0] = ssb[0]; +} + + +/* Merge the two runs at stack indices I and I+1. */ + +static void +merge_at (merge_state *ms, const ptrdiff_t i) +{ + eassume (ms != NULL); + eassume (ms->n >= 2); + eassume (i >= 0); + eassume (i == ms->n - 2 || i == ms->n - 3); + + Lisp_Object *ssa = ms->pending[i].base; + ptrdiff_t na = ms->pending[i].len; + Lisp_Object *ssb = ms->pending[i + 1].base; + ptrdiff_t nb = ms->pending[i + 1].len; + eassume (na > 0 && nb > 0); + eassume (ssa + na == ssb); + + /* Record the length of the combined runs. The current run i+1 goes + away after the merge. If i is the 3rd-last run now, slide the + last run (which isn't involved in this merge) over to i+1. */ + ms->pending[i].len = na + nb; + if (i == ms->n - 3) + ms->pending[i + 1] = ms->pending[i + 2]; + --ms->n; + + /* Where does b start in a? Elements in a before that can be + ignored (they are already in place). */ + ptrdiff_t k = gallop_right (ms, *ssb, ssa, na, 0); + eassume (k >= 0); + ssa += k; + na -= k; + if (na == 0) + return; + + /* Where does a end in b? Elements in b after that can be ignored + (they are already in place). */ + nb = gallop_left (ms, ssa[na - 1], ssb, nb, nb - 1); + if (nb == 0) + return; + eassume (nb > 0); + /* Merge what remains of the runs using a temp array with size + min(na, nb) elements. */ + if (na <= nb) + merge_lo (ms, ssa, na, ssb, nb); + else + merge_hi (ms, ssa, na, ssb, nb); +} + + +/* Compute the "power" of the first of two adjacent runs begining at + index S1, with the first having length N1 and the second (starting + at index S1+N1) having length N2. The run has total length N. */ + +static int +powerloop (const ptrdiff_t s1, const ptrdiff_t n1, const ptrdiff_t n2, + const ptrdiff_t n) +{ + eassume (s1 >= 0); + eassume (n1 > 0 && n2 > 0); + eassume (s1 + n1 + n2 <= n); + /* The midpoints a and b are + a = s1 + n1/2 + b = s1 + n1 + n2/2 = a + (n1 + n2)/2 + + These may not be integers because of the "/2", so we work with + 2*a and 2*b instead. It makes no difference to the outcome, + since the bits in the expansion of (2*i)/n are merely shifted one + position from those of i/n. */ + ptrdiff_t a = 2 * s1 + n1; + ptrdiff_t b = a + n1 + n2; + int result = 0; + /* Emulate a/n and b/n one bit a time, until their bits differ. */ + for (;;) + { + ++result; + if (a >= n) + { /* Both quotient bits are now 1. */ + eassume (b >= a); + a -= n; + b -= n; + } + else if (b >= n) + { /* a/n bit is 0 and b/n bit is 1. */ + break; + } /* Otherwise both quotient bits are 0. */ + eassume (a < b && b < n); + a <<= 1; + b <<= 1; + } + return result; +} + + +/* Update the state upon identifying a run of length N2. If there's + already a stretch on the stack, apply the "powersort" merge + strategy: compute the topmost stretch's "power" (depth in a + conceptual binary merge tree) and merge adjacent runs on the stack + with greater power. */ + +static void +found_new_run (merge_state *ms, const ptrdiff_t n2) +{ + eassume (ms != NULL); + if (ms->n) + { + eassume (ms->n > 0); + struct stretch *p = ms->pending; + ptrdiff_t s1 = p[ms->n - 1].base - ms->listbase; + ptrdiff_t n1 = p[ms->n - 1].len; + int power = powerloop (s1, n1, n2, ms->listlen); + while (ms->n > 1 && p[ms->n - 2].power > power) + { + merge_at (ms, ms->n - 2); + } + eassume (ms->n < 2 || p[ms->n - 2].power < power); + p[ms->n - 1].power = power; + } +} + + +/* Unconditionally merge all stretches on the stack until only one + remains. */ + +static void +merge_force_collapse (merge_state *ms) +{ + struct stretch *p = ms->pending; + + eassume (ms != NULL); + while (ms->n > 1) + { + ptrdiff_t n = ms->n - 2; + if (n > 0 && p[n - 1].len < p[n + 1].len) + --n; + merge_at (ms, n); + } +} + + +/* Compute a good value for the minimum run length; natural runs + shorter than this are boosted artificially via binary insertion. + + If N < 64, return N (it's too small to bother with fancy stuff). + Otherwise if N is an exact power of 2, return 32. Finally, return + an int k, 32 <= k <= 64, such that N/k is close to, but strictly + less than, an exact power of 2. */ + +static ptrdiff_t +merge_compute_minrun (ptrdiff_t n) +{ + ptrdiff_t r = 0; /* r will become 1 if any non-zero bits are + shifted off. */ + + eassume (n >= 0); + while (n >= 64) + { + r |= n & 1; + n >>= 1; + } + return n + r; +} + + +static void +reverse_vector (Lisp_Object *s, const ptrdiff_t n) +{ + for (ptrdiff_t i = 0; i < n >> 1; i++) + { + Lisp_Object tem = s[i]; + s[i] = s[n - i - 1]; + s[n - i - 1] = tem; + } +} + +/* Sort the array SEQ with LENGTH elements in the order determined by + PREDICATE. */ + +void +tim_sort (Lisp_Object predicate, Lisp_Object *seq, const ptrdiff_t length) +{ + if (SYMBOLP (predicate)) + { + /* Attempt to resolve the function as far as possible ahead of time, + to avoid having to do it for each call. */ + Lisp_Object fun = XSYMBOL (predicate)->u.s.function; + if (SYMBOLP (fun)) + /* Function was an alias; use slow-path resolution. */ + fun = indirect_function (fun); + /* Don't resolve to an autoload spec; that would be very slow. */ + if (!NILP (fun) && !(CONSP (fun) && EQ (XCAR (fun), Qautoload))) + predicate = fun; + } + + merge_state ms; + Lisp_Object *lo = seq; + + merge_init (&ms, length, lo, predicate); + + /* March over the array once, left to right, finding natural runs, + and extending short natural runs to minrun elements. */ + const ptrdiff_t minrun = merge_compute_minrun (length); + ptrdiff_t nremaining = length; + do { + bool descending; + + /* Identify the next run. */ + ptrdiff_t n = count_run (&ms, lo, lo + nremaining, &descending); + if (descending) + reverse_vector (lo, n); + /* If the run is short, extend it to min(minrun, nremaining). */ + if (n < minrun) + { + const ptrdiff_t force = nremaining <= minrun ? + nremaining : minrun; + binarysort (&ms, lo, lo + force, lo + n); + n = force; + } + eassume (ms.n == 0 || ms.pending[ms.n - 1].base + + ms.pending[ms.n - 1].len == lo); + found_new_run (&ms, n); + /* Push the new run on to the stack. */ + eassume (ms.n < MAX_MERGE_PENDING); + ms.pending[ms.n].base = lo; + ms.pending[ms.n].len = n; + ++ms.n; + /* Advance to find the next run. */ + lo += n; + nremaining -= n; + } while (nremaining); + + merge_force_collapse (&ms); + eassume (ms.n == 1); + eassume (ms.pending[0].len == length); + lo = ms.pending[0].base; + + if (ms.a != ms.temparray) + unbind_to (ms.count, Qnil); +} diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 723ef4c710..5b252e184f 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -204,6 +204,76 @@ [-1 2 3 4 5 5 7 8 9])) (should (equal (sort (vector 9 5 2 -1 5 3 8 7 4) (lambda (x y) (> x y))) [9 8 7 5 5 4 3 2 -1])) + ;; Sort a reversed list and vector. + (should (equal + (sort (reverse (number-sequence 1 1000)) (lambda (x y) (< x y))) + (number-sequence 1 1000))) + (should (equal + (sort (reverse (vconcat (number-sequence 1 1000))) + (lambda (x y) (< x y))) + (vconcat (number-sequence 1 1000)))) + ;; Sort a constant list and vector. + (should (equal + (sort (make-vector 100 1) (lambda (x y) (> x y))) + (make-vector 100 1))) + (should (equal + (sort (append (make-vector 100 1) nil) (lambda (x y) (> x y))) + (append (make-vector 100 1) nil))) + ;; Sort a long list and vector with every pair reversed. + (let ((vec (make-vector 100000 nil)) + (logxor-vec (make-vector 100000 nil))) + (dotimes (i 100000) + (aset logxor-vec i (logxor i 1)) + (aset vec i i)) + (should (equal + (sort logxor-vec (lambda (x y) (< x y))) + vec)) + (should (equal + (sort (append logxor-vec nil) (lambda (x y) (< x y))) + (append vec nil)))) + ;; Sort a list and vector with seven swaps. + (let ((vec (make-vector 100 nil)) + (swap-vec (make-vector 100 nil))) + (dotimes (i 100) + (aset vec i (- i 50)) + (aset swap-vec i (- i 50))) + (mapc (lambda (p) + (let ((tmp (elt swap-vec (car p)))) + (aset swap-vec (car p) (elt swap-vec (cdr p))) + (aset swap-vec (cdr p) tmp))) + '((48 . 94) (75 . 77) (33 . 41) (92 . 52) + (10 . 96) (1 . 14) (43 . 81))) + (should (equal + (sort (copy-sequence swap-vec) (lambda (x y) (< x y))) + vec)) + (should (equal + (sort (append swap-vec nil) (lambda (x y) (< x y))) + (append vec nil)))) + ;; Check for possible corruption after GC. + (let* ((size 3000) + (complex-vec (make-vector size nil)) + (vec (make-vector size nil)) + (counter 0) + (my-counter (lambda () + (if (< counter 500) + (cl-incf counter) + (setq counter 0) + (garbage-collect)))) + (rand 1) + (generate-random + (lambda () (setq rand + (logand (+ (* rand 1103515245) 12345) 2147483647))))) + ;; Make a complex vector and its sorted version. + (dotimes (i size) + (let ((r (funcall generate-random))) + (aset complex-vec i (cons r "a")) + (aset vec i (cons r "a")))) + ;; Sort it. + (should (equal + (sort complex-vec + (lambda (x y) (funcall my-counter) (< (car x) (car y)))) + (sort vec 'car-less-than-car)))) + ;; Check for sorting stability. (should (equal (sort (vector commit e091bee8db9926716a3e7778275901696896cbdf Author: Mattias Engdegård Date: Sat Mar 5 11:12:54 2022 +0100 Add optional GC marking function to specpdl unwind_ptr record Add a new `record_unwind_protect_ptr_mark` function for use with C data structures that use the specpdl for clean-up but also contain possibly unique references to Lisp objects. * src/eval.c (record_unwind_protect_ptr_mark): New. (record_unwind_protect_module, set_unwind_protect_ptr): Set the mark function to NULL. (mark_specpdl): Call the mark function if present. * src/lisp.h (unwind_ptr): Add a mark function pointer to the SPECPDL_UNWIND_PTR case. diff --git a/src/eval.c b/src/eval.c index a4449b18f9..7269582333 100644 --- a/src/eval.c +++ b/src/eval.c @@ -3496,6 +3496,20 @@ record_unwind_protect_ptr (void (*function) (void *), void *arg) specpdl_ptr->unwind_ptr.kind = SPECPDL_UNWIND_PTR; specpdl_ptr->unwind_ptr.func = function; specpdl_ptr->unwind_ptr.arg = arg; + specpdl_ptr->unwind_ptr.mark = NULL; + grow_specpdl (); +} + +/* Like `record_unwind_protect_ptr', but also specifies a function + for GC-marking Lisp objects only reachable through ARG. */ +void +record_unwind_protect_ptr_mark (void (*function) (void *), void *arg, + void (*mark) (void *)) +{ + specpdl_ptr->unwind_ptr.kind = SPECPDL_UNWIND_PTR; + specpdl_ptr->unwind_ptr.func = function; + specpdl_ptr->unwind_ptr.arg = arg; + specpdl_ptr->unwind_ptr.mark = mark; grow_specpdl (); } @@ -3539,6 +3553,7 @@ record_unwind_protect_module (enum specbind_tag kind, void *ptr) specpdl_ptr->kind = kind; specpdl_ptr->unwind_ptr.func = NULL; specpdl_ptr->unwind_ptr.arg = ptr; + specpdl_ptr->unwind_ptr.mark = NULL; grow_specpdl (); } @@ -3667,6 +3682,7 @@ set_unwind_protect_ptr (specpdl_ref count, void (*func) (void *), void *arg) p->unwind_ptr.kind = SPECPDL_UNWIND_PTR; p->unwind_ptr.func = func; p->unwind_ptr.arg = arg; + p->unwind_ptr.mark = NULL; } /* Pop and execute entries from the unwind-protect stack until the @@ -4100,6 +4116,10 @@ mark_specpdl (union specbinding *first, union specbinding *ptr) break; case SPECPDL_UNWIND_PTR: + if (pdl->unwind_ptr.mark) + pdl->unwind_ptr.mark (pdl->unwind_ptr.arg); + break; + case SPECPDL_UNWIND_INT: case SPECPDL_UNWIND_INTMAX: case SPECPDL_UNWIND_VOID: diff --git a/src/lisp.h b/src/lisp.h index 9599934c1f..c5a772b423 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3316,8 +3316,9 @@ union specbinding } unwind_array; struct { ENUM_BF (specbind_tag) kind : CHAR_BIT; - void (*func) (void *); + void (*func) (void *); /* Unwind function. */ void *arg; + void (*mark) (void *); /* GC mark function (if non-null). */ } unwind_ptr; struct { ENUM_BF (specbind_tag) kind : CHAR_BIT; @@ -4474,6 +4475,8 @@ extern void specbind (Lisp_Object, Lisp_Object); extern void record_unwind_protect (void (*) (Lisp_Object), Lisp_Object); extern void record_unwind_protect_array (Lisp_Object *, ptrdiff_t); extern void record_unwind_protect_ptr (void (*) (void *), void *); +extern void record_unwind_protect_ptr_mark (void (*function) (void *), + void *arg, void (*mark) (void *)); extern void record_unwind_protect_int (void (*) (int), int); extern void record_unwind_protect_intmax (void (*) (intmax_t), intmax_t); extern void record_unwind_protect_void (void (*) (void)); commit 9fab134ee8b4ed439a8944e0d7058b1898c9bc0b Author: Po Lu Date: Mon Apr 4 07:25:27 2022 +0800 * src/xterm.c (x_dnd_get_target_window): Look at root window proxies too. diff --git a/src/xterm.c b/src/xterm.c index aef3d2d840..e3935bacb9 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -2745,6 +2745,22 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo, if (child != dpyinfo->root_window) { #endif + if (child != None) + { + proxy = x_dnd_get_window_proxy (dpyinfo, child); + + if (proxy) + { + proto = x_dnd_get_window_proto (dpyinfo, proxy); + + if (proto != -1) + { + *proto_out = proto; + return proxy; + } + } + } + *proto_out = x_dnd_get_window_proto (dpyinfo, child); return child; #if defined HAVE_XCOMPOSITE && (XCOMPOSITE_MAJOR > 0 || XCOMPOSITE_MINOR > 2) @@ -2788,6 +2804,22 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo, } } + if (child != None) + { + proxy = x_dnd_get_window_proxy (dpyinfo, child); + + if (proxy) + { + proto = x_dnd_get_window_proto (dpyinfo, proxy); + + if (proto != -1) + { + *proto_out = proto; + return proxy; + } + } + } + *proto_out = x_dnd_get_window_proto (dpyinfo, child); return child; #endif commit c0cf923b0ad6f72eafb58057f4df245bca3da658 Author: Juri Linkov Date: Sun Apr 3 19:51:46 2022 +0300 * lisp/tab-bar.el (tab-bar-undo-close-tab): Update tab-bar-lines (bug#54684) diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index cf1cca4af3..c4d450fe2a 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -1659,9 +1659,10 @@ happens interactively)." (setq index (max 0 (min index (length tabs)))) (cl-pushnew tab (nthcdr index tabs)) (when (eq index 0) - ;; pushnew handles the head of tabs but not frame-parameter + ;; `pushnew' handles the head of tabs but not frame-parameter (tab-bar-tabs-set tabs)) - (tab-bar-select-tab (1+ index)))) + (tab-bar-select-tab (1+ index))) + (tab-bar--update-tab-bar-lines)) (message "No more closed tabs to undo"))) commit 3c6524140b7a5e68875541781c3c48853e763dc3 Author: Philipp Stephani Date: Sun Apr 3 17:51:04 2022 +0200 ; * lisp/emacs-lisp/cl-macs.el (cl-struct-slot-value): Fix typo. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 5d2a7c03ac..da7157f434 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3625,7 +3625,7 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (define-inline cl-struct-slot-value (struct-type slot-name inst) "Return the value of slot SLOT-NAME in INST of STRUCT-TYPE. -STRUCT and SLOT-NAME are symbols. INST is a structure instance." +STRUCT-TYPE and SLOT-NAME are symbols. INST is a structure instance." (declare (side-effect-free t)) (inline-letevals (struct-type slot-name inst) (inline-quote commit 45011b77f42ad87844e757c218a9d4283348d410 Author: Po Lu Date: Sun Apr 3 13:35:28 2022 +0000 Fix various bugs with mouse dragging on Haiku * src/haikuterm.c (haiku_mouse_position): Rewrite so that different track-mouse types can be handled more consistently. diff --git a/src/haikuterm.c b/src/haikuterm.c index 374d066787..91e985e196 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -2568,19 +2568,25 @@ haiku_scroll_run (struct window *w, struct run *run) } /* Haiku doesn't provide any way to get the frame actually underneath - the pointer, so we typically return dpyinfo->last_mouse_frame, and - refrain from returning anything if that doesn't exist. */ + the pointer, so we typically return dpyinfo->last_mouse_frame if + the display is grabbed and `track-mouse' is not `dropping' or + `drag-source'; failing that, we return the selected frame, and + finally a random window system frame (as long as `track-mouse' is + not `drag-source') if that didn't work either. */ static void haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, enum scroll_bar_part *part, Lisp_Object *x, Lisp_Object *y, Time *timestamp) { Lisp_Object frame, tail; - struct frame *f1 = NULL; + struct frame *f1; + int screen_x, screen_y; + void *view; if (!fp) return; + f1 = NULL; block_input (); FOR_EACH_FRAME (tail, frame) @@ -2593,13 +2599,10 @@ haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, && !EQ (track_mouse, Qdropping) && !EQ (track_mouse, Qdrag_source)) f1 = x_display_list->last_mouse_frame; + else + f1 = x_display_list->last_mouse_motion_frame; - if (!f1 || FRAME_TOOLTIP_P (f1)) - f1 = ((EQ (track_mouse, Qdropping) && gui_mouse_grabbed (x_display_list)) - ? x_display_list->last_mouse_frame - : NULL); - - if (!f1 && insist > 0) + if (!f1 && FRAME_HAIKU_P (SELECTED_FRAME ())) f1 = SELECTED_FRAME (); if (!f1 || (!FRAME_HAIKU_P (f1) && (insist > 0))) @@ -2608,26 +2611,37 @@ haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, !FRAME_TOOLTIP_P (XFRAME (frame))) f1 = XFRAME (frame); - if (FRAME_TOOLTIP_P (f1)) + if (f1 && FRAME_TOOLTIP_P (f1)) f1 = NULL; if (f1 && FRAME_HAIKU_P (f1)) { - int sx, sy; - void *view = FRAME_HAIKU_VIEW (f1); + view = FRAME_HAIKU_VIEW (f1); + if (view) { - BView_get_mouse (view, &sx, &sy); - - remember_mouse_glyph (f1, sx, sy, &x_display_list->last_mouse_glyph); + BView_get_mouse (view, &screen_x, &screen_y); + remember_mouse_glyph (f1, screen_x, screen_y, + &x_display_list->last_mouse_glyph); x_display_list->last_mouse_glyph_frame = f1; *bar_window = Qnil; *part = scroll_bar_above_handle; - *fp = f1; + + /* If track-mouse is `drag-source' and the mouse pointer is + certain to not be actually under the chosen frame, return + NULL in FP to at least try being consistent with X. */ + if (EQ (track_mouse, Qdrag_source) + && (screen_x < 0 || screen_y < 0 + || screen_x >= FRAME_PIXEL_WIDTH (f1) + || screen_y >= FRAME_PIXEL_HEIGHT (f1))) + *fp = NULL; + else + *fp = f1; + *timestamp = x_display_list->last_mouse_movement_time; - XSETINT (*x, sx); - XSETINT (*y, sy); + XSETINT (*x, screen_x); + XSETINT (*y, screen_y); } } commit c12a48c3350bb5aa2cbefda10c5364c778463366 Author: Jim Porter Date: Sun Mar 27 12:09:58 2022 -0700 Fix handling of '\\' inside double-quotes in Eshell Previously, Eshell would get confused and think the following command was unterminated due to the second double-quote looking like it was escaped: echo "\\" * lisp/eshell/esh-util.el (eshell-find-delimiter): Correct docstring and treat '\' as an escapeable character when using backslash escapes. * test/lisp/eshell/eshell-tests.el (eshell-test/escape-special-quoted): Adapt test. diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 788404fc43..8089d4d74b 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -151,49 +151,52 @@ Otherwise, evaluates FORM with no error handling." (defun eshell-find-delimiter (open close &optional bound reverse-p backslash-p) "From point, find the CLOSE delimiter corresponding to OPEN. -The matching is bounded by BOUND. -If REVERSE-P is non-nil, process the region backwards. -If BACKSLASH-P is non-nil, and OPEN and CLOSE are the same character, -then quoting is done by a backslash, rather than a doubled delimiter." +The matching is bounded by BOUND. If REVERSE-P is non-nil, +process the region backwards. + +If BACKSLASH-P is non-nil, or OPEN and CLOSE are different +characters, then a backslash can be used to escape a delimiter +(or another backslash). Otherwise, the delimiter is escaped by +doubling it up." (save-excursion (let ((depth 1) (bound (or bound (point-max)))) - (if (if reverse-p - (eq (char-before) close) - (eq (char-after) open)) - (forward-char (if reverse-p -1 1))) + (when (if reverse-p + (eq (char-before) close) + (eq (char-after) open)) + (forward-char (if reverse-p -1 1))) (while (and (> depth 0) - (funcall (if reverse-p '> '<) (point) bound)) - (let ((c (if reverse-p (char-before) (char-after))) nc) + (funcall (if reverse-p #'> #'<) (point) bound)) + (let ((c (if reverse-p (char-before) (char-after)))) (cond ((and (not reverse-p) (or (not (eq open close)) backslash-p) (eq c ?\\) - (setq nc (char-after (1+ (point)))) - (or (eq nc open) (eq nc close))) + (memq (char-after (1+ (point))) + (list open close ?\\))) (forward-char 1)) ((and reverse-p (or (not (eq open close)) backslash-p) - (or (eq c open) (eq c close)) - (eq (char-before (1- (point))) - ?\\)) + (eq (char-before (1- (point))) ?\\) + (memq c (list open close ?\\))) (forward-char -1)) ((eq open close) - (if (eq c open) - (if (and (not backslash-p) - (eq (if reverse-p - (char-before (1- (point))) - (char-after (1+ (point)))) open)) - (forward-char (if reverse-p -1 1)) - (setq depth (1- depth))))) + (when (eq c open) + (if (and (not backslash-p) + (eq (if reverse-p + (char-before (1- (point))) + (char-after (1+ (point)))) + open)) + (forward-char (if reverse-p -1 1)) + (setq depth (1- depth))))) ((= c open) (setq depth (+ depth (if reverse-p -1 1)))) ((= c close) (setq depth (+ depth (if reverse-p 1 -1)))))) (forward-char (if reverse-p -1 1))) - (if (= depth 0) - (if reverse-p (point) (1- (point))))))) + (when (= depth 0) + (if reverse-p (point) (1- (point))))))) (defun eshell-convert (string) "Convert STRING into a more native looking Lisp object." diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el index 1e303f70e5..bcc2dc320b 100644 --- a/test/lisp/eshell/eshell-tests.el +++ b/test/lisp/eshell/eshell-tests.el @@ -148,9 +148,9 @@ chars" "Test that the backslash is not preserved for escaped special chars" (with-temp-eshell - (eshell-command-result-p "echo \"h\\\\i\"" + (eshell-command-result-p "echo \"\\\"hi\\\\\"" ;; Backslashes are doubled for regexp. - "h\\\\i\n"))) + "\\\"hi\\\\\n"))) (ert-deftest eshell-test/command-running-p () "Modeline should show no command running" commit 9f521db6fec6c6dbdfeb1145f4dbb603c0240299 Author: James Thomas Date: Sun Apr 3 14:14:24 2022 +0200 Ensure re-encoding after change in gnus-inews-do-gcc * lisp/gnus/gnus-msg.el (gnus-inews-do-gcc): Re-encode the message body if it has been modified by gnus-gcc-pre-body-encode-hook (bug#54687). diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index f38f6f4ee2..f6ae028a10 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -1593,9 +1593,10 @@ this is a reply." (nnheader-set-temp-buffer " *acc*") (setq message-options (with-current-buffer cur message-options)) (insert-buffer-substring cur) + (restore-buffer-modified-p nil) (run-hooks 'gnus-gcc-pre-body-encode-hook) ;; Avoid re-doing things like GPG-encoding secret parts. - (if (not encoded-cache) + (if (or (buffer-modified-p) (not encoded-cache)) (message-encode-message-body) (erase-buffer) (insert encoded-cache)) commit 5e429e21d9ae7e217c4c2b5b6d78f932c8f6ae39 Author: Lars Ingebrigtsen Date: Sun Apr 3 14:07:55 2022 +0200 Have global minor modes say so in the doc string * lisp/emacs-lisp/easy-mmode.el (easy-mmode--arg-docstring): Allow saying whether it's a global minor mode or not. (easy-mmode--mode-docstring): Use it. (define-minor-mode): Pass in the data. diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 21a29a722c..b2302624b1 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -82,9 +82,9 @@ replacing its case-insensitive matches with the literal string in LIGHTER." (replace-regexp-in-string (regexp-quote lighter) lighter name t t)))) (defconst easy-mmode--arg-docstring - "This is a minor mode. If called interactively, toggle the `%s' -mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. + "This is a %sminor mode. If called interactively, toggle the +`%s' mode. If the prefix argument is positive, enable the mode, +and if it is zero or negative, disable the mode. If called from Lisp, toggle the mode if ARG is `toggle'. Enable the mode if ARG is nil, omitted, or is a positive number. @@ -97,7 +97,7 @@ The mode's hook is called both when the mode is enabled and when it is disabled.") (defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym - getter) + getter global) ;; If we have a doc string, and it's already complete (which we ;; guess at with the simple heuristic below), then just return that ;; as is. @@ -124,10 +124,12 @@ it is disabled.") (let* ((fill-prefix nil) (docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column)) (fill-column (if (integerp docs-fc) docs-fc 65)) - (argdoc (format easy-mmode--arg-docstring mode-pretty-name - ;; Avoid having quotes turn into pretty quotes. - (string-replace "'" "\\\\='" - (format "%S" getter))))) + (argdoc (format + easy-mmode--arg-docstring + (if global "global " "") + mode-pretty-name + ;; Avoid having quotes turn into pretty quotes. + (string-replace "'" "\\\\='" (format "%S" getter))))) (let ((start (point))) (insert argdoc) (when (fboundp 'fill-region) @@ -335,7 +337,7 @@ or call the function `%s'.")))) warnwrap `(defun ,modefun (&optional arg ,@extra-args) ,(easy-mmode--mode-docstring doc pretty-name keymap-sym - getter) + getter globalp) ,(when interactive ;; Use `toggle' rather than (if ,mode 0 1) so that using ;; repeat-command still does the toggling correctly. commit 1fb20a4dde8c63a1aae570b59bb4bbb02673bec9 Author: Po Lu Date: Sun Apr 3 19:33:52 2022 +0800 Implement `drag-source' values of `track-mouse' on PGTK. * src/frame.c (Fmouse_position, mouse_position) (Fmouse_pixel_position): Fix crashes when mouse_position_hook stores nil. * src/pgtkterm.c (pgtk_mouse_position): Behave appropriately. diff --git a/src/frame.c b/src/frame.c index e531891a8a..7a9ed3302e 100644 --- a/src/frame.c +++ b/src/frame.c @@ -2505,9 +2505,12 @@ vertical offset, measured in units of the frame's default character size. If Emacs is running on a mouseless terminal or hasn't been programmed to read the mouse position, it returns the selected frame for FRAME and nil for X and Y. -If `mouse-position-function' is non-nil, `mouse-position' calls it, -passing the normal return value to that function as an argument, -and returns whatever that function returns. */) + +FRAME might be nil if `track-mouse' is set to `drag-source'. This +means there is no frame under the mouse. If `mouse-position-function' +is non-nil, `mouse-position' calls it, passing the normal return value +to that function as an argument, and returns whatever that function +returns. */) (void) { return mouse_position (true); @@ -2534,7 +2537,7 @@ mouse_position (bool call_mouse_position_function) &time_dummy); } - if (! NILP (x)) + if (! NILP (x) && f) { int col = XFIXNUM (x); int row = XFIXNUM (y); @@ -2542,7 +2545,10 @@ mouse_position (bool call_mouse_position_function) XSETINT (x, col); XSETINT (y, row); } - XSETFRAME (lispy_dummy, f); + if (f) + XSETFRAME (lispy_dummy, f); + else + lispy_dummy = Qnil; retval = Fcons (lispy_dummy, Fcons (x, y)); if (call_mouse_position_function && !NILP (Vmouse_position_function)) retval = call1 (Vmouse_position_function, retval); @@ -2555,9 +2561,11 @@ DEFUN ("mouse-pixel-position", Fmouse_pixel_position, The position is given in pixel units, where (0, 0) is the upper-left corner of the frame, X is the horizontal offset, and Y is the vertical offset. -If Emacs is running on a mouseless terminal or hasn't been programmed -to read the mouse position, it returns the selected frame for FRAME -and nil for X and Y. */) +FRAME might be nil if `track-mouse' is set to `drag-source'. This +means there is no frame under the mouse. If Emacs is running on a +mouseless terminal or hasn't been programmed to read the mouse +position, it returns the selected frame for FRAME and nil for X and +Y. */) (void) { struct frame *f; @@ -2578,7 +2586,11 @@ and nil for X and Y. */) &time_dummy); } - XSETFRAME (lispy_dummy, f); + if (f) + XSETFRAME (lispy_dummy, f); + else + lispy_dummy = Qnil; + retval = Fcons (lispy_dummy, Fcons (x, y)); if (!NILP (Vmouse_position_function)) retval = call1 (Vmouse_position_function, retval); diff --git a/src/pgtkterm.c b/src/pgtkterm.c index 216b5ee7dd..9458738142 100644 --- a/src/pgtkterm.c +++ b/src/pgtkterm.c @@ -3329,8 +3329,8 @@ pgtk_frame_up_to_date (struct frame *f) static void pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window, - enum scroll_bar_part *part, Lisp_Object * x, - Lisp_Object * y, Time * timestamp) + enum scroll_bar_part *part, Lisp_Object *x, + Lisp_Object *y, Time *timestamp) { struct frame *f1; struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (*fp); @@ -3339,6 +3339,7 @@ pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window, GdkDevice *device; GdkModifierType mask; GdkWindow *win; + bool return_frame_flag = false; block_input (); @@ -3352,30 +3353,37 @@ pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window, dpyinfo->last_mouse_scroll_bar = NULL; - if (gui_mouse_grabbed (dpyinfo)) + if (gui_mouse_grabbed (dpyinfo) + && (!EQ (track_mouse, Qdropping) + && !EQ (track_mouse, Qdrag_source))) { - /* 1.1. use last_mouse_frame as frame where the pointer is on. */ + /* 1.1. use last_mouse_frame as frame where the pointer is + on. */ f1 = dpyinfo->last_mouse_frame; } else { f1 = *fp; - /* 1.2. get frame where the pointer is on. */ + /* 1.2. get frame where the pointer is on. */ win = gtk_widget_get_window (FRAME_GTK_WIDGET (*fp)); seat = gdk_display_get_default_seat (dpyinfo->gdpy); device = gdk_seat_get_pointer (seat); - win = - gdk_window_get_device_position (win, device, &win_x, &win_y, &mask); + win = gdk_window_get_device_position (win, device, &win_x, + &win_y, &mask); if (win != NULL) f1 = pgtk_any_window_to_frame (win); else { - /* crossing display server? */ f1 = SELECTED_FRAME (); + + if (!FRAME_PGTK_P (f1)) + f1 = dpyinfo->last_mouse_frame; + + return_frame_flag = EQ (track_mouse, Qdrag_source); } } - /* f1 can be a terminal frame. Bug#50322 */ + /* F1 can be a terminal frame. (Bug#50322) */ if (f1 == NULL || !FRAME_PGTK_P (f1)) { unblock_input (); @@ -3399,7 +3407,7 @@ pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window, *bar_window = Qnil; *part = 0; - *fp = f1; + *fp = !return_frame_flag ? f1 : NULL; XSETINT (*x, win_x); XSETINT (*y, win_y); *timestamp = dpyinfo->last_mouse_movement_time; commit 9ccaf35e0b52de2fdf906efe1ae935012745e832 Author: Po Lu Date: Sun Apr 3 19:20:56 2022 +0800 Implement `drag-source' values of track-mouse on NS * src/nsterm.m (ns_mouse_position): Don't return frame when appropriate. diff --git a/src/nsterm.m b/src/nsterm.m index f4c1e08925..15127d53fb 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -2270,6 +2270,7 @@ Hide the window (X11 semantics) Lisp_Object frame, tail; struct frame *f = NULL; struct ns_display_info *dpyinfo; + bool return_no_frame_flag = false; NSTRACE ("ns_mouse_position"); @@ -2313,15 +2314,25 @@ Hide the window (X11 semantics) #endif if (!f) - f = dpyinfo->ns_focus_frame ? dpyinfo->ns_focus_frame : SELECTED_FRAME (); + { + f = (dpyinfo->ns_focus_frame + ? dpyinfo->ns_focus_frame : SELECTED_FRAME ()); + return_no_frame_flag = EQ (track_mouse, Qdrag_source); + } + + if (!FRAME_NS_P (f)) + f = NULL; /* While dropping, use the last mouse frame only if there is no currently focused frame. */ - if (!f - && EQ (track_mouse, Qdropping) + if (!f && (EQ (track_mouse, Qdropping) + || EQ (track_mouse, Qdrag_source)) && dpyinfo->last_mouse_frame && FRAME_LIVE_P (dpyinfo->last_mouse_frame)) - f = dpyinfo->last_mouse_frame; + { + f = dpyinfo->last_mouse_frame; + return_no_frame_flag = EQ (track_mouse, Qdrag_source); + } if (f && FRAME_NS_P (f)) { @@ -2340,7 +2351,7 @@ Hide the window (X11 semantics) if (y) XSETINT (*y, lrint (view_position.y)); if (time) *time = dpyinfo->last_mouse_movement_time; - *fp = f; + *fp = return_no_frame_flag ? NULL : f; } unblock_input (); commit c3f12cd5da54c9d5180fccaeee2e34b05489def2 Author: Po Lu Date: Sun Apr 3 11:08:42 2022 +0000 Implement (sort of) `drag-source' on Haiku * src/haikuterm.c (haiku_mouse_or_wdesc_frame) (haiku_mouse_position): Behave reasonably when track_mouse is Qdrag_source. diff --git a/src/haikuterm.c b/src/haikuterm.c index cdddf50d19..374d066787 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -452,7 +452,8 @@ haiku_mouse_or_wdesc_frame (void *window) ? x_display_list->last_mouse_frame : NULL); - if (lm_f && !EQ (track_mouse, Qdropping)) + if (lm_f && !EQ (track_mouse, Qdropping) + && !EQ (track_mouse, Qdrag_source)) return lm_f; else { @@ -2566,6 +2567,9 @@ haiku_scroll_run (struct window *w, struct run *run) unblock_input (); } +/* Haiku doesn't provide any way to get the frame actually underneath + the pointer, so we typically return dpyinfo->last_mouse_frame, and + refrain from returning anything if that doesn't exist. */ static void haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, enum scroll_bar_part *part, Lisp_Object *x, Lisp_Object *y, @@ -2585,7 +2589,9 @@ haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, XFRAME (frame)->mouse_moved = false; } - if (gui_mouse_grabbed (x_display_list) && !EQ (track_mouse, Qdropping)) + if (gui_mouse_grabbed (x_display_list) + && !EQ (track_mouse, Qdropping) + && !EQ (track_mouse, Qdrag_source)) f1 = x_display_list->last_mouse_frame; if (!f1 || FRAME_TOOLTIP_P (f1)) commit 28f720e7c483c37a6c94f6b561e8f175b3af51a4 Author: Po Lu Date: Sun Apr 3 18:59:12 2022 +0800 Make dragging stuff to a window above a frame work * doc/lispref/frames.texi (Mouse Tracking): * etc/NEWS: Announce new `drag-source' value of `track-mouse'. * lisp/mouse.el (mouse-drag-and-drop-region): Use new value of `track-mouse' during interprogram drag and drop. * src/keyboard.c (make_lispy_position): Handle nil values of f correctly. * src/xdisp.c (define_frame_cursor1): Ignore if `drag-source' as well. (syms_of_xdisp): New defsym `drag-source'. * src/xterm.c (XTmouse_position): Implement `drag-source'. (mouse_or_wdesc_frame): Likewise. diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index ebf426fe50..057f070ccc 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -3512,10 +3512,18 @@ enabled. Typically, @var{body} would use @code{read-event} to read the motion events and modify the display accordingly. @xref{Motion Events}, for the format of mouse motion events. -The value of @code{track-mouse} is that of the last form in @var{body}. -You should design @var{body} to return when it sees the up-event that -indicates the release of the button, or whatever kind of event means -it is time to stop tracking. +The value of @code{track-mouse} is that of the last form in +@var{body}. You should design @var{body} to return when it sees the +up-event that indicates the release of the button, or whatever kind of +event means it is time to stop tracking. Its value also controls how +mouse events are reported while a mouse button is held down: if it is +@code{dropping} or @code{drag-source}, the motion events are reported +relative to the frame underneath the pointer. If there is no such +frame, the events will be reported relative to the frame the mouse +buttons were first pressed on. In addition, the @code{posn-window} of +the mouse position list will be @code{nil} if the value is +@code{drag-source}. This is useful to determine if a frame is not +directly visible underneath the mouse pointer. The @code{track-mouse} form causes Emacs to generate mouse motion events by binding the variable @code{track-mouse} to a diff --git a/etc/NEWS b/etc/NEWS index 037a9724d8..f81d194a2f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1331,6 +1331,12 @@ functions. * Lisp Changes in Emacs 29.1 ++++ +** 'track-mouse' can be a new value 'drag-source'. +This means the same as 'dropping', but modifies the mouse position +list in reported motion events if there is no frame underneath the +mouse pointer. + +++ ** New function 'x-begin-drag'. This function initiates a drag-and-drop request with the contents of diff --git a/lisp/mouse.el b/lisp/mouse.el index 92e289b4ce..f42492bb5d 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -3085,7 +3085,18 @@ is copied instead of being cut." (ignore-errors (catch 'cross-program-drag (track-mouse - (setq track-mouse 'dropping) + (setq track-mouse (if mouse-drag-and-drop-region-cross-program + ;; When `track-mouse' is `drop', we + ;; get events with a posn-window of + ;; the grabbed frame even if some + ;; window is between that and the + ;; pointer. This makes dragging to a + ;; window on top of a frame + ;; impossible. With this value of + ;; `track-mouse', no frame is returned + ;; in that particular case. + 'drag-source + 'drop)) ;; When event was "click" instead of "drag", skip loop. (while (progn (setq event (read-key)) ; read-event or read-key @@ -3151,15 +3162,16 @@ is copied instead of being cut." (when (and mouse-drag-and-drop-region-cross-program (display-graphic-p) (fboundp 'x-begin-drag) - (framep (posn-window (event-end event))) - (let ((location (posn-x-y (event-end event))) - (frame (posn-window (event-end event)))) - (or (< (car location) 0) - (< (cdr location) 0) - (> (car location) - (frame-pixel-width frame)) - (> (cdr location) - (frame-pixel-height frame))))) + (or (and (framep (posn-window (event-end event))) + (let ((location (posn-x-y (event-end event))) + (frame (posn-window (event-end event)))) + (or (< (car location) 0) + (< (cdr location) 0) + (> (car location) + (frame-pixel-width frame)) + (> (cdr location) + (frame-pixel-height frame))))) + (not (posn-window (event-end event))))) (mouse-drag-and-drop-region-hide-tooltip) (gui-set-selection 'XdndSelection value-selection) (let ((drag-action-or-frame diff --git a/src/keyboard.c b/src/keyboard.c index 8b451d834d..d34bec48a6 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -5253,13 +5253,13 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, /* Report mouse events on the tab bar and (on GUI frames) on the tool bar. */ - if ((WINDOWP (f->tab_bar_window) - && EQ (window_or_frame, f->tab_bar_window)) + if (f && ((WINDOWP (f->tab_bar_window) + && EQ (window_or_frame, f->tab_bar_window)) #ifndef HAVE_EXT_TOOL_BAR - || (WINDOWP (f->tool_bar_window) - && EQ (window_or_frame, f->tool_bar_window)) + || (WINDOWP (f->tool_bar_window) + && EQ (window_or_frame, f->tool_bar_window)) #endif - ) + )) { /* While 'track-mouse' is neither nil nor t, do not report this event as something that happened on the tool or tab bar since @@ -5283,7 +5283,7 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, window_or_frame = Qnil; } - if (FRAME_TERMINAL (f)->toolkit_position_hook) + if (f && FRAME_TERMINAL (f)->toolkit_position_hook) { FRAME_TERMINAL (f)->toolkit_position_hook (f, mx, my, &menu_bar_p, &tool_bar_p); @@ -5524,9 +5524,16 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, } #endif } - else - window_or_frame = Qnil; + { + if (EQ (track_mouse, Qdrag_source)) + { + xret = mx; + yret = my; + } + + window_or_frame = Qnil; + } return Fcons (window_or_frame, Fcons (posn, @@ -12563,12 +12570,15 @@ and the minor mode maps regardless of `overriding-local-map'. */); doc: /* Non-nil means generate motion events for mouse motion. The special values `dragging' and `dropping' assert that the mouse cursor retains its appearance during mouse motion. Any non-nil value -but `dropping' asserts that motion events always relate to the frame -where the mouse movement started. The value `dropping' asserts -that motion events relate to the frame where the mouse cursor is seen -when generating the event. If there's no such frame, such motion -events relate to the frame where the mouse movement started. */); - +but `dropping' or `drag-source' asserts that motion events always +relate to the frame where the mouse movement started. The value +`dropping' asserts that motion events relate to the frame where the +mouse cursor is seen when generating the event. If there's no such +frame, such motion events relate to the frame where the mouse movement +started. The value `drag-source' is like `dropping', but the +`posn-window' will be nil in mouse position lists inside mouse +movement events if there is no frame directly visible underneath the +mouse pointer. */); DEFVAR_KBOARD ("system-key-alist", Vsystem_key_alist, doc: /* Alist of system-specific X windows key symbols. Each element should have the form (N . SYMBOL) where N is the diff --git a/src/xdisp.c b/src/xdisp.c index 62c8f9d4d9..d731308173 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -33856,7 +33856,8 @@ define_frame_cursor1 (struct frame *f, Emacs_Cursor cursor, Lisp_Object pointer) return; /* Do not change cursor shape while dragging mouse. */ - if (EQ (track_mouse, Qdragging) || EQ (track_mouse, Qdropping)) + if (EQ (track_mouse, Qdragging) || EQ (track_mouse, Qdropping) + || EQ (track_mouse, Qdrag_source)) return; if (!NILP (pointer)) @@ -35678,6 +35679,7 @@ be let-bound around code that needs to disable messages temporarily. */); DEFSYM (Qdragging, "dragging"); DEFSYM (Qdropping, "dropping"); + DEFSYM (Qdrag_source, "drag-source"); DEFSYM (Qdrag_with_mode_line, "drag-with-mode-line"); DEFSYM (Qdrag_with_header_line, "drag-with-header-line"); diff --git a/src/xterm.c b/src/xterm.c index e7c671de74..aef3d2d840 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -9811,7 +9811,8 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, x_catch_errors (FRAME_X_DISPLAY (*fp)); - if (gui_mouse_grabbed (dpyinfo) && !EQ (track_mouse, Qdropping)) + if (gui_mouse_grabbed (dpyinfo) && !EQ (track_mouse, Qdropping) + && !EQ (track_mouse, Qdrag_source)) { /* If mouse was grabbed on a frame, give coords for that frame even if the mouse is now outside it. */ @@ -9900,7 +9901,8 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, } if ((!f1 || FRAME_TOOLTIP_P (f1)) - && EQ (track_mouse, Qdropping) + && (EQ (track_mouse, Qdropping) + || EQ (track_mouse, Qdrag_source)) && gui_mouse_grabbed (dpyinfo)) { /* When dropping then if we didn't get a frame or only a @@ -9916,12 +9918,26 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, root_x, root_y, &win_x, &win_y, /* Child of win. */ &child); - f1 = dpyinfo->last_mouse_frame; + + if (!EQ (track_mouse, Qdrag_source)) + f1 = dpyinfo->last_mouse_frame; + else + { + /* Don't set FP but do set WIN_X and WIN_Y in this + case, so make_lispy_movement knows which + coordinates to report. */ + *bar_window = Qnil; + *part = 0; + *fp = NULL; + XSETINT (*x, win_x); + XSETINT (*y, win_y); + *timestamp = dpyinfo->last_mouse_movement_time; + } } else if (f1 && FRAME_TOOLTIP_P (f1)) f1 = NULL; - if (x_had_errors_p (FRAME_X_DISPLAY (*fp))) + if (x_had_errors_p (dpyinfo->display)) f1 = NULL; x_uncatch_errors_after_check (); @@ -9931,7 +9947,7 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, { struct scroll_bar *bar; - bar = x_window_to_scroll_bar (FRAME_X_DISPLAY (*fp), win, 2); + bar = x_window_to_scroll_bar (dpyinfo->display, win, 2); if (bar) { @@ -12735,7 +12751,8 @@ mouse_or_wdesc_frame (struct x_display_info *dpyinfo, int wdesc) ? dpyinfo->last_mouse_frame : NULL); - if (lm_f && !EQ (track_mouse, Qdropping)) + if (lm_f && !EQ (track_mouse, Qdropping) + && !EQ (track_mouse, Qdrag_source)) return lm_f; else { commit 441ce4672d4aab14d1bef078692fec7ad4ff0c0a Author: Po Lu Date: Sun Apr 3 15:23:01 2022 +0800 Don't touch WAYLAND_DISPLAY in browse-url * lisp/net/browse-url.el (browse-url): Don't touch WAYLAND_DISPLAY. (bug#53969) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 776f774172..4c348781a8 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -851,7 +851,11 @@ If ARGS are omitted, the default is to pass ((featurep 'pgtk) (setq classname (pgtk-backend-display-class)) (if (equal classname "GdkWaylandDisplay") - (setenv "WAYLAND_DISPLAY" dpy) + (progn + ;; The `display' frame parameter is probably wrong. + ;; See bug#53969 for some context. + ;; (setenv "WAYLAND_DISPLAY" dpy) + ) (setenv "DISPLAY" dpy))) (t (setenv "DISPLAY" dpy))))) commit 35928918d1406e61a982e7a036cc6c441484b4cc Author: Po Lu Date: Sun Apr 3 13:32:25 2022 +0800 Look for DND proxies on the root window as well * src/xterm.c (x_dnd_get_target_window): If nothing was found on the COW, look at the root window. diff --git a/src/xterm.c b/src/xterm.c index 8a7a49c883..e7c671de74 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -2653,8 +2653,23 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo, } #endif - /* No toplevel was found and the overlay window was not a proxy, - so return None. */ + /* Now look for an XdndProxy on the root window. */ + + proxy = x_dnd_get_window_proxy (dpyinfo, dpyinfo->root_window); + + if (proxy != None) + { + proto = x_dnd_get_window_proto (dpyinfo, dpyinfo->root_window); + + if (proto != -1) + { + *proto_out = proto; + return proxy; + } + } + + /* No toplevel was found and the overlay and root windows were + not proxies, so return None. */ *proto_out = -1; return None; } commit f229710d41e85752bc1a835bae56c055a62813d9 Author: Po Lu Date: Sun Apr 3 09:59:14 2022 +0800 Implement new DND features on GNUstep * lisp/term/ns-win.el (ns-drag-n-drop): Handle special `lambda' drag-n-drop events. * src/nsterm.m: ([EmacsView wantsPeriodicDraggingUpdates]): ([EmacsView draggingUpdated:]): New functions. diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el index da6c5adee2..065ca235b4 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -508,25 +508,28 @@ unless the current buffer is a scratch buffer." Switch to a buffer editing the last file dropped, or insert the string dropped into the current buffer." (interactive "e") - (let* ((window (posn-window (event-start event))) - (arg (car (cdr (cdr event)))) - (type (car arg)) - (operations (car (cdr arg))) - (objects (cdr (cdr arg))) - (string (mapconcat 'identity objects "\n"))) - (set-frame-selected-window nil window) - (raise-frame) - (setq window (selected-window)) - (cond ((or (memq 'ns-drag-operation-generic operations) - (memq 'ns-drag-operation-copy operations)) - ;; Perform the default/copy action. - (dolist (data objects) - (dnd-handle-one-url window 'private (if (eq type 'file) - (concat "file:" data) - data)))) - (t - ;; Insert the text as is. - (dnd-insert-text window 'private string))))) + (if (eq (car-safe (cdr-safe (cdr-safe event))) 'lambda) + (dnd-handle-movement (event-start event)) + (let* ((window (posn-window (event-start event))) + (arg (car (cdr (cdr event)))) + (type (car arg)) + (operations (car (cdr arg))) + (objects (cdr (cdr arg))) + (string (mapconcat 'identity objects "\n"))) + (set-frame-selected-window nil window) + (raise-frame) + (setq window (selected-window)) + (goto-char (posn-point (event-start event))) + (cond ((or (memq 'ns-drag-operation-generic operations) + (memq 'ns-drag-operation-copy operations)) + ;; Perform the default/copy action. + (dolist (data objects) + (dnd-handle-one-url window 'private (if (eq type 'file) + (concat "file:" data) + data)))) + (t + ;; Insert the text as is. + (dnd-insert-text window 'private string)))))) (global-set-key [drag-n-drop] 'ns-drag-n-drop) diff --git a/src/nsterm.m b/src/nsterm.m index fd56094c28..f4c1e08925 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -8056,6 +8056,37 @@ -(BOOL)prepareForDragOperation: (id ) sender return YES; } +- (BOOL) wantsPeriodicDraggingUpdates +{ + return YES; +} + +- (NSDragOperation) draggingUpdated: (id ) sender +{ + struct input_event ie; + NSPoint position; + int x, y; + + EVENT_INIT (ie); + ie.kind = DRAG_N_DROP_EVENT; + + /* Get rid of mouse face. */ + [self mouseExited: [[self window] currentEvent]]; + + position = [self convertPoint: [sender draggingLocation] + fromView: nil]; + x = lrint (position.x); + y = lrint (position.y); + + XSETINT (ie.x, x); + XSETINT (ie.y, y); + XSETFRAME (ie.frame_or_window, emacsframe); + ie.arg = Qlambda; + ie.modifiers = 0; + + kbd_buffer_store_event (&ie); + return NSDragOperationGeneric; +} -(BOOL)performDragOperation: (id ) sender { commit e9d4f119da48fe119d9d7a6d1b9a054c043bd517 Author: Po Lu Date: Sun Apr 3 01:26:32 2022 +0000 Implement new DND options on Haiku * lisp/term/haiku-win.el (haiku-drag-and-drop): Handle special drag and drop motion events. * src/haiku_support.cc (MouseMoved): Set `dnd_message' flag. * src/haiku_support.h (struct haiku_mouse_motion_event): New member `dnd_message'. * src/haikuterm.c (haiku_read_socket): Create special DND events when the mouse moves with a drop message. diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index 810feced21..5b4ef0aaef 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -245,23 +245,26 @@ VALUE will be encoded as UTF-8 and stored under the type (interactive "e") (let* ((string (caddr event)) (window (posn-window (event-start event)))) - (cond - ((assoc "refs" string) - (with-selected-window window - (raise-frame) - (dolist (filename (cddr (assoc "refs" string))) - (dnd-handle-one-url window 'private - (concat "file:" filename))))) - ((assoc "text/plain" string) - (with-selected-window window - (raise-frame) - (dolist (text (cddr (assoc "text/plain" string))) - (goto-char (posn-point (event-start event))) - (dnd-insert-text window 'private - (if (multibyte-string-p text) - text - (decode-coding-string text 'undecided)))))) - (t (message "Don't know how to drop any of: %s" (mapcar #'car string)))))) + (if (eq string 'lambda) ; This means the mouse moved. + (dnd-handle-movement (event-start event)) + (cond + ((assoc "refs" string) + (with-selected-window window + (raise-frame) + (dolist (filename (cddr (assoc "refs" string))) + (dnd-handle-one-url window 'private + (concat "file:" filename))))) + ((assoc "text/plain" string) + (with-selected-window window + (raise-frame) + (dolist (text (cddr (assoc "text/plain" string))) + (goto-char (posn-point (event-start event))) + (dnd-insert-text window 'private + (if (multibyte-string-p text) + text + (decode-coding-string text 'undecided)))))) + (t (message "Don't know how to drop any of: %s" + (mapcar #'car string))))))) (define-key special-event-map [drag-n-drop] 'haiku-drag-and-drop) diff --git a/src/haiku_support.cc b/src/haiku_support.cc index dd27d6317c..64556ba51b 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -1529,6 +1529,7 @@ class EmacsView : public BView rq.y = point.y; rq.window = this->Window (); rq.time = system_time (); + rq.dnd_message = drag_msg != NULL; if (ToolTip ()) ToolTip ()->SetMouseRelativeLocation (BPoint (-(point.x - tt_absl_pos.x), diff --git a/src/haiku_support.h b/src/haiku_support.h index ae3ad6a68a..ac3029fbf3 100644 --- a/src/haiku_support.h +++ b/src/haiku_support.h @@ -159,6 +159,7 @@ struct haiku_mouse_motion_event int x; int y; bigtime_t time; + bool dnd_message; }; struct haiku_menu_bar_left_event diff --git a/src/haikuterm.c b/src/haikuterm.c index 304b7a3425..cdddf50d19 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -2970,6 +2970,7 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) struct haiku_mouse_motion_event *b = buf; struct frame *f = haiku_mouse_or_wdesc_frame (b->window); Mouse_HLInfo *hlinfo = &x_display_list->mouse_highlight; + Lisp_Object frame; if (!f) continue; @@ -2986,7 +2987,6 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) break; } - Lisp_Object frame; XSETFRAME (frame, f); x_display_list->last_mouse_movement_time = b->time / 1000; @@ -3102,8 +3102,8 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) && (!NILP (focus_follows_mouse) || f == SELECTED_FRAME ())) { - inev.kind = SELECT_WINDOW_EVENT; - inev.frame_or_window = window; + inev2.kind = SELECT_WINDOW_EVENT; + inev2.frame_or_window = window; } last_mouse_window = window; @@ -3118,6 +3118,21 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (!NILP (help_echo_string) || !NILP (previous_help_echo_string)) do_help = 1; + + if (b->dnd_message) + { + /* It doesn't make sense to show tooltips when + another program is dragging stuff over us. */ + + do_help = -1; + inev.kind = DRAG_N_DROP_EVENT; + inev.arg = Qlambda; + + XSETINT (inev.x, b->x); + XSETINT (inev.y, b->y); + XSETFRAME (inev.frame_or_window, f); + break; + } } if (FRAME_DIRTY_P (f)) commit 1694f82e5f91f1ea96604c7c0aee4537fbada765 Author: Po Lu Date: Sun Apr 3 09:14:24 2022 +0800 Add user options to move point and scroll window during DND * doc/emacs/frames.texi (Drag and Drop): * etc/NEWS: Document new options 'dnd-scroll-margin' and 'dnd-indicate-insertion-point'. * lisp/dnd.el (dnd-protocol-alist): (dnd-open-remote-file-function): (dnd-open-file-other-window): Add right group to defcustoms. (dnd-scroll-margin, dnd-indicate-insertion-point): New user options. (dnd-handle-movement): New function. * lisp/x-dnd.el (x-dnd-handle-xdnd): (x-dnd-handle-motif): Call `dnd-handle-movement' when appropriate. diff --git a/doc/emacs/frames.texi b/doc/emacs/frames.texi index 7489344cda..560870a4ed 100644 --- a/doc/emacs/frames.texi +++ b/doc/emacs/frames.texi @@ -1196,6 +1196,18 @@ the variable @code{dnd-open-file-other-window}. The XDND and Motif drag and drop protocols, and the old KDE 1.x protocol, are currently supported. +@vindex dnd-indicate-insertion-point +@vindex dnd-scroll-margin + + It can be difficult to scroll a window or determine where dropped +text will be inserted while dragging text onto an Emacs window. +Setting the option @var{dnd-indicate-insertion-point} to a +non-@code{nil} value makes point move to the location any dropped text +will be inserted when the mouse moves in a window during drag, and +setting @code{dnd-scroll-margin} to an integer value causes a window +to be scrolled if the mouse moves within that many lines of the top +or bottom of the window during drag. + @vindex mouse-drag-and-drop-region Emacs can also optionally drag the region with the mouse into another portion of this or another buffer. To enable that, customize diff --git a/etc/NEWS b/etc/NEWS index 199f07a033..037a9724d8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -195,6 +195,11 @@ to another program. If non-nil, this option allows scrolling a window while dragging text around without a scroll wheel. ++++ +** New user options 'dnd-indicate-insertion-point' and 'dnd-scroll-margin'. +These options allow adjusting point and scrolling a window when +dragging items from another program. + +++ ** New function 'command-query'. This function makes its argument command prompt the user for diff --git a/lisp/dnd.el b/lisp/dnd.el index 97e81e9bf1..8b11973eb4 100644 --- a/lisp/dnd.el +++ b/lisp/dnd.el @@ -42,8 +42,7 @@ `((,(purecopy "^file:///") . dnd-open-local-file) ; XDND format. (,(purecopy "^file://") . dnd-open-file) ; URL with host (,(purecopy "^file:") . dnd-open-local-file) ; Old KDE, Motif, Sun - (,(purecopy "^\\(https?\\|ftp\\|file\\|nfs\\)://") . dnd-open-file) - ) + (,(purecopy "^\\(https?\\|ftp\\|file\\|nfs\\)://") . dnd-open-file)) "The functions to call for different protocols when a drop is made. This variable is used by `dnd-handle-one-url' and `dnd-handle-file-name'. @@ -57,7 +56,8 @@ If no match is found, the URL is inserted as text by calling `dnd-insert-text'. The function shall return the action done (move, copy, link or private) if some action was made, or nil if the URL is ignored." :version "22.1" - :type '(repeat (cons (regexp) (function)))) + :type '(repeat (cons (regexp) (function))) + :group 'dnd) (defcustom dnd-open-remote-file-function @@ -73,17 +73,66 @@ Predefined functions are `dnd-open-local-file' and `dnd-open-remote-url'. is the default on MS-Windows. `dnd-open-remote-url' uses `url-handler-mode' and is the default except for MS-Windows." :version "22.1" - :type 'function) + :type 'function + :group 'dnd) (defcustom dnd-open-file-other-window nil "If non-nil, always use `find-file-other-window' to open dropped files." :version "22.1" - :type 'boolean) - + :type 'boolean + :group 'dnd) + +(defcustom dnd-scroll-margin nil + "The scroll margin inside a window underneath the cursor during drag-and-drop. +If the mouse moves this many lines close to the top or bottom of +a window while dragging text, then that window will be scrolled +down and up respectively." + :type '(choice (const :tag "Don't scroll during mouse movement") + (integer :tag "This many lines from window top or bottom")) + :version "29.1" + :group 'dnd) + +(defcustom dnd-indicate-insertion-point nil + "Whether or not point should follow the position of the mouse. +If non-nil, the point of the window underneath the mouse will be +adjusted to reflect where any text will be inserted upon drop +when the mouse moves while receiving a drop from another +program." + :type 'boolean + :version "29.1" + :group 'dnd) ;; Functions +(defun dnd-handle-movement (posn) + "Handle mouse movement to POSN when receiving a drop from another program." + (when dnd-scroll-margin + (ignore-errors + (let* ((row (cdr (posn-col-row posn))) + (window (when (windowp (posn-window posn)) + (posn-window posn))) + (text-height (window-text-height window)) + ;; Make sure it's possible to scroll both up + ;; and down if the margin is too large for the + ;; window. + (margin (min (/ text-height 3) dnd-scroll-margin))) + ;; At 2 lines, the window becomes too small for any + ;; meaningful scrolling. + (unless (<= text-height 2) + (cond + ;; Inside the bottom scroll margin, scroll up. + ((> row (- text-height margin)) + (with-selected-window window + (scroll-up 1))) + ;; Inside the top scroll margin, scroll down. + ((< row margin) + (with-selected-window window + (scroll-down 1)))))))) + (when dnd-indicate-insertion-point + (ignore-errors + (goto-char (posn-point posn))))) + (defun dnd-handle-one-url (window action url) "Handle one dropped url by calling the appropriate handler. The handler is first located by looking at `dnd-protocol-alist'. diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index e26703ad84..af9c7b83d9 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -499,7 +499,7 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." ))) (x-send-client-message frame dnd-source frame "XdndStatus" 32 list-to-send) - )) + (dnd-handle-movement (event-start event)))) ((equal "XdndLeave" message) (x-dnd-forget-drop window)) @@ -676,7 +676,8 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." frame "_MOTIF_DRAG_AND_DROP_MESSAGE" 8 - reply))) + reply) + (dnd-handle-movement (event-start event)))) ((eq message-type 'XmOPERATION_CHANGED) (let* ((state (x-dnd-get-state-for-frame frame)) commit 4afd34edd34ef734eda36efda08add5566a72fd9 Author: Po Lu Date: Sun Apr 3 08:52:26 2022 +0800 Fix Motif drag-and-drop on servers without XI2 * src/xterm.c (handle_one_xevent): Pass right flags to the receiver when handling drops for core button events. diff --git a/src/xterm.c b/src/xterm.c index 68b96c13d8..8a7a49c883 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -14977,7 +14977,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, dmsg.side_effects = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, x_dnd_wanted_action), - XM_DROP_SITE_VALID, XM_DRAG_NOOP, + XM_DROP_SITE_VALID, + xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), (!x_dnd_xm_use_help ? XM_DROP_ACTION_DROP : XM_DROP_ACTION_DROP_HELP)); commit 6904fcb11d76c2ccd8663a81a07bce212e042e95 Author: Po Lu Date: Sun Apr 3 08:42:52 2022 +0800 Fix incorrect usage of XM_DRAG_SIDE_EFFECT * src/xterm.c (xm_send_top_level_leave_message) (handle_one_xevent): Pass corret alt side effects and flags to XM_DRAG_SIDE_EFFECT. diff --git a/src/xterm.c b/src/xterm.c index 08e3a95633..68b96c13d8 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1610,7 +1610,8 @@ xm_send_top_level_leave_message (struct x_display_info *dpyinfo, Window source, mmsg.byteorder = XM_TARGETS_TABLE_CUR; mmsg.side_effects = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, x_dnd_wanted_action), - XM_DROP_SITE_NONE, 0, 0); + XM_DROP_SITE_NONE, XM_DRAG_NOOP, + XM_DROP_ACTION_DROP_CANCEL); mmsg.timestamp = dmsg->timestamp; mmsg.x = 65535; mmsg.y = 65535; @@ -14414,7 +14415,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, dmsg.byteorder = XM_TARGETS_TABLE_CUR; dmsg.side_effects = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, x_dnd_wanted_action), - XM_DROP_SITE_NONE, 0, 0); + XM_DROP_SITE_NONE, XM_DRAG_NOOP, + XM_DROP_ACTION_DROP_CANCEL); dmsg.timestamp = event->xmotion.time; dmsg.x = event->xmotion.x_root; dmsg.y = event->xmotion.y_root; @@ -15865,7 +15867,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, dmsg.side_effects = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, x_dnd_wanted_action), - XM_DROP_SITE_NONE, 0, 0); + XM_DROP_SITE_NONE, XM_DRAG_NOOP, + XM_DROP_ACTION_DROP_CANCEL); dmsg.timestamp = xev->time; dmsg.x = lrint (xev->root_x); dmsg.y = lrint (xev->root_y); commit 98775e6cf6ca600c6c8e2ef1fdd1d1bc65c65098 Author: Basil L. Contovounesios Date: Sat Apr 2 19:40:05 2022 +0300 ; Pacify obsoletion warnings in image-tests.el. diff --git a/test/lisp/image-tests.el b/test/lisp/image-tests.el index 6abfcfedcf..2b3e818d72 100644 --- a/test/lisp/image-tests.el +++ b/test/lisp/image-tests.el @@ -75,9 +75,10 @@ (should-not (find-image '((:type png :file "does-not-exist-foo-bar.png"))))) (ert-deftest image-type-from-file-name () - (should (eq (image-type-from-file-name "foo.jpg") 'jpeg)) - (should (eq (image-type-from-file-name "foo.png") 'png)) - (should (eq (image-type-from-file-name "foo.webp") 'webp))) + (with-suppressed-warnings ((obsolete image-type-from-file-name)) + (should (eq (image-type-from-file-name "foo.jpg") 'jpeg)) + (should (eq (image-type-from-file-name "foo.png") 'png)) + (should (eq (image-type-from-file-name "foo.webp") 'webp)))) (ert-deftest image-type/from-filename () ;; On emba, `image-types' and `image-load-path' do not exist. commit 781c43de3d017323b945088cdb39031d51a5e6ef Author: Lars Ingebrigtsen Date: Sat Apr 2 16:53:24 2022 +0200 Fix bootstrap errors after previous easy-mmode change * lisp/subr.el (ensure-empty-lines, string-lines): Moved from subr-x so that they can be used in early bootstrap files. * lisp/emacs-lisp/easy-mmode.el (easy-mmode--mode-docstring): Don't use string-empty-p because of bootstrap issues. diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 6827faab20..21a29a722c 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -114,7 +114,7 @@ it is disabled.") ;; line. (ensure-empty-lines) (while (and lines - (string-empty-p (car lines))) + (equal (car lines) "")) (pop lines)) ;; Insert the doc string. (dolist (line lines) diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 7ad4e9ba2a..abf85ab6c6 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -320,12 +320,6 @@ than this function." (end (substring string (- (length string) length))) (t (substring string 0 length))))) -;;;###autoload -(defun string-lines (string &optional omit-nulls) - "Split STRING into a list of lines. -If OMIT-NULLS, empty lines will be removed from the results." - (split-string string "\n" omit-nulls)) - (defun string-pad (string length &optional padding start) "Pad STRING to LENGTH using PADDING. If PADDING is nil, the space character is used. If not nil, it @@ -414,32 +408,6 @@ and return the value found in PLACE instead." ,(funcall setter val) ,val))))) -;;;###autoload -(defun ensure-empty-lines (&optional lines) - "Ensure that there are LINES number of empty lines before point. -If LINES is nil or omitted, ensure that there is a single empty -line before point. - -If called interactively, LINES is given by the prefix argument. - -If there are more than LINES empty lines before point, the number -of empty lines is reduced to LINES. - -If point is not at the beginning of a line, a newline character -is inserted before adjusting the number of empty lines." - (interactive "p") - (unless (bolp) - (insert "\n")) - (let ((lines (or lines 1)) - (start (save-excursion - (if (re-search-backward "[^\n]" nil t) - (+ (point) 2) - (point-min))))) - (cond - ((> (- (point) start) lines) - (delete-region (point) (- (point) (- (point) start lines)))) - ((< (- (point) start) lines) - (insert (make-string (- lines (- (point) start)) ?\n)))))) ;;;###autoload (defun string-pixel-width (string) diff --git a/lisp/subr.el b/lisp/subr.el index 603acffea7..34f7bb6888 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -6619,4 +6619,35 @@ OBJECT if it is readable." (forward-line 1) (point)))) +(defun ensure-empty-lines (&optional lines) + "Ensure that there are LINES number of empty lines before point. +If LINES is nil or omitted, ensure that there is a single empty +line before point. + +If called interactively, LINES is given by the prefix argument. + +If there are more than LINES empty lines before point, the number +of empty lines is reduced to LINES. + +If point is not at the beginning of a line, a newline character +is inserted before adjusting the number of empty lines." + (interactive "p") + (unless (bolp) + (insert "\n")) + (let ((lines (or lines 1)) + (start (save-excursion + (if (re-search-backward "[^\n]" nil t) + (+ (point) 2) + (point-min))))) + (cond + ((> (- (point) start) lines) + (delete-region (point) (- (point) (- (point) start lines)))) + ((< (- (point) start) lines) + (insert (make-string (- lines (- (point) start)) ?\n)))))) + +(defun string-lines (string &optional omit-nulls) + "Split STRING into a list of lines. +If OMIT-NULLS, empty lines will be removed from the results." + (split-string string "\n" omit-nulls)) + ;;; subr.el ends here commit 56fb536e78f3e3019b85995ba1d788065c3ac415 Author: Lars Ingebrigtsen Date: Sat Apr 2 16:36:39 2022 +0200 Fix regression in tex alignment * lisp/align.el (align-rules-list): Make alignment in tex mode work better again (bug#54663). diff --git a/lisp/align.el b/lisp/align.el index b054b1bac4..9364d54665 100644 --- a/lisp/align.el +++ b/lisp/align.el @@ -546,15 +546,16 @@ The possible settings for `align-region-separate' are: (regexp . "\\(\\s-*\\)\\\\\\\\") (modes . align-tex-modes)) - ;; With a numeric prefix argument, or C-u, space delimited text - ;; tables will be aligned. + ;; Align space delimited text as columns. (text-column (regexp . "\\(^\\|\\S-\\)\\([ \t]+\\)\\(\\S-\\|$\\)") (group . 2) (modes . align-text-modes) (repeat . t) (run-if . ,(lambda () - (not (eq '- current-prefix-arg))))) + (and (not (eq '- current-prefix-arg)) + (not (apply #'provided-mode-derived-p + major-mode align-tex-modes)))))) ;; With a negative prefix argument, lists of dollar figures will ;; be aligned. commit 02ef00d89c64d713f29f4ed12dbcae9f8d31bb9a Author: Sean Whitton Date: Sat Apr 2 16:08:41 2022 +0200 em-extpipe: Catch eshell-incomplete thrown while parsing * lisp/eshell/em-extpipe.el (em-extpipe--or-with-catch): New macro. (eshell-parse-external-pipeline): Use new macro to treat `eshell-incomplete' as a failure of the parse function to move us forward (Bug#54603). Thanks to Jim Porter for the report and for help isolating the problem. * test/lisp/eshell/eshell-tests.el (eshell-test/lisp-command-with-quote): New test for Bug#54603, thanks to Jim Porter (bug#54603). diff --git a/lisp/eshell/em-extpipe.el b/lisp/eshell/em-extpipe.el index eb5b3bfe1d..3db1dea595 100644 --- a/lisp/eshell/em-extpipe.el +++ b/lisp/eshell/em-extpipe.el @@ -49,6 +49,19 @@ (add-hook 'eshell-pre-rewrite-command-hook #'eshell-rewrite-external-pipeline -20 t)) +(defmacro em-extpipe--or-with-catch (&rest disjuncts) + "Evaluate DISJUNCTS like `or' but catch `eshell-incomplete'. + +If `eshell-incomplete' is thrown during the evaluation of a +disjunct, that disjunct yields nil." + (let ((result (gensym))) + `(let (,result) + (or ,@(cl-loop for disjunct in disjuncts collect + `(if (catch 'eshell-incomplete + (ignore (setq ,result ,disjunct))) + nil + ,result)))))) + (defun eshell-parse-external-pipeline () "Parse a pipeline intended for execution by the external shell. @@ -105,10 +118,11 @@ as though it were Eshell syntax." (if (re-search-forward pat next t) (throw 'found (match-beginning 1)) (goto-char next) - (while (or (eshell-parse-lisp-argument) - (eshell-parse-backslash) - (eshell-parse-double-quote) - (eshell-parse-literal-quote))) + (while (em-extpipe--or-with-catch + (eshell-parse-lisp-argument) + (eshell-parse-backslash) + (eshell-parse-double-quote) + (eshell-parse-literal-quote))) ;; Guard against an infinite loop if none of ;; the parsers moved us forward. (unless (or (> (point) next) (eobp)) diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el index e31db07c61..1e303f70e5 100644 --- a/test/lisp/eshell/eshell-tests.el +++ b/test/lisp/eshell/eshell-tests.el @@ -44,6 +44,10 @@ "Test `eshell-command-result' with an elisp command." (should (equal (eshell-test-command-result "(+ 1 2)") 3))) +(ert-deftest eshell-test/lisp-command-with-quote () + "Test `eshell-command-result' with an elisp command containing a quote." + (should (equal (eshell-test-command-result "(eq 'foo nil)") nil))) + (ert-deftest eshell-test/for-loop () "Test `eshell-command-result' with a for loop.." (let ((process-environment (cons "foo" process-environment))) commit 6dc4e3b95ca9589f24530979cdc83ea346d1ca45 Author: August Feng Date: Sat Apr 2 16:01:43 2022 +0200 Add S-SPC key sequence to bookmark-bmenu-mode-map * lisp/bookmark.el (bookmark-bmenu-mode-map): Add an S-SPC binding for symmetry (bug#54672). Copyright-paperwork-exempt: yes diff --git a/lisp/bookmark.el b/lisp/bookmark.el index e3baa7607d..31876c83a2 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -1732,6 +1732,7 @@ unique numeric suffixes \"<2>\", \"<3>\", etc." "x" #'bookmark-bmenu-execute-deletions "d" #'bookmark-bmenu-delete "D" #'bookmark-bmenu-delete-all + "S-SPC" #'previous-line "SPC" #'next-line "DEL" #'bookmark-bmenu-backup-unmark "u" #'bookmark-bmenu-unmark commit ec464789dfc5179c72e6929ea99a72f508c562b6 Author: Lars Ingebrigtsen Date: Sat Apr 2 15:55:29 2022 +0200 Put the define-minor-mode boilerplate at the end of the doc strings * lisp/emacs-lisp/easy-mmode.el (easy-mmode--mode-docstring): Put the boilerplate at the end of the doc string. diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 688c76e0c5..6827faab20 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -82,9 +82,7 @@ replacing its case-insensitive matches with the literal string in LIGHTER." (replace-regexp-in-string (regexp-quote lighter) lighter name t t)))) (defconst easy-mmode--arg-docstring - " - -This is a minor mode. If called interactively, toggle the `%s' + "This is a minor mode. If called interactively, toggle the `%s' mode. If the prefix argument is positive, enable the mode, and if it is zero or negative, disable the mode. @@ -100,27 +98,47 @@ it is disabled.") (defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym getter) - (let ((doc (or doc (format "Toggle %s on or off. - -\\{%s}" mode-pretty-name keymap-sym)))) - (if (string-match-p "\\bARG\\b" doc) - doc - (let* ((fill-prefix nil) - (docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column)) - (fill-column (if (integerp docs-fc) docs-fc 65)) - (argdoc (format easy-mmode--arg-docstring mode-pretty-name - ;; Avoid having quotes turn into pretty quotes. - (string-replace "'" "\\\\='" - (format "%S" getter)))) - (filled (if (fboundp 'fill-region) - (with-temp-buffer - (insert argdoc) - (fill-region (point-min) (point-max) 'left t) - (buffer-string)) - argdoc))) - (replace-regexp-in-string "\\(\n\n\\|\\'\\)\\(.\\|\n\\)*\\'" - (concat filled "\\1") - doc nil nil 1))))) + ;; If we have a doc string, and it's already complete (which we + ;; guess at with the simple heuristic below), then just return that + ;; as is. + (if (and doc (string-match-p "\\bARG\\b" doc)) + doc + ;; Compose a new doc string. + (with-temp-buffer + (let ((lines (if doc + (string-lines doc) + (list (format "Toggle %s on or off." mode-pretty-name))))) + ;; Insert the first line from the doc string. + (insert (pop lines)) + ;; Ensure that we have (only) one blank line after the first + ;; line. + (ensure-empty-lines) + (while (and lines + (string-empty-p (car lines))) + (pop lines)) + ;; Insert the doc string. + (dolist (line lines) + (insert line "\n")) + (ensure-empty-lines) + ;; Insert the boilerplate. + (let* ((fill-prefix nil) + (docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column)) + (fill-column (if (integerp docs-fc) docs-fc 65)) + (argdoc (format easy-mmode--arg-docstring mode-pretty-name + ;; Avoid having quotes turn into pretty quotes. + (string-replace "'" "\\\\='" + (format "%S" getter))))) + (let ((start (point))) + (insert argdoc) + (when (fboundp 'fill-region) + (fill-region start (point) 'left t)))) + ;; Finally, insert the keymap. + (when (and (boundp keymap-sym) + (or (not doc) + (not (string-search "\\{" doc)))) + (ensure-empty-lines) + (insert (format "\\{%s}" keymap-sym))) + (buffer-string))))) ;;;###autoload (defalias 'easy-mmode-define-minor-mode #'define-minor-mode) commit 9c30276c426e0b67d288b479a9570428673de331 Author: Eli Zaretskii Date: Sat Apr 2 16:45:26 2022 +0300 ; Improve documentation of 'font-lock-ignore' * etc/NEWS: * lisp/font-lock.el (font-lock-ignore): * doc/lispref/modes.texi (Customizing Keywords): Clarify the documentation of 'font-lock-ignore'. * doc/emacs/display.texi (Font Lock): Mention 'font-lock-ignore'. diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi index 4fcd2a3f7d..534bf5881e 100644 --- a/doc/emacs/display.texi +++ b/doc/emacs/display.texi @@ -1011,10 +1011,15 @@ in C comments, use this: @end example @findex font-lock-remove-keywords +@vindex font-lock-ignore @noindent To remove keywords from the font-lock highlighting patterns, use the function @code{font-lock-remove-keywords}. @xref{Search-based Fontification,,, elisp, The Emacs Lisp Reference Manual}. +Alternatively, you can selectively disable highlighting due to some +keywords by customizing the @code{font-lock-ignore} option, +@pxref{Customizing Keywords,,, elisp, The Emacs Lisp Reference +Manual}. @cindex just-in-time (JIT) font-lock @cindex background syntax highlighting diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index b61ba56e18..ff09a78749 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -3204,9 +3204,9 @@ Non-@code{nil} means that regular expression matching for the sake of You can use @code{font-lock-add-keywords} to add additional search-based fontification rules to a major mode, and -@code{font-lock-remove-keywords} to remove rules. You can also set -the @code{font-lock-ignore} variable to disable keywords that match -certain criteria. +@code{font-lock-remove-keywords} to remove rules. You can also +customize the @code{font-lock-ignore} option to selectively disable +fontification rules for keywords that match certain criteria. @defun font-lock-add-keywords mode keywords &optional how This function adds highlighting @var{keywords}, for the current buffer @@ -3276,51 +3276,64 @@ mode @emph{and} all modes derived from it, do this instead: font-lock-keyword-face))))) @end smallexample -@defvar font-lock-ignore -This variable contains rules to selectively disable Font Lock -keywords. It is a list with elements of the following form: +@defopt font-lock-ignore +@cindex selectively disabling font-lock fontifications +This option defines conditions for selectively disabling +fontifications due to certain Font Lock keywords. If non-@code{nil}, +its value is a list of elements of the following form: @example -(@var{mode} @var{rule} @dots{}) +(@var{symbol} @var{condition} @dots{}) @end example -Here, @var{mode} is a symbol, say a major or minor mode. The -subsequent rules apply if the current major mode is derived from -@var{mode} or @var{mode} is bound and true as a variable. Each -@var{rule} can be one of the following: - -@table @code -@cindex @var{font-lock-ignore} rules -@item @var{symbol} -A symbol, say a face name, matches any Font Lock keyword containing -the symbol in its definition. The symbol is interpreted as a glob -pattern; in particular, @code{*} matches everything. - -@item @var{string} -A string matches any font-lock keyword defined by a regexp that -matches the string. - -@item (pred @var{function}) -A rule of this form matches if @var{function}, called with the -Font Lock keyword as argument, returns non-@code{nil}. - -@item (not @var{rule}) -A rule of this form matches if @var{rule} doesn’t. - -@item (and @var{rule} @dots{}) -A rule of this form matches if each @var{rule} matches. - -@item (or @var{rule} @dots{}) -A rule of this form matches if some @var{rule} matches. - -@item (except @var{rule}) -A rule of this form can only be used at top level or inside an -@code{or} clause. It undoes the effect of a previously matching rule. +Here, @var{symbol} is a symbol, usually a major or minor mode. The +subsequent @var{condition}s of a @var{symbol}'s list element will be in +effect if @var{symbol} is bound and its value is non-@code{nil}. For +a mode's symbol, it means that the current major mode is derived from +that mode, or that minor mode is enabled in the buffer. When a +@var{condition} is in effect, any fontifications caused by +@code{font-lock-keywords} elements that match the @var{condition} will +be disabled. + +Each @var{condition} can be one of the following: + +@table @asis +@item a symbol +This condition matches any element of Font Lock keywords that +references the symbol. This is usually a face, but can be any symbol +referenced by an element of the @code{font-lock-keywords} list. The +symbol can contain wildcards: @code{*} matches any string in the +symbol'ss name, @code{?} matches a single character, and +@code{[@var{char-set}]}, where @var{char-set} is a string of one or +more characters, matches a single character from the set. + +@item a string +This condition matches any element of Font Lock keywords whose +@var{matcher} is a regexp which matches the string. In other words, +this condition matches a Font Lock rule which highlights the string. +Thus, the string could be a specific program keyword whose +highlighting you want to disable. + +@item @code{(pred @var{function})} +This condition matches any element of Font Lock keywords for which +@var{function}, when called with the element as the argument, returns +non-@code{nil}. + +@item @code{(not @var{condition})} +This matches if @var{condition} doesn’t. + +@item @code{(and @var{condition} @dots{})} +This matches if each of the @var{condition}s matches. + +@item @code{(or @var{condition} @dots{})} +This matches if at least one of the @var{condition}s matches. + +@item @code{(except @var{condition})} +This condition can only be used at top level or inside an +@code{or} clause. It undoes the effect of a previously matching +condition on the same level. @end table - -In each buffer, Font Lock keywords that match at least one applicable -rule are disabled. -@end defvar +@end defopt As an example, consider the following setting: @@ -3337,23 +3350,23 @@ Line by line, this does the following: @enumerate @item -In all programming modes, disable all font-lock keywords that apply -one of the standard font-lock faces (excluding strings and comments, -which are covered by syntactic Font Lock). +In all programming modes, disable fontifications due to all font-lock +keywords that apply one of the standard font-lock faces (excluding +strings and comments, which are covered by syntactic Font Lock). @item However, keep any keywords that add a @code{help-echo} text property. @item In Emacs Lisp mode, also keep the highlighting of autoload cookies, -which would have been excluded by rule 1. +which would have been excluded by the first condition. @item -In @code{whitespace-mode} (a minor mode), don't highlight an empty -line at beginning of buffer. +When @code{whitespace-mode} (a minor mode) is enabled, also don't +highlight an empty line at beginning of buffer. @item -Finally, in Makefile mode, don't apply any ignore rules. +Finally, in Makefile mode, don't apply any conditions. @end enumerate @node Other Font Lock Variables diff --git a/etc/NEWS b/etc/NEWS index 9196e9fb90..199f07a033 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1142,8 +1142,8 @@ support for pipelines which will move a lot of data. See section +++ *** New user option 'font-lock-ignore'. -This variable provides a mechanism to selectively disable font-lock -keywords. +This option provides a mechanism to selectively disable font-lock +keyword-driven fontifications. +++ *** New package vtable.el for formatting tabular data. diff --git a/lisp/font-lock.el b/lisp/font-lock.el index 8af3c30c9a..5034c98d26 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -281,37 +281,42 @@ decoration for buffers in C++ mode, and level 1 decoration otherwise." :group 'font-lock) (defcustom font-lock-ignore nil - "Rules to selectively disable font-lock keywords. -This is a list of rule sets of the form + "Rules to selectively disable fontifications due to `font-lock-keywords'. +If non-nil, the value should be a list of condition sets of the form - (MODE RULE ...) + (SYMBOL CONDITION ...) where: - - MODE is a symbol, say a major or minor mode. The subsequent - rules apply if the current major mode is derived from MODE or - MODE is bound and true as a variable. + - SYMBOL is a symbol, usually a major or minor mode. The subsequent + CONDITIONs apply if SYMBOL is bound as variable and its value is non-nil. + If SYMBOL is a symbol of a mode, that means the buffer has that mode + enabled (for major modes, it means the buffer's major mode is derived + from SYMBOL's mode). - - Each RULE can be one of the following: - - A symbol, say a face name. It matches any font-lock keyword - containing the symbol in its definition. The symbol is + - Each CONDITION can be one of the following: + - A symbol, typically a face. It matches any element of + `font-lock-keywords' that references the symbol. The symbol is interpreted as a glob pattern; in particular, `*' matches - everything. - - A string. It matches any font-lock keyword defined by a regexp - that matches the string. - - A form (pred FUNCTION). It matches if FUNCTION, which is called - with the font-lock keyword as argument, returns non-nil. - - A form (not RULE). It matches if RULE doesn't. - - A form (and RULE ...). It matches if all the provided rules - match. - - A form (or RULE ...). It matches if any of the provided rules - match. - - A form (except RULE ...). This can be used only at top level or - inside an `or' clause. It undoes the effect of a previous - matching rule. - -In each buffer, font lock keywords that match at least one -applicable rule are disabled." + everything, `?' matches any single character, and `[abcd]' + matches one character from the set. + - A string. It matches any element of `font-lock-keywords' whose + MATCHER is a regexp that matches the string. This can be used to + disable fontification of a particular programming keyword. + - A form (pred FUNCTION). It matches an element of `font-lock-keywords' + if FUNCTION, when called with the element as the argument, returns + non-nil. + - A form (not CONDITION). It matches if CONDITION doesn't. + - A form (and CONDITION ...). It matches if all the provided + CONDITIONs match. + - A form (or CONDITION ...). It matches if at least one of the + provided CONDITIONs matches. + - A form (except CONDITIONs ...). This can be used only at top level + or inside an `or' clause. It undoes the effect of previous + matching CONDITIONs on the same level. + +In each buffer, fontifications due to the elements of `font-lock-keywords' +that match at least one applicable CONDITION are disabled." :type '(alist :key-type symbol :value-type sexp) :group 'font-lock :version "29.1") commit 338f5667f46282f9b40c25bbf9704566069ec950 Author: Lars Ingebrigtsen Date: Sat Apr 2 15:19:05 2022 +0200 Further tweaks to cl--generic-describe * lisp/emacs-lisp/cl-generic.el (cl--generic-describe): Further tweak the look of the implementation output. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 1e820adaff..2ca84b019f 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1096,7 +1096,13 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (dolist (method (cl--generic-method-table generic)) (let* ((info (cl--generic-method-info method))) ;; FIXME: Add hyperlinks for the types as well. - (insert (format "%s%S" (nth 0 info) (cons function (nth 1 info)))) + (if (length> (nth 0 info) 0) + (insert (format "%s%S" (nth 0 info) + (let ((print-quoted nil)) + (nth 1 info)))) + ;; Make the non-":extra" bits look more like `C-h f' + ;; output. + (insert (format "%S" (cons function (nth 1 info))))) (let* ((met-name (cl--generic-load-hist-format function (cl--generic-method-qualifiers method) commit d86e47c86056e7bb80a75d9620428895b309f723 Author: Po Lu Date: Sat Apr 2 20:48:09 2022 +0800 * lisp/dired.el (dired-mouse-drag): Offer HOST_NAME as well. diff --git a/lisp/dired.el b/lisp/dired.el index 0524ac16c2..d6e189cba3 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1750,7 +1750,7 @@ when Emacs exits or the user drags another file.") #'dired-remove-last-dragged-local-file)) (gui-backend-set-selection 'XdndSelection filename) (x-begin-drag '("text/uri-list" "text/x-dnd-username" - "FILE_NAME" "FILE") + "FILE_NAME" "FILE" "HOST_NAME") (if (eq 'dired-mouse-drag-files 'link) 'XdndActionLink 'XdndActionCopy) commit ca5f259cff93ad7fc4d5e70319412420affb6d17 Author: Po Lu Date: Sat Apr 2 20:12:12 2022 +0800 Fix crash when retrieving window property with invalid atom data This happens when dropping files from dtfile, which somehow puts non-atom stuff in window properties of type ATOM_PAIR. * src/xselect.c (x_atom_to_symbol): Catch errors around XGetAtomName. diff --git a/src/xselect.c b/src/xselect.c index 76a2f9f507..7719876884 100644 --- a/src/xselect.c +++ b/src/xselect.c @@ -285,7 +285,9 @@ x_atom_to_symbol (struct x_display_info *dpyinfo, Atom atom) return QNULL; block_input (); + x_catch_errors (dpyinfo->display); str = XGetAtomName (dpyinfo->display, atom); + x_uncatch_errors (); unblock_input (); TRACE1 ("XGetAtomName --> %s", str); if (! str) return Qnil; commit f66a47b5bca7a9c603040b7c62a2562a925c94d3 Author: Po Lu Date: Sat Apr 2 16:38:19 2022 +0800 Compute size of structs with flexible arrays correctly in Motif DND code * src/xterm.c (xm_read_targets_table_rec, xm_setup_dnd_targets): Use FLEXSIZEOF instead of sizeof on struct xm_targets_table_rec. diff --git a/src/xterm.c b/src/xterm.c index 48c054c478..08e3a95633 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -604,6 +604,7 @@ along with GNU Emacs. If not, see . */ #include #include #include +#include #include "character.h" #include "coding.h" #include "composite.h" @@ -1135,7 +1136,8 @@ xm_read_targets_table_rec (uint8_t *bytes, ptrdiff_t length, if (byteorder != XM_TARGETS_TABLE_CUR) SWAPCARD16 (nitems); - rec = xmalloc (sizeof *rec + nitems * 4); + rec = xmalloc (FLEXSIZEOF (struct xm_targets_table_rec, + targets, nitems * 4)); rec->n_targets = nitems; for (i = 0; i < nitems; ++i) @@ -1428,7 +1430,8 @@ xm_setup_dnd_targets (struct x_display_info *dpyinfo, header.total_data_size = 8 + 2 + ntargets * 4; recs = xmalloc (sizeof *recs); - recs[0] = xmalloc (sizeof **recs + ntargets * 4); + recs[0] = xmalloc (FLEXSIZEOF (struct xm_targets_table_rec, + targets, ntargets * 4)); recs[0]->n_targets = ntargets; @@ -1448,7 +1451,9 @@ xm_setup_dnd_targets (struct x_display_info *dpyinfo, header.target_list_count++; header.total_data_size += 2 + ntargets * 4; - recs[header.target_list_count - 1] = xmalloc (sizeof **recs + ntargets * 4); + recs[header.target_list_count - 1] + = xmalloc (FLEXSIZEOF (struct xm_targets_table_rec, + targets, ntargets * 4)); recs[header.target_list_count - 1]->n_targets = ntargets; for (i = 0; i < ntargets; ++i) commit b312959ebd528b01e95fe5eca71cc3890a97421d Author: Po Lu Date: Sat Apr 2 16:31:06 2022 +0800 ; * src/sqlite.c: Fix up header comment. diff --git a/src/sqlite.c b/src/sqlite.c index 649cb38294..1ca8669931 100644 --- a/src/sqlite.c +++ b/src/sqlite.c @@ -1,4 +1,5 @@ -/* +/* Support for accessing SQLite databases. + Copyright (C) 2021-2022 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -19,8 +20,7 @@ along with GNU Emacs. If not, see . This file is based on the emacs-sqlite3 package written by Syohei YOSHIDA , which can be found at: - https://github.com/syohex/emacs-sqlite3 -*/ + https://github.com/syohex/emacs-sqlite3 */ #include #include "lisp.h" commit 7899e8daff6730ae0b4521cbedf6141dd2f1531e Author: Po Lu Date: Sat Apr 2 15:59:15 2022 +0800 Fix error on mouse move over something not a window while dragging text * lisp/mouse.el (mouse-drag-and-drop-region): Handle non-window values of `posn-window' correctly. diff --git a/lisp/mouse.el b/lisp/mouse.el index 3f43b39079..92e289b4ce 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -3097,20 +3097,23 @@ is copied instead of being cut." ;; either up or down depending on which margin it is in. (when mouse-drag-and-drop-region-scroll-margin (let* ((row (cdr (posn-col-row (event-end event)))) - (window (posn-window (event-end event))) - (text-height (window-text-height window)) + (window (when (windowp (posn-window (event-end event))) + (posn-window (event-end event)))) + (text-height (when window + (window-text-height window))) ;; Make sure it's possible to scroll both up ;; and down if the margin is too large for the ;; window. - (margin (min (/ text-height 3) - mouse-drag-and-drop-region-scroll-margin))) - ;; At 2 lines, the window becomes too small for any - ;; meaningful scrolling. - (unless (<= text-height 2) - ;; We could end up at the beginning or end of the - ;; buffer. - (ignore-errors - (when (windowp window) + (margin (when text-height + (min (/ text-height 3) + mouse-drag-and-drop-region-scroll-margin)))) + (when (windowp window) + ;; At 2 lines, the window becomes too small for any + ;; meaningful scrolling. + (unless (<= text-height 2) + ;; We could end up at the beginning or end of the + ;; buffer. + (ignore-errors (cond ;; Inside the bottom scroll margin, scroll up. ((> row (- text-height margin)) commit c8a49b69abc0beb7eca4c4ccf18eefc52aaf7cee Author: Po Lu Date: Sat Apr 2 15:48:57 2022 +0800 ; * lisp/mouse.el (mouse-drag-and-drop-region-scroll-margin): Fix type. diff --git a/lisp/mouse.el b/lisp/mouse.el index 5e56a9e972..3f43b39079 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -102,7 +102,8 @@ point at the click position." If the mouse moves this many lines close to the top or bottom of a window while dragging text, then that window will be scrolled down and up respectively." - :type 'integer + :type '(choice (const :tag "Don't scroll during mouse movement") + (integer :tag "This many lines from window top or bottom")) :version "29.1") (defvar mouse--last-down nil) commit e351e9037cbb7c63d7a022256bb87baa9990570d Author: Po Lu Date: Sat Apr 2 15:45:00 2022 +0800 Add new option `mouse-drag-and-drop-region-scroll-margin' * etc/NEWS: Announce new user option. * lisp/mouse.el (mouse-drag-and-drop-region-scroll-margin): New user option. (mouse-drag-and-drop-region): Implement "scroll margin" like behavior during mouse movement. diff --git a/etc/NEWS b/etc/NEWS index 3df326aa5b..9196e9fb90 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -190,6 +190,11 @@ methods instead. If non-nil, this option allows dragging text in the region from Emacs to another program. +--- +** New user option 'mouse-drag-and-drop-region-scroll-margin'. +If non-nil, this option allows scrolling a window while dragging text +around without a scroll wheel. + +++ ** New function 'command-query'. This function makes its argument command prompt the user for diff --git a/lisp/mouse.el b/lisp/mouse.el index 4d6acf0d92..5e56a9e972 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -97,6 +97,14 @@ point at the click position." :type 'boolean :version "22.1") +(defcustom mouse-drag-and-drop-region-scroll-margin nil + "If non-nil, the scroll margin inside a window when dragging text. +If the mouse moves this many lines close to the top or bottom of +a window while dragging text, then that window will be scrolled +down and up respectively." + :type 'integer + :version "29.1") + (defvar mouse--last-down nil) (defun mouse--down-1-maybe-follows-link (&optional _prompt) @@ -3084,6 +3092,34 @@ is copied instead of being cut." ;; Handle `mouse-autoselect-window'. (memq (car event) '(select-window switch-frame)))) (catch 'drag-again + ;; If the mouse is in the drag scroll margin, scroll + ;; either up or down depending on which margin it is in. + (when mouse-drag-and-drop-region-scroll-margin + (let* ((row (cdr (posn-col-row (event-end event)))) + (window (posn-window (event-end event))) + (text-height (window-text-height window)) + ;; Make sure it's possible to scroll both up + ;; and down if the margin is too large for the + ;; window. + (margin (min (/ text-height 3) + mouse-drag-and-drop-region-scroll-margin))) + ;; At 2 lines, the window becomes too small for any + ;; meaningful scrolling. + (unless (<= text-height 2) + ;; We could end up at the beginning or end of the + ;; buffer. + (ignore-errors + (when (windowp window) + (cond + ;; Inside the bottom scroll margin, scroll up. + ((> row (- text-height margin)) + (with-selected-window window + (scroll-up 1))) + ;; Inside the top scroll margin, scroll down. + ((< row margin) + (with-selected-window window + (scroll-down 1))))))))) + ;; Obtain the dragged text in region. When the loop was ;; skipped, value-selection remains nil. (unless value-selection commit 0a32037c92be331d4f44401109e90ff826494b6d Author: Po Lu Date: Sat Apr 2 14:59:08 2022 +0800 Implement DELETE selection target for cross program drags * lisp/mouse.el (mouse-drag-and-drop-region): Make sure mark stays deactivated if a "cut" operation was performed. * lisp/select.el (xselect-convert-to-delete): Don't clear selection contents if it's the XdndSelection. diff --git a/lisp/mouse.el b/lisp/mouse.el index 381fc0c47e..4d6acf0d92 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -3037,6 +3037,10 @@ is copied instead of being cut." (cdr bounds))) (region-bounds))) (region-noncontiguous (region-noncontiguous-p)) + ;; Whether or not some text was ``cut'' from Emacs to another + ;; program and the cleaanup code should not try modifying the + ;; region. + drag-was-cross-program point-to-paste point-to-paste-read-only window-to-paste @@ -3131,12 +3135,20 @@ is copied instead of being cut." (when (framep drag-action-or-frame) (throw 'drag-again nil)) - (when (eq drag-action-or-frame 'XdndActionMove) - ;; Remove the dragged text from source buffer like - ;; operation `cut'. - (dolist (overlay mouse-drag-and-drop-overlays) - (delete-region (overlay-start overlay) - (overlay-end overlay)))) + (let ((min-char (point))) + (when (eq drag-action-or-frame 'XdndActionMove) + ;; Remove the dragged text from source buffer like + ;; operation `cut'. + (dolist (overlay mouse-drag-and-drop-overlays) + (when (< min-char (min (overlay-start overlay) + (overlay-end overlay))) + (setq min-char (min (overlay-start overlay) + (overlay-end overlay)))) + (delete-region (overlay-start overlay) + (overlay-end overlay))) + (goto-char min-char) + (setq deactivate-mark t) + (setq drag-was-cross-program t))) (when (eq drag-action-or-frame 'XdndActionCopy) ;; Set back the dragged text as region on source buffer @@ -3243,87 +3255,88 @@ is copied instead of being cut." ;; Do not modify any buffers when event is "click", ;; "drag but negligible", or "drag to read-only". - (let* ((mouse-drag-and-drop-region-cut-when-buffers-differ - (if no-modifier-on-drop - mouse-drag-and-drop-region-cut-when-buffers-differ - (not mouse-drag-and-drop-region-cut-when-buffers-differ))) - (wanna-paste-to-same-buffer (equal buffer-to-paste buffer)) - (wanna-cut-on-same-buffer (and wanna-paste-to-same-buffer - no-modifier-on-drop)) - (wanna-cut-on-other-buffer - (and (not wanna-paste-to-same-buffer) - mouse-drag-and-drop-region-cut-when-buffers-differ)) - (cannot-paste (or point-to-paste-read-only - (when (or wanna-cut-on-same-buffer - wanna-cut-on-other-buffer) - text-from-read-only)))) - - (cond - ;; Move point within region. - (clicked - (deactivate-mark) - (mouse-set-point event)) - ;; Undo operation. Set back the original text as region. - ((or (and drag-but-negligible - no-modifier-on-drop) - cannot-paste) - ;; Inform user either source or destination buffer cannot be modified. - (when (and (not drag-but-negligible) - cannot-paste) - (message "Buffer is read-only")) - - ;; Select source window back and restore region. - ;; (set-window-point window point) - (select-window window) - (goto-char point) - (setq deactivate-mark nil) - (activate-mark) - (when region-noncontiguous - (rectangle-mark-mode))) - ;; Modify buffers. - (t - ;; * DESTINATION BUFFER:: - ;; Insert the text to destination buffer under mouse. - (select-window window-to-paste) - (setq window-exempt window-to-paste) - (goto-char point-to-paste) - (push-mark) - (insert-for-yank value-selection) - - ;; On success, set the text as region on destination buffer. - (when (not (equal (mark) (point))) + (unless drag-was-cross-program + (let* ((mouse-drag-and-drop-region-cut-when-buffers-differ + (if no-modifier-on-drop + mouse-drag-and-drop-region-cut-when-buffers-differ + (not mouse-drag-and-drop-region-cut-when-buffers-differ))) + (wanna-paste-to-same-buffer (equal buffer-to-paste buffer)) + (wanna-cut-on-same-buffer (and wanna-paste-to-same-buffer + no-modifier-on-drop)) + (wanna-cut-on-other-buffer + (and (not wanna-paste-to-same-buffer) + mouse-drag-and-drop-region-cut-when-buffers-differ)) + (cannot-paste (or point-to-paste-read-only + (when (or wanna-cut-on-same-buffer + wanna-cut-on-other-buffer) + text-from-read-only)))) + + (cond + ;; Move point within region. + (clicked + (deactivate-mark) + (mouse-set-point event)) + ;; Undo operation. Set back the original text as region. + ((or (and drag-but-negligible + no-modifier-on-drop) + cannot-paste) + ;; Inform user either source or destination buffer cannot be modified. + (when (and (not drag-but-negligible) + cannot-paste) + (message "Buffer is read-only")) + + ;; Select source window back and restore region. + ;; (set-window-point window point) + (select-window window) + (goto-char point) (setq deactivate-mark nil) (activate-mark) (when region-noncontiguous (rectangle-mark-mode))) - - ;; * SOURCE BUFFER:: - ;; Set back the original text as region or delete the original - ;; text, on source buffer. - (if wanna-paste-to-same-buffer - ;; When source buffer and destination buffer are the same, - ;; remove the original text. - (when no-modifier-on-drop - (let (deactivate-mark) + ;; Modify buffers. + (t + ;; * DESTINATION BUFFER:: + ;; Insert the text to destination buffer under mouse. + (select-window window-to-paste) + (setq window-exempt window-to-paste) + (goto-char point-to-paste) + (push-mark) + (insert-for-yank value-selection) + + ;; On success, set the text as region on destination buffer. + (when (not (equal (mark) (point))) + (setq deactivate-mark nil) + (activate-mark) + (when region-noncontiguous + (rectangle-mark-mode))) + + ;; * SOURCE BUFFER:: + ;; Set back the original text as region or delete the original + ;; text, on source buffer. + (if wanna-paste-to-same-buffer + ;; When source buffer and destination buffer are the same, + ;; remove the original text. + (when no-modifier-on-drop + (let (deactivate-mark) + (dolist (overlay mouse-drag-and-drop-overlays) + (delete-region (overlay-start overlay) + (overlay-end overlay))))) + ;; When source buffer and destination buffer are different, + ;; keep (set back the original text as region) or remove the + ;; original text. + (select-window window) ; Select window with source buffer. + (goto-char point) ; Move point to the original text on source buffer. + + (if mouse-drag-and-drop-region-cut-when-buffers-differ + ;; Remove the dragged text from source buffer like + ;; operation `cut'. (dolist (overlay mouse-drag-and-drop-overlays) - (delete-region (overlay-start overlay) - (overlay-end overlay))))) - ;; When source buffer and destination buffer are different, - ;; keep (set back the original text as region) or remove the - ;; original text. - (select-window window) ; Select window with source buffer. - (goto-char point) ; Move point to the original text on source buffer. - - (if mouse-drag-and-drop-region-cut-when-buffers-differ - ;; Remove the dragged text from source buffer like - ;; operation `cut'. - (dolist (overlay mouse-drag-and-drop-overlays) (delete-region (overlay-start overlay) (overlay-end overlay))) - ;; Set back the dragged text as region on source buffer - ;; like operation `copy'. - (activate-mark)) - (select-window window-to-paste)))))) + ;; Set back the dragged text as region on source buffer + ;; like operation `copy'. + (activate-mark)) + (select-window window-to-paste))))))) ;; Clean up. (dolist (overlay mouse-drag-and-drop-overlays) diff --git a/lisp/select.el b/lisp/select.el index 0b51f01cc5..3646a28b9b 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -607,7 +607,9 @@ two markers or an overlay. Otherwise, it is nil." selection-converter-alist)))))) (defun xselect-convert-to-delete (selection _type _value) - (gui-backend-set-selection selection nil) + ;; This should be handled by the caller of `x-begin-drag'. + (unless (eq selection 'XdndSelection) + (gui-backend-set-selection selection nil)) ;; A return value of nil means that we do not know how to do this conversion, ;; and replies with an "error". A return value of NULL means that we have ;; done the conversion (and any side-effects) but have no value to return. commit 35ad6bc2acf1c5a76c9f46cd0c7b64e72a88e2ea Author: Po Lu Date: Sat Apr 2 11:44:15 2022 +0800 Work around dynamic drag bugs in modern Motif * src/xterm.c (xm_send_top_level_leave_message): Send a motion event with impossible coordinates by default. (handle_one_xevent): Slightly update drop motion message parameters. (syms_of_xterm): New variable `x-dnd-fix-motif-leave'. diff --git a/src/xterm.c b/src/xterm.c index 7c41122ca1..48c054c478 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1077,7 +1077,7 @@ typedef struct xm_top_level_leave_message #define XM_DROP_SITE_VALID 3 /* #define XM_DROP_SITE_INVALID 2 */ -/* #define XM_DROP_SITE_NONE 1 */ +#define XM_DROP_SITE_NONE 1 static uint8_t xm_side_effect_from_action (struct x_display_info *dpyinfo, Atom action) @@ -1589,6 +1589,29 @@ xm_send_top_level_leave_message (struct x_display_info *dpyinfo, Window source, Window target, xm_top_level_leave_message *dmsg) { XEvent msg; + xm_drag_motion_message mmsg; + + /* Motif support for TOP_LEVEL_LEAVE has bitrotted, since these days + it assumes every client supports the preregister protocol style, + but we only support drop-only and dynamic. (Interestingly enough + LessTif works fine.) Sending an event with impossible + coordinates serves to get rid of any active drop site that might + still be around in the target drag context. */ + + if (x_dnd_fix_motif_leave) + { + mmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DRAG_MOTION); + mmsg.byteorder = XM_TARGETS_TABLE_CUR; + mmsg.side_effects = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_NONE, 0, 0); + mmsg.timestamp = dmsg->timestamp; + mmsg.x = 65535; + mmsg.y = 65535; + + xm_send_drag_motion_message (dpyinfo, source, target, &mmsg); + } msg.xclient.type = ClientMessage; msg.xclient.message_type @@ -14384,10 +14407,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, XM_DRAG_REASON_DRAG_MOTION); dmsg.byteorder = XM_TARGETS_TABLE_CUR; - dmsg.side_effects = 0; - dmsg.timestamp = event->xbutton.time; - dmsg.x = event->xbutton.x_root; - dmsg.y = event->xbutton.y_root; + dmsg.side_effects = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_NONE, 0, 0); + dmsg.timestamp = event->xmotion.time; + dmsg.x = event->xmotion.x_root; + dmsg.y = event->xmotion.y_root; lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, XM_DRAG_REASON_TOP_LEVEL_LEAVE); @@ -15832,7 +15857,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, XM_DRAG_REASON_DRAG_MOTION); dmsg.byteorder = XM_TARGETS_TABLE_CUR; - dmsg.side_effects = 0; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_NONE, 0, 0); dmsg.timestamp = xev->time; dmsg.x = lrint (xev->root_x); dmsg.y = lrint (xev->root_y); @@ -22742,4 +22770,12 @@ reliably continue to receive updates even if the finger moves off the frame, but may cause crashes with some window managers and/or external programs. */); x_input_grab_touch_events = true; + + DEFVAR_BOOL ("x-dnd-fix-motif-leave", x_dnd_fix_motif_leave, + doc: /* Work around Motif bug during drag-and-drop. +When non-nil, Emacs will send a motion event containing impossible +coordinates to a Motif drop receiver when the mouse moves outside it +during a drag-and-drop session, to work around broken implementations +of Motif. */); + x_dnd_fix_motif_leave = true; } commit 59fb6783e6ee2d99cd8f58ac10130313f4b51927 Author: Po Lu Date: Sat Apr 2 09:53:03 2022 +0800 Make Motif drag work on window managers that don't support client lists * xterm.c (x_dnd_send_xm_leave_for_drop): New function. (x_dnd_get_wm_state_and_proto): New field `motif_out'. (x_dnd_get_target_window): Return Motif protocol style if looking for windows via XTranslateCoordinates. (x_dnd_cleanup_drag_and_drop, x_dnd_begin_drag_and_drop) (x_dnd_update_state, handle_one_xevent): Send toplevel leave along with drops. diff --git a/src/xterm.c b/src/xterm.c index 109c7789f3..7c41122ca1 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1698,6 +1698,25 @@ xm_read_drag_receiver_info (struct x_display_info *dpyinfo, return !rc; } +static void +x_dnd_send_xm_leave_for_drop (struct x_display_info *dpyinfo, + struct frame *f, Window wdesc, + Time timestamp) +{ + xm_top_level_leave_message lmsg; + + lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_LEAVE); + lmsg.byteorder = XM_TARGETS_TABLE_CUR; + lmsg.zero = 0; + lmsg.timestamp = timestamp; + lmsg.source_window = FRAME_X_WINDOW (f); + + if (x_dnd_motif_setup_p) + xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (f), + wdesc, &lmsg); +} + static void x_dnd_free_toplevels (void) { @@ -2396,14 +2415,25 @@ x_dnd_get_target_window_1 (struct x_display_info *dpyinfo, static int x_dnd_get_wm_state_and_proto (struct x_display_info *dpyinfo, Window window, int *wmstate_out, - int *proto_out) + int *proto_out, int *motif_out) { #ifndef USE_XCB Atom type; - int format, rc; + int format; unsigned long nitems, bytes_after; unsigned char *data = NULL; + xm_drag_receiver_info xm_info; +#else + xcb_get_property_cookie_t wmstate_cookie; + xcb_get_property_cookie_t xdnd_proto_cookie; + xcb_get_property_cookie_t xm_style_cookie; + xcb_get_property_reply_t *reply; + xcb_generic_error_t *error; + uint8_t *xmdata; +#endif + int rc; +#ifndef USE_XCB x_catch_errors (dpyinfo->display); rc = ((XGetWindowProperty (dpyinfo->display, window, dpyinfo->Xatom_wm_state, @@ -2420,17 +2450,14 @@ x_dnd_get_wm_state_and_proto (struct x_display_info *dpyinfo, *proto_out = x_dnd_get_window_proto (dpyinfo, window); + if (!xm_read_drag_receiver_info (dpyinfo, window, &xm_info)) + *motif_out = xm_info.protocol_style; + else + *motif_out = XM_DRAG_STYLE_NONE; + if (data) XFree (data); - - return rc; #else - xcb_get_property_cookie_t wmstate_cookie; - xcb_get_property_cookie_t xdnd_proto_cookie; - xcb_get_property_reply_t *reply; - xcb_generic_error_t *error; - int rc; - rc = true; wmstate_cookie = xcb_get_property (dpyinfo->xcb_connection, 0, @@ -2441,6 +2468,11 @@ x_dnd_get_wm_state_and_proto (struct x_display_info *dpyinfo, (xcb_window_t) window, (xcb_atom_t) dpyinfo->Xatom_XdndAware, XCB_ATOM_ATOM, 0, 1); + xm_style_cookie = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) window, + (xcb_atom_t) dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, + (xcb_atom_t) dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, + 0, 4); reply = xcb_get_property_reply (dpyinfo->xcb_connection, wmstate_cookie, &error); @@ -2473,8 +2505,28 @@ x_dnd_get_wm_state_and_proto (struct x_display_info *dpyinfo, free (reply); } - return rc; + *motif_out = XM_DRAG_STYLE_NONE; + + reply = xcb_get_property_reply (dpyinfo->xcb_connection, + xm_style_cookie, &error); + + if (!reply) + free (error); + else + { + if (reply->format == 8 + && reply->type == dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO + && xcb_get_property_value_length (reply) >= 4) + { + xmdata = xcb_get_property_value (reply); + *motif_out = xmdata[2]; + } + + free (reply); + } #endif + + return rc; } static Window @@ -2483,7 +2535,7 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo, int *motif_out) { Window child_return, child, dummy, proxy; - int dest_x_return, dest_y_return, rc, proto; + int dest_x_return, dest_y_return, rc, proto, motif; #if defined HAVE_XCOMPOSITE && (XCOMPOSITE_MAJOR > 0 || XCOMPOSITE_MINOR > 2) Window overlay_window; XWindowAttributes attrs; @@ -2616,12 +2668,13 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo, if (child_return) { if (x_dnd_get_wm_state_and_proto (dpyinfo, child_return, - &wmstate, &proto) - /* Proto is set by x_dnd_get_wm_state even if getting - the wm state failed. */ - || proto != -1) + &wmstate, &proto, &motif) + /* `proto' and `motif' are set by x_dnd_get_wm_state + even if getting the wm state failed. */ + || proto != -1 || motif != XM_DRAG_STYLE_NONE) { *proto_out = proto; + *motif_out = motif; x_uncatch_errors (); return child_return; @@ -3004,7 +3057,7 @@ x_dnd_cleanup_drag_and_drop (void *frame) dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, XM_DRAG_REASON_DROP_START); dmsg.byte_order = XM_TARGETS_TABLE_CUR; - dmsg.timestamp = 0; + dmsg.timestamp = FRAME_DISPLAY_INFO (f)->last_user_time; dmsg.side_effects = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (FRAME_DISPLAY_INFO (f), x_dnd_wanted_action), @@ -3017,6 +3070,9 @@ x_dnd_cleanup_drag_and_drop (void *frame) dmsg.index_atom = FRAME_DISPLAY_INFO (f)->Xatom_XdndSelection; dmsg.source_window = FRAME_X_WINDOW (f); + x_dnd_send_xm_leave_for_drop (FRAME_DISPLAY_INFO (f), f, + x_dnd_last_seen_window, + FRAME_DISPLAY_INFO (f)->last_user_time); xm_send_drop_message (FRAME_DISPLAY_INFO (f), FRAME_X_WINDOW (f), x_dnd_last_seen_window, &dmsg); } @@ -9017,6 +9073,9 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, dmsg.index_atom = FRAME_DISPLAY_INFO (f)->Xatom_XdndSelection; dmsg.source_window = FRAME_X_WINDOW (f); + x_dnd_send_xm_leave_for_drop (FRAME_DISPLAY_INFO (f), f, + x_dnd_last_seen_window, + hold_quit.timestamp); xm_send_drop_message (FRAME_DISPLAY_INFO (f), FRAME_X_WINDOW (f), x_dnd_last_seen_window, &dmsg); } @@ -12802,6 +12861,8 @@ x_dnd_update_state (struct x_display_info *dpyinfo, Time timestamp) = FRAME_DISPLAY_INFO (x_dnd_frame)->Xatom_XdndSelection; dsmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + x_dnd_send_xm_leave_for_drop (dpyinfo, x_dnd_frame, + x_dnd_last_seen_window, timestamp); xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), x_dnd_last_seen_window, &dsmsg); } @@ -13659,7 +13720,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, #endif if (x_dnd_in_progress) - x_dnd_update_state (dpyinfo, 0); + x_dnd_update_state (dpyinfo, dpyinfo->last_user_time); if (x_dnd_in_progress && x_dnd_use_toplevels && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) @@ -14308,12 +14369,26 @@ handle_one_xevent (struct x_display_info *dpyinfo, && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); else if (x_dnd_last_seen_window != None - && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) - && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) { if (!x_dnd_motif_setup_p) xm_setup_drag_info (dpyinfo, x_dnd_frame); + /* This is apparently required. If we don't send + a motion event with the current root window + coordinates of the pointer before the top level + leave, then Motif displays an ugly black border + around the previous drop site. */ + + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DRAG_MOTION); + dmsg.byteorder = XM_TARGETS_TABLE_CUR; + dmsg.side_effects = 0; + dmsg.timestamp = event->xbutton.time; + dmsg.x = event->xbutton.x_root; + dmsg.y = event->xbutton.y_root; + lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, XM_DRAG_REASON_TOP_LEVEL_LEAVE); lmsg.byteorder = XM_TARGETS_TABLE_CUR; @@ -14322,8 +14397,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); if (x_dnd_motif_setup_p) - xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), - x_dnd_last_seen_window, &lmsg); + { + xm_send_drag_motion_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &dmsg); + xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &lmsg); + } } if (target != FRAME_OUTER_WINDOW (x_dnd_frame) @@ -14780,7 +14859,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, } if (x_dnd_in_progress) - x_dnd_update_state (dpyinfo, 0); + x_dnd_update_state (dpyinfo, dpyinfo->last_user_time); goto OTHER; case ButtonRelease: @@ -14876,6 +14955,11 @@ handle_one_xevent (struct x_display_info *dpyinfo, dmsg.index_atom = dpyinfo->Xatom_XdndSelection; dmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + if (!XM_DRAG_STYLE_IS_DROP_ONLY (drag_receiver_info.protocol_style)) + x_dnd_send_xm_leave_for_drop (FRAME_DISPLAY_INFO (x_dnd_frame), + x_dnd_frame, x_dnd_last_seen_window, + event->xbutton.time); + xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), x_dnd_last_seen_window, &dmsg); @@ -15111,7 +15195,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, case CirculateNotify: if (x_dnd_in_progress) - x_dnd_update_state (dpyinfo, 0); + x_dnd_update_state (dpyinfo, dpyinfo->last_user_time); goto OTHER; case CirculateRequest: @@ -15738,6 +15822,21 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (!x_dnd_motif_setup_p) xm_setup_drag_info (dpyinfo, x_dnd_frame); + /* This is apparently required. If we don't + send a motion event with the current root + window coordinates of the pointer before + the top level leave, then Motif displays + an ugly black border around the previous + drop site. */ + + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DRAG_MOTION); + dmsg.byteorder = XM_TARGETS_TABLE_CUR; + dmsg.side_effects = 0; + dmsg.timestamp = xev->time; + dmsg.x = lrint (xev->root_x); + dmsg.y = lrint (xev->root_y); + lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, XM_DRAG_REASON_TOP_LEVEL_LEAVE); lmsg.byteorder = XM_TARGETS_TABLE_CUR; @@ -15746,8 +15845,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); if (x_dnd_motif_setup_p) - xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), - x_dnd_last_seen_window, &lmsg); + { + xm_send_drag_motion_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &dmsg); + xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &lmsg); + } } if (target != FRAME_OUTER_WINDOW (x_dnd_frame) @@ -15995,6 +16098,11 @@ handle_one_xevent (struct x_display_info *dpyinfo, dmsg.index_atom = dpyinfo->Xatom_XdndSelection; dmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + if (!XM_DRAG_STYLE_IS_DROP_ONLY (drag_receiver_info.protocol_style)) + x_dnd_send_xm_leave_for_drop (FRAME_DISPLAY_INFO (x_dnd_frame), + x_dnd_frame, x_dnd_last_seen_window, + xev->time); + xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), x_dnd_last_seen_window, &dmsg); commit d62b43f760a5fd998bcb93d16e4f7c85a9ea02bc Author: Dmitry Gutov Date: Sat Apr 2 04:34:52 2022 +0300 * lisp/progmodes/xref.el (xref-search-program): Fix typo. diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 870dad61a4..277934c08a 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1745,7 +1745,7 @@ utility function used by commands like `dired-do-find-regexp' and :type '(choice (const :tag "Use Grep" grep) (const :tag "Use ripgrep" ripgrep) - (const :tag "Use ugrep" grep) + (const :tag "Use ugrep" ugrep) (symbol :tag "User defined")) :version "28.1" :package-version '(xref . "1.0.4")) commit 9468ab257064bc911ba5ad5cb527f7745d78cff3 Author: Manuel Uberti Date: Mon Mar 28 14:26:50 2022 +0200 Support ugrep in xref-search-program-alist * lisp/progmodes/xref.el (xref-search-program-alist) (xref-search-program): Add entries for ugrep (bug#54608). diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 5d1ba4eaf5..870dad61a4 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1715,7 +1715,8 @@ IGNORES is a list of glob patterns for files to ignore." . ;; '!*/' is there to filter out dirs (e.g. submodules). "xargs -0 rg --null -nH --no-heading --no-messages -g '!*/' -e " - )) + ) + (ugrep . "xargs -0 ugrep --null -ns -e ")) "Associative list mapping program identifiers to command templates. Program identifier should be a symbol, named after the search program. @@ -1744,6 +1745,7 @@ utility function used by commands like `dired-do-find-regexp' and :type '(choice (const :tag "Use Grep" grep) (const :tag "Use ripgrep" ripgrep) + (const :tag "Use ugrep" grep) (symbol :tag "User defined")) :version "28.1" :package-version '(xref . "1.0.4")) commit c75f65442ddfd2427d95278c44214c0cf1d5a2ee Author: Stefan Monnier Date: Fri Apr 1 20:07:33 2022 -0400 kmacro: Represent it as an OClosure Merge the old lambda+list into a single OClosure object which plays both roles at the same time. Take advantage of it to provide a `cl-print-object` method so kmacro objects print nicely using the `key-parse` syntax. Also replace the old `kmacro-lambda-form` with a new `kmacro` constructor which takes a `key-parse` syntax, so that the code inserted with `insert-kbd-macro` is now more readable. * lisp/kmacro.el (kmacro): New OClosure type. (kmacro-ring-head): Use `kmacro` constructor. (kmacro-push-ring): Convert `elt` from old representation if needed. (kmacro-split-ring-element, kmacro-view-ring-2nd, kmacro-view-macro): Adapt to new representation. (kmacro-exec-ring-item): Turn into obsolete alias. (kmacro-call-ring-2nd, kmacro-end-or-call-macro): Adjust accordingly. (kmacro-start-macro): Simplify call to `kmacro-push-ring`. (kmacro): New constructor function. Replaces `kmacro-lambda-form`. (kmacro-lambda-form): Use it and declare obsolete. (kmacro-extract-lambda): Rewrite and declare obsolete. (kmacro-p): Rewrite. (cl-print-object): New method. (kmacro-bind-to-key, kmacro-name-last-macro): Simplify. * lisp/macros.el (macro--string-to-vector): New function. (insert-kbd-macro): Use it. Generate code using the `kmacro` constructor. * test/lisp/kmacro-tests.el (kmacro-tests-kmacro-bind-to-single-key): Silence warning. (kmacro-tests-name-last-macro-bind-and-rebind): Strengthen the test a bit. (kmacro-tests--cl-print): New test. diff --git a/etc/NEWS b/etc/NEWS index e2998de002..3df326aa5b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -576,6 +576,12 @@ This uses the Tai Tham script, whose support has been enhanced. * Changes in Specialized Modes and Packages in Emacs 29.1 +--- +** kmacro +Kmacros are now OClosures and have a new constructor 'kmacro' which +uses the 'key-parse' syntax. It replaces the old 'kmacro-lambda-form' +(which is now declared obsolete). + --- ** 'savehist.el' can now truncate variables that are too long. An element of 'savehist-additional-variables' can now be of the form diff --git a/lisp/kmacro.el b/lisp/kmacro.el index 9bbaaa666d..8a9d89929e 100644 --- a/lisp/kmacro.el +++ b/lisp/kmacro.el @@ -362,9 +362,13 @@ information." ;;; Keyboard macro ring +(oclosure-define kmacro + "Keyboard macro." + keys (counter :mutable t) format) + (defvar kmacro-ring nil "The keyboard macro ring. -Each element is a list (MACRO COUNTER FORMAT). Actually, the head of +Each element is a `kmacro'. Actually, the head of the macro ring (when defining or executing) is not stored in the ring; instead it is available in the variables `last-kbd-macro', `kmacro-counter', and `kmacro-counter-format'.") @@ -378,20 +382,23 @@ and `kmacro-counter-format'.") (defun kmacro-ring-head () "Return pseudo head element in macro ring." (and last-kbd-macro - (list last-kbd-macro kmacro-counter kmacro-counter-format-start))) + (kmacro last-kbd-macro kmacro-counter kmacro-counter-format-start))) (defun kmacro-push-ring (&optional elt) "Push ELT or current macro onto `kmacro-ring'." (when (setq elt (or elt (kmacro-ring-head))) + (when (consp elt) + (message "Converting obsolete list form of kmacro: %S" elt) + (setq elt (apply #'kmacro elt))) (let ((history-delete-duplicates nil)) (add-to-history 'kmacro-ring elt kmacro-ring-max)))) (defun kmacro-split-ring-element (elt) - (setq last-kbd-macro (car elt) - kmacro-counter (nth 1 elt) - kmacro-counter-format-start (nth 2 elt))) + (setq last-kbd-macro (kmacro--keys elt) + kmacro-counter (kmacro--counter elt) + kmacro-counter-format-start (kmacro--format elt))) (defun kmacro-pop-ring1 (&optional raw) @@ -481,21 +488,16 @@ Optional arg EMPTY is message to print if no macros are defined." ;;;###autoload -(defun kmacro-exec-ring-item (item arg) +(define-obsolete-function-alias 'kmacro-exec-ring-item #'funcall "29.1" "Execute item ITEM from the macro ring. -ARG is the number of times to execute the item." - ;; Use counter and format specific to the macro on the ring! - (let ((kmacro-counter (nth 1 item)) - (kmacro-counter-format-start (nth 2 item))) - (execute-kbd-macro (car item) arg #'kmacro-loop-setup-function) - (setcar (cdr item) kmacro-counter))) +ARG is the number of times to execute the item.") (defun kmacro-call-ring-2nd (arg) "Execute second keyboard macro in macro ring." (interactive "P") (unless (kmacro-ring-empty-p) - (kmacro-exec-ring-item (car kmacro-ring) arg))) + (funcall (car kmacro-ring) arg))) (defun kmacro-call-ring-2nd-repeat (arg) @@ -515,7 +517,7 @@ without repeating the prefix." "Display the second macro in the keyboard macro ring." (interactive) (unless (kmacro-ring-empty-p) - (kmacro-display (car (car kmacro-ring)) nil "2nd macro"))) + (kmacro-display (kmacro--keys (car kmacro-ring)) nil "2nd macro"))) (defun kmacro-cycle-ring-next (&optional _arg) @@ -611,8 +613,7 @@ Use \\[kmacro-bind-to-key] to bind it to a key sequence." (let ((append (and arg (listp arg)))) (unless append (if last-kbd-macro - (kmacro-push-ring - (list last-kbd-macro kmacro-counter kmacro-counter-format-start))) + (kmacro-push-ring)) (setq kmacro-counter (or (if arg (prefix-numeric-value arg)) kmacro-initial-counter-value 0) @@ -748,9 +749,9 @@ With \\[universal-argument], call second macro in macro ring." (if kmacro-call-repeat-key (kmacro-call-macro arg no-repeat t) (kmacro-end-macro arg))) - ((and (eq this-command 'kmacro-view-macro) ;; We are in repeat mode! + ((and (eq this-command #'kmacro-view-macro) ;; We are in repeat mode! kmacro-view-last-item) - (kmacro-exec-ring-item (car kmacro-view-last-item) arg)) + (funcall (car kmacro-view-last-item) arg)) ((and arg (listp arg)) (kmacro-call-ring-2nd 1)) (t @@ -811,42 +812,67 @@ If kbd macro currently being defined end it before activating it." ;; letters and digits, provided that we inhibit the keymap while ;; executing the macro later on (but that's controversial...) +;;;###autoload +(defun kmacro (keys &optional counter format) + "Create a `kmacro' for macro bound to symbol or key. +KEYS should be a vector or a string that obeys `key-valid-p'." + (oclosure-lambda (kmacro (keys (if (stringp keys) (key-parse keys) keys)) + (counter (or counter 0)) + (format (or format "%d"))) + (&optional arg) + (interactive "p") + ;; Use counter and format specific to the macro on the ring! + (let ((kmacro-counter counter) + (kmacro-counter-format-start format)) + (execute-kbd-macro keys arg #'kmacro-loop-setup-function) + (setq counter kmacro-counter)))) + ;;;###autoload (defun kmacro-lambda-form (mac &optional counter format) - "Create lambda form for macro bound to symbol or key." ;; Apparently, there are two different ways this is called: ;; either `counter' and `format' are both provided and `mac' is a vector, ;; or only `mac' is provided, as a list (MAC COUNTER FORMAT). ;; The first is used from `insert-kbd-macro' and `edmacro-finish-edit', ;; while the second is used from within this file. - (let ((mac (if counter (list mac counter format) mac))) - ;; FIXME: This should be a "funcallable struct"! - (lambda (&optional arg) - "Keyboard macro." - ;; We put an "unused prompt" as a special marker so - ;; `kmacro-extract-lambda' can see it's "one of us". - (interactive "pkmacro") - (if (eq arg 'kmacro--extract-lambda) - (cons 'kmacro--extract-lambda mac) - (kmacro-exec-ring-item mac arg))))) + (declare (obsolete kmacro "29.1")) + (if (kmacro-p mac) mac + (when (and (null counter) (consp mac)) + (setq format (nth 2 mac)) + (setq counter (nth 1 mac)) + (setq mac (nth 0 mac))) + (when (stringp mac) + ;; `kmacro' interprets a string according to `key-parse'. + (require 'macros) + (declare-function macro--string-to-vector "macros") + (setq mac (macro--string-to-vector mac))) + (kmacro mac counter format))) (defun kmacro-extract-lambda (mac) "Extract kmacro from a kmacro lambda form." - (let ((mac (cond - ((eq (car-safe mac) 'lambda) - (let ((e (assoc 'kmacro-exec-ring-item mac))) - (car-safe (cdr-safe (car-safe (cdr-safe e)))))) - ((and (functionp mac) - (equal (interactive-form mac) '(interactive "pkmacro"))) - (let ((r (funcall mac 'kmacro--extract-lambda))) - (and (eq (car-safe r) 'kmacro--extract-lambda) (cdr r))))))) - (and (consp mac) - (= (length mac) 3) - (arrayp (car mac)) - mac))) - -(defalias 'kmacro-p #'kmacro-extract-lambda - "Return non-nil if MAC is a kmacro keyboard macro.") + (declare (obsolete nil "29.1")) + (when (kmacro-p mac) + (list (kmacro--keys mac) + (kmacro--counter mac) + (kmacro--format mac)))) + +(defun kmacro-p (x) + "Return non-nil if MAC is a kmacro keyboard macro." + (cl-typep x 'kmacro)) + +(cl-defmethod cl-print-object ((object kmacro) stream) + (princ "#f(kmacro " stream) + (require 'macros) + (declare-function macros--insert-vector-macro "macros" (definition)) + (let ((vecdef (kmacro--keys object)) + (counter (kmacro--counter object)) + (format (kmacro--format object))) + (prin1 (key-description vecdef) stream) + (unless (and (equal counter 0) (equal format "%d")) + (princ " " stream) + (prin1 counter stream) + (princ " " stream) + (prin1 format stream)) + (princ ")" stream))) (defun kmacro-bind-to-key (_arg) "When not defining or executing a macro, offer to bind last macro to a key. @@ -884,16 +910,15 @@ The ARG parameter is unused." (yes-or-no-p (format "%s runs command %S. Bind anyway? " (format-kbd-macro key-seq) cmd)))) - (define-key global-map key-seq - (kmacro-lambda-form (kmacro-ring-head))) + (define-key global-map key-seq (kmacro-ring-head)) (message "Keyboard macro bound to %s" (format-kbd-macro key-seq)))))) (defun kmacro-keyboard-macro-p (symbol) "Return non-nil if SYMBOL is the name of some sort of keyboard macro." (let ((f (symbol-function symbol))) (when f - (or (stringp f) - (vectorp f) + (or (stringp f) ;FIXME: Really deprecated. + (vectorp f) ;FIXME: Deprecated. (kmacro-p f))))) (defun kmacro-name-last-macro (symbol) @@ -910,9 +935,7 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command symbol)) (if (string-equal symbol "") (error "No command name given")) - ;; FIXME: Use plain old `last-kbd-macro' for kmacros where it doesn't - ;; make a difference? - (fset symbol (kmacro-lambda-form (kmacro-ring-head))) + (fset symbol (kmacro-ring-head)) ;; This used to be used to detect when a symbol corresponds to a kmacro. ;; Nowadays it's unused because we used `kmacro-p' instead to see if the ;; symbol's function definition matches that of a kmacro, which is more @@ -953,7 +976,7 @@ The ARG parameter is unused." (interactive) (cond ((or (kmacro-ring-empty-p) - (not (eq last-command 'kmacro-view-macro))) + (not (eq last-command #'kmacro-view-macro))) (setq kmacro-view-last-item nil)) ((null kmacro-view-last-item) (setq kmacro-view-last-item kmacro-ring @@ -963,10 +986,10 @@ The ARG parameter is unused." kmacro-view-item-no (1+ kmacro-view-item-no))) (t (setq kmacro-view-last-item nil))) - (setq this-command 'kmacro-view-macro + (setq this-command #'kmacro-view-macro last-command this-command) ;; in case we repeat (kmacro-display (if kmacro-view-last-item - (car (car kmacro-view-last-item)) + (kmacro--keys (car kmacro-view-last-item)) last-kbd-macro) nil (if kmacro-view-last-item @@ -1068,21 +1091,27 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (concat (format "Macro: %s%s%s%s%s\n" (format-kbd-macro kmacro-step-edit-new-macro 1) - (if (and kmacro-step-edit-new-macro (> (length kmacro-step-edit-new-macro) 0)) " " "") + (if (and kmacro-step-edit-new-macro + (> (length kmacro-step-edit-new-macro) 0)) + " " "") (propertize (if keys (format-kbd-macro keys) - (if kmacro-step-edit-appending "" "")) 'face 'region) + (if kmacro-step-edit-appending + "" "")) + 'face 'region) (if future " " "") (if future (format-kbd-macro future) "")) (cond ((minibufferp) (format "%s\n%s\n" (propertize "\ - minibuffer " 'face 'header-line) + minibuffer " + 'face 'header-line) (buffer-substring (point-min) (point-max)))) (curmsg (format "%s\n%s\n" (propertize "\ - echo area " 'face 'header-line) + echo area " + 'face 'header-line) curmsg)) (t "")) (if keys @@ -1113,7 +1142,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', ;; Handle commands which reads additional input using read-char. (cond - ((and (eq this-command 'quoted-insert) + ((and (eq this-command #'quoted-insert) (not (eq kmacro-step-edit-action t))) ;; Find the actual end of this key sequence. ;; Must be able to backtrack in case we actually execute it. @@ -1133,7 +1162,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (cond ((eq kmacro-step-edit-action t) ;; Reentry for actual command @ end of prefix arg. (cond - ((eq this-command 'quoted-insert) + ((eq this-command #'quoted-insert) (clear-this-command-keys) ;; recent-keys actually (let (unread-command-events) (quoted-insert (prefix-numeric-value current-prefix-arg)) @@ -1177,7 +1206,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', ((eq act 'skip) nil) ((eq act 'skip-keep) - (setq this-command 'ignore) + (setq this-command #'ignore) t) ((eq act 'skip-rest) (setq kmacro-step-edit-active 'ignore) @@ -1227,7 +1256,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (if restore-index (setq executing-kbd-macro-index restore-index))) (t - (setq this-command 'ignore))) + (setq this-command #'ignore))) (setq kmacro-step-edit-key-index next-index))) (defun kmacro-step-edit-insert () @@ -1271,7 +1300,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (setq next-index kmacro-step-edit-key-index) t) (t nil)) - (setq this-command 'ignore) + (setq this-command #'ignore) (setq this-command cmd) (if (memq this-command '(self-insert-command digit-argument)) (setq last-command-event (aref keys (1- (length keys))))) @@ -1284,7 +1313,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (when kmacro-step-edit-active (cond ((eq kmacro-step-edit-active 'ignore) - (setq this-command 'ignore)) + (setq this-command #'ignore)) ((eq kmacro-step-edit-active 'append-end) (if (= executing-kbd-macro-index (length executing-kbd-macro)) (setq executing-kbd-macro (vconcat executing-kbd-macro [nil]) diff --git a/lisp/macros.el b/lisp/macros.el index 35d34d2e33..0baf380433 100644 --- a/lisp/macros.el +++ b/lisp/macros.el @@ -46,6 +46,16 @@ " ") ?\])) +(defun macro--string-to-vector (str) + "Convert an old-style string key sequence to the vector form." + (let ((vec (string-to-vector str))) + (unless (multibyte-string-p str) + (dotimes (i (length vec)) + (let ((k (aref vec i))) + (when (> k 127) + (setf (aref vec i) (+ k ?\M-\C-@ -128)))))) + vec)) + ;;;###autoload (defun insert-kbd-macro (macroname &optional keys) "Insert in buffer the definition of kbd macro MACRONAME, as Lisp code. @@ -72,66 +82,31 @@ use this command, and then save the file." (setq macroname 'last-kbd-macro definition last-kbd-macro) (insert "(setq ")) (setq definition (symbol-function macroname)) - (insert "(fset '")) + ;; Prefer `defalias' over `fset' since it additionally keeps + ;; track of the file where the users added it, and it interacts + ;; better with `advice-add' (and hence things like ELP). + (insert "(defalias '")) (prin1 macroname (current-buffer)) (insert "\n ") - (if (stringp definition) - (let ((beg (point)) end) - (prin1 definition (current-buffer)) - (setq end (point-marker)) - (goto-char beg) - (while (< (point) end) - (let ((char (following-char))) - (cond ((= char 0) - (delete-region (point) (1+ (point))) - (insert "\\C-@")) - ((< char 27) - (delete-region (point) (1+ (point))) - (insert "\\C-" (+ 96 char))) - ((= char ?\C-\\) - (delete-region (point) (1+ (point))) - (insert "\\C-\\\\")) - ((< char 32) - (delete-region (point) (1+ (point))) - (insert "\\C-" (+ 64 char))) - ((< char 127) - (forward-char 1)) - ((= char 127) - (delete-region (point) (1+ (point))) - (insert "\\C-?")) - ((= char 128) - (delete-region (point) (1+ (point))) - (insert "\\M-\\C-@")) - ((= char (aref "\M-\C-\\" 0)) - (delete-region (point) (1+ (point))) - (insert "\\M-\\C-\\\\")) - ((< char 155) - (delete-region (point) (1+ (point))) - (insert "\\M-\\C-" (- char 32))) - ((< char 160) - (delete-region (point) (1+ (point))) - (insert "\\M-\\C-" (- char 64))) - ((= char (aref "\M-\\" 0)) - (delete-region (point) (1+ (point))) - (insert "\\M-\\\\")) - ((< char 255) - (delete-region (point) (1+ (point))) - (insert "\\M-" (- char 128))) - ((= char 255) - (delete-region (point) (1+ (point))) - (insert "\\M-\\C-?")))))) - (if (vectorp definition) - (macros--insert-vector-macro definition) - (pcase (kmacro-extract-lambda definition) - (`(,vecdef ,counter ,format) - (insert "(kmacro-lambda-form ") - (macros--insert-vector-macro vecdef) - (insert " ") - (prin1 counter (current-buffer)) - (insert " ") - (prin1 format (current-buffer)) - (insert ")")) - (_ (prin1 definition (current-buffer)))))) + (when (stringp definition) + (setq definition (macro--string-to-vector definition))) + (if (vectorp definition) + (setq definition (kmacro definition))) + (if (kmacro-p definition) + (let ((vecdef (kmacro--keys definition)) + (counter (kmacro--counter definition)) + (format (kmacro--format definition))) + (insert "(kmacro ") + (prin1 (key-description vecdef) (current-buffer)) + ;; FIXME: Do we really want to store the counter? + (unless (and (equal counter 0) (equal format "%d")) + (insert " ") + (prin1 counter (current-buffer)) + (insert " ") + (prin1 format (current-buffer))) + (insert ")")) + ;; FIXME: Shouldn't this signal an error? + (prin1 definition (current-buffer))) (insert ")\n") (if keys (let ((keys (or (and (symbol-function macroname) diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el index c62a2a501b..75d700070a 100644 --- a/test/lisp/kmacro-tests.el +++ b/test/lisp/kmacro-tests.el @@ -580,8 +580,10 @@ This is a regression test for: Bug#3412, Bug#11817." ;; Check the bound key and run it and verify correct counter ;; and format. (should (equal (string-to-vector "\C-cxi") - (car (kmacro-extract-lambda - (key-binding "\C-x\C-kA"))))) + (car (with-suppressed-warnings + ((obsolete kmacro-extract-lambda)) + (kmacro-extract-lambda + (key-binding "\C-x\C-kA")))))) (kmacro-tests-should-insert "<5>" (funcall (key-binding "\C-x\C-kA"))))) @@ -605,7 +607,7 @@ This is a regression test for: Bug#3412, Bug#11817." (dotimes (i 2) (kmacro-tests-define-macro (make-vector (1+ i) (+ ?a i))) (kmacro-name-last-macro 'kmacro-tests-symbol-for-test) - (should (fboundp 'kmacro-tests-symbol-for-test))) + (should (commandp 'kmacro-tests-symbol-for-test))) ;; Now run the function bound to the symbol. Result should be the ;; second macro. @@ -822,6 +824,15 @@ This is a regression for item 7 in Bug#24991." :macro-result "x") (kmacro-tests-simulate-command '(beginning-of-line)))) +(ert-deftest kmacro-tests--cl-print () + (should (equal (cl-prin1-to-string + (kmacro [?a ?b backspace backspace])) + "#f(kmacro \"a b \")")) + (should (equal (cl-prin1-to-string + (with-suppressed-warnings ((obsolete kmacro-lambda-form)) + (kmacro-lambda-form [?a ?b backspace backspace] 1 "%d"))) + "#f(kmacro \"a b \" 1 \"%d\")"))) + (cl-defun kmacro-tests-run-step-edit (macro &key events sequences result macro-result) "Set up and run a test of `kmacro-step-edit-macro'. commit a15f9d4e58223c6b40b0522e2f2921830b136894 Author: Andrew G Cohen Date: Fri Apr 1 14:10:51 2022 +0800 ; gnus/nnselect must get headers from the right group * lisp/gnus/nnselect.el (nnselect-retrieve-headers): Make sure we are in the right group. It might have been affected by another request. diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 3aef1eb696..89ddd60897 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -388,6 +388,7 @@ artlist; otherwise store the ARTLIST in the group parameters." (gnus-group-find-parameter artgroup 'gnus-fetch-old-headers t)) fetch-old))) + (gnus-request-group artgroup) (erase-buffer) (pcase (setq gnus-headers-retrieved-by (or commit 518150cfd6f534c53d34521457f9805bd6f0a9aa Author: Eli Zaretskii Date: Fri Apr 1 22:00:04 2022 +0300 ; * etc/NEWS: Fix typos. Reported by "T.V Raman" . diff --git a/etc/NEWS b/etc/NEWS index ade0adad8c..e2998de002 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1444,10 +1444,10 @@ option. ** Keymaps and key definitions +++ -*** New functions for defining and manipulating keystrokes have been added. -These all take just the syntax defined by 'key-valid-p'. None of the -older functions have been depreciated or altered, but are deemphasised -in the documentation. +*** New functions for defining and manipulating keystrokes. +These all take the syntax defined by 'key-valid-p'. None of the older +functions have been deprecated or altered, but they are now +de-emphasized in the documentation. +++ *** Use 'keymap-set' instead of 'define-key'. commit 5c70ff9f470d444738219904f55681b86ff2c910 Author: Augusto Stoffel Date: Tue Mar 8 11:23:56 2022 +0100 New user option 'font-lock-ignore' * lisp/font-lock (font-lock-ignore): New defcustom. (font-lock-compile-keywords): Call 'font-lock--filter-keywords'. (font-lock--match-keyword, font-lock--filter-keywords): New functions, implement the functionality described in 'font-lock-ignore'. * doc/lispref/modes.texi: Describe 'font-lock-ignore'. diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index c29936d5ca..b61ba56e18 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -3204,7 +3204,9 @@ Non-@code{nil} means that regular expression matching for the sake of You can use @code{font-lock-add-keywords} to add additional search-based fontification rules to a major mode, and -@code{font-lock-remove-keywords} to remove rules. +@code{font-lock-remove-keywords} to remove rules. You can also set +the @code{font-lock-ignore} variable to disable keywords that match +certain criteria. @defun font-lock-add-keywords mode keywords &optional how This function adds highlighting @var{keywords}, for the current buffer @@ -3274,6 +3276,86 @@ mode @emph{and} all modes derived from it, do this instead: font-lock-keyword-face))))) @end smallexample +@defvar font-lock-ignore +This variable contains rules to selectively disable Font Lock +keywords. It is a list with elements of the following form: + +@example +(@var{mode} @var{rule} @dots{}) +@end example + +Here, @var{mode} is a symbol, say a major or minor mode. The +subsequent rules apply if the current major mode is derived from +@var{mode} or @var{mode} is bound and true as a variable. Each +@var{rule} can be one of the following: + +@table @code +@cindex @var{font-lock-ignore} rules +@item @var{symbol} +A symbol, say a face name, matches any Font Lock keyword containing +the symbol in its definition. The symbol is interpreted as a glob +pattern; in particular, @code{*} matches everything. + +@item @var{string} +A string matches any font-lock keyword defined by a regexp that +matches the string. + +@item (pred @var{function}) +A rule of this form matches if @var{function}, called with the +Font Lock keyword as argument, returns non-@code{nil}. + +@item (not @var{rule}) +A rule of this form matches if @var{rule} doesn’t. + +@item (and @var{rule} @dots{}) +A rule of this form matches if each @var{rule} matches. + +@item (or @var{rule} @dots{}) +A rule of this form matches if some @var{rule} matches. + +@item (except @var{rule}) +A rule of this form can only be used at top level or inside an +@code{or} clause. It undoes the effect of a previously matching rule. +@end table + +In each buffer, Font Lock keywords that match at least one applicable +rule are disabled. +@end defvar + +As an example, consider the following setting: + +@smallexample +(setq font-lock-ignore + '((prog-mode font-lock-*-face + (except help-echo)) + (emacs-lisp-mode (except ";;;###autoload)") + (whitespace-mode whitespace-empty-at-bob-regexp) + (makefile-mode (except *)))) +@end smallexample + +Line by line, this does the following: + +@enumerate +@item +In all programming modes, disable all font-lock keywords that apply +one of the standard font-lock faces (excluding strings and comments, +which are covered by syntactic Font Lock). + +@item +However, keep any keywords that add a @code{help-echo} text property. + +@item +In Emacs Lisp mode, also keep the highlighting of autoload cookies, +which would have been excluded by rule 1. + +@item +In @code{whitespace-mode} (a minor mode), don't highlight an empty +line at beginning of buffer. + +@item +Finally, in Makefile mode, don't apply any ignore rules. +@end enumerate + @node Other Font Lock Variables @subsection Other Font Lock Variables diff --git a/etc/NEWS b/etc/NEWS index aaab0f4517..ade0adad8c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1129,6 +1129,11 @@ support for pipelines which will move a lot of data. See section ** Miscellaneous ++++ +*** New user option 'font-lock-ignore'. +This variable provides a mechanism to selectively disable font-lock +keywords. + +++ *** New package vtable.el for formatting tabular data. This package allows formatting data using variable-pitch fonts. diff --git a/lisp/font-lock.el b/lisp/font-lock.el index d8a1fe399b..8af3c30c9a 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -208,6 +208,7 @@ (require 'syntax) (eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) ;; Define core `font-lock' group. (defgroup font-lock '((jit-lock custom-group)) @@ -279,6 +280,42 @@ decoration for buffers in C++ mode, and level 1 decoration otherwise." (integer :tag "level" 1))))) :group 'font-lock) +(defcustom font-lock-ignore nil + "Rules to selectively disable font-lock keywords. +This is a list of rule sets of the form + + (MODE RULE ...) + +where: + + - MODE is a symbol, say a major or minor mode. The subsequent + rules apply if the current major mode is derived from MODE or + MODE is bound and true as a variable. + + - Each RULE can be one of the following: + - A symbol, say a face name. It matches any font-lock keyword + containing the symbol in its definition. The symbol is + interpreted as a glob pattern; in particular, `*' matches + everything. + - A string. It matches any font-lock keyword defined by a regexp + that matches the string. + - A form (pred FUNCTION). It matches if FUNCTION, which is called + with the font-lock keyword as argument, returns non-nil. + - A form (not RULE). It matches if RULE doesn't. + - A form (and RULE ...). It matches if all the provided rules + match. + - A form (or RULE ...). It matches if any of the provided rules + match. + - A form (except RULE ...). This can be used only at top level or + inside an `or' clause. It undoes the effect of a previous + matching rule. + +In each buffer, font lock keywords that match at least one +applicable rule are disabled." + :type '(alist :key-type symbol :value-type sexp) + :group 'font-lock + :version "29.1") + (defcustom font-lock-verbose nil "If non-nil, means show status messages for buffer fontification. If a number, only buffers greater than this size have fontification messages." @@ -1810,9 +1847,8 @@ If SYNTACTIC-KEYWORDS is non-nil, it means these keywords are used for (error "Font-lock trying to use keywords before setting them up")) (if (eq (car-safe keywords) t) keywords - (setq keywords - (cons t (cons keywords - (mapcar #'font-lock-compile-keyword keywords)))) + (let ((compiled (mapcar #'font-lock-compile-keyword keywords))) + (setq keywords `(t ,keywords ,@(font-lock--filter-keywords compiled)))) (if (and (not syntactic-keywords) (let ((beg-function (with-no-warnings syntax-begin-function))) (or (eq beg-function #'beginning-of-defun) @@ -1883,6 +1919,50 @@ A LEVEL of nil is equal to a LEVEL of 0, a LEVEL of t is equal to (t (car keywords)))) +(defun font-lock--match-keyword (rule keyword) + "Return non-nil if font-lock KEYWORD matches RULE. +See `font-lock-ignore' for the possible rules." + (pcase-exhaustive rule + ('* t) + ((pred symbolp) + (let ((regexp (when (string-match-p "[*?]" (symbol-name rule)) + (wildcard-to-regexp (symbol-name rule))))) + (named-let search ((obj keyword)) + (cond + ((consp obj) (or (search (car obj)) (search (cdr obj)))) + ((not regexp) (eq rule obj)) + ((symbolp obj) (string-match-p regexp (symbol-name obj))))))) + ((pred stringp) (when (stringp (car keyword)) + (string-match-p (concat "\\`\\(?:" (car keyword) "\\)") + rule))) + (`(or . ,rules) (let ((match nil)) + (while rules + (pcase-exhaustive (pop rules) + (`(except ,rule) + (when match + (setq match (not (font-lock--match-keyword rule keyword))))) + (rule + (unless match + (setq match (font-lock--match-keyword rule keyword)))))) + match)) + (`(not ,rule) (not (font-lock--match-keyword rule keyword))) + (`(and . ,rules) (seq-every-p (lambda (rule) + (font-lock--match-keyword rule keyword)) + rules)) + (`(pred ,fun) (funcall fun keyword)))) + +(defun font-lock--filter-keywords (keywords) + "Filter a list of KEYWORDS using `font-lock-ignore'." + (if-let ((rules (mapcan (pcase-lambda (`(,mode . ,rules)) + (when (or (and (boundp mode) mode) + (derived-mode-p mode)) + (copy-sequence rules))) + font-lock-ignore))) + (seq-filter (lambda (keyword) (not (font-lock--match-keyword + `(or ,@rules) keyword))) + keywords) + keywords)) + (defun font-lock-refresh-defaults () "Restart fontification in current buffer after recomputing from defaults. Recompute fontification variables using `font-lock-defaults' and commit 6cb688684065ca74b14263fcc22036cededa2bbe Author: Stefan Monnier Date: Fri Apr 1 10:02:32 2022 -0400 cl-generic: Rework obsolescence checks for defmethod * lisp/emacs-lisp/cl-generic.el (cl-defgeneric): Silence obsolescence warnings in the included methods. (cl-defmethod): Reuse standard obsolescence checks. * lisp/emacs-lisp/seq.el (seq-contains): Remove redundant `with-suppressed-warnings`. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 32a5fe5e54..1e820adaff 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -308,8 +308,10 @@ DEFAULT-BODY, if present, is used as the body of a default method. `(help-add-fundoc-usage ,doc ',args) (help-add-fundoc-usage doc args))) :autoload-end - ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) - (nreverse methods))) + ,(when methods + `(with-suppressed-warnings ((obsolete ,name)) + ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) + (nreverse methods))))) ,@(mapcar (lambda (declaration) (let ((f (cdr (assq (car declaration) defun-declarations-alist)))) @@ -552,8 +554,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined cl--generic-edebug-make-name nil] lambda-doc ; documentation string def-body))) ; part to be debugged - (let ((qualifiers nil) - (orig-name name)) + (let ((qualifiers nil)) (while (cl-generic--method-qualifier-p args) (push args qualifiers) (setq args (pop body))) @@ -563,18 +564,15 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (setq name (gv-setter (cadr name)))) (pcase-let* ((`(,call-con . ,fun) (cl--generic-lambda args body))) `(progn - ,(and (get name 'byte-obsolete-info) - (let* ((obsolete (get name 'byte-obsolete-info))) - (macroexp-warn-and-return - (macroexp--obsolete-warning name obsolete "generic function") - nil (list 'obsolete name) nil orig-name))) ;; You could argue that `defmethod' modifies rather than defines the ;; function, so warnings like "not known to be defined" are fair game. ;; But in practice, it's common to use `cl-defmethod' ;; without a previous `cl-defgeneric'. ;; The ",'" is a no-op that pacifies check-declare. (,'declare-function ,name "") - (cl-generic-define-method ',name ',(nreverse qualifiers) ',args + ;; We use #' to quote `name' so as to trigger an + ;; obsolescence warning when applicable. + (cl-generic-define-method #',name ',(nreverse qualifiers) ',args ',call-con ,fun))))) (defun cl--generic-member-method (specializers qualifiers methods) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 1bcb844d8e..133d3c9e11 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -403,15 +403,14 @@ found or not." (setq count (+ 1 count)))) count)) -(with-suppressed-warnings ((obsolete seq-contains)) - (cl-defgeneric seq-contains (sequence elt &optional testfn) - "Return the first element in SEQUENCE that is equal to ELT. +(cl-defgeneric seq-contains (sequence elt &optional testfn) + "Return the first element in SEQUENCE that is equal to ELT. Equality is defined by TESTFN if non-nil or by `equal' if nil." - (declare (obsolete seq-contains-p "27.1")) - (seq-some (lambda (e) - (when (funcall (or testfn #'equal) elt e) - e)) - sequence))) + (declare (obsolete seq-contains-p "27.1")) + (seq-some (lambda (e) + (when (funcall (or testfn #'equal) elt e) + e)) + sequence)) (cl-defgeneric seq-contains-p (sequence elt &optional testfn) "Return non-nil if SEQUENCE contains an element equal to ELT. commit 2b564f504bbf7c050355840b40a9897f12ed91f9 Author: Ignacio Date: Sun Mar 13 21:05:18 2022 +0100 Better check for when clipboard or primary selection have changed Previously it was done by just comparing new and old selection text, now we use also selection timestamps for systems that support it (only enabled in X for now). (bug#53894) * lisp/select.el: (gui--last-selection-timestamp-clipboard) (gui--last-selection-timestamp-primary): New variables. (gui--set-last-clipboard-selection) (gui--set-last-primary-selection) (gui--clipboard-selection-unchanged-p) (gui--primary-selection-unchanged-p): New functions. diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index ab64928fe7..d8c8c760f7 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -606,7 +606,8 @@ "Insert the clipboard contents, or the last stretch of killed text." (interactive "*") (let ((select-enable-clipboard t) - ;; Ensure that we defeat the DWIM login in `gui-selection-value'. + ;; Ensure that we defeat the DWIM logic in `gui-selection-value' + ;; (i.e., that gui--clipboard-selection-unchanged-p returns nil). (gui--last-selected-text-clipboard nil)) (yank))) diff --git a/lisp/select.el b/lisp/select.el index c352a48261..0b51f01cc5 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -25,9 +25,10 @@ ;; Based partially on earlier release by Lucid. ;; The functionality here is divided in two parts: -;; - Low-level: gui-get-selection, gui-set-selection, gui-selection-owner-p, -;; gui-selection-exists-p are the backend-dependent functions meant to access -;; various kinds of selections (CLIPBOARD, PRIMARY, SECONDARY). +;; - Low-level: gui-backend-get-selection, gui-backend-set-selection, +;; gui-backend-selection-owner-p, gui-backend-selection-exists-p are +;; the backend-dependent functions meant to access various kinds of +;; selections (CLIPBOARD, PRIMARY, SECONDARY). ;; - Higher-level: gui-select-text and gui-selection-value go together to ;; access the general notion of "GUI selection" for interoperation with other ;; applications. This can use either the clipboard or the primary selection, @@ -108,9 +109,10 @@ E.g. it doesn't exist under MS-Windows." :group 'killing :version "25.1") -;; We keep track of the last text selected here, so we can check the -;; current selection against it, and avoid passing back our own text -;; from gui-selection-value. We track both +;; We keep track of the last selection here, so we can check the +;; current selection against it, and avoid passing back with +;; gui-selection-value the same text we previously killed or +;; yanked. We track both ;; separately in case another X application only sets one of them ;; we aren't fooled by the PRIMARY or CLIPBOARD selection staying the same. @@ -119,22 +121,68 @@ E.g. it doesn't exist under MS-Windows." (defvar gui--last-selected-text-primary nil "The value of the PRIMARY selection last seen.") +(defvar gui--last-selection-timestamp-clipboard nil + "The timestamp of the CLIPBOARD selection last seen.") +(defvar gui--last-selection-timestamp-primary nil + "The timestamp of the PRIMARY selection last seen.") + +(defun gui--set-last-clipboard-selection (text) + "Save last clipboard selection. +Save the selected text, passed as argument, and for window +systems that support it, save the selection timestamp too." + (setq gui--last-selected-text-clipboard text) + (when (eq window-system 'x) + (setq gui--last-selection-timestamp-clipboard + (gui-backend-get-selection 'CLIPBOARD 'TIMESTAMP)))) + +(defun gui--set-last-primary-selection (text) + "Save last primary selection. +Save the selected text, passed as argument, and for window +systems that support it, save the selection timestamp too." + (setq gui--last-selected-text-primary text) + (when (eq window-system 'x) + (setq gui--last-selection-timestamp-primary + (gui-backend-get-selection 'PRIMARY 'TIMESTAMP)))) + +(defun gui--clipboard-selection-unchanged-p (text) + "Check whether the clipboard selection has changed. +Compare the selection text, passed as argument, with the text +from the last saved selection. For window systems that support +it, compare the selection timestamp too." + (and + (equal text gui--last-selected-text-clipboard) + (or (not (eq window-system 'x)) + (eq gui--last-selection-timestamp-clipboard + (gui-backend-get-selection 'CLIPBOARD 'TIMESTAMP))))) + +(defun gui--primary-selection-unchanged-p (text) + "Check whether the primary selection has changed. +Compare the selection text, passed as argument, with the text +from the last saved selection. For window systems that support +it, compare the selection timestamp too." + (and + (equal text gui--last-selected-text-primary) + (or (not (eq window-system 'x)) + (eq gui--last-selection-timestamp-primary + (gui-backend-get-selection 'PRIMARY 'TIMESTAMP))))) + + (defun gui-select-text (text) "Select TEXT, a string, according to the window system. -if `select-enable-clipboard' is non-nil, copy TEXT to the system's clipboard. +If `select-enable-clipboard' is non-nil, copy TEXT to the system's clipboard. If `select-enable-primary' is non-nil, put TEXT in the primary selection. MS-Windows does not have a \"primary\" selection." (when select-enable-primary (gui-set-selection 'PRIMARY text) - (setq gui--last-selected-text-primary text)) + (gui--set-last-primary-selection text)) (when select-enable-clipboard ;; When cutting, the selection is cleared and PRIMARY ;; set to the empty string. Prevent that, PRIMARY ;; should not be reset by cut (Bug#16382). (setq saved-region-selection text) (gui-set-selection 'CLIPBOARD text) - (setq gui--last-selected-text-clipboard text))) + (gui--set-last-clipboard-selection text))) (define-obsolete-function-alias 'x-select-text 'gui-select-text "25.1") (defcustom x-select-request-type nil @@ -175,6 +223,7 @@ decoded. If `gui-get-selection' signals an error, return nil." ;; some other window systems. (memq window-system '(x haiku)) (eq type 'CLIPBOARD) + ;; Should we unify this with gui--clipboard-selection-unchanged-p? (gui-backend-selection-owner-p type)) (let ((request-type (if (memq window-system '(x pgtk haiku)) (or x-select-request-type @@ -197,19 +246,17 @@ decoded. If `gui-get-selection' signals an error, return nil." (let ((text (gui--selection-value-internal 'CLIPBOARD))) (when (string= text "") (setq text nil)) - ;; When `select-enable-clipboard' is non-nil, - ;; killing/copying text (with, say, `C-w') will push the - ;; text to the clipboard (and store it in - ;; `gui--last-selected-text-clipboard'). We check - ;; whether the text on the clipboard is identical to this - ;; text, and if so, we report that the clipboard is - ;; empty. See (bug#27442) for further discussion about - ;; this DWIM action, and possible ways to make this check - ;; less fragile, if so desired. - (prog1 - (unless (equal text gui--last-selected-text-clipboard) - text) - (setq gui--last-selected-text-clipboard text))))) + ;; Check the CLIPBOARD selection for 'newness', i.e., + ;; whether it is different from the last time we did a + ;; yank operation or whether it was set by Emacs itself + ;; with a kill operation, since in both cases the text + ;; will already be in the kill ring. See (bug#27442) and + ;; (bug#53894) for further discussion about this DWIM + ;; action, and possible ways to make this check less + ;; fragile, if so desired. + (unless (gui--clipboard-selection-unchanged-p text) + (gui--set-last-clipboard-selection text) + text)))) (primary-text (when select-enable-primary (let ((text (gui--selection-value-internal 'PRIMARY))) @@ -217,10 +264,9 @@ decoded. If `gui-get-selection' signals an error, return nil." ;; Check the PRIMARY selection for 'newness', is it different ;; from what we remembered them to be last time we did a ;; cut/paste operation. - (prog1 - (unless (equal text gui--last-selected-text-primary) - text) - (setq gui--last-selected-text-primary text)))))) + (unless (gui--primary-selection-unchanged-p text) + (gui--set-last-primary-selection text) + text))))) ;; As we have done one selection, clear this now. (setq next-selection-coding-system nil) @@ -235,11 +281,11 @@ decoded. If `gui-get-selection' signals an error, return nil." ;; something like the following has happened since the last time ;; we looked at the selections: Application X set all the ;; selections, then Application Y set only one of them. - ;; In this case since we don't have - ;; timestamps there is no way to know what the 'correct' value to - ;; return is. The nice thing to do would be to tell the user we - ;; saw multiple possible selections and ask the user which was the - ;; one they wanted. + ;; In this case, for systems that support selection timestamps, we + ;; could return the newer. For systems that don't, there is no + ;; way to know what the 'correct' value to return is. The nice + ;; thing to do would be to tell the user we saw multiple possible + ;; selections and ask the user which was the one they wanted. (or clip-text primary-text) )) diff --git a/lisp/term/pc-win.el b/lisp/term/pc-win.el index 327d51f275..514267a52d 100644 --- a/lisp/term/pc-win.el +++ b/lisp/term/pc-win.el @@ -246,6 +246,14 @@ Consult the selection. Treat empty strings as if they were unset." ;; if it does not exist, or exists and compares ;; equal with the last text we've put into the ;; Windows clipboard. + ;; NOTE: that variable is actually the last text any program + ;; (not just Emacs) has put into the windows clipboard (up + ;; until the last time Emacs read or set the clipboard), so + ;; it's not suitable for checking actual selection + ;; ownership. This should not result in a bug for the current + ;; uses of gui-backend-selection-owner however, since they + ;; don't actually care about selection ownership, but about + ;; the selected text having changed. (cond ((not text) t) ((equal text gui--last-selected-text-clipboard) text) commit ff067408e460c02e69c5b7fd06a03c9b12a5744b Author: Stefan Monnier Date: Fri Apr 1 08:54:55 2022 -0400 OClosure: Add support for defmethod dispatch * lisp/emacs-lisp/oclosure.el (oclosure--class): Add slot `allparents`. (oclosure--class-make): Add corresponding arg `allparents`. (oclosure, oclosure--build-class): Pass the new arg to the constructor. (oclosure--define): Make the predicate function understand subtyping. * lisp/emacs-lisp/cl-preloaded.el (cl--class-allparents): Move from `cl-generic.el`. * lisp/emacs-lisp/cl-generic.el (cl--generic-class-parents): Move to `cl-preloaded.el` and rename to `cl--class-allparents`. Adjust all callers. (cl--generic-oclosure-tag, cl-generic--oclosure-specializers): New functions. (cl-generic-generalizers) : New generalizer. * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-test-gen): New generic function. (oclosure-test): Add test for dispatch on oclosure types. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 5cbdb9523a..32a5fe5e54 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1126,7 +1126,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (let ((sclass (cl--find-class specializer)) (tclass (cl--find-class type))) (when (and sclass tclass) - (member specializer (cl--generic-class-parents tclass)))))) + (member specializer (cl--class-allparents tclass)))))) (setq applies t))) applies)) @@ -1255,22 +1255,11 @@ These match if the argument is `eql' to VAL." ;; Use exactly the same code as for `typeof'. `(if ,name (type-of ,name) 'null)) -(defun cl--generic-class-parents (class) - (let ((parents ()) - (classes (list class))) - ;; BFS precedence. FIXME: Use a topological sort. - (while (let ((class (pop classes))) - (cl-pushnew (cl--class-name class) parents) - (setq classes - (append classes - (cl--class-parents class))))) - (nreverse parents))) - (defun cl--generic-struct-specializers (tag &rest _) (and (symbolp tag) (let ((class (get tag 'cl--class))) (when (cl-typep class 'cl-structure-class) - (cl--generic-class-parents class))))) + (cl--class-allparents class))))) (cl-generic-define-generalizer cl--generic-struct-generalizer 50 #'cl--generic-struct-tag @@ -1353,6 +1342,42 @@ Used internally for the (major-mode MODE) context specializers." (progn (cl-assert (null modes)) mode) `(derived-mode ,mode . ,modes)))) +;;; Dispatch on OClosure type + +;; It would make sense to put this into `oclosure.el' except that when +;; `oclosure.el' is loaded `cl-defmethod' is not available yet. + +(defun cl--generic-oclosure-tag (name &rest _) + `(oclosure-type ,name)) + +(defun cl-generic--oclosure-specializers (tag &rest _) + (and (symbolp tag) + (let ((class (cl--find-class tag))) + (when (cl-typep class 'oclosure--class) + (oclosure--class-allparents class))))) + +(cl-generic-define-generalizer cl-generic--oclosure-generalizer + ;; Give slightly higher priority than the struct specializer, so that + ;; for a generic function with methods dispatching structs and on OClosures, + ;; we first try `oclosure-type' before `type-of' since `type-of' will return + ;; non-nil for an OClosure as well. + 51 #'cl--generic-oclosure-tag + #'cl-generic--oclosure-specializers) + +(cl-defmethod cl-generic-generalizers :extra "oclosure-struct" (type) + "Support for dispatch on types defined by `oclosure-define'." + (or + (when (symbolp type) + ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than + ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can + ;; take place without requiring cl-lib. + (let ((class (cl--find-class type))) + (and (cl-typep class 'oclosure--class) + (list cl-generic--oclosure-generalizer)))) + (cl-call-next-method))) + +(cl--generic-prefill-dispatchers 0 oclosure) + ;;; Support for unloading. (cl-defmethod loadhist-unload-element ((x (head cl-defmethod))) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 6aa45526d8..93713f506d 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -305,6 +305,17 @@ supertypes from the most specific to least specific.") (cl-assert (cl--class-p (cl--find-class 'cl-structure-class))) (cl-assert (cl--class-p (cl--find-class 'cl-structure-object))) +(defun cl--class-allparents (class) + (let ((parents ()) + (classes (list class))) + ;; BFS precedence. FIXME: Use a topological sort. + (while (let ((class (pop classes))) + (cl-pushnew (cl--class-name class) parents) + (setq classes + (append classes + (cl--class-parents class))))) + (nreverse parents))) + ;; Make sure functions defined with cl-defsubst can be inlined even in ;; packages which do not require CL. We don't put an autoload cookie ;; directly on that function, since those cookies only go to cl-loaddefs. diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index db108bd7be..c37a5352a3 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -131,16 +131,17 @@ (cl-defstruct (oclosure--class (:constructor nil) (:constructor oclosure--class-make - ( name docstring slots parents + ( name docstring slots parents allparents &aux (index-table (oclosure--index-table slots)))) (:include cl--class) (:copier nil)) - "Metaclass for OClosure classes.") + "Metaclass for OClosure classes." + (allparents nil :read-only t :type (list-of symbol))) (setf (cl--find-class 'oclosure) (oclosure--class-make 'oclosure "The root parent of all OClosure classes" - nil nil)) + nil nil '(oclosure))) (defun oclosure--p (oclosure) (not (not (oclosure-type oclosure)))) @@ -283,7 +284,9 @@ list of slot properties. The currently known properties are the following: (oclosure--class-make name docstring slotdescs (if (cdr parent-names) (oclosure--class-parents parent-class) - (list parent-class))))) + (list parent-class)) + (cons name (oclosure--class-allparents + parent-class))))) (defmacro oclosure--define-functions (name copiers) (let* ((class (cl--find-class name)) @@ -324,7 +327,10 @@ list of slot properties. The currently known properties are the following: &rest props) (let* ((class (oclosure--build-class name docstring parent-names slots)) (pred (lambda (oclosure) - (eq name (oclosure-type oclosure)))) + (let ((type (oclosure-type oclosure))) + (when type + (memq name (oclosure--class-allparents + (cl--find-class type))))))) (predname (or (plist-get props :predicate) (intern (format "%s--internal-p" name))))) (setf (cl--find-class name) class) diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el index e7e76fa4bd..c72a9dbd7a 100644 --- a/test/lisp/emacs-lisp/oclosure-tests.el +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -29,6 +29,16 @@ "Simple OClosure." fst snd name) +(cl-defmethod oclosure-test-gen ((_x compiled-function)) "#") + +(cl-defmethod oclosure-test-gen ((_x cons)) "#") + +(cl-defmethod oclosure-test-gen ((_x oclosure)) + (format "#" (cl-call-next-method))) + +(cl-defmethod oclosure-test-gen ((_x oclosure-test)) + (format "#" (cl-call-next-method))) + (ert-deftest oclosure-test () (let* ((i 42) (ocl1 (oclosure-lambda (oclosure-test (fst 1) (snd 2) (name "hi")) @@ -51,6 +61,9 @@ (should (equal (funcall (oclosure-test-copy1 ocl1 9)) '(9 2 44))) (should (cl-typep ocl1 'oclosure-test)) (should (cl-typep ocl1 'oclosure)) + (should (member (oclosure-test-gen ocl1) + '("#>>" + "#>>"))) )) (ert-deftest oclosure-test-limits () commit 611179d000cd5cf8e8955e3b3c205692a3e91225 Author: Po Lu Date: Fri Apr 1 19:57:42 2022 +0800 Implement the Motif drag protocol * src/xterm.c (struct x_client_list_window): New field `xm_protocol_style'. (xm_top_level_enter_message, xm_drag_motion_message) (xm_top_level_leave_message): New structures. (xm_setup_drag_info, xm_send_top_level_enter_message) (xm_send_drag_motion_message, xm_send_top_level_leave_message): New functions. (x_dnd_compute_toplevels): Compute `xm_protocol_style'. (x_dnd_get_target_window_1, x_dnd_get_target_window): New parameter `motif_out'. Place the xm protocol style in it if necessary. (x_dnd_cleanup_drag_and_drop, x_dnd_begin_drag_and_drop) (x_dnd_update_state, handle_one_xevent): Handle Motif drag protocol messages. (x_free_frame_resources): Cancel Motif drag protocol operations correctly. diff --git a/src/xterm.c b/src/xterm.c index ed4d0a6d27..109c7789f3 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -511,12 +511,12 @@ along with GNU Emacs. If not, see . */ However, dragging contents from Emacs is implemented entirely in C. X Windows has several competing drag-and-drop protocols, of which Emacs supports two: the XDND protocol (see - https://freedesktop.org/wiki/Specifications/XDND) and the Motif drop - protocol. These protocols are based on the initiator owning a - special selection, specifying an action the recipient should - perform, grabbing the mouse, and sending various different client - messages to the toplevel window underneath the mouse as it moves, or - when buttons are released. + https://freedesktop.org/wiki/Specifications/XDND) and the Motif drag + and drop protocols. These protocols are based on the initiator + owning a special selection, specifying an action the recipient + should perform, grabbing the mouse, and sending various different + client messages to the toplevel window underneath the mouse as it + moves, or when buttons are released. The Lisp interface to drag-and-drop is synchronous, and involves running a nested event loop with some global state until the drag @@ -852,6 +852,7 @@ static bool x_dnd_waiting_for_finish; or XmTRANSFER_FAILURE. */ static int x_dnd_waiting_for_motif_finish; static bool x_dnd_xm_use_help; +static bool x_dnd_motif_setup_p; static Window x_dnd_pending_finish_target; static int x_dnd_waiting_for_finish_proto; static bool x_dnd_allow_current_frame; @@ -867,6 +868,7 @@ static struct frame *x_dnd_return_frame_object; static Window x_dnd_last_seen_window; static Window x_dnd_end_window; static int x_dnd_last_protocol_version; +static int x_dnd_last_motif_style; static Time x_dnd_selection_timestamp; static Window x_dnd_mouse_rect_target; @@ -891,6 +893,7 @@ struct x_client_list_window unsigned long wm_state; struct x_client_list_window *next; + uint8_t xm_protocol_style; #ifdef HAVE_XSHAPE int border_width; @@ -996,6 +999,37 @@ typedef struct xm_drag_receiver_info /* CARD32 */ uint32_t unspecified3; } xm_drag_receiver_info; +typedef struct xm_top_level_enter_message +{ + /* BYTE */ uint8_t reason; + /* BYTE */ uint8_t byteorder; + + /* CARD16 */ uint16_t zero; + /* CARD32 */ uint32_t timestamp; + /* CARD32 */ uint32_t source_window; + /* CARD32 */ uint32_t index_atom; +} xm_top_level_enter_message; + +typedef struct xm_drag_motion_message +{ + /* BYTE */ uint8_t reason; + /* BYTE */ uint8_t byteorder; + + /* CARD16 */ uint16_t side_effects; + /* CARD32 */ uint32_t timestamp; + /* CARD16 */ uint16_t x, y; +} xm_drag_motion_message; + +typedef struct xm_top_level_leave_message +{ + /* BYTE */ uint8_t reason; + /* BYTE */ uint8_t byteorder; + + /* CARD16 */ uint16_t zero; + /* CARD32 */ uint32_t timestamp; + /* CARD32 */ uint32_t source_window; +} xm_top_level_leave_message; + #define XM_DRAG_SIDE_EFFECT(op, site, ops, act) \ ((op) | ((site) << 4) | ((ops) << 8) | ((act) << 12)) @@ -1020,10 +1054,26 @@ typedef struct xm_drag_receiver_info #define XM_DRAG_REASON_CODE(reason) ((reason) & 0x7f) #define XM_DRAG_REASON_DROP_START 5 +#define XM_DRAG_REASON_TOP_LEVEL_ENTER 0 +#define XM_DRAG_REASON_TOP_LEVEL_LEAVE 1 +#define XM_DRAG_REASON_DRAG_MOTION 2 #define XM_DRAG_ORIGINATOR_INITIATOR 0 #define XM_DRAG_ORIGINATOR_RECEIVER 1 -#define XM_DRAG_STYLE_NONE 0 +#define XM_DRAG_STYLE_NONE 0 + +#define XM_DRAG_STYLE_DROP_ONLY 1 +#define XM_DRAG_STYLE_DROP_ONLY_REC 3 + +#define XM_DRAG_STYLE_DYNAMIC 5 +#define XM_DRAG_STYLE_DYNAMIC_REC 2 +#define XM_DRAG_STYLE_DYNAMIC_REC1 4 + +#define XM_DRAG_STYLE_IS_DROP_ONLY(n) ((n) == XM_DRAG_STYLE_DROP_ONLY \ + || (n) == XM_DRAG_STYLE_DROP_ONLY_REC) +#define XM_DRAG_STYLE_IS_DYNAMIC(n) ((n) == XM_DRAG_STYLE_DYNAMIC \ + || (n) == XM_DRAG_STYLE_DYNAMIC_REC \ + || (n) == XM_DRAG_STYLE_DYNAMIC_REC1) #define XM_DROP_SITE_VALID 3 /* #define XM_DROP_SITE_INVALID 2 */ @@ -1425,6 +1475,32 @@ xm_setup_dnd_targets (struct x_display_info *dpyinfo, return idx; } +static void +xm_setup_drag_info (struct x_display_info *dpyinfo, + struct frame *source_frame) +{ + xm_drag_initiator_info drag_initiator_info; + int idx; + + idx = xm_setup_dnd_targets (dpyinfo, x_dnd_targets, + x_dnd_n_targets); + + if (idx != -1) + { + drag_initiator_info.byteorder = XM_TARGETS_TABLE_CUR; + drag_initiator_info.protocol = 0; + drag_initiator_info.table_index = idx; + drag_initiator_info.selection = dpyinfo->Xatom_XdndSelection; + + xm_write_drag_initiator_info (dpyinfo->display, FRAME_X_WINDOW (source_frame), + dpyinfo->Xatom_XdndSelection, + dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, + &drag_initiator_info); + + x_dnd_motif_setup_p = true; + } +} + static void xm_send_drop_message (struct x_display_info *dpyinfo, Window source, Window target, xm_drop_start_message *dmsg) @@ -1450,6 +1526,94 @@ xm_send_drop_message (struct x_display_info *dpyinfo, Window source, x_uncatch_errors (); } +static void +xm_send_top_level_enter_message (struct x_display_info *dpyinfo, Window source, + Window target, xm_top_level_enter_message *dmsg) +{ + XEvent msg; + + msg.xclient.type = ClientMessage; + msg.xclient.message_type + = dpyinfo->Xatom_MOTIF_DRAG_AND_DROP_MESSAGE; + msg.xclient.format = 8; + msg.xclient.window = target; + msg.xclient.data.b[0] = dmsg->reason; + msg.xclient.data.b[1] = dmsg->byteorder; + *((uint16_t *) &msg.xclient.data.b[2]) = dmsg->zero; + *((uint32_t *) &msg.xclient.data.b[4]) = dmsg->timestamp; + *((uint32_t *) &msg.xclient.data.b[8]) = dmsg->source_window; + *((uint32_t *) &msg.xclient.data.b[12]) = dmsg->index_atom; + msg.xclient.data.b[16] = 0; + msg.xclient.data.b[17] = 0; + msg.xclient.data.b[18] = 0; + msg.xclient.data.b[19] = 0; + + x_catch_errors (dpyinfo->display); + XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg); + x_uncatch_errors (); +} + +static void +xm_send_drag_motion_message (struct x_display_info *dpyinfo, Window source, + Window target, xm_drag_motion_message *dmsg) +{ + XEvent msg; + + msg.xclient.type = ClientMessage; + msg.xclient.message_type + = dpyinfo->Xatom_MOTIF_DRAG_AND_DROP_MESSAGE; + msg.xclient.format = 8; + msg.xclient.window = target; + msg.xclient.data.b[0] = dmsg->reason; + msg.xclient.data.b[1] = dmsg->byteorder; + *((uint16_t *) &msg.xclient.data.b[2]) = dmsg->side_effects; + *((uint32_t *) &msg.xclient.data.b[4]) = dmsg->timestamp; + *((uint16_t *) &msg.xclient.data.b[8]) = dmsg->x; + *((uint16_t *) &msg.xclient.data.b[10]) = dmsg->y; + msg.xclient.data.b[12] = 0; + msg.xclient.data.b[13] = 0; + msg.xclient.data.b[14] = 0; + msg.xclient.data.b[15] = 0; + msg.xclient.data.b[16] = 0; + msg.xclient.data.b[17] = 0; + msg.xclient.data.b[18] = 0; + msg.xclient.data.b[19] = 0; + + x_catch_errors (dpyinfo->display); + XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg); + x_uncatch_errors (); +} + +static void +xm_send_top_level_leave_message (struct x_display_info *dpyinfo, Window source, + Window target, xm_top_level_leave_message *dmsg) +{ + XEvent msg; + + msg.xclient.type = ClientMessage; + msg.xclient.message_type + = dpyinfo->Xatom_MOTIF_DRAG_AND_DROP_MESSAGE; + msg.xclient.format = 8; + msg.xclient.window = target; + msg.xclient.data.b[0] = dmsg->reason; + msg.xclient.data.b[1] = dmsg->byteorder; + *((uint16_t *) &msg.xclient.data.b[2]) = dmsg->zero; + *((uint32_t *) &msg.xclient.data.b[4]) = dmsg->timestamp; + *((uint32_t *) &msg.xclient.data.b[8]) = dmsg->source_window; + msg.xclient.data.b[12] = 0; + msg.xclient.data.b[13] = 0; + msg.xclient.data.b[14] = 0; + msg.xclient.data.b[15] = 0; + msg.xclient.data.b[16] = 0; + msg.xclient.data.b[17] = 0; + msg.xclient.data.b[18] = 0; + msg.xclient.data.b[19] = 0; + + x_catch_errors (dpyinfo->display); + XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg); + x_uncatch_errors (); +} + static int xm_read_drop_start_reply (const XEvent *msg, xm_drop_start_reply *reply) { @@ -1583,15 +1747,19 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) unsigned char *wmstate_data = NULL; XWindowAttributes attrs; Window child; + xm_drag_receiver_info xm_info; #else uint32_t *wmstate; + uint8_t *xmdata; xcb_get_window_attributes_cookie_t *window_attribute_cookies; xcb_translate_coordinates_cookie_t *translate_coordinate_cookies; xcb_get_property_cookie_t *get_property_cookies; + xcb_get_property_cookie_t *xm_property_cookies; xcb_get_geometry_cookie_t *get_geometry_cookies; xcb_get_window_attributes_reply_t attrs, *attrs_reply; xcb_translate_coordinates_reply_t *coordinates_reply; xcb_get_property_reply_t *property_reply; + xcb_get_property_reply_t *xm_property_reply; xcb_get_geometry_reply_t *geometry_reply; xcb_generic_error_t *error; #endif @@ -1637,6 +1805,8 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) = alloca (sizeof *translate_coordinate_cookies * nitems); get_property_cookies = alloca (sizeof *get_property_cookies * nitems); + xm_property_cookies + = alloca (sizeof *xm_property_cookies * nitems); get_geometry_cookies = alloca (sizeof *get_geometry_cookies * nitems); @@ -1664,6 +1834,11 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) = xcb_get_property (dpyinfo->xcb_connection, 0, (xcb_window_t) toplevels[i], (xcb_atom_t) dpyinfo->Xatom_wm_state, XCB_ATOM_ANY, 0, 2); + xm_property_cookies[i] + = xcb_get_property (dpyinfo->xcb_connection, 0, (xcb_window_t) toplevels[i], + (xcb_atom_t) dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, + (xcb_atom_t) dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, + 0, 4); get_geometry_cookies[i] = xcb_get_geometry (dpyinfo->xcb_connection, (xcb_window_t) toplevels[i]); @@ -1748,6 +1923,13 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) free (error); } + xm_property_reply = xcb_get_property_reply (dpyinfo->xcb_connection, + xm_property_cookies[i], + &error); + + if (!xm_property_reply) + free (error); + if (property_reply && (xcb_get_property_value_length (property_reply) != 8 || property_reply->format != 32)) @@ -1796,6 +1978,21 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) tem->next = x_dnd_toplevels; tem->previous_event_mask = attrs.your_event_mask; tem->wm_state = wmstate[0]; + tem->xm_protocol_style = XM_DRAG_STYLE_NONE; + +#ifndef USE_XCB + if (!xm_read_drag_receiver_info (dpyinfo, toplevels[i], &xm_info)) + tem->xm_protocol_style = xm_info.protocol_style; +#else + if (xm_property_reply + && xm_property_reply->format == 8 + && xm_property_reply->type == dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO + && xcb_get_property_value_length (xm_property_reply) >= 4) + { + xmdata = xcb_get_property_value (xm_property_reply); + tem->xm_protocol_style = xmdata[2]; + } +#endif #ifdef HAVE_XSHAPE #ifndef USE_XCB @@ -2026,6 +2223,9 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) if (property_reply) free (property_reply); + if (xm_property_reply) + free (xm_property_reply); + if (geometry_reply) free (geometry_reply); #endif @@ -2138,9 +2338,9 @@ x_dnd_get_target_window_2 (XRectangle *rects, int nrects, static Window x_dnd_get_target_window_1 (struct x_display_info *dpyinfo, - int root_x, int root_y) + int root_x, int root_y, int *motif_out) { - struct x_client_list_window *tem; + struct x_client_list_window *tem, *chosen = NULL; /* Loop through x_dnd_toplevels until we find the toplevel where root_x and root_y are. */ @@ -2157,7 +2357,10 @@ x_dnd_get_target_window_1 (struct x_display_info *dpyinfo, #ifdef HAVE_XSHAPE if (tem->n_bounding_rects == -1) #endif - return tem->window; + { + chosen = tem; + break; + } #ifdef HAVE_XSHAPE if (x_dnd_get_target_window_2 (tem->bounding_rects, @@ -2170,12 +2373,23 @@ x_dnd_get_target_window_1 (struct x_display_info *dpyinfo, tem->n_input_rects, tem->border_width + root_x - tem->x, tem->border_width + root_y - tem->y)) - return tem->window; + { + chosen = tem; + break; + } } #endif } } + if (chosen) + { + *motif_out = chosen->xm_protocol_style; + return chosen->window; + } + else + *motif_out = XM_DRAG_STYLE_NONE; + return None; } @@ -2265,7 +2479,8 @@ x_dnd_get_wm_state_and_proto (struct x_display_info *dpyinfo, static Window x_dnd_get_target_window (struct x_display_info *dpyinfo, - int root_x, int root_y, int *proto_out) + int root_x, int root_y, int *proto_out, + int *motif_out) { Window child_return, child, dummy, proxy; int dest_x_return, dest_y_return, rc, proto; @@ -2280,10 +2495,16 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo, dest_y_return = root_y; proto = -1; + *motif_out = XM_DRAG_STYLE_NONE; if (x_dnd_use_toplevels) { - child = x_dnd_get_target_window_1 (dpyinfo, root_x, root_y); + child = x_dnd_get_target_window_1 (dpyinfo, root_x, + root_y, motif_out); + + if (!x_dnd_allow_current_frame + && FRAME_X_WINDOW (x_dnd_frame) == child) + *motif_out = XM_DRAG_STYLE_NONE; if (child != None) { @@ -2761,6 +2982,7 @@ static void x_dnd_cleanup_drag_and_drop (void *frame) { struct frame *f = frame; + xm_drop_start_message dmsg; if (!x_dnd_unwind_flag) return; @@ -2774,6 +2996,30 @@ x_dnd_cleanup_drag_and_drop (void *frame) && x_dnd_last_protocol_version != -1) x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style) + && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE + && x_dnd_motif_setup_p) + { + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DROP_START); + dmsg.byte_order = XM_TARGETS_TABLE_CUR; + dmsg.timestamp = 0; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (FRAME_DISPLAY_INFO (f), + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (FRAME_DISPLAY_INFO (f), + x_dnd_wanted_action), + XM_DROP_ACTION_DROP_CANCEL); + dmsg.x = 0; + dmsg.y = 0; + dmsg.index_atom = FRAME_DISPLAY_INFO (f)->Xatom_XdndSelection; + dmsg.source_window = FRAME_X_WINDOW (f); + + xm_send_drop_message (FRAME_DISPLAY_INFO (f), FRAME_X_WINDOW (f), + x_dnd_last_seen_window, &dmsg); + } unblock_input (); x_dnd_end_window = x_dnd_last_seen_window; @@ -8571,6 +8817,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, specpdl_ref ref; ptrdiff_t i, end, fill; XTextProperty prop; + xm_drop_start_message dmsg; if (!FRAME_VISIBLE_P (f)) error ("Frame is invisible"); @@ -8643,6 +8890,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, x_dnd_frame = f; x_dnd_last_seen_window = None; x_dnd_last_protocol_version = -1; + x_dnd_last_motif_style = XM_DRAG_STYLE_NONE; x_dnd_mouse_rect_target = None; x_dnd_action = None; x_dnd_wanted_action = xaction; @@ -8650,6 +8898,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, x_dnd_waiting_for_finish = false; x_dnd_waiting_for_motif_finish = 0; x_dnd_xm_use_help = false; + x_dnd_motif_setup_p = false; x_dnd_end_window = None; x_dnd_use_toplevels = x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_client_list_stacking); @@ -8747,6 +8996,30 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1) x_dnd_send_leave (f, x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style) + && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE + && x_dnd_motif_setup_p) + { + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DROP_START); + dmsg.byte_order = XM_TARGETS_TABLE_CUR; + dmsg.timestamp = hold_quit.timestamp; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (FRAME_DISPLAY_INFO (f), + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (FRAME_DISPLAY_INFO (f), + x_dnd_wanted_action), + XM_DROP_ACTION_DROP_CANCEL); + dmsg.x = 0; + dmsg.y = 0; + dmsg.index_atom = FRAME_DISPLAY_INFO (f)->Xatom_XdndSelection; + dmsg.source_window = FRAME_X_WINDOW (f); + + xm_send_drop_message (FRAME_DISPLAY_INFO (f), FRAME_X_WINDOW (f), + x_dnd_last_seen_window, &dmsg); + } x_dnd_end_window = x_dnd_last_seen_window; x_dnd_last_seen_window = None; @@ -12378,11 +12651,15 @@ mouse_or_wdesc_frame (struct x_display_info *dpyinfo, int wdesc) /* Get the window underneath the pointer, see if it moved, and update the DND state accordingly. */ static void -x_dnd_update_state (struct x_display_info *dpyinfo) +x_dnd_update_state (struct x_display_info *dpyinfo, Time timestamp) { - int root_x, root_y, dummy_x, dummy_y, target_proto; + int root_x, root_y, dummy_x, dummy_y, target_proto, motif_style; unsigned int dummy_mask; Window dummy, dummy_child, target; + xm_top_level_leave_message lmsg; + xm_top_level_enter_message emsg; + xm_drag_motion_message dmsg; + xm_drop_start_message dsmsg; if (XQueryPointer (dpyinfo->display, dpyinfo->root_window, @@ -12392,7 +12669,8 @@ x_dnd_update_state (struct x_display_info *dpyinfo) &dummy_mask)) { target = x_dnd_get_target_window (dpyinfo, root_x, - root_y, &target_proto); + root_y, &target_proto, + &motif_style); if (target != x_dnd_last_seen_window) { @@ -12400,6 +12678,24 @@ x_dnd_update_state (struct x_display_info *dpyinfo) && x_dnd_last_protocol_version != -1 && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_LEAVE); + lmsg.byteorder = XM_TARGETS_TABLE_CUR; + lmsg.zero = 0; + lmsg.timestamp = timestamp; + lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + if (x_dnd_motif_setup_p) + xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &lmsg); + } if (target != FRAME_OUTER_WINDOW (x_dnd_frame) && x_dnd_return_frame == 1) @@ -12421,10 +12717,28 @@ x_dnd_update_state (struct x_display_info *dpyinfo) x_dnd_action = None; x_dnd_last_seen_window = target; x_dnd_last_protocol_version = target_proto; + x_dnd_last_motif_style = motif_style; if (target != None && x_dnd_last_protocol_version != -1) x_dnd_send_enter (x_dnd_frame, target, x_dnd_last_protocol_version); + else if (target != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style)) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + emsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_ENTER); + emsg.byteorder = XM_TARGETS_TABLE_CUR; + emsg.zero = 0; + emsg.timestamp = timestamp; + emsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + emsg.index_atom = dpyinfo->Xatom_XdndSelection; + + if (x_dnd_motif_setup_p) + xm_send_top_level_enter_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + target, &emsg); + } } if (x_dnd_last_protocol_version != -1 && target != None) @@ -12433,6 +12747,31 @@ x_dnd_update_state (struct x_display_info *dpyinfo) root_x, root_y, x_dnd_selection_timestamp, x_dnd_wanted_action); + else if (XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && target != None) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DRAG_MOTION); + dmsg.byteorder = XM_TARGETS_TABLE_CUR; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + (!x_dnd_xm_use_help + ? XM_DROP_ACTION_DROP + : XM_DROP_ACTION_DROP_HELP)); + dmsg.timestamp = timestamp; + dmsg.x = root_x; + dmsg.y = root_y; + + if (x_dnd_motif_setup_p) + xm_send_drag_motion_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + target, &dmsg); + } } /* The pointer moved out of the screen. */ else if (x_dnd_last_protocol_version != -1) @@ -12441,6 +12780,31 @@ x_dnd_update_state (struct x_display_info *dpyinfo) && x_dnd_last_protocol_version != -1) x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style) + && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE + && x_dnd_motif_setup_p) + { + dsmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DROP_START); + dmsg.byteorder = XM_TARGETS_TABLE_CUR; + dsmsg.timestamp = timestamp; + dsmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_ACTION_DROP_CANCEL); + dsmsg.x = 0; + dsmsg.y = 0; + dsmsg.index_atom + = FRAME_DISPLAY_INFO (x_dnd_frame)->Xatom_XdndSelection; + dsmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &dsmsg); + } x_dnd_end_window = x_dnd_last_seen_window; x_dnd_last_seen_window = None; @@ -12996,7 +13360,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_uncatch_errors_after_check (); } - x_dnd_update_state (dpyinfo); + x_dnd_update_state (dpyinfo, event->xproperty.time); break; } } @@ -13063,7 +13427,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, } } - x_dnd_update_state (dpyinfo); + x_dnd_update_state (dpyinfo, event->xproperty.time); } x_handle_property_notify (&event->xproperty); @@ -13295,7 +13659,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, #endif if (x_dnd_in_progress) - x_dnd_update_state (dpyinfo); + x_dnd_update_state (dpyinfo, 0); if (x_dnd_in_progress && x_dnd_use_toplevels && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) @@ -13918,7 +14282,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) { Window target; - int target_proto; + int target_proto, motif_style; + xm_top_level_leave_message lmsg; + xm_top_level_enter_message emsg; + xm_drag_motion_message dmsg; /* Sometimes the drag-and-drop operation starts with the pointer of a frame invisible due to input. Since @@ -13931,7 +14298,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, target = x_dnd_get_target_window (dpyinfo, event->xmotion.x_root, event->xmotion.y_root, - &target_proto); + &target_proto, + &motif_style); if (target != x_dnd_last_seen_window) { @@ -13939,6 +14307,24 @@ handle_one_xevent (struct x_display_info *dpyinfo, && x_dnd_last_protocol_version != -1 && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_LEAVE); + lmsg.byteorder = XM_TARGETS_TABLE_CUR; + lmsg.zero = 0; + lmsg.timestamp = event->xbutton.time; + lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + if (x_dnd_motif_setup_p) + xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &lmsg); + } if (target != FRAME_OUTER_WINDOW (x_dnd_frame) && x_dnd_return_frame == 1) @@ -13960,10 +14346,28 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_dnd_action = None; x_dnd_last_seen_window = target; x_dnd_last_protocol_version = target_proto; + x_dnd_last_motif_style = motif_style; if (target != None && x_dnd_last_protocol_version != -1) x_dnd_send_enter (x_dnd_frame, target, x_dnd_last_protocol_version); + else if (target != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style)) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + emsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_ENTER); + emsg.byteorder = XM_TARGETS_TABLE_CUR; + emsg.zero = 0; + emsg.timestamp = event->xbutton.time; + emsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + emsg.index_atom = dpyinfo->Xatom_XdndSelection; + + if (x_dnd_motif_setup_p) + xm_send_top_level_enter_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + target, &emsg); + } } if (x_dnd_last_protocol_version != -1 && target != None) @@ -13973,6 +14377,30 @@ handle_one_xevent (struct x_display_info *dpyinfo, event->xmotion.y_root, x_dnd_selection_timestamp, x_dnd_wanted_action); + else if (XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && target != None) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DRAG_MOTION); + dmsg.byteorder = XM_TARGETS_TABLE_CUR; + dmsg.side_effects = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + (!x_dnd_xm_use_help + ? XM_DROP_ACTION_DROP + : XM_DROP_ACTION_DROP_HELP)); + dmsg.timestamp = event->xbutton.time; + dmsg.x = event->xmotion.x_root; + dmsg.y = event->xmotion.y_root; + + if (x_dnd_motif_setup_p) + xm_send_drag_motion_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + target, &dmsg); + } goto OTHER; } @@ -14352,7 +14780,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, } if (x_dnd_in_progress) - x_dnd_update_state (dpyinfo); + x_dnd_update_state (dpyinfo, 0); goto OTHER; case ButtonRelease: @@ -14416,35 +14844,22 @@ handle_one_xevent (struct x_display_info *dpyinfo, } else if (x_dnd_last_seen_window != None) { - xm_drag_receiver_info drag_receiver_info; - xm_drag_initiator_info drag_initiator_info; xm_drop_start_message dmsg; - int idx; + xm_drag_receiver_info drag_receiver_info; if (!xm_read_drag_receiver_info (dpyinfo, x_dnd_last_seen_window, &drag_receiver_info) && drag_receiver_info.protocol_style != XM_DRAG_STYLE_NONE && (x_dnd_allow_current_frame - || FRAME_OUTER_WINDOW (x_dnd_frame) != x_dnd_last_seen_window)) + || x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))) { - idx = xm_setup_dnd_targets (dpyinfo, x_dnd_targets, - x_dnd_n_targets); + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); - if (idx != -1) + if (x_dnd_motif_setup_p) { - drag_initiator_info.byteorder = XM_TARGETS_TABLE_CUR; - drag_initiator_info.protocol = 0; - drag_initiator_info.table_index = idx; - drag_initiator_info.selection = dpyinfo->Xatom_XdndSelection; - memset (&dmsg, 0, sizeof dmsg); - xm_write_drag_initiator_info (dpyinfo->display, - FRAME_X_WINDOW (x_dnd_frame), - dpyinfo->Xatom_XdndSelection, - dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, - &drag_initiator_info); - dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, XM_DRAG_REASON_DROP_START); dmsg.byte_order = XM_TARGETS_TABLE_CUR; @@ -14471,6 +14886,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, } x_dnd_last_protocol_version = -1; + x_dnd_last_motif_style = XM_DRAG_STYLE_NONE; x_dnd_last_seen_window = None; x_dnd_frame = NULL; x_set_dnd_targets (NULL, 0); @@ -14695,7 +15111,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, case CirculateNotify: if (x_dnd_in_progress) - x_dnd_update_state (dpyinfo); + x_dnd_update_state (dpyinfo, 0); goto OTHER; case CirculateRequest: @@ -15015,6 +15431,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, #endif /* A fake XMotionEvent for x_note_mouse_movement. */ XMotionEvent ev; + xm_top_level_leave_message lmsg; + xm_top_level_enter_message emsg; + xm_drag_motion_message dmsg; + #ifdef HAVE_XINPUT2_1 states = &xev->valuators; @@ -15289,7 +15709,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) { Window target; - int target_proto; + int target_proto, motif_style; /* Sometimes the drag-and-drop operation starts with the pointer of a frame invisible due to input. Since @@ -15302,7 +15722,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, target = x_dnd_get_target_window (dpyinfo, xev->root_x, xev->root_y, - &target_proto); + &target_proto, + &motif_style); if (target != x_dnd_last_seen_window) { @@ -15310,6 +15731,24 @@ handle_one_xevent (struct x_display_info *dpyinfo, && x_dnd_last_protocol_version != -1 && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_LEAVE); + lmsg.byteorder = XM_TARGETS_TABLE_CUR; + lmsg.zero = 0; + lmsg.timestamp = xev->time; + lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + if (x_dnd_motif_setup_p) + xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &lmsg); + } if (target != FRAME_OUTER_WINDOW (x_dnd_frame) && x_dnd_return_frame == 1) @@ -15331,10 +15770,28 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_dnd_action = None; x_dnd_last_seen_window = target; x_dnd_last_protocol_version = target_proto; + x_dnd_last_motif_style = motif_style; if (target != None && x_dnd_last_protocol_version != -1) x_dnd_send_enter (x_dnd_frame, target, x_dnd_last_protocol_version); + else if (target != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style)) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + emsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_ENTER); + emsg.byteorder = XM_TARGETS_TABLE_CUR; + emsg.zero = 0; + emsg.timestamp = xev->time; + emsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + emsg.index_atom = dpyinfo->Xatom_XdndSelection; + + if (x_dnd_motif_setup_p) + xm_send_top_level_enter_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + target, &emsg); + } } if (x_dnd_last_protocol_version != -1 && target != None) @@ -15343,6 +15800,31 @@ handle_one_xevent (struct x_display_info *dpyinfo, xev->root_x, xev->root_y, x_dnd_selection_timestamp, x_dnd_wanted_action); + else if (XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && target != None) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DRAG_MOTION); + dmsg.byteorder = XM_TARGETS_TABLE_CUR; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + (!x_dnd_xm_use_help + ? XM_DROP_ACTION_DROP + : XM_DROP_ACTION_DROP_HELP)); + dmsg.timestamp = xev->time; + dmsg.x = lrint (xev->root_x); + dmsg.y = lrint (xev->root_y); + + if (x_dnd_motif_setup_p) + xm_send_drag_motion_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + target, &dmsg); + } goto XI_OTHER; } @@ -15470,35 +15952,22 @@ handle_one_xevent (struct x_display_info *dpyinfo, } else if (x_dnd_last_seen_window != None) { - xm_drag_receiver_info drag_receiver_info; - xm_drag_initiator_info drag_initiator_info; xm_drop_start_message dmsg; - int idx; + xm_drag_receiver_info drag_receiver_info; if (!xm_read_drag_receiver_info (dpyinfo, x_dnd_last_seen_window, &drag_receiver_info) && drag_receiver_info.protocol_style != XM_DRAG_STYLE_NONE && (x_dnd_allow_current_frame - || FRAME_OUTER_WINDOW (x_dnd_frame) != x_dnd_last_seen_window)) + || x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))) { - idx = xm_setup_dnd_targets (dpyinfo, x_dnd_targets, - x_dnd_n_targets); + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); - if (idx != -1) + if (x_dnd_motif_setup_p) { - drag_initiator_info.byteorder = XM_TARGETS_TABLE_CUR; - drag_initiator_info.protocol = 0; - drag_initiator_info.table_index = idx; - drag_initiator_info.selection = dpyinfo->Xatom_XdndSelection; - memset (&dmsg, 0, sizeof dmsg); - xm_write_drag_initiator_info (dpyinfo->display, - FRAME_X_WINDOW (x_dnd_frame), - dpyinfo->Xatom_XdndSelection, - dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, - &drag_initiator_info); - dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, XM_DRAG_REASON_DROP_START); dmsg.byte_order = XM_TARGETS_TABLE_CUR; @@ -15536,6 +16005,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, } x_dnd_last_protocol_version = -1; + x_dnd_last_motif_style = XM_DRAG_STYLE_NONE; x_dnd_last_seen_window = None; x_dnd_frame = NULL; x_set_dnd_targets (NULL, 0); @@ -19865,6 +20335,7 @@ x_free_frame_resources (struct frame *f) Lisp_Object bar; struct scroll_bar *b; #endif + xm_drop_start_message dmsg; if (x_dnd_in_progress && f == x_dnd_frame) { @@ -19872,6 +20343,30 @@ x_free_frame_resources (struct frame *f) if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1) x_dnd_send_leave (f, x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style) + && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE + && x_dnd_motif_setup_p) + { + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DROP_START); + dmsg.byte_order = XM_TARGETS_TABLE_CUR; + dmsg.timestamp = 0; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_ACTION_DROP_CANCEL); + dmsg.x = 0; + dmsg.y = 0; + dmsg.index_atom = dpyinfo->Xatom_XdndSelection; + dmsg.source_window = FRAME_X_WINDOW (f); + + xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (f), + x_dnd_last_seen_window, &dmsg); + } unblock_input (); x_dnd_end_window = None; commit 7b08e3a8e41db1483322f48305f837e705540249 Author: Protesilaos Stavrou Date: Fri Apr 1 12:51:14 2022 +0300 Update modus-themes to their version 2.3.0 * doc/misc/modus-themes.org (Enable and load): Clarify wording. (Sample configuration with and without use-package): Improve sample code on how to set up the themes. (Customization Options): Update sample configuration. (Option for box buttons, Option for mode line presentation) (Option for completion framework aesthetics) (Option for Org agenda constructs) (Option for the headings' overall style): Document how to optionally pass number values as a cons cell. (Option for mouseover effects): Document new boolean user option. (More accurate colors in terminal emulators): Write about the color range in terminal emulators and provide sample palette for XTerm. (Override colors): Use American English. (Near-monochrome syntax highlighting): Provide sample code on how to achieve a monochrome style. (Full support for packages or face groups) (Indirectly covered packages): Update lists of supported packages. (Note on display-fill-column-indicator-mode): Reword node. (Note on prism.el): Use American English. (Note on SHR colors): Clarify statement. (Note on the Notmuch logo): Remark that the Notmuch logo can be disabled. (Port the Modus themes to other platforms?): Use American English. (Sources of the themes): Fix capitalization of proper nouns. (Acknowledgements): Update list of contributors to the project. * etc/themes/modus-operandi-theme.el: * etc/themes/modus-vivendi-theme.el: Ensure that the theme is reified as expected both at compiletime and runtime. * etc/themes/modus-themes.el (require): Require 'cl-lib' and 'subr-x' at compiletime. (seq): Require the 'seq' library. (modus-themes-completion-standard-first-match) (modus-themes-completion-standard-selected) (modus-themes-completion-extra-selected): Use correct symbol for deprecated faces. (modus-themes-slanted-constructs): Provide it as an alias of 'modus-themes-italic-constructs'. (modus-themes-variable-pitch-headings): Remove obsolete user option. (modus-themes-no-mixed-fonts): Remove obsolete user option alias. (modus-themes-intense-mouseovers): Add new user option. (modus-themes--headings-choice): Accept value as a cons cell. (modus-themes-headings, modus-themes-org-agenda): Update user option to accept number value as a cons cell. (modus-themes-scale-headings, modus-themes-scale-1, modus-themes-scale-2) (modus-themes-scale-3, modus-themes-scale-4, modus-themes-scale-title) (modus-themes-scale-small): Remove obsolete user options. (modus-themes-mode-line): Update user option to accept number values as cons cells. (modus-themes-mode-line-padding): Remove obsolete user option. (modus-themes-completions): Add support for the 'text-also' property and update it accordingly. (modus-themes-success-deuteranopia): Remove obsolete user option. (modus-themes-box-buttons): Update user option to accept number values as cons cells. (modus-themes--warn, modus-themes--list-or-warn) (modus-themes--alist-or-seq): Add functions to check for correct value in some user options. (modus-themes--current-theme): Return the first Modus theme from 'current-enable-themes' (bug#54598). (modus-themes--lang-check, modus-themes--prompt, modus-themes--paren) (modus-themes--syntax-foreground, modus-themes--syntax-extra) (modus-themes--syntax-string, modus-themes--syntax-comment) (modus-themes--heading, modus-themes--agenda-structure) (modus-themes--agenda-date, modus-themes--mode-line-attrs) (modus-themes--completion, modus-themes--link, modus-themes--link-color) (modus-themes--region, modus-themes--hl-line, modus-themes--button): Make private functions check for the desired value. Refine them where necessary. (modus-themes-faces, modus-themes-custom-variables): Update supported faces and relevant variables. diff --git a/doc/misc/modus-themes.org b/doc/misc/modus-themes.org index 70f1e8bd1d..42ad3ee35f 100644 --- a/doc/misc/modus-themes.org +++ b/doc/misc/modus-themes.org @@ -5,9 +5,9 @@ #+options: ':t toc:nil author:t email:t num:t #+startup: content -#+macro: stable-version 2.2.0 -#+macro: release-date 2022-02-23 -#+macro: development-version 2.3.0-dev +#+macro: stable-version 2.3.0 +#+macro: release-date 2022-04-01 +#+macro: development-version 2.4.0-dev #+macro: file @@texinfo:@file{@@$1@@texinfo:}@@ #+macro: space @@texinfo:@: @@ #+macro: kbd @@texinfo:@kbd{@@$1@@texinfo:}@@ @@ -15,7 +15,7 @@ #+texinfo_filename: modus-themes.info #+texinfo_dir_category: Emacs misc features #+texinfo_dir_title: Modus Themes: (modus-themes) -#+texinfo_dir_desc: Highly accessible themes (WCAG AAA) +#+texinfo_dir_desc: Elegant, highly legible and customizable themes #+texinfo_header: @set MAINTAINERSITE @uref{https://protesilaos.com,maintainer webpage} #+texinfo_header: @set MAINTAINER Protesilaos Stavrou #+texinfo_header: @set MAINTAINEREMAIL @email{info@protesilaos.com} @@ -222,16 +222,16 @@ They are now ready to be used: [[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable #+cindex: Essential configuration #+vindex: modus-themes-after-load-theme-hook -Users of the built-in themes can load and automatically enable the theme -of their preference by adding either form to their init file: +Users of the built-in themes cannot ~require~ the package as usual +because there is no package to speak of. Instead, things are simpler as +all one needs is to load the theme of their preference by adding either +form to their init file: #+begin_src emacs-lisp (load-theme 'modus-operandi) ; Light theme (load-theme 'modus-vivendi) ; Dark theme #+end_src -This is all one needs. - Users of packaged variants of the themes must add a few more lines to ensure that everything works as intended. First, one has to require the main library before loading either theme: @@ -260,24 +260,39 @@ a theme with either of the following expressions: Changes to the available customization options must always be evaluated before loading a theme ([[#h:bf1c82f2-46c7-4eb2-ad00-dd11fdd8b53f][Customization Options]]). An exception to this norm is when using the various Custom interfaces or with commands like -{{{kbd(M-x customize-set-variable)}}}, which can automatically reload -the theme ([[#h:9001527a-4e2c-43e0-98e8-3ef72d770639][Option for inhibiting theme reload]]). This is how a basic -setup could look like: +{{{kbd(M-x customize-set-variable)}}}, which can optionally +automatically reload the theme ([[#h:9001527a-4e2c-43e0-98e8-3ef72d770639][Option for inhibiting theme reload]]). + +This is how a basic setup could look like: #+begin_src emacs-lisp +;;; For the built-in themes which cannot use `require': +;; Add all your customizations prior to loading the themes +(setq modus-themes-italic-constructs t + modus-themes-bold-constructs nil + modus-themes-region '(bg-only no-extend)) + +;; Load the theme of your choice: +(load-theme 'modus-operandi) ;; OR (load-theme 'modus-vivendi) + +(define-key global-map (kbd "") #'modus-themes-toggle) + + + +;;; For packaged versions which must use `require': (require 'modus-themes) -;; Your customisations here. For example: -(setq modus-themes-bold-constructs t - modus-themes-mode-line '3d) +;; Add all your customizations prior to loading the themes +(setq modus-themes-italic-constructs t + modus-themes-bold-constructs nil + modus-themes-region '(bg-only no-extend)) -;; Load the theme files before enabling a theme (else you get an error). +;; Load the theme files before enabling a theme (modus-themes-load-themes) -;; Enable the theme of your preference: -(modus-themes-load-operandi) +;; Load the theme of your choice: +(modus-themes-load-operandi) ;; OR (modus-themes-load-vivendi) -;; Optionally add a key binding for the toggle between the themes: (define-key global-map (kbd "") #'modus-themes-toggle) #+end_src @@ -307,15 +322,30 @@ It is common for Emacs users to rely on ~use-package~ for declaring package configurations in their setup. We use this as an example: #+begin_src emacs-lisp +;;; For the built-in themes which cannot use `require': +(use-package emacs + :init + ;; Add all your customizations prior to loading the themes + (setq modus-themes-italic-constructs t + modus-themes-bold-constructs nil + modus-themes-region '(bg-only no-extend)) + :config + ;; Load the theme of your choice: + (load-theme 'modus-operandi) ;; OR (load-theme 'modus-vivendi) + :bind ("" . modus-themes-toggle) + + + +;;; For packaged versions which must use `require': (use-package modus-themes - :ensure ; omit this to use the built-in themes + :ensure :init ;; Add all your customizations prior to loading the themes (setq modus-themes-italic-constructs t modus-themes-bold-constructs nil modus-themes-region '(bg-only no-extend)) - ;; Load the theme files before enabling a theme (else you get an error). + ;; Load the theme files before enabling a theme (modus-themes-load-themes) :config ;; Load the theme of your choice: @@ -326,6 +356,20 @@ package configurations in their setup. We use this as an example: The same without ~use-package~: #+begin_src emacs-lisp +;;; For the built-in themes which cannot use `require': +;; Add all your customizations prior to loading the themes +(setq modus-themes-italic-constructs t + modus-themes-bold-constructs nil + modus-themes-region '(bg-only no-extend)) + +;; Load the theme of your choice: +(load-theme 'modus-operandi) ;; OR (load-theme 'modus-vivendi) + +(define-key global-map (kbd "") #'modus-themes-toggle) + + + +;;; For packaged versions which must use `require': (require 'modus-themes) ;; Add all your customizations prior to loading the themes @@ -418,6 +462,7 @@ this manual. modus-themes-bold-constructs nil modus-themes-mixed-fonts nil modus-themes-subtle-line-numbers nil + modus-themes-intense-mouseovers nil modus-themes-deuteranopia t modus-themes-tabs-accented t modus-themes-variable-pitch-ui nil @@ -433,8 +478,14 @@ this manual. ;; Options for `modus-themes-mode-line' are either nil, or a list ;; that can combine any of `3d' OR `moody', `borderless', - ;; `accented', and a natural number for extra padding - modus-themes-mode-line '(4 accented borderless) + ;; `accented', a natural number for extra padding (or a cons cell + ;; of padding and NATNUM), and a floating point for the height of + ;; the text relative to the base font size (or a cons cell of + ;; height and FLOAT) + modus-themes-mode-line '(accented borderless (padding . 4) (height . 0.9)) + + ;; Same as above: + ;; modus-themes-mode-line '(accented borderless 4 0.9) ;; Options for `modus-themes-markup' are either nil, or a list ;; that can combine any of `bold', `italic', `background', @@ -464,9 +515,10 @@ this manual. ;; Options for `modus-themes-box-buttons' are either nil (the ;; default), or a list that can combine any of `flat', `accented', - ;; `faint', `variable-pitch', `underline', the symbol of any font - ;; weight as listed in `modus-themes-weights', and a floating - ;; point number (e.g. 0.9) for the height of the button's text. + ;; `faint', `variable-pitch', `underline', `all-buttons', the + ;; symbol of any font weight as listed in `modus-themes-weights', + ;; and a floating point number (e.g. 0.9) for the height of the + ;; button's text. modus-themes-box-buttons '(variable-pitch flat faint 0.9) ;; Options for `modus-themes-prompts' are either nil (the @@ -479,8 +531,8 @@ this manual. ;; value (or empty list) or a list of properties that can include ;; any of the following (for WEIGHT read further below): ;; - ;; `key' - `background', `intense', `underline', `italic', WEIGHT - ;; `selection' - `accented', `intense', `underline', `italic', WEIGHT + ;; `matches' - `background', `intense', `underline', `italic', WEIGHT + ;; `selection' - `accented', `intense', `underline', `italic', `text-also' WEIGHT ;; `popup' - same as `selected' ;; `t' - applies to any key not explicitly referenced (check docs) ;; @@ -841,7 +893,9 @@ an empty list). The list can include any of the following symbols: - ~heavy~ - ~extrabold~ - ~ultrabold~ -+ A floating point as a height multiple of the default (e.g. =0.9=) ++ A floating point as a height multiple of the default or a cons cell in + the form of =(height . FLOAT)= ++ ~all-buttons~ The default (a nil value or an empty list) is a gray background combined with a pseudo three-dimensional effect. @@ -873,6 +927,14 @@ defined in the variable ~modus-themes-weights~. A number, expressed as a floating point (e.g. =0.9=), adjusts the height of the button's text to that many times the base font size. The default height is the same as =1.0=, though it need not be explicitly stated. +Instead of a floating point, an acceptable value can be in the form of a +cons cell like =(height . FLOAT)= or =(height FLOAT)=, where FLOAT is +the given number. + +The ~all-buttons~ property extends the box button effect (or the +aforementioned properties) to the faces of the generic widget library. +By default, those do not look like the buttons of the Custom UI as they +are ordinary text wrapped in square brackets. Combinations of any of those properties are expressed as a list, like in these examples: @@ -880,7 +942,9 @@ like in these examples: #+begin_src emacs-lisp (flat) (variable-pitch flat) -(variable-pitch flat 0.9 semibold) +(variable-pitch flat semibold 0.9) +(variable-pitch flat semibold (height 0.9)) ; same as above +(variable-pitch flat semibold (height . 0.9)) ; same as above #+end_src The order in which the properties are set is not significant. @@ -970,7 +1034,10 @@ effect, color, and border visibility: - ~moody~ + ~accented~ + ~borderless~ -+ A natural number > 1 for extra padding ++ A natural number > 1 for extra padding or a cons cell in the form of + ~(padding . NATNUM)~. ++ A floating point to set the height of the mode line's text. It can + also be a cons cell in the form of ~(height . FLOAT)~. The default (a nil value or an empty list) is a two-dimensional rectangle with a border around it. The active and the inactive mode @@ -1006,6 +1073,17 @@ bottom of the mode line, set ~x-underline-at-descent-line~ to non-nil users on Emacs 29, the ~x-use-underline-position-properties~ variable must also be set to nil. +The padding can also be expressed as a cons cell in the form of +=(padding . NATNUM)= or =(padding NATNUM)= where the key is constant and +NATNUM is the desired natural number. + +A floating point applies an adjusted height to the mode line's text as a +multiple of the main font size. The default rate is 1.0 and does not +need to be specified. Apart from a floating point, the height may also +be expressed as a cons cell in the form of =(height . FLOAT)= or +=(height FLOAT)= where the key is constant and the FLOAT is the desired +number. + Combinations of any of those properties are expressed as a list, like in these examples: @@ -1015,6 +1093,15 @@ these examples: (moody accented borderless) #+end_src +Same as above, using the padding and height as an example (these +all yield the same result): + +#+begin_src emacs-lisp +(accented borderless 4 0.9) +(accented borderless (padding . 4) (height . 0.9)) +(accented borderless (padding 4) (height 0.9)) +#+end_src + The order in which the properties are set is not significant. In user configuration files the form may look like this: @@ -1117,12 +1204,14 @@ appear in: The ~selection~ key applies to the current line or currently matched candidate, depending on the specifics of the User Interface. By default -(nil or an empty list), it has a subtle gray background and a bold -weight. The list of properties it accepts is as follows (order is not -significant): +(nil or an empty list), it has a subtle gray background, a bold weight, +and the base foreground value for the text. The list of properties it +accepts is as follows (order is not significant): - ~accented~ to make the background colorful instead of gray; +- ~text-also~ to apply extra color to the text of the selected line; + - ~intense~ to increase the overall coloration; - ~underline~ to draw a line below the characters; @@ -1154,8 +1243,9 @@ Is the same as: #+end_src In the case of the fallback, any property that does not apply to the -corresponding key is simply ignored (~matches~ does not have ~accented~, -~selection~ and ~popup~ do not have ~background~). +corresponding key is simply ignored (~matches~ does not have ~accented~ +and ~text-also~, while ~selection~ and ~popup~ do not have +~background~). A concise expression of those associations can be written as follows, where the ~car~ is always the key and the ~cdr~ is the list of @@ -1389,6 +1479,29 @@ Instead they retain the primary background of the theme, blending with the rest of the buffer. Foreground values for all relevant faces are updated to accommodate this aesthetic. +** Option for mouseover effects +:properties: +:alt_title: Mouse hover effects +:description: Toggle intense style for mouseover highlights +:custom_id: h:9b869620-fcc5-4b5f-9ab8-225d73b7f22f +:end: +#+vindex: modus-themes-intense-mouseovers + +Brief: Toggle intense mouse hover effects. + +Symbol: ~modus-themes-intense-mouseovers~ (=boolean= type) + +Possible value: + +1. ~nil~ (default) +2. ~t~ + +By default all mouseover effects apply a highlight with a subtle colored +background. When non-nil, these have a more pronounced effect. + +Note that this affects the generic ~highlight~ which, strictly speaking, +is not limited to mouse usage. + ** Option for markup style in Org and others :properties: :alt_title: Markup @@ -1674,12 +1787,18 @@ come in the form of a list that can include either or both of those properties: - ~variable-pitch~ to use a proportionately spaced typeface; + - A number as a floating point (e.g. 1.5) to set the height of the text to that many times the default font height. A float of 1.0 or the - symbol ~no-scale~ have the same effect of making the font to the same - height as the rest of the buffer. When neither a number nor ~no-scale~ - are present, the default is a small increase in height (a value of - 1.15). + symbol ~no-scale~ have the same effect of making the font the same + height as the rest of the buffer. When neither a number nor + `no-scale' are present, the default is a small increase in height (a + value of 1.15). + + Instead of a floating point, an acceptable value can be in the form of + a cons cell like =(height . FLOAT)= or =(height FLOAT)=, where FLOAT + is the given number. + - The symbol of a weight attribute adjusts the font of the heading accordingly, such as ~light~, ~semibold~, etc. Valid symbols are defined in the variable ~modus-themes-weights~. The absence of a @@ -1709,16 +1828,24 @@ the following properties: - ~grayscale~ to make weekdays use the main foreground color and weekends a more subtle gray; + - ~workaholic~ to make weekdays and weekends look the same in terms of color; + - ~bold-today~ to apply a bold typographic weight to the current date; + - ~bold-all~ to render all date headings in a bold weight; + - ~underline-today~ applies an underline to the current date while removing the background it has by default; + - A number as a floating point (e.g. 1.2) to set the height of the text to that many times the default font height. The default is the same - as the base font height (the equivalent of 1.0). + as the base font height (the equivalent of 1.0). Instead of a + floating point, an acceptable value can be in the form of a cons cell + like =(height . FLOAT)= or =(height FLOAT)=, where FLOAT is the given + number. For example: @@ -1805,7 +1932,7 @@ passed as a symbol. Those are: attenuated by painting both of them using shades of green. This option thus highlights the alert and overdue states. - When ~modus-themes-deuteranopia~ is non-nil the exact style of the habit - graph adapts to the needs of users with red-green colour deficiency by + graph adapts to the needs of users with red-green color deficiency by substituting every instance of green with blue or cyan (depending on the specifics). @@ -1884,7 +2011,8 @@ Properties: - ~extrabold~ - ~ultrabold~ + ~no-bold~ (deprecated alias of a ~regular~ weight) -+ A floating point as a height multiple of the default (e.g. =1.1=) ++ A floating point as a height multiple of the default or a cons cell in + the form of =(height . FLOAT)=. By default (a ~nil~ value for this variable), all headings have a bold typographic weight and use a desaturated text color. @@ -1916,6 +2044,9 @@ users are encouraged to specify a ~regular~ weight instead. A number, expressed as a floating point (e.g. 1.5), adjusts the height of the heading to that many times the base font size. The default height is the same as 1.0, though it need not be explicitly stated. +Instead of a floating point, an acceptable value can be in the form of a +cons cell like =(height . FLOAT)= or =(height FLOAT)=, where FLOAT is +the given number. Combinations of any of those properties are expressed as a list, like in these examples: @@ -1924,6 +2055,8 @@ these examples: (semibold) (rainbow background) (overline monochrome semibold 1.3) +(overline monochrome semibold (height 1.3)) ; same as above +(overline monochrome semibold (height . 1.3)) ; same as above #+end_src The order in which the properties are set is not significant. @@ -2032,6 +2165,77 @@ Another example that can be bound to a key: : TERM=xterm-direct uxterm -e emacsclient -nw +** Range of color with terminal emulators +:PROPERTIES: +:CUSTOM_ID: h:6b8211b0-d11b-4c00-9543-4685ec3b742f +:END: +#+cindex: Pure white and pure black in terminal emulators + +[ This is based on partial information. Please help verify and/or + expand these findings. ] + +When Emacs runs in a non-windowed session its color reproduction +capacity is framed or determined by the underlying terminal emulator +([[#h:fbb5e254-afd6-4313-bb05-93b3b4f67358][More accurate colors in terminal emulators]]). Emacs cannot produce a +color that lies outside the range of what the terminal's color palette +renders possible. + +This is immediately noticeable when the terminal's first 16 codes do not +include a pure black value for the =termcol0= entry and a pure white for +=termcol15=. Emacs cannot set the correct background (white for +~modus-operandi~; black for ~modus-vivendi~) or foreground (inverse of +the background). It thus falls back to the closest approximation, which +seldom is appropriate for the purposes of the Modus themes. + +In such a case, the user is expected to update their terminal's color +palette such as by adapting these resources: + +#+begin_src emacs-lisp +! Theme: modus-operandi +! Description: XTerm port of modus-operandi (Modus themes for GNU Emacs) +! Author: Protesilaos Stavrou, +xterm*background: #ffffff +xterm*foreground: #000000 +xterm*color0: #000000 +xterm*color1: #a60000 +xterm*color2: #005e00 +xterm*color3: #813e00 +xterm*color4: #0031a9 +xterm*color5: #721045 +xterm*color6: #00538b +xterm*color7: #bfbfbf +xterm*color8: #595959 +xterm*color9: #972500 +xterm*color10: #315b00 +xterm*color11: #70480f +xterm*color12: #2544bb +xterm*color13: #5317ac +xterm*color14: #005a5f +xterm*color15: #ffffff + +! Theme: modus-vivendi +! Description: XTerm port of modus-vivendi (Modus themes for GNU Emacs) +! Author: Protesilaos Stavrou, +xterm*background: #000000 +xterm*foreground: #ffffff +xterm*color0: #000000 +xterm*color1: #ff8059 +xterm*color2: #44bc44 +xterm*color3: #d0bc00 +xterm*color4: #2fafff +xterm*color5: #feacd0 +xterm*color6: #00d3d0 +xterm*color7: #bfbfbf +xterm*color8: #595959 +xterm*color9: #ef8b50 +xterm*color10: #70b900 +xterm*color11: #c0c530 +xterm*color12: #79a8ff +xterm*color13: #b6a0ff +xterm*color14: #6ae4b9 +xterm*color15: #ffffff +#+end_src + ** Visualize the active Modus theme's palette :properties: :custom_id: h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d @@ -2553,7 +2757,7 @@ The themes provide a mechanism for overriding their color values. This is controlled by the variables ~modus-themes-operandi-color-overrides~ and ~modus-themes-vivendi-color-overrides~, which are alists that should mirror a subset of the associations in ~modus-themes-operandi-colors~ and -~modus-themes-vivendi-colors~ respectively. As with all customisations, +~modus-themes-vivendi-colors~ respectively. As with all customizations, overriding must be done before loading the affected theme. [[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Visualize the active Modus theme's palette]]. @@ -2659,7 +2863,7 @@ Operandi and night sky blue shades for Modus Vivendi. Switching between the two themes, such as with {{{kbd(M-x modus-themes-toggle)}}} will also use the overrides. -Given that this is a user-level customisation, one is free to implement +Given that this is a user-level customization, one is free to implement whatever color values they desire, even if the possible combinations fall below the minimum 7:1 contrast ratio that governs the design of the themes (the WCAG AAA legibility standard). Alternatively, this can also @@ -3720,6 +3924,135 @@ coloration. [[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Visualize the active Modus theme's palette]]. +** Near-monochrome syntax highlighting +:properties: +:custom_id: h:c1f3fa8e-7a63-4a6f-baf3-a7febc0661f0 +:end: +#+cindex: Monochrome code syntax + +While the Modus themes do provide a user option to control the overall +style of syntax highlighting in programming major modes, they do not +cover the possibility of a monochromatic or near-monochromatic design +([[#h:c119d7b2-fcd4-4e44-890e-5e25733d5e52][Option for syntax highlighting]]). This is due to the multitude of +preferences involved: one may like comments to be styled with an accent +value, another may want certain constructs to be bold, a third may apply +italics to doc strings but not comments... The possibilities are +virtually endless. As such, this sort of design is best handled at the +user level in accordance with the information furnished elsewhere in +this manual. + +[[#h:1487c631-f4fe-490d-8d58-d72ffa3bd474][Case-by-case face specs using the themes' palette]]. + +[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]]. + +The gist is that we want to override the font-lock faces. For our +changes to persist while switching between ~modus-operandi~ and +~modus-vivendi~ we wrap our face overrides in a function that we hook to +~modus-themes-after-load-theme-hook~. + +Users who want to replicate the structure of the themes' source code are +advised to use the examples with ~custom-set-faces~. Those who prefer a +different approach can use the snippets which call ~set-face-attribute~. +Below are the code blocks. + +The following uses a yellow accent value for comments and green hues for +strings. Regexp grouping constructs have color values that work in the +context of a green string. All other elements use the main foreground +color, except warnings such as the ~user-error~ function in Elisp +buffers which gets a subtle red tint (not to be confused with the +~warning~ face which is used for genuine warnings). Furthermore, notice +the ~modus-themes-bold~ and ~modus-themes-slant~ which apply the +preference set in the user options ~modus-themes-bold-constructs~ and +~modus-themes-italic-constructs~, respectively. Users who do not want +this conditionally must replace these faces with ~bold~ and ~italic~ +respectively (or ~unspecified~ to disable the effect altogether). + +#+begin_src emacs-lisp +;; This is the hook. It will not be replicated across all code samples. +(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-subtle-syntax) + +(defun my-modus-themes-subtle-syntax () + (modus-themes-with-colors + (custom-set-faces + `(font-lock-builtin-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-comment-delimiter-face ((,class :inherit font-lock-comment-face))) + `(font-lock-comment-face ((,class :inherit unspecified :foreground ,fg-comment-yellow))) + `(font-lock-constant-face ((,class :foreground unspecified))) + `(font-lock-doc-face ((,class :inherit modus-themes-slant :foreground ,fg-special-mild))) + `(font-lock-function-name-face ((,class :foreground unspecified))) + `(font-lock-keyword-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-negation-char-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-preprocessor-face ((,class :foreground unspecified))) + `(font-lock-regexp-grouping-backslash ((,class :inherit bold :foreground ,yellow))) + `(font-lock-regexp-grouping-construct ((,class :inherit bold :foreground ,blue-alt-other))) + `(font-lock-string-face ((,class :foreground ,green-alt-other))) + `(font-lock-type-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-variable-name-face ((,class :foreground unspecified))) + `(font-lock-warning-face ((,class :inherit modus-themes-bold :foreground ,red-nuanced-fg)))))) + +;; Same as above with `set-face-attribute' instead of `custom-set-faces' +(defun my-modus-themes-subtle-syntax () + (modus-themes-with-colors + (set-face-attribute 'font-lock-builtin-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-comment-delimiter-face nil :inherit 'font-lock-comment-face) + (set-face-attribute 'font-lock-comment-face nil :inherit 'unspecified :foreground fg-comment-yellow) + (set-face-attribute 'font-lock-constant-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-doc-face nil :inherit 'modus-themes-slant :foreground fg-special-mild) + (set-face-attribute 'font-lock-function-name-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-keyword-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-negation-char-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-preprocessor-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-regexp-grouping-backslash nil :inherit 'bold :foreground yellow) + (set-face-attribute 'font-lock-regexp-grouping-construct nil :inherit 'bold :foreground blue-alt-other) + (set-face-attribute 'font-lock-string-face nil :foreground green-alt-other) + (set-face-attribute 'font-lock-type-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-variable-name-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-warning-face nil :inherit 'modus-themes-bold :foreground red-nuanced-fg))) +#+end_src + +The following sample is the same as above, except strings are blue and +comments are gray. Regexp constructs are adapted accordingly. + +#+begin_src emacs-lisp +(defun my-modus-themes-subtle-syntax () + (modus-themes-with-colors + (custom-set-faces + `(font-lock-builtin-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-comment-delimiter-face ((,class :inherit font-lock-comment-face))) + `(font-lock-comment-face ((,class :inherit unspecified :foreground ,fg-alt))) + `(font-lock-constant-face ((,class :foreground unspecified))) + `(font-lock-doc-face ((,class :inherit modus-themes-slant :foreground ,fg-docstring))) + `(font-lock-function-name-face ((,class :foreground unspecified))) + `(font-lock-keyword-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-negation-char-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-preprocessor-face ((,class :foreground unspecified))) + `(font-lock-regexp-grouping-backslash ((,class :inherit bold :foreground ,fg-escape-char-backslash))) + `(font-lock-regexp-grouping-construct ((,class :inherit bold :foreground ,fg-escape-char-construct))) + `(font-lock-string-face ((,class :foreground ,blue-alt))) + `(font-lock-type-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-variable-name-face ((,class :foreground unspecified))) + `(font-lock-warning-face ((,class :inherit modus-themes-bold :foreground ,red-nuanced-fg)))))) + +;; Same as above with `set-face-attribute' instead of `custom-set-faces' +(defun my-modus-themes-subtle-syntax () + (modus-themes-with-colors + (set-face-attribute 'font-lock-builtin-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-comment-delimiter-face nil :inherit 'font-lock-comment-face) + (set-face-attribute 'font-lock-comment-face nil :inherit 'unspecified :foreground fg-alt) + (set-face-attribute 'font-lock-constant-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-doc-face nil :inherit 'modus-themes-slant :foreground fg-docstring) + (set-face-attribute 'font-lock-function-name-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-keyword-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-negation-char-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-preprocessor-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-regexp-grouping-backslash nil :inherit 'bold :foreground fg-escape-char-backslash) + (set-face-attribute 'font-lock-regexp-grouping-construct nil :inherit 'bold :foreground fg-escape-char-construct) + (set-face-attribute 'font-lock-string-face nil :foreground blue-alt) + (set-face-attribute 'font-lock-type-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-variable-name-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-warning-face nil :inherit 'modus-themes-bold :foreground red-nuanced-fg))) +#+end_src + * Face coverage :properties: :custom_id: h:a9c8f29d-7f72-4b54-b74b-ddefe15d6a19 @@ -3793,6 +4126,7 @@ have lots of extensions, so the "full support" may not be 100% true… + deadgrep + debbugs + deft ++ devdocs + dictionary + diff-hl + diff-mode @@ -3914,6 +4248,7 @@ have lots of extensions, so the "full support" may not be 100% true… + mct + mentor + messages ++ mini-modeline + minimap + mmm-mode + mode-line @@ -4063,6 +4398,7 @@ supported by the themes. + dtache + easy-kill + edit-indirect ++ elfeed-summary + evil-owl + flyspell-correct + fortran-mode @@ -4083,6 +4419,7 @@ supported by the themes. + swift-mode + tab-bar-echo-area + tide ++ undo-hl + vdiff + vertico-indexed + vertico-mouse @@ -4239,29 +4576,20 @@ package: it draws too much attention to unfocused windows. :custom_id: h:2a602816-bc1b-45bf-9675-4cbbd7bf6cab :end: -While designing the style for ~display-fill-column-indicator-mode~, we -stayed close to the mode's defaults: to apply a subtle foreground color -to the ~fill-column-indicator~ face, which blends well with the rest of -theme and is consistent with the role of that mode. This is to not -upset the expectations of users. - -Nevertheless, ~display-fill-column-indicator-mode~ has some known -limitations pertaining to its choice of using typographic characters to -draw its indicator. What should be a continuous vertical line might -appear as a series of dashes in certain contexts or under specific -conditions: a non-default value for ~line-spacing~, scaled and/or -variable-pitch headings have been observed to cause this effect. +The ~display-fill-column-indicator-mode~ uses a typographic character to +draw its line. This has the downside of creating a dashed line. The +dashes are further apart depending on how tall the font's glyph height +is and what integer the ~line-spacing~ is set to. -Given that we cannot control such factors, it may be better for affected -users to deviate from the default style of the ~fill-column-indicator~ -face. Instead of setting a foreground color, one could use a background -and have the foreground be indistinguishable from it. For example: +At the theme level we eliminate this effect by making the character one +pixel tall: the line is contiguous. Users who prefer the dashed line +are advised to change the ~fill-column-indicator~ face, as explained +elsewhere in this document. For example: #+begin_src emacs-lisp (modus-themes-with-colors (custom-set-faces - `(fill-column-indicator ((,class :background ,bg-inactive - :foreground ,bg-inactive))))) + `(fill-column-indicator ((,class :foreground ,bg-active))))) #+end_src [[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]]. @@ -4456,7 +4784,7 @@ implements an alternative to the typical coloration of code. Instead of highlighting the syntactic constructs, it applies color to different levels of depth in the code structure. -As {{{file(prism.el)}}} offers a broad range of customisations, we cannot +As {{{file(prism.el)}}} offers a broad range of customizations, we cannot style it directly at the theme level: that would run contrary to the spirit of the package. Instead, we may offer preset color schemes. Those should offer a starting point for users to adapt to their needs. @@ -4644,7 +4972,7 @@ Emacs' HTML rendering library ({{{file(shr.el)}}}) may need explicit configuration to respect the theme's colors instead of whatever specifications the webpage provides. -Consult {{{kbd(C-h v shr-use-colors)}}}. +Consult the doc string of ~shr-use-colors~. ** Note on SHR fonts :properties: @@ -4806,6 +5134,20 @@ you've customized any faces. "-draw" "text %X,%Y '%c'")))) #+end_src +** Note on the Notmuch logo +:properties: +:custom_id: h:636af312-54a5-4918-84a6-0698e85a3c6d +:end: + +By default, the "hello" buffer of Notmuch includes a header with the +programs' logo and a couple of buttons. The logo has the effect of +enlarging the height of the line, which negatively impacts the shape of +those buttons. Disabling the logo fixes the problem: + +#+begin_src emacs-lisp +(setq notmuch-show-logo nil) +#+end_src + * Frequently Asked Questions :properties: :custom_id: h:b3384767-30d3-4484-ba7f-081729f03a47 @@ -5124,8 +5466,8 @@ themes remains consistent. The former criterion should be crystal clear as it pertains to the scientific foundations of the themes: high legibility and taking care of -the needs of users with red-green colour deficiency (deuteranopia) by -avoiding red+green colour coding paradigms and/or by providing red+blue +the needs of users with red-green color deficiency (deuteranopia) by +avoiding red+green color coding paradigms and/or by providing red+blue variants. The latter criterion is the "je ne sais quoi" of the artistic aspect of @@ -5143,7 +5485,7 @@ but try to understand its spirit. For a trivial example: the curly underline that Emacs draws for spelling errors is thinner than, e.g., what a graphical web browser has, so if I was to design for an editor than has a thicker curly underline I would -make the applicable colours less intense to counterbalance the +make the applicable colors less intense to counterbalance the typographic intensity of the added thickness. With those granted, if anyone is willing to develop a port of the @@ -5166,8 +5508,8 @@ in which you can contribute to their ongoing development. The ~modus-operandi~ and ~modus-vivendi~ themes are built into Emacs 28. -The source code of the themes is [[https://gitlab.com/protesilaos/modus-themes/][available on Gitlab]], for the time -being. A [[https://github.com/protesilaos/modus-themes/][mirror on Github]] is also on offer. +The source code of the themes is [[https://gitlab.com/protesilaos/modus-themes/][available on GitLab]], for the time +being. A [[https://github.com/protesilaos/modus-themes/][mirror on GitHub]] is also on offer. An HTML version of this manual is provided as an extension of the [[https://protesilaos.com/emacs/modus-themes/][author's personal website]] (does not rely on any non-free code). @@ -5274,37 +5616,39 @@ The Modus themes are a collective effort. Every bit of work matters. + Author/maintainer :: Protesilaos Stavrou. + Contributions to code or documentation :: Alex Griffin, Anders - Johansson, Basil L.{{{space()}}} Contovounesios, Björn Lindström, Carlo - Zancanaro, Christian Tietze, Daniel Mendler, Eli Zaretskii, Fritz - Grabo, Illia Ostapyshyn, Kévin Le Gouguec, Kostadin Ninev, Madhavan - Krishnan, Markus Beppler, Matthew Stevenson, Mauro Aranda, Nicolas De - Jaeghere, Philip Kaludercic, Rudolf Adamkovič, Stephen Gildea, Shreyas - Ragavan, Stefan Kangas, Utkarsh Singh, Vincent Murphy, Xinglu Chen, - Yuanchen Xie. + Johansson, Basil L.{{{space()}}} Contovounesios, Björn Lindström, + Carlo Zancanaro, Christian Tietze, Daniel Mendler, Eli Zaretskii, + Fritz Grabo, Illia Ostapyshyn, Kévin Le Gouguec, Kostadin Ninev, + Madhavan Krishnan, Markus Beppler, Matthew Stevenson, Mauro Aranda, + Nicolas De Jaeghere, Philip Kaludercic, Pierre Téchoueyres, Rudolf + Adamkovič, Stephen Gildea, Shreyas Ragavan, Stefan Kangas, Utkarsh + Singh, Vincent Murphy, Xinglu Chen, Yuanchen Xie. + Ideas and user feedback :: Aaron Jensen, Adam Porter, Adam Spiers, Adrian Manea, Alex Griffin, Alex Koen, Alex Peitsinis, Alexey Shmalko, - Alok Singh, Anders Johansson, André Alexandre Gomes, Arif Rezai, Basil - L.{{{space()}}} Contovounesios, Burgess Chang, Christian Tietze, - Christopher Dimech, Damien Cassou, Daniel Mendler, Dario Gjorgjevski, - David Edmondson, Davor Rotim, Divan Santana, Eliraz Kedmi, Emanuele - Michele Alberto Monterosso, Farasha Euker, Feng Shu, Gautier Ponsinet, - Gerry Agbobada, Gianluca Recchia, Guilherme Semente, Gustavo Barros, - Hörmetjan Yiltiz, Ilja Kocken, Iris Garcia, Jeremy Friesen, Jerry - Zhang, Johannes Grødem, John Haman, Joshua O'Connor, Kenta Usami, - Kevin Fleming, Kévin Le Gouguec, Kostadin Ninev, Len Trigg, Magne Hov, - Manuel Uberti, Mark Bestley, Mark Burton, Markus Beppler, Mauro - Aranda, Michael Goldenberg, Morgan Smith, Murilo Pereira, Nicky van + Alok Singh, Anders Johansson, André Alexandre Gomes, Antonio Hernández + Blas, Arif Rezai, Augusto Stoffel, Basil L.{{{space()}}} + Contovounesios, Burgess Chang, Christian Tietze, Christopher Dimech, + Damien Cassou, Daniel Mendler, Dario Gjorgjevski, David Edmondson, + Davor Rotim, Divan Santana, Eliraz Kedmi, Emanuele Michele Alberto + Monterosso, Farasha Euker, Feng Shu, Gautier Ponsinet, Gerry Agbobada, + Gianluca Recchia, Guilherme Semente, Gustavo Barros, Hörmetjan Yiltiz, + Ilja Kocken, Iris Garcia, Jeremy Friesen, Jerry Zhang, Johannes + Grødem, John Haman, Jorge Morais, Joshua O'Connor, Julio + C. Villasante, Kenta Usami, Kevin Fleming, Kévin Le Gouguec, Kostadin + Ninev, Len Trigg, Lennart C. Karssen, Magne Hov, Manuel Uberti, Mark + Bestley, Mark Burton, Markus Beppler, Mauro Aranda, Michael + Goldenberg, Morgan Smith, Morgan Willcock, Murilo Pereira, Nicky van Foreest, Nicolas De Jaeghere, Paul Poloskov, Pengji Zhang, Pete - Kazmier, Peter Wu, Philip Kaludercic, Pierre Téchoueyres, Roman - Rudakov, Ryan Phillips, Rudolf Adamkovič, Sam Kleinman, Samuel - Culpepper, Saša Janiška, Shreyas Ragavan, Simon Pugnet, Tassilo Horn, - Thibaut Verron, Thomas Heartman, Togan Muftuoglu, Trey Merkley, Tomasz - Hołubowicz, Toon Claes, Uri Sharf, Utkarsh Singh, Vincent Foley. As - well as users: Ben, CsBigDataHub1, Emacs Contrib, Eugene, Fourchaux, - Fredrik, Moesasji, Nick, TheBlob42, Trey, bepolymathe, bit9tream, - derek-upham, doolio, fleimgruber, gitrj95, iSeeU, jixiuf, okamsn, - pRot0ta1p. + Kazmier, Peter Wu, Philip Kaludercic, Pierre Téchoueyres, Robert + Hepple, Roman Rudakov, Ryan Phillips, Rytis Paškauskas, Rudolf + Adamkovič, Sam Kleinman, Samuel Culpepper, Saša Janiška, Shreyas + Ragavan, Simon Pugnet, Tassilo Horn, Thibaut Verron, Thomas Heartman, + Togan Muftuoglu, Tony Zorman, Trey Merkley, Tomasz Hołubowicz, Toon + Claes, Uri Sharf, Utkarsh Singh, Vincent Foley. As well as users: + Ben, CsBigDataHub1, Emacs Contrib, Eugene, Fourchaux, Fredrik, + Moesasji, Nick, TheBlob42, Trey, bepolymathe, bit9tream, derek-upham, + doolio, fleimgruber, gitrj95, iSeeU, jixiuf, okamsn, pRot0ta1p. + Packaging :: Basil L.{{{space()}}} Contovounesios, Eli Zaretskii, Glenn Morris, Mauro Aranda, Richard Stallman, Stefan Kangas (core Emacs), diff --git a/etc/themes/modus-operandi-theme.el b/etc/themes/modus-operandi-theme.el index f71962e3f1..be80b39410 100644 --- a/etc/themes/modus-operandi-theme.el +++ b/etc/themes/modus-operandi-theme.el @@ -1,10 +1,10 @@ -;;; modus-operandi-theme.el --- Accessible and customizable light theme (WCAG AAA) -*- lexical-binding:t -*- +;;; modus-operandi-theme.el --- Elegant, highly legible and customizable light theme -*- lexical-binding:t -*- ;; Copyright (C) 2019-2022 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou ;; URL: https://gitlab.com/protesilaos/modus-themes -;; Version: 2.2.0 +;; Version: 2.3.0 ;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility @@ -56,17 +56,17 @@ (equal (file-name-directory load-file-name) (expand-file-name "themes/" data-directory)) (require-theme 'modus-themes t)) - (require 'modus-themes))) + (require 'modus-themes)) -(deftheme modus-operandi - "Accessible and customizable light theme (WCAG AAA standard). + (deftheme modus-operandi + "Elegant, highly legible and customizable light theme. Conforms with the highest legibility standard for color contrast between background and foreground in any given piece of text, which corresponds to a minimum contrast in relative luminance of -7:1.") +7:1 (WCAG AAA standard).") -(modus-themes-theme modus-operandi) + (modus-themes-theme modus-operandi) -(provide-theme 'modus-operandi) + (provide-theme 'modus-operandi)) ;;; modus-operandi-theme.el ends here diff --git a/etc/themes/modus-themes.el b/etc/themes/modus-themes.el index 067fc22ee4..adec113bd2 100644 --- a/etc/themes/modus-themes.el +++ b/etc/themes/modus-themes.el @@ -1,11 +1,11 @@ -;;; modus-themes.el --- Highly accessible and customizable themes (WCAG AAA) -*- lexical-binding:t -*- +;;; modus-themes.el --- Elegant, highly legible and customizable themes -*- lexical-binding:t -*- ;; Copyright (C) 2019-2022 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou ;; URL: https://gitlab.com/protesilaos/modus-themes -;; Version: 2.2.0 -;; Last-Modified: <2022-02-23 08:56:46 +0200> +;; Version: 2.3.0 +;; Last-Modified: <2022-04-01 12:33:34 +0300> ;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility @@ -41,6 +41,7 @@ ;; modus-themes-bold-constructs (boolean) ;; modus-themes-deuteranopia (boolean) ;; modus-themes-inhibit-reload (boolean) +;; modus-themes-intense-mouseovers (boolean) ;; modus-themes-italic-constructs (boolean) ;; modus-themes-mixed-fonts (boolean) ;; modus-themes-subtle-line-numbers (boolean) @@ -123,6 +124,7 @@ ;; deadgrep ;; debbugs ;; deft +;; devdocs ;; dictionary ;; diff-hl ;; diff-mode @@ -243,6 +245,7 @@ ;; mct ;; mentor ;; messages +;; mini-modeline ;; minimap ;; mmm-mode ;; mode-line @@ -377,7 +380,10 @@ -(eval-when-compile (require 'cl-lib)) +(eval-when-compile + (require 'cl-lib) + (require 'subr-x)) +(require 'seq) (defgroup modus-themes () "Options for `modus-operandi', `modus-vivendi'. @@ -1611,17 +1617,17 @@ The actual styling of the face is done by `modus-themes-faces'." (define-obsolete-face-alias 'modus-themes-completion-standard-first-match - 'modus-themes-completion-selection + 'modus-themes-completion-selected "2.2.0") (define-obsolete-face-alias 'modus-themes-completion-standard-selected - 'modus-themes-completion-selection + 'modus-themes-completion-selected "2.2.0") (define-obsolete-face-alias 'modus-themes-completion-extra-selected - 'modus-themes-completion-selection + 'modus-themes-completion-selected "2.2.0") (define-obsolete-face-alias @@ -1737,10 +1743,7 @@ For form, see `modus-themes-vivendi-colors'." (put 'modus-themes-vivendi-color-overrides 'custom-options (copy-sequence colors))) -(define-obsolete-variable-alias - 'modus-themes-slanted-constructs - 'modus-themes-italic-constructs - "1.5.0") +(defvaralias 'modus-themes-slanted-constructs 'modus-themes-italic-constructs) (defcustom modus-themes-italic-constructs nil "Use italic font forms in more code constructs." @@ -1762,18 +1765,6 @@ For form, see `modus-themes-vivendi-colors'." :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Bold constructs")) -(defcustom modus-themes-variable-pitch-headings nil - "DEPRECATED: specify `variable-pitch' in `modus-themes-headings'." - :group 'modus-themes - :package-version '(modus-themes . "1.0.0") - :version "28.1" - :type 'boolean - :set #'modus-themes--set-option - :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Headings' typeface")) - -(make-obsolete 'modus-themes-variable-pitch-headings 'modus-themes-headings "2.0.0") - (defcustom modus-themes-variable-pitch-ui nil "Use proportional fonts (variable-pitch) in UI elements. This includes the mode line, header line, tab bar, and tab line." @@ -1785,10 +1776,6 @@ This includes the mode line, header line, tab bar, and tab line." :initialize #'custom-initialize-default :link '(info-link "(modus-themes) UI typeface")) -(define-obsolete-variable-alias - 'modus-themes-no-mixed-fonts - 'modus-themes-mixed-fonts "On 2021-10-02 for version 1.7.0") - (defcustom modus-themes-mixed-fonts nil "Non-nil to enable inheritance from `fixed-pitch' in some faces. @@ -1806,6 +1793,19 @@ Users may need to explicitly configure the font family of :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Mixed fonts")) +(defcustom modus-themes-intense-mouseovers nil + "When non-nil use more intense style for mouse hover effects. + +This affects the generic `highlight' face which, strictly +speaking, is not limited to mouse usage." + :group 'modus-themes + :package-version '(modus-themes . "2.3.0") + :version "29.1" + :type 'boolean + :set #'modus-themes--set-option + :initialize #'custom-initialize-default + :link '(info-link "(modus-themes) Mouse hover effects")) + (defconst modus-themes--headings-choice '(set :tag "Properties" :greedy t (const :tag "Background color" background) @@ -1823,7 +1823,11 @@ Users may need to explicitly configure the font family of (const :tag "Semi-bold" semibold) (const :tag "Extra-bold" extrabold) (const :tag "Ultra-bold" ultrabold)) - (float :tag "Number (float) to adjust height by" :value 1.1) + (radio :tag "Height" + (float :tag "Floating point to adjust height by") + (cons :tag "Cons cell of `(height . FLOAT)'" + (const :tag "The `height' key (constant)" height) + (float :tag "Floating point"))) (choice :tag "Colors" (const :tag "Subtle colors" nil) (const :tag "Rainbow colors" rainbow) @@ -1883,7 +1887,9 @@ weight instead. A number, expressed as a floating point (e.g. 1.5), adjusts the height of the heading to that many times the base font size. The default height is the same as 1.0, though it need not be -explicitly stated. +explicitly stated. Instead of a floating point, an acceptable +value can be in the form of a cons cell like (height . FLOAT) +or (height FLOAT), where FLOAT is the given number. Combinations of any of those properties are expressed as a list, like in these examples: @@ -1891,6 +1897,8 @@ like in these examples: (semibold) (rainbow background) (overline monochrome semibold 1.3) + (overline monochrome semibold (height 1.3)) ; same as above + (overline monochrome semibold (height . 1.3)) ; same as above The order in which the properties are set is not significant. @@ -1920,7 +1928,7 @@ For Org users, the extent of the heading depends on the variable and `background' properties. Depending on the version of Org, there may be others, such as `org-fontify-done-headline'." :group 'modus-themes - :package-version '(modus-themes . "2.0.0") + :package-version '(modus-themes . "2.3.0") :version "29.1" :type `(alist :options ,(mapcar (lambda (el) @@ -1954,12 +1962,18 @@ font size. Acceptable values come in the form of a list that can include either or both of those properties: - `variable-pitch' to use a proportionately spaced typeface; + - A number as a floating point (e.g. 1.5) to set the height of the text to that many times the default font height. A float of 1.0 or the symbol `no-scale' have the same effect of making - the font to the same height as the rest of the buffer. When + the font the same height as the rest of the buffer. When neither a number nor `no-scale' are present, the default is a small increase in height (a value of 1.15). + + Instead of a floating point, an acceptable value can be in the + form of a cons cell like (height . FLOAT) or (height FLOAT), + where FLOAT is the given number. + - The symbol of a weight attribute adjusts the font of the heading accordingly, such as `light', `semibold', etc. Valid symbols are defined in the variable `modus-themes-weights'. @@ -1987,17 +2001,24 @@ that can include any of the following properties: - `grayscale' to make weekdays use the main foreground color and weekends a more subtle gray; + - `workaholic' to make weekdays and weekends look the same in terms of color; + - `bold-today' to apply a bold typographic weight to the current date; + - `bold-all' to render all date headings in a bold weight; + - `underline-today' applies an underline to the current date while removing the background it has by default; + - A number as a floating point (e.g. 1.2) to set the height of the text to that many times the default font height. The default is the same as the base font height (the equivalent of - 1.0). + 1.0). Instead of a floating point, an acceptable value can be + in the form of a cons cell like (height . FLOAT) or (height + FLOAT), where FLOAT is the given number. For example: @@ -2085,7 +2106,7 @@ value are passed as a symbol. Those are: highlights the alert and overdue states. - When `modus-themes-deuteranopia' is non-nil the exact style of the habit graph adapts to the needs of users with red-green - colour deficiency by substituting every instance of green with + color deficiency by substituting every instance of green with blue or cyan (depending on the specifics). For example: @@ -2094,7 +2115,7 @@ For example: (habit . simplified) (habit . traffic-light)" :group 'modus-themes - :package-version '(modus-themes . "2.1.0") + :package-version '(modus-themes . "2.3.0") :version "29.1" :type '(set (cons :tag "Block header" @@ -2115,10 +2136,14 @@ For example: (const :tag "Semi-bold" semibold) (const :tag "Extra-bold" extrabold) (const :tag "Ultra-bold" ultrabold)) - (choice :tag "Scaling" + (radio :tag "Scaling" (const :tag "Slight increase in height (default)" nil) (const :tag "Do not scale" no-scale) - (float :tag "Number (float) to adjust height by" :value 1.3)))) + (radio :tag "Number (float) to adjust height by" + (float :tag "Just the number") + (cons :tag "Cons cell of `(height . FLOAT)'" + (const :tag "The `height' key (constant)" height) + (float :tag "Floating point")))))) (cons :tag "Date header" :greedy t (const header-date) (set :tag "Header presentation" :greedy t @@ -2126,8 +2151,12 @@ For example: (const :tag "Do not differentiate weekdays from weekends" workaholic) (const :tag "Make today bold" bold-today) (const :tag "Make all dates bold" bold-all) - (float :tag "Number (float) to adjust height by" :value 1.05) - (const :tag "Make today underlined; remove the background" underline-today))) + (const :tag "Make today underlined; remove the background" underline-today) + (radio :tag "Number (float) to adjust height by" + (float :tag "Just the number") + (cons :tag "Cons cell of `(height . FLOAT)'" + (const :tag "The `height' key (constant)" height) + (float :tag "Floating point"))))) (cons :tag "Event entry" :greedy t (const event) (set :tag "Text presentation" :greedy t @@ -2148,84 +2177,6 @@ For example: :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Org agenda")) -(defcustom modus-themes-scale-headings nil - "DEPRECATED: specify height in `modus-themes-headings'." - :group 'modus-themes - :package-version '(modus-themes . "1.2.0") - :version "28.1" - :type 'boolean - :set #'modus-themes--set-option - :initialize #'custom-initialize-default) - -(make-obsolete 'modus-themes-scale-headings 'modus-themes-headings "2.0.0") - -(defcustom modus-themes-scale-1 1.05 - "DEPRECATED: specify height in `modus-themes-headings'." - :group 'modus-themes - :package-version '(modus-themes . "1.2.0") - :version "28.1" - :type 'number - :set #'modus-themes--set-option - :initialize #'custom-initialize-default) - -(make-obsolete 'modus-themes-scale-1 'modus-themes-headings "2.0.0") - -(defcustom modus-themes-scale-2 1.1 - "DEPRECATED: specify height in `modus-themes-headings'." - :group 'modus-themes - :package-version '(modus-themes . "1.2.0") - :version "28.1" - :type 'number - :set #'modus-themes--set-option - :initialize #'custom-initialize-default) - -(make-obsolete 'modus-themes-scale-2 'modus-themes-headings "2.0.0") - -(defcustom modus-themes-scale-3 1.15 - "DEPRECATED: specify height in `modus-themes-headings'." - :group 'modus-themes - :package-version '(modus-themes . "1.2.0") - :version "28.1" - :type 'number - :set #'modus-themes--set-option - :initialize #'custom-initialize-default) - -(make-obsolete 'modus-themes-scale-3 'modus-themes-headings "2.0.0") - -(defcustom modus-themes-scale-4 1.2 - "DEPRECATED: specify height in `modus-themes-headings'." - :group 'modus-themes - :package-version '(modus-themes . "1.2.0") - :version "28.1" - :type 'number - :set #'modus-themes--set-option - :initialize #'custom-initialize-default) - -(make-obsolete 'modus-themes-scale-4 'modus-themes-headings "2.0.0") - -(defcustom modus-themes-scale-title 1.3 - "DEPRECATED: specify height in `modus-themes-headings'. -Same principle for `modus-themes-org-agenda'." - :group 'modus-themes - :package-version '(modus-themes . "1.5.0") - :version "28.1" - :type 'number - :set #'modus-themes--set-option - :initialize #'custom-initialize-default) - -(make-obsolete 'modus-themes-scale-title 'modus-themes-headings "2.0.0") - -(defcustom modus-themes-scale-small 0.9 - "DEPRECATED." - :group 'modus-themes - :package-version '(modus-themes . "1.6.0") - :version "28.1" - :type 'number - :set #'modus-themes--set-option - :initialize #'custom-initialize-default) - -(make-obsolete 'modus-themes-scale-small nil "2.0.0") - (defcustom modus-themes-fringes nil "Define the visibility of fringes. @@ -2395,6 +2346,17 @@ the `borderless' property is also set). For users on Emacs 29, the `x-use-underline-position-properties' variable must also be set to nil. +The padding can also be expressed as a cons cell in the form +of (padding . NATNUM) or (padding NATNUM) where the key is +constant and NATNUM is the desired natural number. + +A floating point (e.g. 0.9) applies an adjusted height to the +mode line's text as a multiple of the main font size. The +default rate is 1.0 and does not need to be specified. Apart +from a floating point, the height may also be expressed as a cons +cell in the form of (height . FLOAT) or (height FLOAT) where the +key is constant and the FLOAT is the desired number. + Combinations of any of those properties are expressed as a list, like in these examples: @@ -2402,6 +2364,13 @@ like in these examples: (borderless 3d) (moody accented borderless) +Same as above, using the padding and height as an example (these +all yield the same result): + + (accented borderless 4 0.9) + (accented borderless (padding . 4) (height . 0.9)) + (accented borderless (padding 4) (height 0.9)) + The order in which the properties are set is not significant. In user configuration files the form may look like this: @@ -2433,8 +2402,8 @@ Furthermore, because Moody expects an underline and overline instead of a box style, it is strongly advised to set `x-underline-at-descent-line' to a non-nil value." :group 'modus-themes - :package-version '(modus-themes . "1.6.0") - :version "28.1" + :package-version '(modus-themes . "2.3.0") + :version "29.1" :type '(set :tag "Properties" :greedy t (choice :tag "Overall style" (const :tag "Rectangular Border" nil) @@ -2442,23 +2411,20 @@ instead of a box style, it is strongly advised to set (const :tag "No box effects (Moody-compatible)" moody)) (const :tag "Colored background" accented) (const :tag "Without border color" borderless) - (natnum :tag "With extra padding")) + (radio :tag "Padding" + (natnum :tag "Natural number (e.g. 4)") + (cons :tag "Cons cell of `(padding . NATNUM)'" + (const :tag "The `padding' key (constant)" padding) + (natnum :tag "Natural number"))) + (radio :tag "Height" + (float :tag "Floating point (e.g. 0.9)") + (cons :tag "Cons cell of `(height . FLOAT)'" + (const :tag "The `height' key (constant)" height) + (float :tag "Floating point")))) :set #'modus-themes--set-option :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Mode line")) -(defcustom modus-themes-mode-line-padding 6 - "DEPRECATED: Set natural number in `modus-themes-mode-line'." - :group 'modus-themes - :package-version '(modus-themes . "1.7.0") - :version "29.1" - :type 'natnum - :set #'modus-themes--set-option - :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Mode line")) - -(make-obsolete 'modus-themes-mode-line-padding 'modus-themes-mode-line "2.0.0") - (defcustom modus-themes-diffs nil "Adjust the overall style of diffs. @@ -2525,11 +2491,15 @@ regardless of the order they may appear in: The `selection' key applies to the current line or currently matched candidate, depending on the specifics of the User Interface. By default (nil or an empty list), it has a subtle -gray background and a bold weight. The list of properties it -accepts is as follows (order is not significant): +gray background, a bold weight, and the base foreground value +for the text. The list of properties it accepts is as +follows (order is not significant): - `accented' to make the background colorful instead of gray; +- `text-also' to apply extra color to the text of the selected + line; + - `intense' to increase the overall coloration; - `underline' to draw a line below the characters; @@ -2560,7 +2530,8 @@ Is the same as: In the case of the fallback, any property that does not apply to the corresponding key is simply ignored (`matches' does not have -`accented', `selection' and `popup' do not have `background'). +`accented' and `text-also', while `selection' and `popup' do not +have `background'). A concise expression of those associations can be written as follows, where the `car' is always the key and the `cdr' is the @@ -2577,7 +2548,7 @@ node `(modus-themes) Configure bold and italic faces'. Also refer to the Orderless documentation for its intersection with Company (if you choose to use those in tandem)." :group 'modus-themes - :package-version '(modus-themes . "2.2.0") + :package-version '(modus-themes . "2.3.0") :version "29.1" :type `(set (cons :tag "Matches" @@ -2614,6 +2585,7 @@ with Company (if you choose to use those in tandem)." (const :tag "Semi-bold" semibold) (const :tag "Extra-bold" extrabold) (const :tag "Ultra-bold" ultrabold)) + (const :tag "Apply color to the line's text" text-also) (const :tag "With accented background" accented) (const :tag "Increased coloration" intense) (const :tag "Italic font (oblique or slanted forms)" italic) @@ -2633,6 +2605,7 @@ with Company (if you choose to use those in tandem)." (const :tag "Semi-bold" semibold) (const :tag "Extra-bold" extrabold) (const :tag "Ultra-bold" ultrabold)) + (const :tag "Apply color to the line's text" text-also) (const :tag "With accented background" accented) (const :tag "Increased coloration" intense) (const :tag "Italic font (oblique or slanted forms)" italic) @@ -2994,11 +2967,6 @@ In user configuration files the form may look like this: :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Active region")) -(define-obsolete-variable-alias - 'modus-themes-success-deuteranopia - 'modus-themes-deuteranopia - "2.0.0") - (defcustom modus-themes-deuteranopia nil "When non-nil use red/blue color-coding instead of red/green. @@ -3101,14 +3069,23 @@ defined in the variable `modus-themes-weights'. A number, expressed as a floating point (e.g. 0.9), adjusts the height of the button's text to that many times the base font size. The default height is the same as 1.0, though it need not -be explicitly stated. +be explicitly stated. Instead of a floating point, an acceptable +value can be in the form of a cons cell like (height . FLOAT) +or (height FLOAT), where FLOAT is the given number. + +The `all-buttons' property extends the box button effect (or the +aforementioned properties) to the faces of the generic widget +library. By default, those do not look like the buttons of the +Custom UI as they are ordinary text wrapped in square brackets. Combinations of any of those properties are expressed as a list, like in these examples: (flat) (variable-pitch flat) - (variable-pitch flat 0.9 semibold) + (variable-pitch flat semibold 0.9) + (variable-pitch flat semibold (height 0.9)) ; same as above + (variable-pitch flat semibold (height . 0.9)) ; same as above The order in which the properties are set is not significant. @@ -3116,7 +3093,7 @@ In user configuration files the form may look like this: (setq modus-themes-box-buttons (quote (variable-pitch flat 0.9)))" :group 'modus-themes - :package-version '(modus-themes . "2.1.0") + :package-version '(modus-themes . "2.3.0") :version "29.1" :type '(set :tag "Properties" :greedy t (const :tag "Two-dimensional button" flat) @@ -3124,6 +3101,7 @@ In user configuration files the form may look like this: (const :tag "Reduce overall coloration" faint) (const :tag "Proportionately spaced font (variable-pitch)" variable-pitch) (const :tag "Underline instead of a box effect" underline) + (const :tag "Apply box button style to generic widget faces" all-buttons) (choice :tag "Font weight (must be supported by the typeface)" (const :tag "Thin" thin) (const :tag "Ultra-light" ultralight) @@ -3136,7 +3114,11 @@ In user configuration files the form may look like this: (const :tag "Semi-bold" semibold) (const :tag "Extra-bold" extrabold) (const :tag "Ultra-bold" ultrabold)) - (float :tag "Number (float) to adjust height by" :value 0.9)) + (radio :tag "Height" + (float :tag "Floating point to adjust height by") + (cons :tag "Cons cell of `(height . FLOAT)'" + (const :tag "The `height' key (constant)" height) + (float :tag "Floating point")))) :set #'modus-themes--set-option :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Box buttons")) @@ -3145,6 +3127,32 @@ In user configuration files the form may look like this: ;;; Internal functions +(defun modus-themes--warn (option) + "Warn that OPTION has changed." + (prog1 nil + (display-warning + 'modus-themes + (format "`%s' has changed; please read the updated documentation" option) + :warning))) + +(defun modus-themes--list-or-warn (option) + "Return list or nil value of OPTION, else `modus-themes--warn'." + (let* ((value (symbol-value option))) + (if (or (null value) (listp value)) + value + (modus-themes--warn option)))) + +(defun modus-themes--alist-or-seq (properties alist-key seq-pred seq-default) + "Return value from alist or sequence. +Check PROPERTIES for an alist value that corresponds to +ALIST-KEY. If no alist is present, search the PROPERTIES +sequence given SEQ-PRED, using SEQ-DEFAULT as a fallback." + (if-let* ((val (or (alist-get alist-key properties) + (seq-find seq-pred properties seq-default))) + ((listp val))) + (car val) + val)) + (defun modus-themes--palette (theme) "Return color palette for Modus theme THEME. THEME is a symbol, either `modus-operandi' or `modus-vivendi'." @@ -3183,8 +3191,9 @@ Those are stored in `modus-themes-faces' and (custom-theme-set-variables ',name ,@modus-themes-custom-variables)))) (defun modus-themes--current-theme () - "Return current theme." - (car custom-enabled-themes)) + "Return current modus theme." + (car (seq-filter (lambda (arg) (string-match-p "^modus" (symbol-name arg))) + custom-enabled-themes))) ;; Helper functions that are meant to ease the implementation of the ;; above customization variables. @@ -3269,45 +3278,36 @@ pattern and represent a value that is faint or vibrant respectively. INTENSEFG-ALT is used when the intensity is high. SUBTLEBG and INTENSEBG are color-coded background colors that differ in overall intensity. FAINTFG is a nuanced color." - (let ((modus-themes-lang-checkers - (if (listp modus-themes-lang-checkers) - modus-themes-lang-checkers - (pcase modus-themes-lang-checkers - ('colored-background '(background intense)) - ('intense-foreground '(intense)) - ('intense-foreground-straight-underline '(intense straight-underline)) - ('subtle-foreground '(text-also)) - ('subtle-foreground-straight-underline '(text-also straight-underline)) - ('straight-underline '(straight-underline)))))) + (let ((properties (modus-themes--list-or-warn 'modus-themes-lang-checkers))) (list :underline (list :color - (if (memq 'faint modus-themes-lang-checkers) + (if (memq 'faint properties) faintfg underline) :style - (if (memq 'straight-underline modus-themes-lang-checkers) + (if (memq 'straight-underline properties) 'line 'wave)) :background (cond - ((and (memq 'background modus-themes-lang-checkers) - (memq 'faint modus-themes-lang-checkers)) + ((and (memq 'background properties) + (memq 'faint properties)) subtlebg) - ((and (memq 'background modus-themes-lang-checkers) - (memq 'intense modus-themes-lang-checkers)) + ((and (memq 'background properties) + (memq 'intense properties)) intensebg) - ((memq 'background modus-themes-lang-checkers) + ((memq 'background properties) subtlebg) ('unspecified)) :foreground (cond - ((and (memq 'faint modus-themes-lang-checkers) - (memq 'text-also modus-themes-lang-checkers)) + ((and (memq 'faint properties) + (memq 'text-also properties)) faintfg) - ((and (memq 'background modus-themes-lang-checkers) - (memq 'intense modus-themes-lang-checkers)) + ((and (memq 'background properties) + (memq 'intense properties)) intensefg-alt) - ((memq 'intense modus-themes-lang-checkers) + ((memq 'intense properties) intensefg) - ((memq 'text-also modus-themes-lang-checkers) + ((memq 'text-also properties) subtlefg) ('unspecified))))) @@ -3326,7 +3326,7 @@ should be combinable with INTENSEBG-FG. SUBTLEBGGRAY and INTENSEBGGRAY are background values. The former can be combined with GRAYFG, while the latter only works with the theme's fallback text color." - (let ((properties modus-themes-prompts)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-prompts))) (list :foreground (cond ((and (memq 'gray properties) @@ -3372,7 +3372,7 @@ NORMALBG should be the special palette color 'bg-paren-match' or something similar. INTENSEBG must be easier to discern next to other backgrounds, such as the special palette color 'bg-paren-match-intense'." - (let ((properties modus-themes-paren-match)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-paren-match))) (list :inherit (if (memq 'bold properties) 'bold @@ -3390,7 +3390,7 @@ other backgrounds, such as the special palette color "Apply foreground value to code syntax. FG is the default. FAINT is typically the same color in its desaturated version." - (let ((properties modus-themes-syntax)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-syntax))) (list :foreground (cond ((memq 'faint properties) @@ -3402,7 +3402,7 @@ desaturated version." FG is the default. FAINT is typically the same color in its desaturated version. ALT is another hue while optional FAINT-ALT is its subtle alternative." - (let ((properties modus-themes-syntax)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-syntax))) (list :foreground (cond ((and (memq 'alt-syntax properties) @@ -3421,7 +3421,7 @@ desaturated version. GREEN is a color variant in that side of the spectrum. ALT is another hue. Optional FAINT-GREEN is a subtle alternative to GREEN. Optional FAINT-ALT is a subtle alternative to ALT." - (let ((properties modus-themes-syntax)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-syntax))) (list :foreground (cond ((and (memq 'faint properties) @@ -3443,7 +3443,7 @@ alternative to ALT." FG is the default. YELLOW is a color variant of that name while optional FAINT-YELLOW is its subtle variant. Optional FAINT is an alternative to the default value." - (let ((properties modus-themes-syntax)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-syntax))) (list :foreground (cond ((and (memq 'faint properties) @@ -3521,7 +3521,7 @@ that combines well with the background and foreground." fg-alt) (fg)) :height - (seq-find #'floatp properties 'unspecified) + (modus-themes--alist-or-seq properties 'height #'floatp 'unspecified) :weight (or weight 'unspecified) :overline @@ -3546,7 +3546,7 @@ FG is the foreground color to use." (or weight 'unspecified) :height (cond ((memq 'no-scale properties) 'unspecified) - ((seq-find #'floatp properties 1.15))) + ((modus-themes--alist-or-seq properties 'height #'floatp 1.15))) :foreground fg))) (defun modus-themes--agenda-date (defaultfg grayscalefg &optional workaholicfg grayscaleworkaholicfg bg bold ul) @@ -3581,7 +3581,7 @@ weight. Optional UL applies an underline." (t defaultfg)) :height - (seq-find #'floatp properties 'unspecified) + (modus-themes--alist-or-seq properties 'height #'floatp 'unspecified) :underline (if (and ul (memq 'underline-today properties)) t @@ -3711,8 +3711,9 @@ line's box property. Optional FG-DISTANT should be close to the main background values. It is intended to be used as a distant-foreground property." - (let* ((properties modus-themes-mode-line) - (padding (seq-find #'natnump properties 1)) + (let* ((properties (modus-themes--list-or-warn 'modus-themes-mode-line)) + (padding (modus-themes--alist-or-seq properties 'padding #'natnump 1)) + (height (modus-themes--alist-or-seq properties 'height #'floatp 'unspecified)) (padded (> padding 1)) (base (cond ((memq 'accented properties) (cons fg-accent bg-accent)) @@ -3735,6 +3736,7 @@ property." (border)))) (list :foreground (car base) :background (cdr base) + :height height :box (cond ((memq 'moody properties) 'unspecified) @@ -3807,26 +3809,21 @@ unspecified." (list deuteran) (list main))) -(defun modus-themes--completion (key bg fg bgintense fgintense &optional bgaccent bgaccentintense) +(make-obsolete 'modus-themes--completion 'modus-themes--completion-line "2.3.0") +(make-obsolete 'modus-themes--completion 'modus-themes--completion-match "2.3.0") + +(defun modus-themes--completion-line (key bg fg bgintense fgintense &optional bgaccent bgaccentintense) "Styles for `modus-themes-completions'. KEY is the key of a cons cell. BG and FG are the main colors. BGINTENSE works with the main foreground. FGINTENSE works on its own. BGACCENT and BGACCENTINTENSE are colorful variants of the other backgrounds." - (let* ((var (if (listp modus-themes-completions) - modus-themes-completions - (prog1 nil - (warn (concat "`modus-themes-completions' has changed." - "\n" - "Its value must now be an alist." - "\n" - "Please read the updated doc string."))))) + (let* ((var (modus-themes--list-or-warn 'modus-themes-completions)) (properties (or (alist-get key var) (alist-get t var))) (popup (eq key 'popup)) (selection (eq key 'selection)) (line (or popup selection)) - (background (or line (memq 'background properties))) - (base-fg (if selection fg 'unspecified)) + (text (memq 'text-also properties)) (accented (memq 'accented properties)) (intense (memq 'intense properties)) (italic (memq 'italic properties)) @@ -3847,6 +3844,43 @@ other backgrounds." bgaccentintense) ((and accented line) bgaccent) + (intense bgintense) + (bg)) + :foreground + (cond + ((and line text intense) + fgintense) + ((and line text) + fg) + ('unspecified)) + :underline + (if (memq 'underline properties) t 'unspecified) + :weight + (if (and weight (null bold)) weight 'unspecified)))) + +(defun modus-themes--completion-match (key bg fg bgintense fgintense) + "Styles for `modus-themes-completions'. +KEY is the key of a cons cell. BG and FG are the main colors. +BGINTENSE works with the main foreground. FGINTENSE works on its +own." + (let* ((var (modus-themes--list-or-warn 'modus-themes-completions)) + (properties (or (alist-get key var) (alist-get t var))) + (background (memq 'background properties)) + (intense (memq 'intense properties)) + (italic (memq 'italic properties)) + (weight (modus-themes--weight properties)) + (bold (when (and weight (eq weight 'bold)) 'bold))) + (list + :inherit + (cond + ((and italic weight (not (eq weight 'bold))) + 'italic) + ((and weight (not (eq weight 'bold))) + 'unspecified) + (italic 'bold-italic) + ('bold)) + :background + (cond ((and background intense) bgintense) (background bg) @@ -3854,7 +3888,7 @@ other backgrounds." :foreground (cond ((and background intense) - base-fg) + 'unspecified) (background fg) (intense fgintense) (fg)) @@ -3869,7 +3903,7 @@ FG is the link's default color for its text and underline property. FGFAINT is a desaturated color for the text and underline. UNDERLINE is a gray color only for the undeline. BG is a background color and BGNEUTRAL is its fallback value." - (let ((properties modus-themes-links)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-links))) (list :inherit (cond ((and (memq 'bold properties) @@ -3907,7 +3941,7 @@ is a background color and BGNEUTRAL is its fallback value." "Extend `modus-themes--link'. FG is the main accented foreground. FGFAINT is also accented, yet desaturated. Optional NEUTRALFG is a gray value." - (let ((properties modus-themes-links)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-links))) (list :foreground (cond ((memq 'no-color properties) @@ -3931,7 +3965,7 @@ is a subtle background value that can be combined with all colors used to fontify text and code syntax. BGACCENT is a colored background that combines well with FG. BGACCENTSUBTLE can be combined with all colors used to fontify text." - (let ((properties modus-themes-region)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-region))) (list :background (cond ((and (memq 'accented properties) @@ -3967,7 +4001,7 @@ LINEACCENT are color values that can remain distinct against the buffer's possible backgrounds: the former is neutral, the latter is accented. LINENEUTRALINTENSE and LINEACCENTINTENSE are their more prominent alternatives." - (let ((properties modus-themes-hl-line)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-hl-line))) (list :background (cond ((and (memq 'intense properties) @@ -4034,7 +4068,12 @@ application of a variable-pitch font." (defun modus-themes--button (bg bgfaint bgaccent bgaccentfaint border &optional pressed-button-p) "Apply `modus-themes-box-buttons' styles. -Work in progress. BG BGFAINT BGACCENT BGACCENTFAINT BORDER PRESSED-BUTTON-P." +BG is the main background. BGFAINT is its subtle alternative. +BGACCENT is its accented variant and BGACCENTFAINT is the same +but less intense. BORDER is the color around the box. + +When optional PRESSED-BUTTON-P is non-nil, the box uses the +pressed button style, else the released button." (let* ((properties modus-themes-box-buttons) (weight (modus-themes--weight properties))) (list :inherit @@ -4075,7 +4114,7 @@ Work in progress. BG BGFAINT BGACCENT BGACCENTFAINT BORDER PRESSED-BUTTON-P." (weight weight) ('unspecified)) :height - (seq-find #'floatp properties 'unspecified) + (modus-themes--alist-or-seq properties 'height #'floatp 'unspecified) :underline (if (memq 'underline properties) t @@ -4228,30 +4267,6 @@ as when they are declared in the `:config' phase)." (defvar modus-themes-after-load-theme-hook nil "Hook that runs after the `modus-themes-toggle' routines.") -;; The reason we use `load-theme' instead of `enable-theme' is that the -;; former does a kind of "reset" on the face specs. So it plays nicely -;; with `custom-set-faces', as well as defcustom user customizations, -;; including the likes of `modus-themes-operandi-color-overrides'. -;; -;; Tests show that `enable-theme' does not re-read those variables, so -;; it might appear to the unsuspecting user that the themes are somehow -;; broken. -;; -;; This "reset", however, comes at the cost of being a bit slower than -;; `enable-theme'. User who have a stable setup and seldom update their -;; variables during a given Emacs session, are better off using -;; something like this: -;; -;; (defun modus-themes-toggle-enabled () -;; "Toggle between `modus-operandi' and `modus-vivendi' themes." -;; (interactive) -;; (pcase (modus-themes--current-theme) -;; ('modus-operandi (progn (enable-theme 'modus-vivendi) -;; (disable-theme 'modus-operandi))) -;; ('modus-vivendi (progn (enable-theme 'modus-operandi) -;; (disable-theme 'modus-vivendi))) -;; (_ (error "No Modus theme is loaded; evaluate `modus-themes-load-themes' first")))) - ;;;###autoload (defun modus-themes-load-operandi () "Load `modus-operandi' and disable `modus-vivendi'. @@ -4505,30 +4520,30 @@ by virtue of calling either of `modus-themes-load-operandi' and `(modus-themes-tab-inactive ((,class ,@(modus-themes--tab bg-tab-inactive bg-tab-inactive-accent fg-dim nil t)))) ;;;;; completion frameworks `(modus-themes-completion-match-0 - ((,class ,@(modus-themes--completion + ((,class ,@(modus-themes--completion-match 'matches bg-special-faint-calm magenta-alt magenta-subtle-bg magenta-intense)))) `(modus-themes-completion-match-1 - ((,class ,@(modus-themes--completion + ((,class ,@(modus-themes--completion-match 'matches bg-special-faint-cold cyan cyan-subtle-bg cyan-intense)))) `(modus-themes-completion-match-2 - ((,class ,@(modus-themes--completion + ((,class ,@(modus-themes--completion-match 'matches bg-special-faint-mild green green-subtle-bg green-intense)))) `(modus-themes-completion-match-3 - ((,class ,@(modus-themes--completion + ((,class ,@(modus-themes--completion-match 'matches bg-special-faint-warm yellow yellow-subtle-bg orange-intense)))) `(modus-themes-completion-selected - ((,class ,@(modus-themes--completion - 'selection bg-inactive 'unspecified - bg-active 'unspecified + ((,class ,@(modus-themes--completion-line + 'selection bg-inactive blue-alt + bg-active blue-active bg-completion-subtle bg-completion)))) `(modus-themes-completion-selected-popup - ((,class ,@(modus-themes--completion - 'popup bg-active 'unspecified - bg-region 'unspecified + ((,class ,@(modus-themes--completion-line + 'popup bg-active blue-alt + bg-region blue-active cyan-subtle-bg cyan-refine-bg)))) ;;;;; buttons `(modus-themes-box-button @@ -4568,6 +4583,7 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; basic and/or ungrouped styles `(bold ((,class :weight bold))) `(bold-italic ((,class :inherit (bold italic)))) + `(underline ((,class :underline ,fg-alt))) `(buffer-menu-buffer ((,class :inherit bold))) `(child-frame-border ((,class :background ,fg-window-divider-inner))) `(comint-highlight-input ((,class :inherit bold))) @@ -4598,6 +4614,7 @@ by virtue of calling either of `modus-themes-load-operandi' and bg-hl-alt-intense bg-region-accent bg-region-accent-subtle)))) `(secondary-selection ((,class :inherit modus-themes-special-cold))) + `(separator-line ((,class :underline ,bg-region))) `(shadow ((,class :foreground ,fg-alt))) `(success ((,class :inherit (bold modus-themes-grue)))) `(trailing-whitespace ((,class :background ,red-intense-bg))) @@ -4611,8 +4628,12 @@ by virtue of calling either of `modus-themes-load-operandi' and ,@(modus-themes--link-color magenta-alt-other magenta-alt-other-faint fg-alt)))) `(tooltip ((,class :background ,bg-special-cold :foreground ,fg-main))) - `(widget-button ((,class :inherit bold :foreground ,blue-alt))) - `(widget-button-pressed ((,class :inherit widget-button :foreground ,magenta))) + `(widget-button ((,class ,@(if (memq 'all-buttons modus-themes-box-buttons) + (list :inherit 'modus-themes-box-button) + (list :inherit 'bold :foreground blue-alt))))) + `(widget-button-pressed ((,class ,@(if (memq 'all-buttons modus-themes-box-buttons) + (list :inherit 'modus-themes-box-button-pressed) + (list :inherit 'bold :foreground magenta-alt))))) `(widget-documentation ((,class :foreground ,green))) `(widget-field ((,class :background ,bg-alt :foreground ,fg-main :extend nil))) `(widget-inactive ((,class :inherit shadow :background ,bg-dim))) @@ -4724,7 +4745,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(font-latex-string-face ((,class :inherit font-lock-string-face))) `(font-latex-subscript-face ((,class :height 0.95))) `(font-latex-superscript-face ((,class :height 0.95))) - `(font-latex-verbatim-face ((,class :background ,bg-dim :foreground ,fg-special-mild))) + `(font-latex-verbatim-face ((,class :inherit modus-themes-markup-verbatim))) `(font-latex-warning-face ((,class :inherit font-lock-warning-face))) `(tex-match ((,class :foreground ,blue-alt-other))) `(tex-verbatim ((,class :inherit modus-themes-markup-verbatim))) @@ -4737,11 +4758,11 @@ by virtue of calling either of `modus-themes-load-operandi' and `(auto-dim-other-buffers-face ((,class :background ,bg-alt))) ;;;;; avy `(avy-background-face ((,class :background ,bg-dim :foreground ,fg-dim :extend t))) - `(avy-goto-char-timer-face ((,class :inherit (modus-themes-intense-yellow bold)))) - `(avy-lead-face ((,class :inherit (modus-themes-intense-magenta bold modus-themes-reset-soft)))) - `(avy-lead-face-0 ((,class :inherit (modus-themes-refine-cyan bold modus-themes-reset-soft)))) - `(avy-lead-face-1 ((,class :inherit (modus-themes-intense-neutral bold modus-themes-reset-soft)))) - `(avy-lead-face-2 ((,class :inherit (modus-themes-refine-red bold modus-themes-reset-soft)))) + `(avy-goto-char-timer-face ((,class :inherit (modus-themes-intense-neutral bold)))) + `(avy-lead-face ((,class :inherit (modus-themes-intense-blue bold modus-themes-reset-soft)))) + `(avy-lead-face-0 ((,class :inherit (modus-themes-refine-magenta bold modus-themes-reset-soft)))) + `(avy-lead-face-1 ((,class :inherit (modus-themes-special-warm modus-themes-reset-soft)))) + `(avy-lead-face-2 ((,class :inherit (modus-themes-refine-green bold modus-themes-reset-soft)))) ;;;;; aw (ace-window) `(aw-background-face ((,class :foreground ,fg-unfocused))) `(aw-key-face ((,class :inherit modus-themes-key-binding))) @@ -4835,7 +4856,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(centaur-tabs-close-unselected ((,class :inherit centaur-tabs-unselected))) `(centaur-tabs-modified-marker-selected ((,class :inherit centaur-tabs-selected))) `(centaur-tabs-modified-marker-unselected ((,class :inherit centaur-tabs-unselected))) - `(centaur-tabs-default (( ))) + `(centaur-tabs-default ((,class :background ,bg-main))) `(centaur-tabs-selected ((,class :inherit modus-themes-tab-active))) `(centaur-tabs-selected-modified ((,class :inherit (italic centaur-tabs-selected)))) `(centaur-tabs-unselected ((,class :inherit modus-themes-tab-inactive))) @@ -4926,7 +4947,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(company-preview-common ((,class :inherit company-echo-common))) `(company-preview-search ((,class :inherit modus-themes-special-calm))) `(company-template-field ((,class :inherit modus-themes-intense-magenta))) - `(company-tooltip ((,class :background ,bg-alt :foreground ,fg-alt))) + `(company-tooltip ((,class :background ,bg-alt))) `(company-tooltip-annotation ((,class :inherit completions-annotations))) `(company-tooltip-common ((,class :inherit company-echo-common))) `(company-tooltip-deprecated ((,class :inherit company-tooltip :strike-through t))) @@ -5079,6 +5100,8 @@ by virtue of calling either of `modus-themes-load-operandi' and `(deft-summary-face ((,class :inherit (shadow modus-themes-slant)))) `(deft-time-face ((,class :foreground ,fg-special-cold))) `(deft-title-face ((,class :inherit bold :foreground ,fg-main))) +;;;;; devdocs + `(devdocs-code-block ((,class :inherit modus-themes-fixed-pitch :background ,bg-dim :extend t))) ;;;;; dictionary `(dictionary-button-face ((,class :inherit bold :foreground ,fg-special-cold))) `(dictionary-reference-face ((,class :inherit button))) @@ -5224,7 +5247,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(diredp-tagged-autofile-name ((,class :inherit modus-themes-refine-magenta))) `(diredp-write-priv ((,class :foreground ,cyan))) ;;;;; display-fill-column-indicator-mode - `(fill-column-indicator ((,class :foreground ,bg-active))) + `(fill-column-indicator ((,class :height 1 :background ,bg-inactive :foreground ,bg-inactive))) ;;;;; doom-modeline `(doom-modeline-bar ((,class :inherit modus-themes-active-blue))) `(doom-modeline-bar-inactive ((,class :background ,fg-inactive :foreground ,bg-main))) @@ -5341,10 +5364,11 @@ by virtue of calling either of `modus-themes-load-operandi' and `(elpher-gemini-heading3 ((,class :inherit modus-themes-heading-3))) ;;;;; embark `(embark-keybinding ((,class :inherit modus-themes-key-binding))) + `(embark-collect-marked ((,class :inherit modus-themes-mark-sel))) ;;;;; ement (ement.el) `(ement-room-fully-read-marker ((,class :background ,cyan-subtle-bg))) `(ement-room-membership ((,class :inherit shadow))) - `(ement-room-mention (( ))) + `(ement-room-mention ((,class :background ,bg-hl-alt-intense))) `(ement-room-name ((,class :inherit bold))) `(ement-room-reactions ((,class :inherit shadow))) `(ement-room-read-receipt-marker ((,class :background ,yellow-subtle-bg))) @@ -5910,7 +5934,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(hi-red-b ((,class :inherit bold :background ,red-intense-bg :foreground ,fg-main))) `(hi-salmon ((,class :background ,red-subtle-bg :foreground ,fg-main))) `(hi-yellow ((,class :background ,yellow-subtle-bg :foreground ,fg-main))) - `(highlight ((,class :background ,cyan-subtle-bg :foreground ,fg-main))) + `(highlight ((,class ,@(if modus-themes-intense-mouseovers + (list :background blue-intense-bg :foreground fg-main) + (list :background cyan-subtle-bg :foreground fg-main))))) `(highlight-changes ((,class :foreground ,red-alt :underline nil))) `(highlight-changes-delete ((,class :background ,red-nuanced-bg :foreground ,red :underline t))) @@ -5942,7 +5968,7 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; icomplete-vertical `(icomplete-vertical-separator ((,class :inherit shadow))) ;;;;; ido-mode - `(ido-first-match ((,class :inherit modus-themes-completion-selected))) + `(ido-first-match ((,class :inherit modus-themes-completion-match-0))) `(ido-incomplete-regexp ((,class :inherit error))) `(ido-indicator ((,class :inherit modus-themes-subtle-yellow))) `(ido-only-match ((,class :inherit ido-first-match))) @@ -6436,6 +6462,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(message-header-xheader ((,class :foreground ,blue-alt))) `(message-mml ((,class :foreground ,cyan-alt-other))) `(message-separator ((,class :inherit modus-themes-intense-neutral))) +;;;;; mini-modeline + `(mini-modeline-mode-line ((,class :background ,blue-intense :height 0.14))) + `(mini-modeline-mode-line-inactive ((,class :background ,fg-window-divider-inner :height 0.1))) ;;;;; minimap `(minimap-active-region-background ((,class :background ,bg-active))) `(minimap-current-line-face ((,class :background ,cyan-intense-bg :foreground ,fg-main))) @@ -6459,7 +6488,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(mode-line-active ((,class :inherit mode-line))) `(mode-line-buffer-id ((,class :inherit bold))) `(mode-line-emphasis ((,class :inherit bold :foreground ,magenta-active))) - `(mode-line-highlight ((,class :inherit highlight))) + `(mode-line-highlight ((,class ,@(if modus-themes-intense-mouseovers + (list :inherit 'modus-themes-active-blue) + (list :inherit 'highlight))))) `(mode-line-inactive ((,class :inherit modus-themes-ui-variable-pitch ,@(modus-themes--mode-line-attrs fg-inactive bg-inactive @@ -6616,7 +6647,7 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; org `(org-agenda-calendar-event ((,class ,@(modus-themes--agenda-event blue-alt)))) `(org-agenda-calendar-sexp ((,class ,@(modus-themes--agenda-event blue-alt t)))) - `(org-agenda-clocking ((,class :inherit modus-themes-special-cold :extend t))) + `(org-agenda-clocking ((,class :background ,yellow-nuanced-bg :foreground ,red-alt))) `(org-agenda-column-dateline ((,class :background ,bg-alt))) `(org-agenda-current-time ((,class :foreground ,blue-alt-other-faint))) `(org-agenda-date ((,class ,@(modus-themes--agenda-date cyan fg-main)))) @@ -6650,7 +6681,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-checkbox (( ))) `(org-checkbox-statistics-done ((,class :inherit org-done))) `(org-checkbox-statistics-todo ((,class :inherit org-todo))) - `(org-clock-overlay ((,class :inherit modus-themes-special-cold))) + `(org-clock-overlay ((,class :background ,yellow-nuanced-bg :foreground ,red-alt-faint))) `(org-code ((,class :inherit modus-themes-markup-code :extend t))) `(org-column ((,class :inherit (modus-themes-fixed-pitch default) :background ,bg-alt))) @@ -6721,7 +6752,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-hide ((,class :foreground ,bg-main))) `(org-indent ((,class :inherit (fixed-pitch org-hide)))) `(org-imminent-deadline ((,class :foreground ,red-intense))) - `(org-latex-and-related ((,class :foreground ,magenta-refine-fg))) + `(org-latex-and-related ((,class :foreground ,magenta-faint))) `(org-level-1 ((,class :inherit modus-themes-heading-1))) `(org-level-2 ((,class :inherit modus-themes-heading-2))) `(org-level-3 ((,class :inherit modus-themes-heading-3))) @@ -7044,13 +7075,14 @@ by virtue of calling either of `modus-themes-load-operandi' and `(show-paren-match-expression ((,class :background ,bg-paren-expression))) `(show-paren-mismatch ((,class :inherit modus-themes-intense-red))) ;;;;; shr + `(shr-abbreviation ((,class :inherit modus-themes-lang-note))) + `(shr-code ((,class :inherit modus-themes-markup-verbatim))) `(shr-h1 ((,class :inherit modus-themes-heading-1))) `(shr-h2 ((,class :inherit modus-themes-heading-2))) `(shr-h3 ((,class :inherit modus-themes-heading-3))) `(shr-h4 ((,class :inherit modus-themes-heading-4))) `(shr-h5 ((,class :inherit modus-themes-heading-5))) `(shr-h6 ((,class :inherit modus-themes-heading-6))) - `(shr-abbreviation ((,class :inherit modus-themes-lang-note))) `(shr-selected-link ((,class :inherit modus-themes-subtle-red))) ;;;;; side-notes `(side-notes ((,class :background ,bg-dim :foreground ,fg-dim))) @@ -7428,8 +7460,8 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; vertico `(vertico-current ((,class :inherit modus-themes-completion-selected))) ;;;;; vertico-quick - `(vertico-quick1 ((,class :inherit (modus-themes-intense-magenta bold)))) - `(vertico-quick2 ((,class :inherit (modus-themes-refine-cyan bold)))) + `(vertico-quick1 ((,class :inherit (modus-themes-intense-blue bold)))) + `(vertico-quick2 ((,class :inherit (modus-themes-refine-magenta bold)))) ;;;;; vimish-fold `(vimish-fold-fringe ((,class :foreground ,cyan-active))) `(vimish-fold-mouse-face ((,class :inherit modus-themes-intense-blue))) @@ -7645,6 +7677,8 @@ by virtue of calling either of `modus-themes-load-operandi' and ("XXX+" . ,red-alt) ("REVIEW" . ,cyan-alt-other) ("DEPRECATED" . ,blue-nuanced-fg))) +;;;; mini-modeline + `(mini-modeline-face-attr '(:background unspecified)) ;;;; pdf-tools `(pdf-view-midnight-colors '(,fg-main . ,bg-dim)) @@ -7671,6 +7705,20 @@ by virtue of calling either of `modus-themes-load-operandi' and (340 . ,blue-alt-other) (360 . ,magenta-alt-other))) `(vc-annotate-very-old-color nil) +;;;; wid-edit + `(widget-link-prefix ,(if (memq 'all-buttons modus-themes-box-buttons) + " " + "[")) + `(widget-link-suffix ,(if (memq 'all-buttons modus-themes-box-buttons) + " " + "]")) + `(widget-mouse-face '(highlight widget-button)) + `(widget-push-button-prefix ,(if (memq 'all-buttons modus-themes-box-buttons) + " " + "[")) + `(widget-push-button-suffix ,(if (memq 'all-buttons modus-themes-box-buttons) + " " + "]")) ;;;; xterm-color `(xterm-color-names ["black" ,red ,green ,yellow ,blue ,magenta ,cyan "gray65"]) `(xterm-color-names-bright ["gray35" ,red-alt ,green-alt ,yellow-alt ,blue-alt ,magenta-alt ,cyan-alt "white"]) diff --git a/etc/themes/modus-vivendi-theme.el b/etc/themes/modus-vivendi-theme.el index 7d38e5cbf2..fb95772654 100644 --- a/etc/themes/modus-vivendi-theme.el +++ b/etc/themes/modus-vivendi-theme.el @@ -1,10 +1,10 @@ -;;; modus-vivendi-theme.el --- Accessible and customizable dark theme (WCAG AAA) -*- lexical-binding:t -*- +;;; modus-vivendi-theme.el --- Elegant, highly legible and customizable light theme -*- lexical-binding:t -*- ;; Copyright (C) 2019-2022 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou ;; URL: https://gitlab.com/protesilaos/modus-themes -;; Version: 2.2.0 +;; Version: 2.3.0 ;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility @@ -56,17 +56,17 @@ (equal (file-name-directory load-file-name) (expand-file-name "themes/" data-directory)) (require-theme 'modus-themes t)) - (require 'modus-themes))) + (require 'modus-themes)) -(deftheme modus-vivendi - "Accessible and customizable dark theme (WCAG AAA standard). + (deftheme modus-vivendi + "Elegant, highly legible and customizable dark theme. Conforms with the highest legibility standard for color contrast between background and foreground in any given piece of text, which corresponds to a minimum contrast in relative luminance of -7:1.") +7:1 (WCAG AAA standard).") -(modus-themes-theme modus-vivendi) + (modus-themes-theme modus-vivendi) -(provide-theme 'modus-vivendi) + (provide-theme 'modus-vivendi)) ;;; modus-vivendi-theme.el ends here commit 2429b9d8c902a26656e0d600abc1b3740208fa3c Author: Michael Albinus Date: Fri Apr 1 09:01:35 2022 +0200 More robust checks for directory buffers in image-mode * lisp/image-mode.el (image-mode--directory-buffers): Apply more robust checks for directory buffers. (Bug#54606) diff --git a/lisp/image-mode.el b/lisp/image-mode.el index d7dfb4336b..721f2f2bbd 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -1196,8 +1196,9 @@ replacing the current Image mode buffer." "Return an alist of type/buffer for all \"parent\" buffers to image FILE. This is normally a list of Dired buffers, but can also be archive and tar mode buffers." - (let ((buffers nil) - (dir (file-name-directory file))) + (let* ((non-essential t) ; Do not block for remote buffers. + (buffers nil) + (dir (file-name-directory file))) (cond ((and (boundp 'tar-superior-buffer) tar-superior-buffer) @@ -1212,6 +1213,8 @@ tar mode buffers." (dolist (buffer (buffer-list)) (with-current-buffer buffer (when (and (derived-mode-p 'dired-mode) + (equal (file-remote-p dir) + (file-remote-p default-directory)) (equal (file-truename dir) (file-truename default-directory))) (push (cons 'dired (current-buffer)) buffers)))) commit 8c031d8fcf04a9d79f7a1e90bc0c59d27b16e3b8 Author: Po Lu Date: Fri Apr 1 14:13:44 2022 +0800 Only read 16 bytes of motif drag receiver info * src/xterm.c (xm_drag_receiver_info): Only read 16 bytes of receiver info. (handle_one_xevent): Fix default XM drop action. diff --git a/src/xterm.c b/src/xterm.c index b2059e69aa..ed4d0a6d27 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1494,7 +1494,7 @@ xm_read_drag_receiver_info (struct x_display_info *dpyinfo, x_catch_errors (dpyinfo->display); rc = XGetWindowProperty (dpyinfo->display, wdesc, dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, - 0, LONG_MAX, False, + 0, 4, False, dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, &actual_type, &actual_format, &nitems, &bytes_remaining, @@ -14452,7 +14452,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, x_dnd_wanted_action), XM_DROP_SITE_VALID, XM_DRAG_NOOP, - (x_dnd_xm_use_help + (!x_dnd_xm_use_help ? XM_DROP_ACTION_DROP : XM_DROP_ACTION_DROP_HELP)); dmsg.timestamp = event->xbutton.time; @@ -15508,7 +15508,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, XM_DROP_SITE_VALID, xm_side_effect_from_action (dpyinfo, x_dnd_wanted_action), - (x_dnd_xm_use_help + (!x_dnd_xm_use_help ? XM_DROP_ACTION_DROP : XM_DROP_ACTION_DROP_HELP)); dmsg.timestamp = xev->time; commit f8be5eb97fe938483d64691e1ccc3a276f7da3db Author: Po Lu Date: Fri Apr 1 03:59:38 2022 +0000 Simplify Haiku drag-and-drop implementation * lisp/term/haiku-win.el (x-begin-drag): Bind `mouse-highlight' to nil. * src/haikuselect.c (haiku_unwind_drag_message) (Fhaiku_drag_message): * src/haikuterm.h (HAVE_CHAR_CACHE_MAX): * src/xdisp.c (note_mouse_highlight): Delete `haiku_dnd_in_progress' variable. diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index 738cf56caa..810feced21 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -279,6 +279,7 @@ take effect on menu items until the menu bar is updated again." (unless haiku-dnd-selection-value (error "No local value for XdndSelection")) (let ((message nil) + (mouse-highlight nil) (haiku-signal-invalid-refs nil)) (dolist (target targets) (let ((selection-converter (cdr (assoc (intern target) diff --git a/src/haikuselect.c b/src/haikuselect.c index d2582e777f..f6199ccc1e 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -27,7 +27,6 @@ along with GNU Emacs. If not, see . */ #include -bool haiku_dnd_in_progress; static void haiku_lisp_to_message (Lisp_Object, void *); DEFUN ("haiku-selection-data", Fhaiku_selection_data, Shaiku_selection_data, @@ -728,7 +727,6 @@ static void haiku_unwind_drag_message (void *message) { BMessage_delete (message); - haiku_dnd_in_progress = false; } DEFUN ("haiku-drag-message", Fhaiku_drag_message, Shaiku_drag_message, @@ -776,7 +774,6 @@ ignored if it is dropped on top of FRAME. */) if (!FRAME_VISIBLE_P (f)) error ("Frame is invisible"); - haiku_dnd_in_progress = true; be_message = be_create_simple_message (); record_unwind_protect_ptr (haiku_unwind_drag_message, be_message); diff --git a/src/haikuterm.h b/src/haikuterm.h index 86abcc560c..5f8052f0f9 100644 --- a/src/haikuterm.h +++ b/src/haikuterm.h @@ -35,7 +35,6 @@ along with GNU Emacs. If not, see . */ #define HAVE_CHAR_CACHE_MAX 65535 extern int popup_activated_p; -extern bool haiku_dnd_in_progress; extern void be_app_quit (void); diff --git a/src/xdisp.c b/src/xdisp.c index f6fe3253e9..62c8f9d4d9 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -34247,7 +34247,7 @@ note_mouse_highlight (struct frame *f, int x, int y) #endif #if defined (HAVE_HAIKU) - if (popup_activated_p || haiku_dnd_in_progress) + if (popup_activated_p) return; #endif commit 52c31f9e13c349609091620ecf56ac42747c1652 Author: Po Lu Date: Fri Apr 1 11:50:14 2022 +0800 Support Motif DND help * src/xterm.c (x_dnd_xm_use_help): New state variable. (x_dnd_begin_drag_and_drop): Clear new variable. (handle_one_xevent): Set new variable if we get a key press event F1 during the drag-and-drop session, and use help action when dropping onto a Motif program if it is set. diff --git a/src/xterm.c b/src/xterm.c index 07074d19cb..b2059e69aa 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -851,6 +851,7 @@ static bool x_dnd_waiting_for_finish; target to convert one of the special selections XmTRANSFER_SUCCESS or XmTRANSFER_FAILURE. */ static int x_dnd_waiting_for_motif_finish; +static bool x_dnd_xm_use_help; static Window x_dnd_pending_finish_target; static int x_dnd_waiting_for_finish_proto; static bool x_dnd_allow_current_frame; @@ -1011,7 +1012,7 @@ typedef struct xm_drag_receiver_info #define XM_DRAG_LINK (1L << 2) #define XM_DROP_ACTION_DROP 0 -/* #define XM_DROP_ACTION_DROP_HELP 1 */ +#define XM_DROP_ACTION_DROP_HELP 1 #define XM_DROP_ACTION_DROP_CANCEL 2 #define XM_DRAG_REASON(originator, code) ((code) | ((originator) << 7)) @@ -8648,6 +8649,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, x_dnd_return_frame = 0; x_dnd_waiting_for_finish = false; x_dnd_waiting_for_motif_finish = 0; + x_dnd_xm_use_help = false; x_dnd_end_window = None; x_dnd_use_toplevels = x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_client_list_stacking); @@ -12597,7 +12599,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, } if (status != XM_DROP_SITE_VALID - || action == XM_DROP_ACTION_DROP_CANCEL) + || (action == XM_DROP_ACTION_DROP_CANCEL + || action == XM_DROP_ACTION_DROP_HELP)) { x_dnd_waiting_for_finish = false; goto OTHER; @@ -13542,6 +13545,14 @@ handle_one_xevent (struct x_display_info *dpyinfo, &compose_status); #endif +#ifdef XK_F1 + if (x_dnd_in_progress && keysym == XK_F1) + { + x_dnd_xm_use_help = true; + goto done_keysym; + } +#endif + /* If not using XIM/XIC, and a compose sequence is in progress, we break here. Otherwise, chars_matched is always 0. */ if (compose_status.chars_matched > 0 && nbytes == 0) @@ -14441,7 +14452,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, x_dnd_wanted_action), XM_DROP_SITE_VALID, XM_DRAG_NOOP, - XM_DROP_ACTION_DROP); + (x_dnd_xm_use_help + ? XM_DROP_ACTION_DROP + : XM_DROP_ACTION_DROP_HELP)); dmsg.timestamp = event->xbutton.time; dmsg.x = event->xbutton.x_root; dmsg.y = event->xbutton.y_root; @@ -15495,7 +15508,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, XM_DROP_SITE_VALID, xm_side_effect_from_action (dpyinfo, x_dnd_wanted_action), - XM_DROP_ACTION_DROP); + (x_dnd_xm_use_help + ? XM_DROP_ACTION_DROP + : XM_DROP_ACTION_DROP_HELP)); dmsg.timestamp = xev->time; dmsg.x = lrint (xev->root_x); dmsg.y = lrint (xev->root_y); @@ -16115,6 +16130,14 @@ handle_one_xevent (struct x_display_info *dpyinfo, } } +#ifdef XK_F1 + if (x_dnd_in_progress && keysym == XK_F1) + { + x_dnd_xm_use_help = true; + goto xi_done_keysym; + } +#endif + /* First deal with keysyms which have defined translations to characters. */ if (keysym >= 32 && keysym < 128) commit 7378287f598bcfa1450e31fd219e557f02470278 Author: Po Lu Date: Fri Apr 1 10:29:00 2022 +0800 ; * src/xterm.c: Update commentary. diff --git a/src/xterm.c b/src/xterm.c index aec78dece5..07074d19cb 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -496,7 +496,44 @@ along with GNU Emacs. If not, see . */ compositing manager that the contents of the window now accurately reflect the new size. The compositing manager will then display the contents of the window, and the window manager might also postpone - updating the window decorations until this moment. */ + updating the window decorations until this moment. + + DRAG AND DROP + + Drag and drop in Emacs is implemented in two ways, depending on + which side initiated the drag-and-drop operation. When another X + client initiates a drag, and the user drops something on Emacs, a + `drag-n-drop-event' is sent with the contents of the ClientMessage, + and further processing (i.e. retrieving selection contents and + replying to the initiating client) is performed from Lisp inside + `x-dnd.el'. + + However, dragging contents from Emacs is implemented entirely in C. + X Windows has several competing drag-and-drop protocols, of which + Emacs supports two: the XDND protocol (see + https://freedesktop.org/wiki/Specifications/XDND) and the Motif drop + protocol. These protocols are based on the initiator owning a + special selection, specifying an action the recipient should + perform, grabbing the mouse, and sending various different client + messages to the toplevel window underneath the mouse as it moves, or + when buttons are released. + + The Lisp interface to drag-and-drop is synchronous, and involves + running a nested event loop with some global state until the drag + finishes. When the mouse moves, Emacs looks up the toplevel window + underneath the pointer (the target window) either using a cache + provided by window managers that support the + _NET_WM_CLIENT_LIST_STACKING root window property, or by calling + XTranslateCoordinates in a loop until a toplevel window is found, + and sends various entry, exit, or motion events to the window + containing a list of targets the special selection can be converted + to, and the chosen action that the recipient should perform. The + recipient can then send messages in reply detailing the action it + has actually chosen to perform. Finally, when the mouse buttons are + released over the recipient window, Emacs sends a "drop" message to + the target window, waits for a reply, and returns the action + selected by the recipient to the Lisp code that initiated the + drag-and-drop operation. */ #include #include commit 540e7298a96e4e1668bd7f7b5540653391b3f534 Author: Po Lu Date: Fri Apr 1 09:50:58 2022 +0800 Make dropping files on Motif programs work * lisp/dired.el (dired-mouse-drag): Announce "FILE" and "FILE_NAME" as targets as well. * lisp/select.el (xselect-convert-to-filename): Handle XdndSelection specially. (xselect-convert-to-xm-file): New function. (selection-converter-alist): Add new converters. diff --git a/lisp/dired.el b/lisp/dired.el index 0b5f2cab41..0524ac16c2 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1749,8 +1749,8 @@ when Emacs exits or the user drags another file.") (add-hook 'kill-emacs-hook #'dired-remove-last-dragged-local-file)) (gui-backend-set-selection 'XdndSelection filename) - (x-begin-drag '("text/uri-list" - "text/x-dnd-username") + (x-begin-drag '("text/uri-list" "text/x-dnd-username" + "FILE_NAME" "FILE") (if (eq 'dired-mouse-drag-files 'link) 'XdndActionLink 'XdndActionCopy) diff --git a/lisp/select.el b/lisp/select.el index ee65678c69..c352a48261 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -567,9 +567,13 @@ two markers or an overlay. Otherwise, it is nil." ;; done the conversion (and any side-effects) but have no value to return. 'NULL) -(defun xselect-convert-to-filename (_selection _type value) - (when (setq value (xselect--selection-bounds value)) - (xselect--encode-string 'TEXT (buffer-file-name (nth 2 value))))) +(defun xselect-convert-to-filename (selection _type value) + (if (not (eq selection 'XdndSelection)) + (when (setq value (xselect--selection-bounds value)) + (xselect--encode-string 'TEXT (buffer-file-name (nth 2 value)))) + (when (and (stringp value) + (file-exists-p value)) + (xselect--encode-string 'C_STRING value)))) (defun xselect-convert-to-charpos (_selection _type value) (when (setq value (xselect--selection-bounds value)) @@ -648,6 +652,13 @@ This function returns the string \"emacs\"." (concat "file://" (expand-file-name value))) "\n"))) +(defun xselect-convert-to-xm-file (selection _type value) + (when (and (stringp value) + (file-exists-p value) + (eq selection 'XdndSelection)) + (xselect--encode-string 'C_STRING + (concat value [0])))) + (defun xselect-uri-list-available-p (selection _type value) "Return whether or not `text/uri-list' is a valid target for SELECTION. VALUE is the local selection value of SELECTION." @@ -667,6 +678,7 @@ VALUE is the local selection value of SELECTION." (text/plain\;charset=utf-8 . xselect-convert-to-string) (text/uri-list . (xselect-uri-list-available-p . xselect-convert-to-text-uri-list)) (text/x-xdnd-username . xselect-convert-to-username) + (FILE . (xselect-uri-list-available-p . xselect-convert-to-xm-file)) (TARGETS . xselect-convert-to-targets) (LENGTH . xselect-convert-to-length) (DELETE . xselect-convert-to-delete) commit 79b50d0f90707f28d8ce7d83e03c54c3572af782 Author: Po Lu Date: Fri Apr 1 08:47:45 2022 +0800 Avoid extra sync if we didn't get the right wmstate * src/xterm.c (x_dnd_get_wm_state_and_proto): Always set proto version. (x_dnd_get_target_window): Optimize accordingly. diff --git a/src/xterm.c b/src/xterm.c index 3c71ddf395..aec78dece5 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -2164,10 +2164,9 @@ x_dnd_get_wm_state_and_proto (struct x_display_info *dpyinfo, x_uncatch_errors (); if (rc) - { - *wmstate_out = *(unsigned long *) data; - *proto_out = x_dnd_get_window_proto (dpyinfo, window); - } + *wmstate_out = *(unsigned long *) data; + + *proto_out = x_dnd_get_window_proto (dpyinfo, window); if (data) XFree (data); @@ -2210,6 +2209,7 @@ x_dnd_get_wm_state_and_proto (struct x_display_info *dpyinfo, reply = xcb_get_property_reply (dpyinfo->xcb_connection, xdnd_proto_cookie, &error); + *proto_out = -1; if (!reply) free (error); else @@ -2217,8 +2217,6 @@ x_dnd_get_wm_state_and_proto (struct x_display_info *dpyinfo, if (reply->format == 32 && xcb_get_property_value_length (reply) >= 4) *proto_out = *(uint32_t *) xcb_get_property_value (reply); - else - *proto_out = -1; free (reply); } @@ -2359,17 +2357,10 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo, if (child_return) { if (x_dnd_get_wm_state_and_proto (dpyinfo, child_return, - &wmstate, &proto)) - { - *proto_out = proto; - x_uncatch_errors (); - - return child_return; - } - - proto = x_dnd_get_window_proto (dpyinfo, child_return); - - if (proto != -1) + &wmstate, &proto) + /* Proto is set by x_dnd_get_wm_state even if getting + the wm state failed. */ + || proto != -1) { *proto_out = proto; x_uncatch_errors (); commit c3ad47b7e4d6efeebee4ac1d40597700be749c88 Author: Po Lu Date: Fri Apr 1 08:39:40 2022 +0800 Fix a build warning on the non-XI2 build * src/xterm.c (xm_read_drop_start_reply): Take a const XEvent as msg. diff --git a/src/xterm.c b/src/xterm.c index df9fe1fe8c..3c71ddf395 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1413,11 +1413,11 @@ xm_send_drop_message (struct x_display_info *dpyinfo, Window source, } static int -xm_read_drop_start_reply (XEvent *msg, xm_drop_start_reply *reply) +xm_read_drop_start_reply (const XEvent *msg, xm_drop_start_reply *reply) { - uint8_t *data; + const uint8_t *data; - data = (uint8_t *) &msg->xclient.data.b[0]; + data = (const uint8_t *) &msg->xclient.data.b[0]; if ((XM_DRAG_REASON_ORIGINATOR (data[0]) != XM_DRAG_ORIGINATOR_RECEIVER) commit c5af19cba5924de89a38e7a177c07f42fd3cd543 Author: Eli Zaretskii Date: Thu Mar 31 19:15:45 2022 +0300 Fix a bug in configure.ac that failed the --without-x build * configure.ac (USE_TOOLKIT_SCROLL_BARS): Fix test for unsupported scroll-bars configuration. (Bug#54629) diff --git a/configure.ac b/configure.ac index 93c821eda0..254f15bef3 100644 --- a/configure.ac +++ b/configure.ac @@ -3357,7 +3357,7 @@ if test "${with_toolkit_scroll_bars}" != "no"; then AC_DEFINE(USE_TOOLKIT_SCROLL_BARS) USE_TOOLKIT_SCROLL_BARS=yes fi -elif test "${window_system}" != "x11"; then +elif test "${window_system}" != "x11" && "${window_system}" != "none"; then AC_MSG_ERROR(Non-toolkit scroll bars are not implemented for your system) fi commit 948181df9cbdcc8845fc3662e2007d8e09f48c71 Author: Po Lu Date: Thu Mar 31 21:53:04 2022 +0800 Fix Motif DND on window managers that don't support client lists * src/xterm.c (x_dnd_compute_toplevels): Fix usage of `x_uncatch_errors_after_check'. (x_dnd_get_wm_state_and_proto): New function. (x_dnd_get_target_window): Also return first toplevel window found. diff --git a/src/xterm.c b/src/xterm.c index 2f53bb469b..df9fe1fe8c 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1674,7 +1674,7 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) == Success) && !x_had_errors_p (dpyinfo->display) && wmstate_data && wmstate_items == 2 && format == 32); - x_uncatch_errors_after_check (); + x_uncatch_errors (); #else rc = true; @@ -2141,6 +2141,92 @@ x_dnd_get_target_window_1 (struct x_display_info *dpyinfo, return None; } +static int +x_dnd_get_wm_state_and_proto (struct x_display_info *dpyinfo, + Window window, int *wmstate_out, + int *proto_out) +{ +#ifndef USE_XCB + Atom type; + int format, rc; + unsigned long nitems, bytes_after; + unsigned char *data = NULL; + + x_catch_errors (dpyinfo->display); + rc = ((XGetWindowProperty (dpyinfo->display, window, + dpyinfo->Xatom_wm_state, + 0, 2, False, AnyPropertyType, + &type, &format, &nitems, + &bytes_after, &data) + == Success) + && !x_had_errors_p (dpyinfo->display) + && data && nitems == 2 && format == 32); + x_uncatch_errors (); + + if (rc) + { + *wmstate_out = *(unsigned long *) data; + *proto_out = x_dnd_get_window_proto (dpyinfo, window); + } + + if (data) + XFree (data); + + return rc; +#else + xcb_get_property_cookie_t wmstate_cookie; + xcb_get_property_cookie_t xdnd_proto_cookie; + xcb_get_property_reply_t *reply; + xcb_generic_error_t *error; + int rc; + + rc = true; + + wmstate_cookie = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) window, + (xcb_atom_t) dpyinfo->Xatom_wm_state, + XCB_ATOM_ANY, 0, 2); + xdnd_proto_cookie = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) window, + (xcb_atom_t) dpyinfo->Xatom_XdndAware, + XCB_ATOM_ATOM, 0, 1); + + reply = xcb_get_property_reply (dpyinfo->xcb_connection, + wmstate_cookie, &error); + + if (!reply) + free (error), rc = false; + else + { + if (reply->format != 32 + || xcb_get_property_value_length (reply) != 8) + rc = false; + else + *wmstate_out = *(uint32_t *) xcb_get_property_value (reply); + + free (reply); + } + + reply = xcb_get_property_reply (dpyinfo->xcb_connection, + xdnd_proto_cookie, &error); + + if (!reply) + free (error); + else + { + if (reply->format == 32 + && xcb_get_property_value_length (reply) >= 4) + *proto_out = *(uint32_t *) xcb_get_property_value (reply); + else + *proto_out = -1; + + free (reply); + } + + return rc; +#endif +} + static Window x_dnd_get_target_window (struct x_display_info *dpyinfo, int root_x, int root_y, int *proto_out) @@ -2151,6 +2237,8 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo, Window overlay_window; XWindowAttributes attrs; #endif + int wmstate; + child_return = dpyinfo->root_window; dest_x_return = root_x; dest_y_return = root_y; @@ -2270,6 +2358,15 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo, if (child_return) { + if (x_dnd_get_wm_state_and_proto (dpyinfo, child_return, + &wmstate, &proto)) + { + *proto_out = proto; + x_uncatch_errors (); + + return child_return; + } + proto = x_dnd_get_window_proto (dpyinfo, child_return); if (proto != -1) commit 1bd14387027d5fa93ccbc38b6e4ce715c916bbc6 Author: Po Lu Date: Thu Mar 31 21:28:09 2022 +0800 Implement missing parts of the Motif drag and drop protocol * src/xterm.c (xm_drop_start_reply): New structure. (xm_get_drag_window): Don't grab the server since this leads to weird freezes when creating the drag window. (xm_read_drop_start_reply): New function. (x_dnd_begin_drag_and_drop): Set Motif finish flag to 0. (handle_one_xevent): When starting a motif drop, set the finish flag to 1. When the receiver replies to our drop message, set the finish flag to 2 if the drop was accepted, and only clear the waiting for finish flag when a selection request for XmTRANSFER_SUCCESS or XmTRANSFER_FAILURE arrives. (x_term_init): New atoms. * src/xterm.h (struct x_display_info): New atoms. diff --git a/src/xterm.c b/src/xterm.c index 81b84c8609..2f53bb469b 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -807,6 +807,13 @@ static int x_filter_event (struct x_display_info *, XEvent *); static bool x_dnd_in_progress; static bool x_dnd_waiting_for_finish; +/* 0 means nothing has happened. 1 means an XmDROP_START message was + sent to the target, but no response has yet been received. 2 means + a response to our XmDROP_START message was received and the target + accepted the drop, so Emacs should start waiting for the drop + target to convert one of the special selections XmTRANSFER_SUCCESS + or XmTRANSFER_FAILURE. */ +static int x_dnd_waiting_for_motif_finish; static Window x_dnd_pending_finish_target; static int x_dnd_waiting_for_finish_proto; static bool x_dnd_allow_current_frame; @@ -920,6 +927,16 @@ typedef struct xm_drop_start_message /* CARD32 */ uint32_t source_window; } xm_drop_start_message; +typedef struct xm_drop_start_reply +{ + /* BYTE */ uint8_t reason; + /* BYTE */ uint8_t byte_order; + + /* CARD16 */ uint16_t side_effects; + /* CARD16 */ uint16_t better_x; + /* CARD16 */ uint16_t better_y; +} xm_drop_start_reply; + typedef struct xm_drag_initiator_info { /* BYTE */ uint8_t byteorder; @@ -942,33 +959,38 @@ typedef struct xm_drag_receiver_info } xm_drag_receiver_info; #define XM_DRAG_SIDE_EFFECT(op, site, ops, act) \ - ((op) | ((site) << 4) | ((ops) << 8) | ((act) << 16)) + ((op) | ((site) << 4) | ((ops) << 8) | ((act) << 12)) /* Some of the macros below are temporarily unused. */ -/* #define XM_DRAG_SIDE_EFFECT_OPERATION(effect) ((effect) & 0xf) */ -/* #define XM_DRAG_SIDE_EFFECT_SITE_STATUS(effect) (((effect) & 0xf0) >> 4) */ +#define XM_DRAG_SIDE_EFFECT_OPERATION(effect) ((effect) & 0xf) +#define XM_DRAG_SIDE_EFFECT_SITE_STATUS(effect) (((effect) & 0xf0) >> 4) /* #define XM_DRAG_SIDE_EFFECT_OPERATIONS(effect) (((effect) & 0xf00) >> 8) */ -/* #define XM_DRAG_SIDE_EFFECT_DROP_ACTION(effect) (((effect) & 0xf000) >> 16) */ +#define XM_DRAG_SIDE_EFFECT_DROP_ACTION(effect) (((effect) & 0xf000) >> 12) #define XM_DRAG_NOOP 0 #define XM_DRAG_MOVE (1L << 0) #define XM_DRAG_COPY (1L << 1) #define XM_DRAG_LINK (1L << 2) -#define XM_DROP_ACTION_DROP 0 -#define XM_DROP_SITE_VALID 1 +#define XM_DROP_ACTION_DROP 0 +/* #define XM_DROP_ACTION_DROP_HELP 1 */ +#define XM_DROP_ACTION_DROP_CANCEL 2 #define XM_DRAG_REASON(originator, code) ((code) | ((originator) << 7)) -/* #define XM_DRAG_REASON_ORIGINATOR(reason) (((reason) & 0x80) ? 1 : 0) */ -/* #define XM_DRAG_REASON_CODE(reason) ((reason) & 0x7f) */ +#define XM_DRAG_REASON_ORIGINATOR(reason) (((reason) & 0x80) ? 1 : 0) +#define XM_DRAG_REASON_CODE(reason) ((reason) & 0x7f) #define XM_DRAG_REASON_DROP_START 5 #define XM_DRAG_ORIGINATOR_INITIATOR 0 -/* #define XM_DRAG_ORIGINATOR_RECEIVER 1 */ +#define XM_DRAG_ORIGINATOR_RECEIVER 1 #define XM_DRAG_STYLE_NONE 0 +#define XM_DROP_SITE_VALID 3 +/* #define XM_DROP_SITE_INVALID 2 */ +/* #define XM_DROP_SITE_NONE 1 */ + static uint8_t xm_side_effect_from_action (struct x_display_info *dpyinfo, Atom action) { @@ -1150,7 +1172,6 @@ xm_get_drag_window (struct x_display_info *dpyinfo) Display *temp_display; drag_window = None; - XGrabServer (dpyinfo->display); rc = XGetWindowProperty (dpyinfo->display, dpyinfo->root_window, dpyinfo->Xatom_MOTIF_DRAG_WINDOW, 0, 1, False, XA_WINDOW, &actual_type, @@ -1177,8 +1198,6 @@ xm_get_drag_window (struct x_display_info *dpyinfo) XFree (tmp_data); } - XUngrabServer (dpyinfo->display); - if (drag_window == None) { unrequest_sigio (); @@ -1189,8 +1208,6 @@ xm_get_drag_window (struct x_display_info *dpyinfo) return None; XSetCloseDownMode (temp_display, RetainPermanent); - - XGrabServer (temp_display); attrs.override_redirect = True; drag_window = XCreateWindow (temp_display, DefaultRootWindow (temp_display), -1, -1, 1, 1, 0, CopyFromParent, InputOnly, @@ -1200,7 +1217,6 @@ xm_get_drag_window (struct x_display_info *dpyinfo) "_MOTIF_DRAG_WINDOW", False), XA_WINDOW, 32, PropModeReplace, (unsigned char *) &drag_window, 1); - XUngrabServer (temp_display); XCloseDisplay (temp_display); /* Make sure the drag window created is actually valid for the @@ -1396,6 +1412,37 @@ xm_send_drop_message (struct x_display_info *dpyinfo, Window source, x_uncatch_errors (); } +static int +xm_read_drop_start_reply (XEvent *msg, xm_drop_start_reply *reply) +{ + uint8_t *data; + + data = (uint8_t *) &msg->xclient.data.b[0]; + + if ((XM_DRAG_REASON_ORIGINATOR (data[0]) + != XM_DRAG_ORIGINATOR_RECEIVER) + || (XM_DRAG_REASON_CODE (data[0]) + != XM_DRAG_REASON_DROP_START)) + return 1; + + reply->reason = *(data++); + reply->byte_order = *(data++); + reply->side_effects = *(uint16_t *) data; + reply->better_x = *(uint16_t *) (data + 2); + reply->better_y = *(uint16_t *) (data + 4); + + if (reply->byte_order != XM_TARGETS_TABLE_CUR) + { + SWAPCARD16 (reply->side_effects); + SWAPCARD16 (reply->better_x); + SWAPCARD16 (reply->better_y); + } + + reply->byte_order = XM_TARGETS_TABLE_CUR; + + return 0; +} + static int xm_read_drag_receiver_info (struct x_display_info *dpyinfo, Window wdesc, xm_drag_receiver_info *rec) @@ -8475,6 +8522,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, x_dnd_wanted_action = xaction; x_dnd_return_frame = 0; x_dnd_waiting_for_finish = false; + x_dnd_waiting_for_motif_finish = 0; x_dnd_end_window = None; x_dnd_use_toplevels = x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_client_list_stacking); @@ -12384,7 +12432,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, } if (event->xclient.message_type == dpyinfo->Xatom_XdndFinished - && x_dnd_waiting_for_finish + && (x_dnd_waiting_for_finish && !x_dnd_waiting_for_motif_finish) && event->xclient.data.l[0] == x_dnd_pending_finish_target) { x_dnd_waiting_for_finish = false; @@ -12397,6 +12445,59 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_dnd_action = None; } + if ((event->xclient.message_type + == dpyinfo->Xatom_MOTIF_DRAG_AND_DROP_MESSAGE) + /* FIXME: There should probably be a check that the event + comes from the same display where the drop event was + sent, but there's no way to get that information here + safely. */ + && x_dnd_waiting_for_finish + && x_dnd_waiting_for_motif_finish == 1) + { + xm_drop_start_reply reply; + uint16_t operation, status, action; + + if (!xm_read_drop_start_reply (event, &reply)) + { + operation = XM_DRAG_SIDE_EFFECT_OPERATION (reply.side_effects); + status = XM_DRAG_SIDE_EFFECT_SITE_STATUS (reply.side_effects); + action = XM_DRAG_SIDE_EFFECT_DROP_ACTION (reply.side_effects); + + if (operation != XM_DRAG_MOVE + && operation != XM_DRAG_COPY + && operation != XM_DRAG_LINK) + { + x_dnd_waiting_for_finish = false; + goto OTHER; + } + + if (status != XM_DROP_SITE_VALID + || action == XM_DROP_ACTION_DROP_CANCEL) + { + x_dnd_waiting_for_finish = false; + goto OTHER; + } + + switch (operation) + { + case XM_DRAG_MOVE: + x_dnd_action = dpyinfo->Xatom_XdndActionMove; + break; + + case XM_DRAG_COPY: + x_dnd_action = dpyinfo->Xatom_XdndActionCopy; + break; + + case XM_DRAG_LINK: + x_dnd_action = dpyinfo->Xatom_XdndActionLink; + break; + } + + x_dnd_waiting_for_motif_finish = 2; + goto OTHER; + } + } + if (event->xclient.message_type == dpyinfo->Xatom_wm_protocols && event->xclient.format == 32) { @@ -12703,6 +12804,13 @@ handle_one_xevent (struct x_display_info *dpyinfo, *hold_quit = inev.ie; EVENT_INIT (inev.ie); } + + if (x_dnd_waiting_for_finish + && x_dnd_waiting_for_motif_finish == 2 + && eventp->selection == dpyinfo->Xatom_XdndSelection + && (eventp->target == dpyinfo->Xatom_XmTRANSFER_SUCCESS + || eventp->target == dpyinfo->Xatom_XmTRANSFER_FAILURE)) + x_dnd_waiting_for_finish = false; } break; @@ -14197,7 +14305,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, xm_write_drag_initiator_info (dpyinfo->display, FRAME_X_WINDOW (x_dnd_frame), - dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, + dpyinfo->Xatom_XdndSelection, dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, &drag_initiator_info); @@ -14207,18 +14315,19 @@ handle_one_xevent (struct x_display_info *dpyinfo, dmsg.side_effects = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, x_dnd_wanted_action), - XM_DROP_SITE_VALID, - xm_side_effect_from_action (dpyinfo, - x_dnd_wanted_action), + XM_DROP_SITE_VALID, XM_DRAG_NOOP, XM_DROP_ACTION_DROP); dmsg.timestamp = event->xbutton.time; dmsg.x = event->xbutton.x_root; dmsg.y = event->xbutton.y_root; - dmsg.index_atom = dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO; + dmsg.index_atom = dpyinfo->Xatom_XdndSelection; dmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), x_dnd_last_seen_window, &dmsg); + + x_dnd_waiting_for_finish = true; + x_dnd_waiting_for_motif_finish = 1; } } } @@ -15248,7 +15357,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, xm_write_drag_initiator_info (dpyinfo->display, FRAME_X_WINDOW (x_dnd_frame), - dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, + dpyinfo->Xatom_XdndSelection, dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, &drag_initiator_info); @@ -15265,11 +15374,23 @@ handle_one_xevent (struct x_display_info *dpyinfo, dmsg.timestamp = xev->time; dmsg.x = lrint (xev->root_x); dmsg.y = lrint (xev->root_y); - dmsg.index_atom = dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO; + /* This atom technically has to be + unique to each drag-and-drop + operation, but that isn't easy to + accomplish, since we cannot + randomly move data around between + selections. Let's hope no two + instances of Emacs try to drag + into the same window at the same + time. */ + dmsg.index_atom = dpyinfo->Xatom_XdndSelection; dmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), x_dnd_last_seen_window, &dmsg); + + x_dnd_waiting_for_finish = true; + x_dnd_waiting_for_motif_finish = 1; } } } @@ -21140,6 +21261,8 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) Xatom_MOTIF_DRAG_INITIATOR_INFO) ATOM_REFS_INIT ("_MOTIF_DRAG_RECEIVER_INFO", Xatom_MOTIF_DRAG_RECEIVER_INFO) + ATOM_REFS_INIT ("XmTRANSFER_SUCCESS", Xatom_XmTRANSFER_SUCCESS) + ATOM_REFS_INIT ("XmTRANSFER_FAILURE", Xatom_XmTRANSFER_FAILURE) }; int i; diff --git a/src/xterm.h b/src/xterm.h index eb9e25d3cd..062b34b35c 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -437,6 +437,8 @@ struct x_display_info Xatom_MOTIF_DRAG_TARGETS, Xatom_MOTIF_DRAG_AND_DROP_MESSAGE, Xatom_MOTIF_DRAG_INITIATOR_INFO, Xatom_MOTIF_DRAG_RECEIVER_INFO; + Atom Xatom_XmTRANSFER_SUCCESS, Xatom_XmTRANSFER_FAILURE; + /* The frame (if any) which has the X window that has keyboard focus. Zero if none. This is examined by Ffocus_frame in xfns.c. Note that a mere EnterNotify event can set this; if you need to know the commit af0ea35ea00725d2700a5215b56b725dc0d88d0d Author: Lars Ingebrigtsen Date: Thu Mar 31 13:36:40 2022 +0200 Tweak how functions are formatted in Implementation in *Help* * lisp/emacs-lisp/cl-generic.el (cl--generic-describe): Include the function name in the implementations (bug#54628). This clarifies what we're talking about here, and avoids getting (function ...) translated into #'... diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 279f73f36a..5cbdb9523a 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1098,7 +1098,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (dolist (method (cl--generic-method-table generic)) (let* ((info (cl--generic-method-info method))) ;; FIXME: Add hyperlinks for the types as well. - (insert (format "%s%S" (nth 0 info) (nth 1 info))) + (insert (format "%s%S" (nth 0 info) (cons function (nth 1 info)))) (let* ((met-name (cl--generic-load-hist-format function (cl--generic-method-qualifiers method) commit ce1f7f2467a59924134a89f61debd5a0a59a73ea Author: Po Lu Date: Thu Mar 31 18:52:01 2022 +0800 Minor fixes to treatment of `allow_current_frame' * src/xterm.c (x_dnd_send_drop): Don't send special event for wrong frame. (x_dnd_send_drop): Fix condition for returning XdndActionPrivate. diff --git a/src/xterm.c b/src/xterm.c index 6a19828a36..81b84c8609 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -2502,6 +2502,10 @@ x_dnd_send_drop (struct frame *f, Window target, Time timestamp, if (self_frame) { + if (!x_dnd_allow_current_frame + && self_frame == x_dnd_frame) + return false; + /* Send a special drag-and-drop event when dropping on top of an Emacs frame to avoid all the overhead involved with sending client events. */ @@ -8625,7 +8629,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, if (x_dnd_end_window != None && (any = x_any_window_to_frame (FRAME_DISPLAY_INFO (f), x_dnd_end_window)) - && (any != f)) + && (allow_current_frame || any != f)) return QXdndActionPrivate; if (x_dnd_action != None) commit c1792c51de30d161131753181db2cfdc3cd70eaf Author: Po Lu Date: Thu Mar 31 17:30:13 2022 +0800 ; * src/xterm.c (handle_one_xevent): Respect current window in Motif DND. diff --git a/src/xterm.c b/src/xterm.c index bd5d756c8c..6a19828a36 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -14166,62 +14166,64 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_dnd_selection_timestamp, x_dnd_last_protocol_version); } + else if (x_dnd_last_seen_window != None) + { + xm_drag_receiver_info drag_receiver_info; + xm_drag_initiator_info drag_initiator_info; + xm_drop_start_message dmsg; + int idx; + + if (!xm_read_drag_receiver_info (dpyinfo, x_dnd_last_seen_window, + &drag_receiver_info) + && drag_receiver_info.protocol_style != XM_DRAG_STYLE_NONE + && (x_dnd_allow_current_frame + || FRAME_OUTER_WINDOW (x_dnd_frame) != x_dnd_last_seen_window)) + { + idx = xm_setup_dnd_targets (dpyinfo, x_dnd_targets, + x_dnd_n_targets); + + if (idx != -1) + { + drag_initiator_info.byteorder = XM_TARGETS_TABLE_CUR; + drag_initiator_info.protocol = 0; + drag_initiator_info.table_index = idx; + drag_initiator_info.selection = dpyinfo->Xatom_XdndSelection; + + memset (&dmsg, 0, sizeof dmsg); + + xm_write_drag_initiator_info (dpyinfo->display, + FRAME_X_WINDOW (x_dnd_frame), + dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, + dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, + &drag_initiator_info); + + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DROP_START); + dmsg.byte_order = XM_TARGETS_TABLE_CUR; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_ACTION_DROP); + dmsg.timestamp = event->xbutton.time; + dmsg.x = event->xbutton.x_root; + dmsg.y = event->xbutton.y_root; + dmsg.index_atom = dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO; + dmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &dmsg); + } + } + } x_dnd_last_protocol_version = -1; x_dnd_last_seen_window = None; x_dnd_frame = NULL; x_set_dnd_targets (NULL, 0); } - else if (x_dnd_last_seen_window != None) - { - xm_drag_receiver_info drag_receiver_info; - xm_drag_initiator_info drag_initiator_info; - xm_drop_start_message dmsg; - int idx; - - if (!xm_read_drag_receiver_info (dpyinfo, x_dnd_last_seen_window, - &drag_receiver_info) - && drag_receiver_info.protocol_style != XM_DRAG_STYLE_NONE) - { - idx = xm_setup_dnd_targets (dpyinfo, x_dnd_targets, - x_dnd_n_targets); - - if (idx != -1) - { - drag_initiator_info.byteorder = XM_TARGETS_TABLE_CUR; - drag_initiator_info.protocol = 0; - drag_initiator_info.table_index = idx; - drag_initiator_info.selection = dpyinfo->Xatom_XdndSelection; - - memset (&dmsg, 0, sizeof dmsg); - - xm_write_drag_initiator_info (dpyinfo->display, - FRAME_X_WINDOW (x_dnd_frame), - dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, - dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, - &drag_initiator_info); - - dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, - XM_DRAG_REASON_DROP_START); - dmsg.byte_order = XM_TARGETS_TABLE_CUR; - dmsg.side_effects - = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, - x_dnd_wanted_action), - XM_DROP_SITE_VALID, - xm_side_effect_from_action (dpyinfo, - x_dnd_wanted_action), - XM_DROP_ACTION_DROP); - dmsg.timestamp = event->xbutton.time; - dmsg.x = event->xbutton.x_root; - dmsg.y = event->xbutton.y_root; - dmsg.index_atom = dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO; - dmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); - - xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), - x_dnd_last_seen_window, &dmsg); - } - } - } goto OTHER; } @@ -15224,7 +15226,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (!xm_read_drag_receiver_info (dpyinfo, x_dnd_last_seen_window, &drag_receiver_info) - && drag_receiver_info.protocol_style != XM_DRAG_STYLE_NONE) + && drag_receiver_info.protocol_style != XM_DRAG_STYLE_NONE + && (x_dnd_allow_current_frame + || FRAME_OUTER_WINDOW (x_dnd_frame) != x_dnd_last_seen_window)) { idx = xm_setup_dnd_targets (dpyinfo, x_dnd_targets, x_dnd_n_targets); commit 1d4306a8a770cb73db3b39301ee41e15f9e3656f Author: Po Lu Date: Thu Mar 31 17:21:37 2022 +0800 Implement Motif drop protocol This is the second most widely implemented drag-and-drop protocol on X Windows, but seems to have some unsolvable problems (i.e. stuff will keep accumulating in the drag window as long the target lists keep changing.) The implementation is not yet complete and doesn't work with some programs. * lisp/select.el (xselect-convert-xm-special): New functions. (selection-converter-alist): Add new converters. * lisp/x-dnd.el (x-dnd-handle-motif): Ignore messages sent by the receiver. * src/xterm.c (xm_targets_table_byte_order): New enum; (SWAPCARD32, SWAPCARD16): New macros. (xm_targets_table_rec, xm_drop_start_message) (xm_drag_initiator_info, xm_drag_receiver_info): New structures. (XM_DRAG_SIDE_EFFECT, xm_read_targets_table_header) (xm_read_targets_table_rec, xm_find_targets_table_idx) (x_atoms_compare, xm_write_targets_table) (xm_write_drag_initiator_info, xm_get_drag_window) (xm_setup_dnd_targets, xm_send_drop_message) (xm_read_drag_receiver_info): New functions. (x_dnd_compute_toplevels): Correctly free some temp data. (x_dnd_get_window_proxy, x_dnd_get_window_proto) (x_set_frame_alpha): Likewise. (handle_one_xevent): If the window has no XDND proto but has motif drag receiver data, send a motif drop protocol request. (x_term_init): New atoms for Motif DND support. * src/xterm.h (struct x_display_info): Add new atoms. diff --git a/lisp/select.el b/lisp/select.el index 7b9475a640..ee65678c69 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -655,6 +655,9 @@ VALUE is the local selection value of SELECTION." (stringp value) (file-exists-p value))) +(defun xselect-convert-xm-special (_selection _type _value) + "") + (setq selection-converter-alist '((TEXT . xselect-convert-to-string) (COMPOUND_TEXT . xselect-convert-to-string) @@ -679,7 +682,9 @@ VALUE is the local selection value of SELECTION." (ATOM . xselect-convert-to-atom) (INTEGER . xselect-convert-to-integer) (SAVE_TARGETS . xselect-convert-to-save-targets) - (_EMACS_INTERNAL . xselect-convert-to-identity))) + (_EMACS_INTERNAL . xselect-convert-to-identity) + (XmTRANSFER_SUCCESS . xselect-convert-xm-special) + (XmTRANSFER_FAILURE . xselect-convert-xm-special))) (provide 'select) diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index 17e65adc64..e26703ad84 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -603,174 +603,177 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." (2 . private)) ; Motif does not have private, so use copy for private. "Mapping from number to operation for Motif DND.") -(defun x-dnd-handle-motif (event frame window message-atom _format data) - (let* ((message-type (cdr (assoc (aref data 0) x-dnd-motif-message-types))) +(defun x-dnd-handle-motif (event frame window _message-atom _format data) + (let* ((message-type (cdr (assoc (logand (aref data 0) #x3f) + x-dnd-motif-message-types))) + (initiator-p (eq (lsh (aref data 0) -7) 0)) (source-byteorder (aref data 1)) (my-byteorder (byteorder)) (source-flags (x-dnd-get-motif-value data 2 2 source-byteorder)) (source-action (cdr (assoc (logand ?\xF source-flags) x-dnd-motif-to-action)))) - (cond ((eq message-type 'XmTOP_LEVEL_ENTER) - (let* ((dnd-source (x-dnd-get-motif-value - data 8 4 source-byteorder)) - (selection-atom (x-dnd-get-motif-value - data 12 4 source-byteorder)) - (atom-name (x-get-atom-name selection-atom)) - (types (when atom-name - (x-get-selection-internal (intern atom-name) - 'TARGETS)))) - (x-dnd-forget-drop frame) - (when types (x-dnd-save-state window nil nil - types - dnd-source)))) - - ;; Can not forget drop here, LEAVE comes before DROP_START and - ;; we need the state in DROP_START. - ((eq message-type 'XmTOP_LEVEL_LEAVE) - nil) - - ((eq message-type 'XmDRAG_MOTION) - (let* ((state (x-dnd-get-state-for-frame frame)) - (timestamp (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 4 4 - source-byteorder) - 4 my-byteorder)) - (x (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 8 2 source-byteorder) + (when initiator-p + (cond ((eq message-type 'XmTOP_LEVEL_ENTER) + (let* ((dnd-source (x-dnd-get-motif-value + data 8 4 source-byteorder)) + (selection-atom (x-dnd-get-motif-value + data 12 4 source-byteorder)) + (atom-name (x-get-atom-name selection-atom)) + (types (when atom-name + (x-get-selection-internal (intern atom-name) + 'TARGETS)))) + (x-dnd-forget-drop frame) + (when types (x-dnd-save-state window nil nil + types + dnd-source)))) + + ;; Can not forget drop here, LEAVE comes before DROP_START and + ;; we need the state in DROP_START. + ((eq message-type 'XmTOP_LEVEL_LEAVE) + nil) + + ((eq message-type 'XmDRAG_MOTION) + (let* ((state (x-dnd-get-state-for-frame frame)) + (timestamp (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 4 4 + source-byteorder) + 4 my-byteorder)) + (x (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 8 2 source-byteorder) + 2 my-byteorder)) + (y (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 10 2 source-byteorder) + 2 my-byteorder)) + (dnd-source (aref state 6)) + (first-move (not (aref state 3))) + (action-type (x-dnd-maybe-call-test-function + window + source-action)) + (reply-action (car (rassoc (car action-type) + x-dnd-motif-to-action))) + (reply-flags + (x-dnd-motif-value-to-list + (if reply-action + (+ reply-action + ?\x30 ; 30: valid drop site + ?\x700) ; 700: can do copy, move or link + ?\x30) ; 30: drop site, but noop. 2 my-byteorder)) - (y (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 10 2 source-byteorder) - 2 my-byteorder)) - (dnd-source (aref state 6)) - (first-move (not (aref state 3))) - (action-type (x-dnd-maybe-call-test-function - window - source-action)) - (reply-action (car (rassoc (car action-type) - x-dnd-motif-to-action))) - (reply-flags - (x-dnd-motif-value-to-list - (if reply-action - (+ reply-action - ?\x30 ; 30: valid drop site - ?\x700) ; 700: can do copy, move or link - ?\x30) ; 30: drop site, but noop. - 2 my-byteorder)) - (reply (append - (list - (+ ?\x80 ; 0x80 indicates a reply. - (if first-move - 3 ; First time, reply is SITE_ENTER. - 2)) ; Not first time, reply is DRAG_MOTION. - my-byteorder) - reply-flags - timestamp - x - y))) - (x-send-client-message frame - dnd-source - frame - "_MOTIF_DRAG_AND_DROP_MESSAGE" - 8 - reply))) - - ((eq message-type 'XmOPERATION_CHANGED) - (let* ((state (x-dnd-get-state-for-frame frame)) - (timestamp (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 4 4 source-byteorder) - 4 my-byteorder)) - (dnd-source (aref state 6)) - (action-type (x-dnd-maybe-call-test-function - window - source-action)) - (reply-action (car (rassoc (car action-type) - x-dnd-motif-to-action))) - (reply-flags - (x-dnd-motif-value-to-list - (if reply-action - (+ reply-action - ?\x30 ; 30: valid drop site - ?\x700) ; 700: can do copy, move or link - ?\x30) ; 30: drop site, but noop - 2 my-byteorder)) - (reply (append - (list - (+ ?\x80 ; 0x80 indicates a reply. - 8) ; 8 is OPERATION_CHANGED - my-byteorder) - reply-flags - timestamp))) - (x-send-client-message frame - dnd-source - frame - "_MOTIF_DRAG_AND_DROP_MESSAGE" - 8 - reply))) - - ((eq message-type 'XmDROP_START) - (let* ((x (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 8 2 source-byteorder) + (reply (append + (list + (+ ?\x80 ; 0x80 indicates a reply. + (if first-move + 3 ; First time, reply is SITE_ENTER. + 2)) ; Not first time, reply is DRAG_MOTION. + my-byteorder) + reply-flags + timestamp + x + y))) + (x-send-client-message frame + dnd-source + frame + "_MOTIF_DRAG_AND_DROP_MESSAGE" + 8 + reply))) + + ((eq message-type 'XmOPERATION_CHANGED) + (let* ((state (x-dnd-get-state-for-frame frame)) + (timestamp (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 4 4 source-byteorder) + 4 my-byteorder)) + (dnd-source (aref state 6)) + (action-type (x-dnd-maybe-call-test-function + window + source-action)) + (reply-action (car (rassoc (car action-type) + x-dnd-motif-to-action))) + (reply-flags + (x-dnd-motif-value-to-list + (if reply-action + (+ reply-action + ?\x30 ; 30: valid drop site + ?\x700) ; 700: can do copy, move or link + ?\x30) ; 30: drop site, but noop 2 my-byteorder)) - (y (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 10 2 source-byteorder) + (reply (append + (list + (+ ?\x80 ; 0x80 indicates a reply. + 8) ; 8 is OPERATION_CHANGED + my-byteorder) + reply-flags + timestamp))) + (x-send-client-message frame + dnd-source + frame + "_MOTIF_DRAG_AND_DROP_MESSAGE" + 8 + reply))) + + ((eq message-type 'XmDROP_START) + (let* ((x (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 8 2 source-byteorder) + 2 my-byteorder)) + (y (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 10 2 source-byteorder) + 2 my-byteorder)) + (selection-atom (x-dnd-get-motif-value + data 12 4 source-byteorder)) + (atom-name (x-get-atom-name selection-atom)) + (dnd-source (x-dnd-get-motif-value + data 16 4 source-byteorder)) + (action-type (x-dnd-maybe-call-test-function + window + source-action)) + (reply-action (car (rassoc (car action-type) + x-dnd-motif-to-action))) + (reply-flags + (x-dnd-motif-value-to-list + (if reply-action + (+ reply-action + ?\x30 ; 30: valid drop site + ?\x700) ; 700: can do copy, move or link + (+ ?\x30 ; 30: drop site, but noop. + ?\x200)) ; 200: drop cancel. 2 my-byteorder)) - (selection-atom (x-dnd-get-motif-value - data 12 4 source-byteorder)) - (atom-name (x-get-atom-name selection-atom)) - (dnd-source (x-dnd-get-motif-value - data 16 4 source-byteorder)) - (action-type (x-dnd-maybe-call-test-function - window - source-action)) - (reply-action (car (rassoc (car action-type) - x-dnd-motif-to-action))) - (reply-flags - (x-dnd-motif-value-to-list - (if reply-action - (+ reply-action - ?\x30 ; 30: valid drop site - ?\x700) ; 700: can do copy, move or link - (+ ?\x30 ; 30: drop site, but noop. - ?\x200)) ; 200: drop cancel. - 2 my-byteorder)) - (reply (append - (list - (+ ?\x80 ; 0x80 indicates a reply. - 5) ; DROP_START. - my-byteorder) - reply-flags - x - y)) - (timestamp (x-dnd-get-motif-value - data 4 4 source-byteorder)) - action) - - (x-send-client-message frame - dnd-source - frame - "_MOTIF_DRAG_AND_DROP_MESSAGE" - 8 - reply) - (setq action - (when (and reply-action atom-name) - (let* ((value (x-get-selection-internal - (intern atom-name) - (intern (x-dnd-current-type window))))) - (when value - (condition-case info - (x-dnd-drop-data event frame window value - (x-dnd-current-type window)) - (error - (message "Error: %s" info) - nil)))))) - (x-get-selection-internal - (intern atom-name) - (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE) - timestamp) - (x-dnd-forget-drop frame))) - - (t (error "Unknown Motif DND message %s %s" message-atom data))))) + (reply (append + (list + (+ ?\x80 ; 0x80 indicates a reply. + 5) ; DROP_START. + my-byteorder) + reply-flags + x + y)) + (timestamp (x-dnd-get-motif-value + data 4 4 source-byteorder)) + action) + + (x-send-client-message frame + dnd-source + frame + "_MOTIF_DRAG_AND_DROP_MESSAGE" + 8 + reply) + (setq action + (when (and reply-action atom-name) + (let* ((value (x-get-selection-internal + (intern atom-name) + (intern (x-dnd-current-type window))))) + (when value + (condition-case info + (x-dnd-drop-data event frame window value + (x-dnd-current-type window)) + (error + (message "Error: %s" info) + nil)))))) + (x-get-selection-internal + (intern atom-name) + (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE) + timestamp) + (x-dnd-forget-drop frame))) + + (t (message "Unknown Motif drag-and-drop message: %s" (logand (aref data 0) #x3f))))))) ;;; diff --git a/src/xterm.c b/src/xterm.c index a92c34396c..bd5d756c8c 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -861,6 +861,594 @@ struct x_client_list_window static struct x_client_list_window *x_dnd_toplevels = NULL; static bool x_dnd_use_toplevels; +/* Motif drag-and-drop protocol support. */ + +typedef enum xm_targets_table_byte_order + { + XM_TARGETS_TABLE_LSB = 'l', + XM_TARGETS_TABLE_MSB = 'B', +#ifndef WORDS_BIGENDIAN + XM_TARGETS_TABLE_CUR = 'l', +#else + XM_TARGETS_TABLE_CUR = 'B', +#endif + } xm_targets_table_byte_order; + +#define SWAPCARD32(l) \ + { \ + struct { unsigned t : 32; } bit32; \ + char n, *tp = (char *) &bit32; \ + bit32.t = l; \ + n = tp[0]; tp[0] = tp[3]; tp[3] = n; \ + n = tp[1]; tp[1] = tp[2]; tp[2] = n; \ + l = bit32.t; \ + } + +#define SWAPCARD16(s) \ + { \ + struct { unsigned t : 16; } bit16; \ + char n, *tp = (char *) &bit16; \ + bit16.t = s; \ + n = tp[0]; tp[0] = tp[1]; tp[1] = n; \ + s = bit16.t; \ + } + +typedef struct xm_targets_table_header +{ + /* BYTE */ uint8_t byte_order; + /* BYTE */ uint8_t protocol; + + /* CARD16 */ uint16_t target_list_count; + /* CARD32 */ uint32_t total_data_size; +} xm_targets_table_header; + +typedef struct xm_targets_table_rec +{ + /* CARD16 */ uint16_t n_targets; + /* CARD32 */ uint32_t targets[FLEXIBLE_ARRAY_MEMBER]; +} xm_targets_table_rec; + +typedef struct xm_drop_start_message +{ + /* BYTE */ uint8_t reason; + /* BYTE */ uint8_t byte_order; + + /* CARD16 */ uint16_t side_effects; + /* CARD32 */ uint32_t timestamp; + /* CARD16 */ uint16_t x, y; + /* CARD32 */ uint32_t index_atom; + /* CARD32 */ uint32_t source_window; +} xm_drop_start_message; + +typedef struct xm_drag_initiator_info +{ + /* BYTE */ uint8_t byteorder; + /* BYTE */ uint8_t protocol; + + /* CARD16 */ uint16_t table_index; + /* CARD32 */ uint32_t selection; +} xm_drag_initiator_info; + +typedef struct xm_drag_receiver_info +{ + /* BYTE */ uint8_t byteorder; + /* BYTE */ uint8_t protocol; + + /* BYTE */ uint8_t protocol_style; + /* BYTE */ uint8_t unspecified0; + /* CARD32 */ uint32_t unspecified1; + /* CARD32 */ uint32_t unspecified2; + /* CARD32 */ uint32_t unspecified3; +} xm_drag_receiver_info; + +#define XM_DRAG_SIDE_EFFECT(op, site, ops, act) \ + ((op) | ((site) << 4) | ((ops) << 8) | ((act) << 16)) + +/* Some of the macros below are temporarily unused. */ + +/* #define XM_DRAG_SIDE_EFFECT_OPERATION(effect) ((effect) & 0xf) */ +/* #define XM_DRAG_SIDE_EFFECT_SITE_STATUS(effect) (((effect) & 0xf0) >> 4) */ +/* #define XM_DRAG_SIDE_EFFECT_OPERATIONS(effect) (((effect) & 0xf00) >> 8) */ +/* #define XM_DRAG_SIDE_EFFECT_DROP_ACTION(effect) (((effect) & 0xf000) >> 16) */ + +#define XM_DRAG_NOOP 0 +#define XM_DRAG_MOVE (1L << 0) +#define XM_DRAG_COPY (1L << 1) +#define XM_DRAG_LINK (1L << 2) + +#define XM_DROP_ACTION_DROP 0 +#define XM_DROP_SITE_VALID 1 + +#define XM_DRAG_REASON(originator, code) ((code) | ((originator) << 7)) +/* #define XM_DRAG_REASON_ORIGINATOR(reason) (((reason) & 0x80) ? 1 : 0) */ +/* #define XM_DRAG_REASON_CODE(reason) ((reason) & 0x7f) */ + +#define XM_DRAG_REASON_DROP_START 5 +#define XM_DRAG_ORIGINATOR_INITIATOR 0 +/* #define XM_DRAG_ORIGINATOR_RECEIVER 1 */ + +#define XM_DRAG_STYLE_NONE 0 + +static uint8_t +xm_side_effect_from_action (struct x_display_info *dpyinfo, Atom action) +{ + if (action == dpyinfo->Xatom_XdndActionCopy) + return XM_DRAG_COPY; + else if (action == dpyinfo->Xatom_XdndActionMove) + return XM_DRAG_MOVE; + else if (action == dpyinfo->Xatom_XdndActionLink) + return XM_DRAG_LINK; + + return XM_DRAG_NOOP; +} + +static int +xm_read_targets_table_header (uint8_t *bytes, ptrdiff_t length, + xm_targets_table_header *header_return, + xm_targets_table_byte_order *byteorder_return) +{ + if (length < 8) + return -1; + + header_return->byte_order = *byteorder_return = *(bytes++); + header_return->protocol = *(bytes++); + + header_return->target_list_count = *(uint16_t *) bytes; + header_return->total_data_size = *(uint32_t *) (bytes + 2); + + if (header_return->byte_order != XM_TARGETS_TABLE_CUR) + { + SWAPCARD16 (header_return->target_list_count); + SWAPCARD32 (header_return->total_data_size); + } + + header_return->byte_order = XM_TARGETS_TABLE_CUR; + + return 8; +} + +static xm_targets_table_rec * +xm_read_targets_table_rec (uint8_t *bytes, ptrdiff_t length, + xm_targets_table_byte_order byteorder) +{ + uint16_t nitems, i; + xm_targets_table_rec *rec; + + if (length < 2) + return NULL; + + nitems = *(uint16_t *) bytes; + + if (length < 2 + nitems * 4) + return NULL; + + if (byteorder != XM_TARGETS_TABLE_CUR) + SWAPCARD16 (nitems); + + rec = xmalloc (sizeof *rec + nitems * 4); + rec->n_targets = nitems; + + for (i = 0; i < nitems; ++i) + { + rec->targets[i] = ((uint32_t *) (bytes + 2))[i]; + + if (byteorder != XM_TARGETS_TABLE_CUR) + SWAPCARD32 (rec->targets[i]); + } + + return rec; +} + +static int +xm_find_targets_table_idx (xm_targets_table_header *header, + xm_targets_table_rec **recs, + Atom *sorted_targets, int ntargets) +{ + int j; + uint16_t i; + uint32_t *targets; + + targets = alloca (sizeof *targets * ntargets); + + for (j = 0; j < ntargets; ++j) + targets[j] = sorted_targets[j]; + + for (i = 0; i < header->target_list_count; ++i) + { + if (recs[i]->n_targets == ntargets + && !memcmp (&recs[i]->targets, targets, + sizeof *targets * ntargets)) + return i; + } + + return -1; +} + +static int +x_atoms_compare (const void *a, const void *b) +{ + return *(Atom *) a - *(Atom *) b; +} + +static void +xm_write_targets_table (Display *dpy, Window wdesc, + Atom targets_table_atom, + xm_targets_table_header *header, + xm_targets_table_rec **recs) +{ + uint8_t *header_buffer, *ptr, *rec_buffer; + ptrdiff_t rec_buffer_size; + uint16_t i, j; + + header_buffer = alloca (8); + ptr = header_buffer; + + *(header_buffer++) = header->byte_order; + *(header_buffer++) = header->protocol; + *((uint16_t *) header_buffer) = header->target_list_count; + *((uint32_t *) (header_buffer + 2)) = header->total_data_size; + + rec_buffer = xmalloc (600); + rec_buffer_size = 600; + + XGrabServer (dpy); + XChangeProperty (dpy, wdesc, targets_table_atom, + targets_table_atom, 8, PropModeReplace, + (unsigned char *) ptr, 8); + + for (i = 0; i < header->target_list_count; ++i) + { + if (rec_buffer_size < 2 + recs[i]->n_targets * 4) + { + rec_buffer_size = 2 + recs[i]->n_targets * 4; + rec_buffer = xrealloc (rec_buffer, rec_buffer_size); + } + + *((uint16_t *) rec_buffer) = recs[i]->n_targets; + + for (j = 0; j < recs[i]->n_targets; ++j) + ((uint32_t *) (rec_buffer + 2))[j] = recs[i]->targets[j]; + + XChangeProperty (dpy, wdesc, targets_table_atom, + targets_table_atom, 8, PropModeAppend, + (unsigned char *) rec_buffer, + 2 + recs[i]->n_targets * 4); + } + XUngrabServer (dpy); + + xfree (rec_buffer); +} + +static void +xm_write_drag_initiator_info (Display *dpy, Window wdesc, + Atom prop_name, Atom type_name, + xm_drag_initiator_info *info) +{ + uint8_t *buf; + + buf = alloca (8); + buf[0] = info->byteorder; + buf[1] = info->protocol; + + *((uint16_t *) (buf + 2)) = info->table_index; + *((uint32_t *) (buf + 4)) = info->selection; + + XChangeProperty (dpy, wdesc, prop_name, type_name, 8, + PropModeReplace, (unsigned char *) buf, 8); +} + +static Window +xm_get_drag_window (struct x_display_info *dpyinfo) +{ + Atom actual_type; + int rc, actual_format; + unsigned long nitems, bytes_remaining; + unsigned char *tmp_data = NULL; + Window drag_window; + XSetWindowAttributes attrs; + XWindowAttributes wattrs; + Display *temp_display; + + drag_window = None; + XGrabServer (dpyinfo->display); + rc = XGetWindowProperty (dpyinfo->display, dpyinfo->root_window, + dpyinfo->Xatom_MOTIF_DRAG_WINDOW, + 0, 1, False, XA_WINDOW, &actual_type, + &actual_format, &nitems, &bytes_remaining, + &tmp_data) == Success; + + if (rc) + { + if (actual_type == XA_WINDOW + && actual_format == 32 && nitems == 1) + { + drag_window = *(Window *) tmp_data; + x_catch_errors (dpyinfo->display); + XGetWindowAttributes (dpyinfo->display, + drag_window, &wattrs); + rc = !x_had_errors_p (dpyinfo->display); + x_uncatch_errors_after_check (); + + if (!rc) + drag_window = None; + } + + if (tmp_data) + XFree (tmp_data); + } + + XUngrabServer (dpyinfo->display); + + if (drag_window == None) + { + unrequest_sigio (); + temp_display = XOpenDisplay (XDisplayString (dpyinfo->display)); + request_sigio (); + + if (!temp_display) + return None; + + XSetCloseDownMode (temp_display, RetainPermanent); + + XGrabServer (temp_display); + attrs.override_redirect = True; + drag_window = XCreateWindow (temp_display, DefaultRootWindow (temp_display), + -1, -1, 1, 1, 0, CopyFromParent, InputOnly, + CopyFromParent, CWOverrideRedirect, &attrs); + XChangeProperty (temp_display, DefaultRootWindow (temp_display), + XInternAtom (temp_display, + "_MOTIF_DRAG_WINDOW", False), + XA_WINDOW, 32, PropModeReplace, + (unsigned char *) &drag_window, 1); + XUngrabServer (temp_display); + XCloseDisplay (temp_display); + + /* Make sure the drag window created is actually valid for the + current display, and the XOpenDisplay above didn't + accidentally connect to some other display. */ + x_catch_errors (dpyinfo->display); + XGetWindowAttributes (dpyinfo->display, + drag_window, &wattrs); + rc = !x_had_errors_p (dpyinfo->display); + x_uncatch_errors_after_check (); + + /* We connected to the wrong display, so just give up. */ + if (!rc) + drag_window = None; + } + + return drag_window; +} + +/* TODO: overflow checks when inserting targets. */ +static int +xm_setup_dnd_targets (struct x_display_info *dpyinfo, + Atom *targets, int ntargets) +{ + Window drag_window; + Atom *targets_sorted, actual_type; + unsigned char *tmp_data = NULL; + unsigned long nitems, bytes_remaining; + int rc, actual_format, idx; + xm_targets_table_header header; + xm_targets_table_rec **recs; + xm_targets_table_byte_order byteorder; + uint8_t *data; + ptrdiff_t total_bytes, total_items, i; + + drag_window = xm_get_drag_window (dpyinfo); + + if (drag_window == None || ntargets > 64) + return -1; + + targets_sorted = xmalloc (sizeof *targets * ntargets); + memcpy (targets_sorted, targets, + sizeof *targets * ntargets); + qsort (targets_sorted, ntargets, + sizeof (Atom), x_atoms_compare); + + XGrabServer (dpyinfo->display); + rc = XGetWindowProperty (dpyinfo->display, drag_window, + dpyinfo->Xatom_MOTIF_DRAG_TARGETS, + /* Do larger values occur in practice? */ + 0L, 20000L, False, + dpyinfo->Xatom_MOTIF_DRAG_TARGETS, + &actual_type, &actual_format, &nitems, + &bytes_remaining, &tmp_data) == Success; + + if (rc && tmp_data && !bytes_remaining + && actual_type == dpyinfo->Xatom_MOTIF_DRAG_TARGETS + && actual_format == 8) + { + data = (uint8_t *) tmp_data; + if (xm_read_targets_table_header ((uint8_t *) tmp_data, + nitems, &header, + &byteorder) == 8) + { + data += 8; + nitems -= 8; + total_bytes = 0; + total_items = 0; + + /* The extra rec is used to store a new target list if a + preexisting one doesn't already exist. */ + recs = xmalloc ((header.target_list_count + 1) + * sizeof *recs); + + while (total_items < header.target_list_count) + { + recs[total_items] = xm_read_targets_table_rec (data + total_bytes, + nitems, byteorder); + + if (!recs[total_items]) + break; + + total_bytes += 2 + recs[total_items]->n_targets * 4; + nitems -= 2 + recs[total_items]->n_targets * 4; + total_items++; + } + + if (header.target_list_count != total_items + || header.total_data_size != 8 + total_bytes) + { + for (i = 0; i < total_items; ++i) + { + if (recs[i]) + xfree (recs[i]); + else + break; + } + + xfree (recs); + + rc = false; + } + } + else + rc = false; + } + else + rc = false; + + if (tmp_data) + XFree (tmp_data); + + /* Now rc means whether or not the target lists weren't updated and + shouldn't be written to the drag window. */ + + if (!rc) + { + header.byte_order = XM_TARGETS_TABLE_CUR; + header.protocol = 0; + header.target_list_count = 1; + header.total_data_size = 8 + 2 + ntargets * 4; + + recs = xmalloc (sizeof *recs); + recs[0] = xmalloc (sizeof **recs + ntargets * 4); + + recs[0]->n_targets = ntargets; + + for (i = 0; i < ntargets; ++i) + recs[0]->targets[i] = targets_sorted[i]; + + idx = 0; + } + else + { + idx = xm_find_targets_table_idx (&header, recs, + targets_sorted, + ntargets); + + if (idx == -1) + { + header.target_list_count++; + header.total_data_size += 2 + ntargets * 4; + + recs[header.target_list_count - 1] = xmalloc (sizeof **recs + ntargets * 4); + recs[header.target_list_count - 1]->n_targets = ntargets; + + for (i = 0; i < ntargets; ++i) + recs[header.target_list_count - 1]->targets[i] = targets_sorted[i]; + + idx = header.target_list_count - 1; + rc = false; + } + } + + if (!rc) + xm_write_targets_table (dpyinfo->display, drag_window, + dpyinfo->Xatom_MOTIF_DRAG_TARGETS, + &header, recs); + + XUngrabServer (dpyinfo->display); + + for (i = 0; i < header.target_list_count; ++i) + xfree (recs[i]); + + xfree (recs); + xfree (targets_sorted); + + return idx; +} + +static void +xm_send_drop_message (struct x_display_info *dpyinfo, Window source, + Window target, xm_drop_start_message *dmsg) +{ + XEvent msg; + + msg.xclient.type = ClientMessage; + msg.xclient.message_type + = dpyinfo->Xatom_MOTIF_DRAG_AND_DROP_MESSAGE; + msg.xclient.format = 8; + msg.xclient.window = target; + msg.xclient.data.b[0] = dmsg->reason; + msg.xclient.data.b[1] = dmsg->byte_order; + *((uint16_t *) &msg.xclient.data.b[2]) = dmsg->side_effects; + *((uint32_t *) &msg.xclient.data.b[4]) = dmsg->timestamp; + *((uint16_t *) &msg.xclient.data.b[8]) = dmsg->x; + *((uint16_t *) &msg.xclient.data.b[10]) = dmsg->y; + *((uint32_t *) &msg.xclient.data.b[12]) = dmsg->index_atom; + *((uint32_t *) &msg.xclient.data.b[16]) = dmsg->source_window; + + x_catch_errors (dpyinfo->display); + XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg); + x_uncatch_errors (); +} + +static int +xm_read_drag_receiver_info (struct x_display_info *dpyinfo, + Window wdesc, xm_drag_receiver_info *rec) +{ + Atom actual_type; + int rc, actual_format; + unsigned long nitems, bytes_remaining; + unsigned char *tmp_data = NULL; + uint8_t *data; + + x_catch_errors (dpyinfo->display); + rc = XGetWindowProperty (dpyinfo->display, wdesc, + dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, + 0, LONG_MAX, False, + dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, + &actual_type, &actual_format, &nitems, + &bytes_remaining, + &tmp_data) == Success; + + if (x_had_errors_p (dpyinfo->display) + || actual_format != 8 || nitems < 16 || !tmp_data + || actual_type != dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO) + rc = 0; + x_uncatch_errors_after_check (); + + if (rc) + { + data = (uint8_t *) tmp_data; + + rec->byteorder = data[0]; + rec->protocol = data[1]; + rec->protocol_style = data[2]; + rec->unspecified0 = data[3]; + rec->unspecified1 = *(uint32_t *) &data[4]; + rec->unspecified2 = *(uint32_t *) &data[8]; + rec->unspecified3 = *(uint32_t *) &data[12]; + + if (rec->byteorder != XM_TARGETS_TABLE_CUR) + { + SWAPCARD32 (rec->unspecified1); + SWAPCARD32 (rec->unspecified2); + SWAPCARD32 (rec->unspecified3); + } + + rec->byteorder = XM_TARGETS_TABLE_CUR; + } + + if (tmp_data) + XFree (tmp_data); + + return !rc; +} + static void x_dnd_free_toplevels (void) { @@ -1124,10 +1712,6 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) tem->previous_event_mask = attrs.your_event_mask; tem->wm_state = wmstate[0]; -#ifndef USE_XCB - XFree (wmstate_data); -#endif - #ifdef HAVE_XSHAPE #ifndef USE_XCB tem->border_width = attrs.border_width; @@ -1360,6 +1944,14 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) if (geometry_reply) free (geometry_reply); #endif + +#ifndef USE_XCB + if (wmstate_data) + { + XFree (wmstate_data); + wmstate_data = NULL; + } +#endif } return 0; @@ -1715,7 +2307,7 @@ x_dnd_get_window_proxy (struct x_display_info *dpyinfo, Window wdesc) { int rc, actual_format; unsigned long actual_size, bytes_remaining; - unsigned char *tmp_data; + unsigned char *tmp_data = NULL; XWindowAttributes attrs; Atom actual_type; Window proxy; @@ -1731,12 +2323,12 @@ x_dnd_get_window_proxy (struct x_display_info *dpyinfo, Window wdesc) if (!x_had_errors_p (dpyinfo->display) && rc == Success + && tmp_data && actual_type == XA_WINDOW && actual_format == 32 && actual_size == 1) { proxy = *(Window *) tmp_data; - XFree (tmp_data); /* Verify the proxy window exists. */ XGetWindowAttributes (dpyinfo->display, proxy, &attrs); @@ -1744,6 +2336,9 @@ x_dnd_get_window_proxy (struct x_display_info *dpyinfo, Window wdesc) if (x_had_errors_p (dpyinfo->display)) proxy = None; } + + if (tmp_data) + XFree (tmp_data); x_uncatch_errors_after_check (); return proxy; @@ -1753,7 +2348,7 @@ static int x_dnd_get_window_proto (struct x_display_info *dpyinfo, Window wdesc) { Atom actual, value; - unsigned char *tmp_data; + unsigned char *tmp_data = NULL; int rc, format; unsigned long n, left; bool had_errors; @@ -1769,8 +2364,13 @@ x_dnd_get_window_proto (struct x_display_info *dpyinfo, Window wdesc) had_errors = x_had_errors_p (dpyinfo->display); x_uncatch_errors_after_check (); - if (had_errors || rc != Success || actual != XA_ATOM || format != 32 || n < 1) - return -1; + if (had_errors || rc != Success || actual != XA_ATOM || format != 32 || n < 1 + || !tmp_data) + { + if (tmp_data) + XFree (tmp_data); + return -1; + } value = (int) *(Atom *) tmp_data; XFree (tmp_data); @@ -3545,7 +4145,7 @@ x_set_frame_alpha (struct frame *f) /* return unless necessary */ { - unsigned char *data; + unsigned char *data = NULL; Atom actual; int rc, format; unsigned long n, left; @@ -3555,16 +4155,19 @@ x_set_frame_alpha (struct frame *f) &actual, &format, &n, &left, &data); - if (rc == Success && actual != None) + if (rc == Success && actual != None && data) { - unsigned long value = *(unsigned long *)data; - XFree (data); + unsigned long value = *(unsigned long *) data; if (value == opac) { x_uncatch_errors (); + XFree (data); return; } } + + if (data) + XFree (data); } XChangeProperty (dpy, win, dpyinfo->Xatom_net_wm_window_opacity, @@ -12144,12 +12747,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (!x_had_errors_p (dpyinfo->display) && rc == Success && data && nitems == 2 && actual_format == 32) - { - tem->wm_state = ((unsigned long *) data)[0]; - XFree (data); - } + tem->wm_state = ((unsigned long *) data)[0]; else tem->wm_state = WithdrawnState; + + if (data) + XFree (data); x_uncatch_errors_after_check (); } @@ -13569,6 +14172,56 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_dnd_frame = NULL; x_set_dnd_targets (NULL, 0); } + else if (x_dnd_last_seen_window != None) + { + xm_drag_receiver_info drag_receiver_info; + xm_drag_initiator_info drag_initiator_info; + xm_drop_start_message dmsg; + int idx; + + if (!xm_read_drag_receiver_info (dpyinfo, x_dnd_last_seen_window, + &drag_receiver_info) + && drag_receiver_info.protocol_style != XM_DRAG_STYLE_NONE) + { + idx = xm_setup_dnd_targets (dpyinfo, x_dnd_targets, + x_dnd_n_targets); + + if (idx != -1) + { + drag_initiator_info.byteorder = XM_TARGETS_TABLE_CUR; + drag_initiator_info.protocol = 0; + drag_initiator_info.table_index = idx; + drag_initiator_info.selection = dpyinfo->Xatom_XdndSelection; + + memset (&dmsg, 0, sizeof dmsg); + + xm_write_drag_initiator_info (dpyinfo->display, + FRAME_X_WINDOW (x_dnd_frame), + dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, + dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, + &drag_initiator_info); + + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DROP_START); + dmsg.byte_order = XM_TARGETS_TABLE_CUR; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_ACTION_DROP); + dmsg.timestamp = event->xbutton.time; + dmsg.x = event->xbutton.x_root; + dmsg.y = event->xbutton.y_root; + dmsg.index_atom = dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO; + dmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &dmsg); + } + } + } goto OTHER; } @@ -14562,6 +15215,56 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_dnd_selection_timestamp, x_dnd_last_protocol_version); } + else if (x_dnd_last_seen_window != None) + { + xm_drag_receiver_info drag_receiver_info; + xm_drag_initiator_info drag_initiator_info; + xm_drop_start_message dmsg; + int idx; + + if (!xm_read_drag_receiver_info (dpyinfo, x_dnd_last_seen_window, + &drag_receiver_info) + && drag_receiver_info.protocol_style != XM_DRAG_STYLE_NONE) + { + idx = xm_setup_dnd_targets (dpyinfo, x_dnd_targets, + x_dnd_n_targets); + + if (idx != -1) + { + drag_initiator_info.byteorder = XM_TARGETS_TABLE_CUR; + drag_initiator_info.protocol = 0; + drag_initiator_info.table_index = idx; + drag_initiator_info.selection = dpyinfo->Xatom_XdndSelection; + + memset (&dmsg, 0, sizeof dmsg); + + xm_write_drag_initiator_info (dpyinfo->display, + FRAME_X_WINDOW (x_dnd_frame), + dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, + dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, + &drag_initiator_info); + + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DROP_START); + dmsg.byte_order = XM_TARGETS_TABLE_CUR; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_ACTION_DROP); + dmsg.timestamp = xev->time; + dmsg.x = lrint (xev->root_x); + dmsg.y = lrint (xev->root_y); + dmsg.index_atom = dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO; + dmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &dmsg); + } + } + } x_dnd_last_protocol_version = -1; x_dnd_last_seen_window = None; @@ -20420,6 +21123,15 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) ATOM_REFS_INIT ("XdndLeave", Xatom_XdndLeave) ATOM_REFS_INIT ("XdndDrop", Xatom_XdndDrop) ATOM_REFS_INIT ("XdndFinished", Xatom_XdndFinished) + /* Motif drop protocol support. */ + ATOM_REFS_INIT ("_MOTIF_DRAG_WINDOW", Xatom_MOTIF_DRAG_WINDOW) + ATOM_REFS_INIT ("_MOTIF_DRAG_TARGETS", Xatom_MOTIF_DRAG_TARGETS) + ATOM_REFS_INIT ("_MOTIF_DRAG_AND_DROP_MESSAGE", + Xatom_MOTIF_DRAG_AND_DROP_MESSAGE) + ATOM_REFS_INIT ("_MOTIF_DRAG_INITIATOR_INFO", + Xatom_MOTIF_DRAG_INITIATOR_INFO) + ATOM_REFS_INIT ("_MOTIF_DRAG_RECEIVER_INFO", + Xatom_MOTIF_DRAG_RECEIVER_INFO) }; int i; diff --git a/src/xterm.h b/src/xterm.h index 57b55ecf0d..eb9e25d3cd 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -433,7 +433,9 @@ struct x_display_info /* Atom used to determine whether or not the screen is composited. */ Atom Xatom_NET_WM_CM_Sn; - Atom Xatom_MOTIF_WM_HINTS; + Atom Xatom_MOTIF_WM_HINTS, Xatom_MOTIF_DRAG_WINDOW, + Xatom_MOTIF_DRAG_TARGETS, Xatom_MOTIF_DRAG_AND_DROP_MESSAGE, + Xatom_MOTIF_DRAG_INITIATOR_INFO, Xatom_MOTIF_DRAG_RECEIVER_INFO; /* The frame (if any) which has the X window that has keyboard focus. Zero if none. This is examined by Ffocus_frame in xfns.c. Note commit 6f973faa912a5ac1ba643c6f5deb0c02baa0ba6d Author: Stefan Monnier Date: Wed Mar 30 13:54:56 2022 -0400 cl-generic: Use OClosures for `cl--generic-isnot-nnm-p` Rewrite the handling of `cl-no-next-method` to get rid of the hideous hack used in `cl--generic-isnot-nnm-p` and also to try and move some of the cost to the construction of the effective method rather than its invocation. This speeds up method calls measurably when there's a `cl-call-next-method` in the body. * lisp/loadup.el ("emacs-lisp/oclosure"): Load. * lisp/emacs-lisp/oclosure.el (oclosure-define): Remove workaround now that we're preloaded. * lisp/emacs-lisp/cl-generic.el (cl--generic-method): Rename `uses-cnm` to `call-con` to reflect it's not a boolean any more. (cl-defmethod): Adjust to the new name and new values. (cl-generic-define-method): Adjust to the new name. (cl--generic-lambda): Use the new `curried` calling convention. (cl--generic-no-next-method-function): Delete function. (cl--generic-nnm): New type. (cl-generic-call-method): Rewrite to support the various calling conventions. (cl--generic-nnm-sample, cl--generic-cnm-sample): Delete consts. (cl--generic-isnot-nnm-p): Rewrite using `oclosure-type`. (cl--generic-method-info): Add support for new calling convention. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 295512d51e..279f73f36a 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -144,13 +144,20 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG (cl-defstruct (cl--generic-method (:constructor nil) (:constructor cl--generic-make-method - (specializers qualifiers uses-cnm function)) + (specializers qualifiers call-con function)) (:predicate nil)) (specializers nil :read-only t :type list) (qualifiers nil :read-only t :type (list-of atom)) - ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument - ;; holding the next-method. - (uses-cnm nil :read-only t :type boolean) + ;; CALL-CON indicates the calling convention expected by FUNCTION: + ;; - nil: FUNCTION is just a normal function with no extra arguments for + ;; `call-next-method' or `next-method-p' (which it hence can't use). + ;; - `curried': FUNCTION is a curried function that first takes the + ;; "next combined method" and return the resulting combined method. + ;; It can distinguish `next-method-p' by checking if that next method + ;; is `cl--generic-isnot-nnm-p'. + ;; - t: FUNCTION takes the `call-next-method' function as its first (extra) + ;; argument. + (call-con nil :read-only t :type symbol) (function nil :read-only t :type function)) (cl-defstruct (cl--generic @@ -400,6 +407,8 @@ the specializer used will be the one returned by BODY." (pcase (macroexpand fun macroenv) (`#'(lambda ,args . ,body) (let* ((parsed-body (macroexp-parse-body body)) + (nm (make-symbol "cl--nm")) + (arglist (make-symbol "cl--args")) (cnm (make-symbol "cl--cnm")) (nmp (make-symbol "cl--nmp")) (nbody (macroexpand-all @@ -412,15 +421,49 @@ the specializer used will be the one returned by BODY." ;; is used. ;; FIXME: Also, optimize the case where call-next-method is ;; only called with explicit arguments. - (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody))) - (cons (not (not uses-cnm)) - `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) - ,@(car parsed-body) - ,(if (not (assq nmp uses-cnm)) - nbody - `(let ((,nmp (lambda () - (cl--generic-isnot-nnm-p ,cnm)))) - ,nbody)))))) + (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody)) + (λ-lift (mapcar #'car uses-cnm))) + (if (not uses-cnm) + (cons nil + `#'(lambda (,@args) + ,@(car parsed-body) + ,nbody)) + (cons 'curried + `#'(lambda (,nm) ;Called when constructing the effective method. + (let ((,nmp (if (cl--generic-isnot-nnm-p ,nm) + #'always #'ignore))) + ;; This `(λ (&rest x) .. (apply (λ (args) ..) x))' + ;; dance is needed because we need to get the original + ;; args as a list when `cl-call-next-method' is + ;; called with no arguments. It's important to + ;; capture it as a list since it needs to distinguish + ;; the nil case from the absent case in optional + ;; arguments and it needs to properly remember the + ;; original value if `nbody' mutates some of its + ;; formal args. + ;; FIXME: This `(λ (&rest ,arglist)' could be skipped + ;; when we know `cnm' is always called with args, and + ;; it could be implemented more efficiently if `cnm' + ;; is always called directly and there are no + ;; `&optional' args. + (lambda (&rest ,arglist) + ,@(let* ((prebody (car parsed-body)) + (ds (if (stringp (car prebody)) + prebody + (setq prebody (cons nil prebody)))) + (usage (help-split-fundoc (car ds) nil))) + (unless usage + (setcar ds (help-add-fundoc-usage (car ds) + args))) + prebody) + (let ((,cnm (lambda (&rest args) + (apply ,nm (or args ,arglist))))) + ;; This `apply+lambda' basically parses + ;; `arglist' according to `args'. + ;; A destructuring-bind would do the trick + ;; as well when/if it's more efficient. + (apply (lambda (,@λ-lift ,@args) ,nbody) + ,@λ-lift ,arglist))))))))) (f (error "Unexpected macroexpansion result: %S" f)))))) (put 'cl-defmethod 'function-documentation @@ -518,11 +561,9 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (require 'gv) (declare-function gv-setter "gv" (name)) (setq name (gv-setter (cadr name)))) - (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body))) + (pcase-let* ((`(,call-con . ,fun) (cl--generic-lambda args body))) `(progn ,(and (get name 'byte-obsolete-info) - (or (not (fboundp 'byte-compile-warning-enabled-p)) - (byte-compile-warning-enabled-p 'obsolete name)) (let* ((obsolete (get name 'byte-obsolete-info))) (macroexp-warn-and-return (macroexp--obsolete-warning name obsolete "generic function") @@ -534,7 +575,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; The ",'" is a no-op that pacifies check-declare. (,'declare-function ,name "") (cl-generic-define-method ',name ',(nreverse qualifiers) ',args - ,uses-cnm ,fun))))) + ',call-con ,fun))))) (defun cl--generic-member-method (specializers qualifiers methods) (while @@ -552,7 +593,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined `(,name ,qualifiers . ,specializers)) ;;;###autoload -(defun cl-generic-define-method (name qualifiers args uses-cnm function) +(defun cl-generic-define-method (name qualifiers args call-con function) (pcase-let* ((generic (cl-generic-ensure-function name)) (`(,spec-args . ,_) (cl--generic-split-args args)) @@ -561,7 +602,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined spec-arg (cdr spec-arg))) spec-args)) (method (cl--generic-make-method - specializers qualifiers uses-cnm function)) + specializers qualifiers call-con function)) (mt (cl--generic-method-table generic)) (me (cl--generic-member-method specializers qualifiers mt)) (dispatches (cl--generic-dispatches generic)) @@ -738,29 +779,38 @@ for all those different tags in the method-cache.") (list (cl--generic-name generic))) f)))) -(defun cl--generic-no-next-method-function (generic method) - (lambda (&rest args) - (apply #'cl-no-next-method generic method args))) +(oclosure-define (cl--generic-nnm) + "Special type for `call-next-method's that just call `no-next-method'.") (defun cl-generic-call-method (generic method &optional fun) "Return a function that calls METHOD. FUN is the function that should be called when METHOD calls `call-next-method'." - (if (not (cl--generic-method-uses-cnm method)) - (cl--generic-method-function method) - (let ((met-fun (cl--generic-method-function method)) - (next (or fun (cl--generic-no-next-method-function - generic method)))) - (lambda (&rest args) - (apply met-fun - ;; FIXME: This sucks: passing just `next' would - ;; be a lot more efficient than the lambda+apply - ;; quasi-η, but we need this to implement the - ;; "if call-next-method is called with no - ;; arguments, then use the previous arguments". - (lambda (&rest cnm-args) - (apply next (or cnm-args args))) - args))))) + (let ((met-fun (cl--generic-method-function method))) + (pcase (cl--generic-method-call-con method) + ('nil met-fun) + ('curried + (funcall met-fun (or fun + (oclosure-lambda (cl--generic-nnm) (&rest args) + (apply #'cl-no-next-method generic method + args))))) + ;; FIXME: backward compatibility with old convention for `.elc' files + ;; compiled before the `curried' convention. + (_ + (lambda (&rest args) + (apply met-fun + (if fun + ;; FIXME: This sucks: passing just `next' would + ;; be a lot more efficient than the lambda+apply + ;; quasi-η, but we need this to implement the + ;; "if call-next-method is called with no + ;; arguments, then use the previous arguments". + (lambda (&rest cnm-args) + (apply fun (or cnm-args args))) + (oclosure-lambda (cl--generic-nnm) (&rest cnm-args) + (apply #'cl-no-next-method generic method + (or cnm-args args)))) + args)))))) ;; Standard CLOS name. (defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers) @@ -926,36 +976,9 @@ those methods.") "Standard support for :after, :before, :around, and `:extra NAME' qualifiers." (cl--generic-standard-method-combination generic methods)) -(defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t)) -(defconst cl--generic-cnm-sample - (funcall (cl--generic-build-combined-method - nil (list (cl--generic-make-method () () t #'identity))))) - (defun cl--generic-isnot-nnm-p (cnm) "Return non-nil if CNM is the function that calls `cl-no-next-method'." - ;; ¡Big Gross Ugly Hack! - ;; `next-method-p' just sucks, we should let it die. But EIEIO did support - ;; it, and some packages use it, so we need to support it. - (catch 'found - (cl-assert (function-equal cnm cl--generic-cnm-sample)) - (if (byte-code-function-p cnm) - (let ((cnm-constants (aref cnm 2)) - (sample-constants (aref cl--generic-cnm-sample 2))) - (dotimes (i (length sample-constants)) - (when (function-equal (aref sample-constants i) - cl--generic-nnm-sample) - (throw 'found - (not (function-equal (aref cnm-constants i) - cl--generic-nnm-sample)))))) - (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample))) - (let ((cnm-env (cadr cnm))) - (dolist (vb (cadr cl--generic-cnm-sample)) - (when (function-equal (cdr vb) cl--generic-nnm-sample) - (throw 'found - (not (function-equal (cdar cnm-env) - cl--generic-nnm-sample)))) - (setq cnm-env (cdr cnm-env))))) - (error "Haven't found no-next-method-sample in cnm-sample"))) + (not (eq (oclosure-type cnm) 'cl--generic-nnm))) ;;; Define some pre-defined generic functions, used internally. @@ -1031,9 +1054,12 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (defun cl--generic-method-info (method) (let* ((specializers (cl--generic-method-specializers method)) (qualifiers (cl--generic-method-qualifiers method)) - (uses-cnm (cl--generic-method-uses-cnm method)) + (call-con (cl--generic-method-call-con method)) (function (cl--generic-method-function method)) - (args (help-function-arglist function 'names)) + (args (help-function-arglist (if (not (eq call-con 'curried)) + function + (funcall function #'ignore)) + 'names)) (docstring (documentation function)) (qual-string (if (null qualifiers) "" @@ -1044,7 +1070,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (let ((split (help-split-fundoc docstring nil))) (if split (cdr split) docstring)))) (combined-args ())) - (if uses-cnm (setq args (cdr args))) + (if (eq t call-con) (setq args (cdr args))) (dolist (specializer specializers) (let ((arg (if (eq '&rest (car args)) (intern (format "arg%d" (length combined-args))) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index f5a21151f1..db108bd7be 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -248,8 +248,6 @@ list of slot properties. The currently known properties are the following: ,(when options (macroexp-warn-and-return name (format "Ignored options: %S" options) nil)) - (eval-when-compile (unless (fboundp 'oclosure--define) - (load "oclosure.el"))) (eval-and-compile (oclosure--define ',name ,docstring ',parent-names ',slots ,@(when predicate `(:predicate ',predicate)))) diff --git a/lisp/loadup.el b/lisp/loadup.el index faeb9188e4..6ca699f901 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -197,6 +197,7 @@ (load "button") ;After loaddefs, because of define-minor-mode! (load "emacs-lisp/cl-preloaded") +(load "emacs-lisp/oclosure") ;Used by cl-generic (load "obarray") ;abbrev.el is implemented in terms of obarrays. (load "abbrev") ;lisp-mode.el and simple.el use define-abbrev-table. commit b12ad270ebffb2b048f01d2992b472503b78dc33 Author: Stefan Monnier Date: Wed Mar 30 13:49:31 2022 -0400 EIEIO tests: Fix failure when `eieio-core.el` is interpreted * lisp/emacs-lisp/eieio-core.el (eieio--validate-slot-value) (eieio--slot-name-index): Use the `cl--class` accessor functions. diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 19aa20fa08..ed1a28a24f 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -704,7 +704,7 @@ an error." nil ;; Trim off object IDX junk added in for the object index. (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots))) - (let* ((sd (aref (eieio--class-slots class) + (let* ((sd (aref (cl--class-slots class) slot-idx)) (st (cl--slot-descriptor-type sd))) (cond @@ -712,7 +712,7 @@ an error." (signal 'invalid-slot-type (list (eieio--class-name class) slot st value))) ((alist-get :read-only (cl--slot-descriptor-props sd)) - (signal 'eieio-read-only (list (eieio--class-name class) slot))))))) + (signal 'eieio-read-only (list (cl--class-name class) slot))))))) (defun eieio--validate-class-slot-value (class slot-idx value slot) "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. @@ -896,7 +896,7 @@ The slot is a symbol which is installed in CLASS by the `defclass' call. If SLOT is the value created with :initarg instead, reverse-lookup that name, and recurse with the associated slot value." ;; Removed checks to outside this call - (let* ((fsi (gethash slot (eieio--class-index-table class)))) + (let* ((fsi (gethash slot (cl--class-index-table class)))) (if (integerp fsi) fsi (let ((fn (eieio--initarg-to-attribute class slot))) commit 2ec77fcd8f9b4ef92ad68175c60bd85e4221bb96 Author: Andrea Corallo Date: Wed Mar 30 17:13:27 2022 +0200 * src/pdumper.c (dump_get_max_page_size): Rename from 'dump_get_page_size'. diff --git a/src/pdumper.c b/src/pdumper.c index d9dc13770c..24393e0366 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -162,7 +162,7 @@ ptrdiff_t_to_dump_off (ptrdiff_t value) /* Worst-case allocation granularity on any system that might load this dump. */ static int -dump_get_page_size (void) +dump_get_max_page_size (void) { return 64 * 1024; } @@ -4210,7 +4210,7 @@ types. */) eassert (dump_queue_empty_p (&ctx->dump_queue)); dump_off discardable_end = ctx->offset; - dump_align_output (ctx, dump_get_page_size ()); + dump_align_output (ctx, dump_get_max_page_size ()); ctx->header.cold_start = ctx->offset; /* Start the cold section. This section contains bytes that should @@ -4928,7 +4928,7 @@ dump_mmap_contiguous (struct dump_memory_map *maps, int nr_maps) return true; size_t total_size = 0; - int worst_case_page_size = dump_get_page_size (); + int worst_case_page_size = dump_get_max_page_size (); for (int i = 0; i < nr_maps; ++i) { @@ -5616,7 +5616,7 @@ pdumper_load (const char *dump_filename, char *argv0) err = PDUMPER_LOAD_OOM; adj_discardable_start = header->discardable_start; - dump_page_size = dump_get_page_size (); + dump_page_size = dump_get_max_page_size (); /* Snap to next page boundary. */ adj_discardable_start = ROUNDUP (adj_discardable_start, dump_page_size); eassert (adj_discardable_start % dump_page_size == 0); commit 2a081274e11246349a47e69701f407b174cc9293 Author: Andrea Corallo Date: Wed Mar 30 17:12:43 2022 +0200 * src/pdumper.c: Remove getpagesize.h dependecy. diff --git a/src/pdumper.c b/src/pdumper.c index 1183102362..d9dc13770c 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -36,7 +36,6 @@ along with GNU Emacs. If not, see . */ #include "coding.h" #include "fingerprint.h" #include "frame.h" -#include "getpagesize.h" #include "intervals.h" #include "lisp.h" #include "pdumper.h" commit 2212b42806757957fff6a9646debddecb301241c Author: Michael Albinus Date: Wed Mar 30 13:16:54 2022 +0200 Extend signal-process and proced.el * doc/lispref/processes.texi (Signals to Processes): Document changes in signal-process. * etc/NEWS: Mention changes in proced.el and signal-process. * lisp/proced.el (proced-signal-function): Declare it obsolete. (proced-remote-directory): New user option. (proced-mode): Adapt docstring. (proced-send-signal, proced-renice): Handle interactive prefix argument. * lisp/net/tramp.el (tramp-signal-process): New defun. Add it to `signal-process-functions'. * src/process.c (Finternal_default_signal_process): New defun, providing the hitherto existing implementation of Fsignal_process. (Fsignal_process): Loop through Vsignal_process_functions. (Vsignal_process_functions): New defvar. (Qinternal_default_signal_process, Qsignal_process_functions): Declare symbols. (Sinternal_default_signal_process): Declare subroutine. * test/lisp/net/tramp-tests.el (tramp-test31-signal-process): New test. diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index ea51abda4b..ffc0f10a78 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -1472,7 +1472,7 @@ incoming data from the connection. For serial connections, data that arrived during the time the process was stopped might be lost. @end defun -@deffn Command signal-process process signal +@deffn Command signal-process process signal &optional remote This function sends a signal to process @var{process}. The argument @var{signal} specifies which signal to send; it should be an integer, or a symbol whose name is a signal. @@ -1480,12 +1480,18 @@ or a symbol whose name is a signal. The @var{process} argument can be a system process @acronym{ID} (an integer); that allows you to send signals to processes that are not children of Emacs. @xref{System Processes}. + +If @var{process} is a process object which contains the property +@code{remote-pid}, or @var{process} is a number and @var{remote} is a +remote file name, @var{process} is interpreted as process on the +respective remote host, which will be the process to signal. @end deffn Sometimes, it is necessary to send a signal to a non-local asynchronous process. This is possible by writing an own -@code{interrupt-process} implementation. This function must be added -then to @code{interrupt-process-functions}. +@code{interrupt-process} or @code{signal-process} implementation. +This function must be added then to @code{interrupt-process-functions} +or @code{signal-process-functions}, respectively. @defvar interrupt-process-functions This variable is a list of functions to be called for @@ -1498,6 +1504,17 @@ default function, which shall always be the last in this list, is This is the mechanism, how Tramp implements @code{interrupt-process}. @end defvar +@defvar signal-process-functions +This variable is a list of functions to be called for +@code{signal-process}. The arguments of the functions are the same as +for @code{signal-process}. These functions are called in the order of +the list, until one of them returns non-@code{nil}. The default +function, which shall always be the last in this list, is +@code{signal-default-interrupt-process}. + +This is the mechanism, how Tramp implements @code{signal-process}. +@end defvar + @node Output from Processes @section Receiving Output from Processes @cindex process output diff --git a/etc/NEWS b/etc/NEWS index e684ee30f0..aaab0f4517 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -132,8 +132,8 @@ If you have code in your init file that removes directories from To get the previous action back, put something like the following in your init file: - (require 'ido) - (keymap-set ido-file-completion-map "C-k" #'ido-delete-file-at-head) + (require 'ido) + (keymap-set ido-file-completion-map "C-k" #'ido-delete-file-at-head) --- ** New user option 'term-clear-full-screen-programs'. @@ -590,8 +590,8 @@ value. To enable this behavior, customize the user option 'completion-auto-select' to t, then pressing 'TAB' will switch to the "*Completions*" buffer when it pops up that buffer. If the value is -'second-tab', then the first tab will display "*Completions*", and the -second one will switch to the "*Completions*" buffer. +'second-tab', then the first 'TAB' will display "*Completions*", and +the second one will switch to the "*Completions*" buffer. *** New user option 'completion-wrap-movement'. When non-nil, the commands 'next-completion' and 'previous-completion' @@ -710,8 +710,8 @@ It narrows to the current node. +++ *** 'eudc-expansion-overwrites-query' to 'eudc-expansion-save-query-as-kill'. 'eudc-expansion-overwrites-query' is renamed to -'eudc-expansion-save-query-as-kill' to reflect the actual behaviour of -the customization variable. +'eudc-expansion-save-query-as-kill' to reflect the actual behavior of +the user option. +++ *** New command 'eudc-expand-try-all'. @@ -722,10 +722,10 @@ return any. This is useful for example, if one wants to search LDAP for a name that happens to match a contact in one's BBDB. +++ -*** New behaviour and default for option 'eudc-inline-expansion-format' +*** New behavior and default for user option 'eudc-inline-expansion-format'. EUDC inline expansion result formatting defaulted to - '("%s %s <%s>" firstname name email) + '("%s %s <%s>" firstname name email) Since email address specifications need to comply with RFC 5322 in order to be useful in messages, there was a risk to produce syntax @@ -738,7 +738,7 @@ function. In both cases, the formatted result will be in compliance with RFC 5322. When set to nil, a default format very similar to the old default will be produced. When set to a function, that function is called, and the returned values are used to populate the phrase and -comment parts (see RFC 5322 for definitions). In both cases, the +comment parts (see RFC 5322 for definitions). In both cases, the phrase part will be automatically quoted if necessary. ** eww/shr @@ -1153,13 +1153,20 @@ This library provides the 'autoarg-mode' and 'autoarg-kp-mode' minor modes to emulate the behavior of the historical editor Twenex Emacs. It is believed to no longer be useful. +--- +** proced.el supports sending signals to local processes with root permissions. +When typing 'C-u k' or 'C-u r', sending a signal to or renicing of a +local process will use alternative credentials. The credentials to be +used can be customised by the user option 'proced-remote-directory', +which defaults to "/sudo::". 'proced-signal-function' has been marked obsolete. + * New Modes and Packages in Emacs 29.1 +++ ** New package 'oclosure'. Allows the creation of "functions with slots" or "function objects" -via the macros `oclosure-define` and `oclosure-lambda`. +via the macros 'oclosure-define' and 'oclosure-lambda'. --- ** New theme 'leuven-dark'. @@ -1814,6 +1821,13 @@ translation. This is useful when quoting shell arguments for a remote shell invocation. Such shells are POSIX conform by default. ++++ +** 'signal-process' now consults the list 'signal-process-functions'. +This is to determine which function has to be called in order to +deliver the signal. This allows Tramp to send the signal to remote +asynchronous processes. The hitherto existing implementation has been +moved to 'signal-default-interrupt-process'. + * Changes in Emacs 29.1 on Non-Free Operating Systems diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 4e5eed9d99..bddbe3f91a 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -5961,6 +5961,45 @@ name of a process or buffer, or nil to default to the current buffer." (lambda () (remove-hook 'interrupt-process-functions #'tramp-interrupt-process))) +(defun tramp-signal-process (process sigcode &optional remote) + "Send PROCESS the signal with code SIGCODE. +PROCESS may also be a number specifying the process id of the +process to signal; in this case, the process need not be a child of +this Emacs. +If PROCESS is a process object which contains the property +`remote-pid', or PROCESS is a number and REMOTE is a remote file name, +PROCESS is interpreted as process on the respective remote host, which +will be the process to signal. +SIGCODE may be an integer, or a symbol whose name is a signal name." + (let (pid vec) + (cond + ((processp process) + (setq pid (process-get process 'remote-pid) + vec (process-get process 'vector))) + ((numberp process) + (setq pid process + vec (and (stringp remote) (tramp-dissect-file-name remote)))) + (t (signal 'wrong-type-argument (list #'processp process)))) + (unless (or (numberp sigcode) (symbolp sigcode)) + (signal 'wrong-type-argument (list #'numberp sigcode))) + ;; If it's a Tramp process, send SIGCODE remotely. + (when (and pid vec) + (tramp-message + vec 5 "Send signal %s to process %s with pid %s" sigcode process pid) + ;; This is for tramp-sh.el. Other backends do not support this (yet). + (if (tramp-compat-funcall + 'tramp-send-command-and-check + vec (format "\\kill -%s %d" sigcode pid)) + 0 -1)))) + +;; `signal-process-functions' exists since Emacs 29.1. +(when (boundp 'signal-process-functions) + (add-hook 'signal-process-functions #'tramp-signal-process) + (add-hook + 'tramp-unload-hook + (lambda () + (remove-hook 'signal-process-functions #'tramp-signal-process)))) + (defun tramp-get-remote-null-device (vec) "Return null device on the remote host identified by VEC. If VEC is `tramp-null-hop', return local null device." diff --git a/lisp/proced.el b/lisp/proced.el index c1d599afc4..7966ccfb08 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -29,10 +29,6 @@ ;; ;; To do: ;; - Interactive temporary customizability of flags in `proced-grammar-alist' -;; - Allow "sudo kill PID", "sudo renice PID" -;; `proced-send-signal' operates on multiple processes one by one. -;; With "sudo" we want to execute one "kill" or "renice" command -;; for all marked processes. Is there a `sudo-call-process'? ;; ;; Thoughts and Ideas ;; - Currently, `process-attributes' returns the list of @@ -61,6 +57,14 @@ It can be an elisp function (usually `signal-process') or a string specifying the external command (usually \"kill\")." :type '(choice (function :tag "function") (string :tag "command"))) +(make-obsolete-variable 'proced-signal-function "no longer used." "29.1") + +(defcustom proced-remote-directory "/sudo::" + "Remote directory to be used when sending a signal. +It must point to the local host, via a `sudo' or `doas' method, +or alike. See `proced-send-signal' and `proced-renice'." + :version "29.1" + :type '(string :tag "remote directory")) (defcustom proced-renice-command "renice" "Name of renice command." @@ -626,6 +630,9 @@ Return nil if point is not on a process line." Type \\[proced] to start a Proced session. In a Proced buffer type \\\\[proced-mark] to mark a process for later commands. Type \\[proced-send-signal] to send signals to marked processes. +Type \\[proced-renice] to renice marked processes. +With a prefix argument \\[universal-argument], sending signals to and renicing of processes +will be performed with the credentials of `proced-remote-directory'. The initial content of a listing is defined by the variable `proced-filter' and the variable `proced-format'. @@ -1766,7 +1773,10 @@ runs the normal hook `proced-after-send-signal-hook'. For backward compatibility SIGNAL and PROCESS-ALIST may be nil. Then PROCESS-ALIST contains the marked processes or the process point is on and SIGNAL is queried interactively. This noninteractive usage is still -supported but discouraged. It will be removed in a future version of Emacs." +supported but discouraged. It will be removed in a future version of Emacs. + +With a prefix argument \\[universal-argument], send the signal with the credentials of +`proced-remote-directory'." (interactive (let* ((process-alist (proced-marked-processes)) (pnum (if (= 1 (length process-alist)) @@ -1808,7 +1818,10 @@ supported but discouraged. It will be removed in a future version of Emacs." proced-signal-list nil nil nil nil "TERM")))))) - (let (failures) + (let ((default-directory + (if (and current-prefix-arg (stringp proced-remote-directory)) + proced-remote-directory temporary-file-directory)) + failures) ;; Why not always use `signal-process'? See ;; https://lists.gnu.org/r/emacs-devel/2008-03/msg02955.html (if (functionp proced-signal-function) @@ -1821,7 +1834,8 @@ supported but discouraged. It will be removed in a future version of Emacs." (dolist (process process-alist) (condition-case err (unless (zerop (funcall - proced-signal-function (car process) signal)) + proced-signal-function (car process) signal + (file-remote-p default-directory))) (proced-log "%s\n" (cdr process)) (push (cdr process) failures)) (error ; catch errors from failed signals @@ -1833,7 +1847,7 @@ supported but discouraged. It will be removed in a future version of Emacs." (dolist (process process-alist) (with-temp-buffer (condition-case nil - (unless (zerop (call-process + (unless (zerop (process-file proced-signal-function nil t nil signal (number-to-string (car process)))) (proced-log (current-buffer)) @@ -1862,7 +1876,10 @@ PROCESS-ALIST is an alist as returned by `proced-marked-processes'. Interactively, PROCESS-ALIST contains the marked processes. If no process is marked, it contains the process point is on, After renicing all processes in PROCESS-ALIST, this command runs -the normal hook `proced-after-send-signal-hook'." +the normal hook `proced-after-send-signal-hook'. + +With a prefix argument \\[universal-argument], apply renice with the credentials of +`proced-remote-directory'." (interactive (let ((process-alist (proced-marked-processes))) (proced-with-processes-buffer process-alist @@ -1871,11 +1888,14 @@ the normal hook `proced-after-send-signal-hook'." proced-mode) (if (numberp priority) (setq priority (number-to-string priority))) - (let (failures) + (let ((default-directory + (if (and current-prefix-arg (stringp proced-remote-directory)) + proced-remote-directory temporary-file-directory)) + failures) (dolist (process process-alist) (with-temp-buffer (condition-case nil - (unless (zerop (call-process + (unless (zerop (process-file proced-renice-command nil t nil priority (number-to-string (car process)))) (proced-log (current-buffer)) diff --git a/src/process.c b/src/process.c index 993e1c5603..e8aafd02d7 100644 --- a/src/process.c +++ b/src/process.c @@ -7034,14 +7034,13 @@ abbr_to_signal (char const *name) return -1; } -DEFUN ("signal-process", Fsignal_process, Ssignal_process, - 2, 2, "sProcess (name or number): \nnSignal code: ", - doc: /* Send PROCESS the signal with code SIGCODE. -PROCESS may also be a number specifying the process id of the -process to signal; in this case, the process need not be a child of -this Emacs. -SIGCODE may be an integer, or a symbol whose name is a signal name. */) - (Lisp_Object process, Lisp_Object sigcode) +DEFUN ("internal-default-signal-process", + Finternal_default_signal_process, + Sinternal_default_signal_process, 2, 3, 0, + doc: /* Default function to send PROCESS the signal with code SIGCODE. +It shall be the last element in list `signal-process-functions'. +See function `signal-process' for more details on usage. */) + (Lisp_Object process, Lisp_Object sigcode, Lisp_Object remote) { pid_t pid; int signo; @@ -7091,6 +7090,23 @@ SIGCODE may be an integer, or a symbol whose name is a signal name. */) return make_fixnum (kill (pid, signo)); } +DEFUN ("signal-process", Fsignal_process, Ssignal_process, + 2, 3, "sProcess (name or number): \nnSignal code: ", + doc: /* Send PROCESS the signal with code SIGCODE. +PROCESS may also be a number specifying the process id of the +process to signal; in this case, the process need not be a child of +this Emacs. +If PROCESS is a process object which contains the property +`remote-pid', or PROCESS is a number and REMOTE is a remote file name, +PROCESS is interpreted as process on the respective remote host, which +will be the process to signal. +SIGCODE may be an integer, or a symbol whose name is a signal name. */) + (Lisp_Object process, Lisp_Object sigcode, Lisp_Object remote) +{ + return CALLN (Frun_hook_with_args_until_success, Qsignal_process_functions, + process, sigcode, remote); +} + DEFUN ("process-send-eof", Fprocess_send_eof, Sprocess_send_eof, 0, 1, 0, doc: /* Make PROCESS see end-of-file in its input. EOF comes after any text already sent to it. @@ -8580,6 +8596,13 @@ These functions are called in the order of the list, until one of them returns non-nil. */); Vinterrupt_process_functions = list1 (Qinternal_default_interrupt_process); + DEFVAR_LISP ("signal-process-functions", Vsignal_process_functions, + doc: /* List of functions to be called for `signal-process'. +The arguments of the functions are the same as for `signal-process'. +These functions are called in the order of the list, until one of them +returns non-nil. */); + Vsignal_process_functions = list1 (Qinternal_default_signal_process); + DEFVAR_LISP ("internal--daemon-sockname", Vinternal__daemon_sockname, doc: /* Name of external socket passed to Emacs, or nil if none. */); Vinternal__daemon_sockname = Qnil; @@ -8600,6 +8623,10 @@ sentinel or a process filter function has an error. */); "internal-default-interrupt-process"); DEFSYM (Qinterrupt_process_functions, "interrupt-process-functions"); + DEFSYM (Qinternal_default_signal_process, + "internal-default-signal-process"); + DEFSYM (Qsignal_process_functions, "signal-process-functions"); + DEFSYM (Qnull, "null"); DEFSYM (Qpipe_process_p, "pipe-process-p"); @@ -8654,6 +8681,7 @@ sentinel or a process filter function has an error. */); defsubr (&Scontinue_process); defsubr (&Sprocess_running_child_p); defsubr (&Sprocess_send_eof); + defsubr (&Sinternal_default_signal_process); defsubr (&Ssignal_process); defsubr (&Swaiting_for_user_input_p); defsubr (&Sprocess_type); diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 94ff12bab4..c3b3f21d52 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -4984,6 +4984,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (ert-deftest tramp-test31-interrupt-process () "Check `interrupt-process'." :tags (append '(:expensive-test :tramp-asynchronous-processes) + ;; The final `process-live-p' check does not run sufficiently. (and (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) '(:unstable))) (skip-unless (tramp--test-enabled)) @@ -5022,6 +5023,73 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Cleanup. (ignore-errors (delete-process proc))))) +(ert-deftest tramp-test31-signal-process () + "Check `signal-process'." + :tags (append '(:expensive-test :tramp-asynchronous-processes) + ;; The final `process-live-p' check does not run sufficiently. + (and (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) + '(:unstable))) + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) + ;; Since Emacs 29.1. + (skip-unless (boundp 'signal-process-functions)) + + ;; We must use `file-truename' for the temporary directory, in + ;; order to establish the connection prior running an asynchronous + ;; process. + (let ((default-directory (file-truename tramp-test-temporary-file-directory)) + (delete-exited-processes t) + kill-buffer-query-functions command proc) + + (dolist (sigcode '(2 INT)) + (unwind-protect + (with-temp-buffer + (setq command "trap 'echo boom; exit 1' 2; sleep 100" + proc (start-file-process-shell-command + (format "test1%s" sigcode) (current-buffer) command)) + (should (processp proc)) + (should (process-live-p proc)) + (should (equal (process-status proc) 'run)) + (should (numberp (process-get proc 'remote-pid))) + (should (equal (process-get proc 'remote-command) + (with-connection-local-variables + `(,shell-file-name ,shell-command-switch ,command)))) + (should (zerop (signal-process proc sigcode))) + ;; Let the process accept the signal. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (accept-process-output proc 0 nil t))) + (should-not (process-live-p proc))) + + ;; Cleanup. + (ignore-errors (kill-process proc)) + (ignore-errors (delete-process proc))) + + (unwind-protect + (with-temp-buffer + (setq command "trap 'echo boom; exit 1' 2; sleep 100" + proc (start-file-process-shell-command + (format "test2%s" sigcode) (current-buffer) command)) + (should (processp proc)) + (should (process-live-p proc)) + (should (equal (process-status proc) 'run)) + (should (numberp (process-get proc 'remote-pid))) + (should (equal (process-get proc 'remote-command) + (with-connection-local-variables + `(,shell-file-name ,shell-command-switch ,command)))) + (should + (zerop + (signal-process + (process-get proc 'remote-pid) sigcode default-directory))) + ;; Let the process accept the signal. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (accept-process-output proc 0 nil t))) + (should-not (process-live-p proc))) + + ;; Cleanup. + (ignore-errors (kill-process proc)) + (ignore-errors (delete-process proc)))))) + (defun tramp--test-async-shell-command (command output-buffer &optional error-buffer input) "Like `async-shell-command', reading the output. commit c0f5e0a559bab530d6a2e1de3bb021d004a855cf Author: Michael Albinus Date: Wed Mar 30 11:16:57 2022 +0200 ; Extend Tramp FAQ * doc/misc/tramp.texi (Frequently Asked Questions): Explain Tramp temporary file identification. diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index c527f3e806..526e92aadd 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -5029,6 +5029,26 @@ be restored by moving them manually from @file{$@{XDG_DATA_HOME@}/Trash/files/}, if needed. +@item +How to identify temporary files produced by @value{tramp}? + +@vindex tramp-temp-name-prefix +Temporary files are kept in your @code{temporary-file-directory} +directory, which is often @file{/tmp/}. By default, they have the +file name prefix @t{"tramp."}. If you want to change this prefix, for +example because you want to identify temporary files produced by +@code{file-local-copy} in your package, you can bind the variable +@code{tramp-temp-name-prefix} temporarily: + +@example +@group +(let ((tramp-temp-name-prefix "my-prefix.")) + (file-local-copy "@trampfn{ssh,,.emacs}")) +@result{} "/tmp/my-prefix.HDfgDZ" +@end group +@end example + + @item How to shorten long file names when typing in @value{tramp}? commit 34ff19a8820334f92802be13e9d88f1264e493ab Author: Po Lu Date: Wed Mar 30 16:36:10 2022 +0800 Remove local copies of remote files created for drag-and-drop * lisp/dired.el (dired-mouse-drag): Remove last dragged remote file and save a record of any local copy created. (dired-remove-last-dragged-local-file): New function. diff --git a/lisp/dired.el b/lisp/dired.el index 41313f5eb9..0b5f2cab41 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1699,13 +1699,29 @@ see `dired-use-ls-dired' for more details.") beg)) beg)))) -(declare-function x-begin-drag "xfns.cx") +(defvar dired-last-dragged-remote-file nil + "If non-nil, the name of a local copy of the last remote file that was dragged. +It can't be removed immediately after the drag-and-drop operation +completes, since there is no way to determine when the drop +target has finished opening it. So instead, this file is removed +when Emacs exits or the user drags another file.") + +(declare-function x-begin-drag "xfns.c") + +(defun dired-remove-last-dragged-local-file () + "Remove the local copy of the last remote file to be dragged." + (when dired-last-dragged-remote-file + (unwind-protect + (delete-file dired-last-dragged-remote-file) + (setq dired-last-dragged-remote-file nil))) + (remove-hook 'kill-emacs-hook #'dired-remove-last-dragged-local-file)) (defun dired-mouse-drag (event) "Begin a drag-and-drop operation for the file at EVENT." (interactive "e") (when mark-active (deactivate-mark)) + (dired-remove-last-dragged-local-file) (save-excursion (with-selected-window (posn-window (event-end event)) (goto-char (posn-point (event-end event)))) @@ -1728,7 +1744,10 @@ see `dired-use-ls-dired' for more details.") ;; actually implements file DND according to the ;; spec. (when (file-remote-p filename) - (setq filename (file-local-copy filename))) + (setq filename (file-local-copy filename)) + (setq dired-last-dragged-remote-file filename) + (add-hook 'kill-emacs-hook + #'dired-remove-last-dragged-local-file)) (gui-backend-set-selection 'XdndSelection filename) (x-begin-drag '("text/uri-list" "text/x-dnd-username") commit ea86ba8966c80256e05c45aead130aff462f9ad8 Author: Po Lu Date: Wed Mar 30 08:24:45 2022 +0000 Ignore mouse movement correctly on Haiku during drag and drop * src/haikuselect.c (haiku_unwind_drag_message): New function. (Fhaiku_drag_message): Set `haiku_dnd_in_progress' to false. * src/haikuterm.c (haiku_read_socket): Fix overriding of need_flush when reading events from multiple frames. * src/haikuterm.h (haiku_dnd_in_progress): New variable. * src/xdisp.c (note_mouse_highlight): Ignore if said variable is true. diff --git a/src/haikuselect.c b/src/haikuselect.c index 77dcff42a6..d2582e777f 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -27,6 +27,7 @@ along with GNU Emacs. If not, see . */ #include +bool haiku_dnd_in_progress; static void haiku_lisp_to_message (Lisp_Object, void *); DEFUN ("haiku-selection-data", Fhaiku_selection_data, Shaiku_selection_data, @@ -723,6 +724,13 @@ haiku_should_quit_drag (void) return !NILP (Vquit_flag); } +static void +haiku_unwind_drag_message (void *message) +{ + BMessage_delete (message); + haiku_dnd_in_progress = false; +} + DEFUN ("haiku-drag-message", Fhaiku_drag_message, Shaiku_drag_message, 2, 3, 0, doc: /* Begin dragging MESSAGE from FRAME. @@ -768,9 +776,10 @@ ignored if it is dropped on top of FRAME. */) if (!FRAME_VISIBLE_P (f)) error ("Frame is invisible"); + haiku_dnd_in_progress = true; be_message = be_create_simple_message (); - record_unwind_protect_ptr (BMessage_delete, be_message); + record_unwind_protect_ptr (haiku_unwind_drag_message, be_message); haiku_lisp_to_message (message, be_message); rc = be_drag_message (FRAME_HAIKU_VIEW (f), be_message, !NILP (allow_same_frame), diff --git a/src/haikuterm.c b/src/haikuterm.c index c2e8375a10..304b7a3425 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -58,7 +58,7 @@ struct unhandled_event uint8_t buffer[200]; }; -static bool any_help_event_p = false; +static bool any_help_event_p; char * get_keysym_name (int keysym) @@ -3120,7 +3120,8 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) do_help = 1; } - need_flush = FRAME_DIRTY_P (f); + if (FRAME_DIRTY_P (f)) + need_flush = 1; break; } case BUTTON_UP: diff --git a/src/haikuterm.h b/src/haikuterm.h index 5f8052f0f9..86abcc560c 100644 --- a/src/haikuterm.h +++ b/src/haikuterm.h @@ -35,6 +35,7 @@ along with GNU Emacs. If not, see . */ #define HAVE_CHAR_CACHE_MAX 65535 extern int popup_activated_p; +extern bool haiku_dnd_in_progress; extern void be_app_quit (void); diff --git a/src/xdisp.c b/src/xdisp.c index 62c8f9d4d9..f6fe3253e9 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -34247,7 +34247,7 @@ note_mouse_highlight (struct frame *f, int x, int y) #endif #if defined (HAVE_HAIKU) - if (popup_activated_p) + if (popup_activated_p || haiku_dnd_in_progress) return; #endif commit 9f54cb5f8f0df79468546b9431a0fe72ee2f1a52 Author: Po Lu Date: Wed Mar 30 08:13:35 2022 +0000 Prevent signals when dragging nonexistent files on Haiku * lisp/term/haiku-win.el (x-begin-drag): Bind `haiku-signal-invalid-refs' to nil. * src/haiku_support.cc (MouseMoved): Send motion events while dragging as well. * src/haikuselect.c (haiku_lisp_to_message): Respect new variable. (syms_of_haikuselect): New variable `haiku-signal-invalid-refs'. diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index f9dcd0d192..738cf56caa 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -44,6 +44,7 @@ (defvar x-command-line-resources) (defvar haiku-initialized) +(defvar haiku-signal-invalid-refs) (defvar haiku-dnd-selection-value nil "The local value of the special `XdndSelection' selection.") @@ -277,7 +278,8 @@ take effect on menu items until the menu bar is updated again." "SKIP: real doc in xfns.c." (unless haiku-dnd-selection-value (error "No local value for XdndSelection")) - (let ((message nil)) + (let ((message nil) + (haiku-signal-invalid-refs nil)) (dolist (target targets) (let ((selection-converter (cdr (assoc (intern target) haiku-dnd-selection-converters)))) diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 39df06e436..dd27d6317c 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -1530,9 +1530,6 @@ class EmacsView : public BView rq.window = this->Window (); rq.time = system_time (); - if (drag_msg && transit != B_EXITED_VIEW) - return; - if (ToolTip ()) ToolTip ()->SetMouseRelativeLocation (BPoint (-(point.x - tt_absl_pos.x), -(point.y - tt_absl_pos.y))); diff --git a/src/haikuselect.c b/src/haikuselect.c index 38d4933948..77dcff42a6 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -520,7 +520,8 @@ haiku_lisp_to_message (Lisp_Object obj, void *message) case 'RREF': CHECK_STRING (data); - if (be_add_refs_data (message, SSDATA (name), SSDATA (data))) + if (be_add_refs_data (message, SSDATA (name), SSDATA (data)) + && haiku_signal_invalid_refs) signal_error ("Invalid file name", data); break; @@ -787,6 +788,12 @@ ignored if it is dropped on top of FRAME. */) void syms_of_haikuselect (void) { + DEFVAR_BOOL ("haiku-signal-invalid-refs", haiku_signal_invalid_refs, + doc: /* If nil, silently ignore invalid file names in system messages. +Otherwise, an error will be signalled if adding a file reference to a +system message failed. */); + haiku_signal_invalid_refs = true; + DEFSYM (QSECONDARY, "SECONDARY"); DEFSYM (QCLIPBOARD, "CLIPBOARD"); DEFSYM (QSTRING, "STRING"); commit 7a5f2b79e9d75e4fd67844bdb8325a32b011383d Author: Po Lu Date: Wed Mar 30 14:20:13 2022 +0800 ; * lisp/dired.el (dired-mouse-drag): Create local copy if file is remote. diff --git a/lisp/dired.el b/lisp/dired.el index 409a312d0d..41313f5eb9 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1717,17 +1717,25 @@ see `dired-use-ls-dired' for more details.") ;; We can get an error if there's by some chance no file ;; name at point. (condition-case nil - (progn - (gui-backend-set-selection 'XdndSelection - (with-selected-window (posn-window - (event-end event)) - (dired-file-name-at-point))) - (x-begin-drag '("text/uri-list" - "text/x-dnd-username") - (if (eq 'dired-mouse-drag-files 'link) - 'XdndActionLink - 'XdndActionCopy) - nil nil t)) + (let ((filename (with-selected-window (posn-window + (event-end event)) + (dired-file-name-at-point)))) + (when filename + ;; In theory x-dnd-username combined with a proper + ;; file URI containing the hostname of the remote + ;; server could be used here instead of creating a + ;; local copy of the remote file, but no program + ;; actually implements file DND according to the + ;; spec. + (when (file-remote-p filename) + (setq filename (file-local-copy filename))) + (gui-backend-set-selection 'XdndSelection filename) + (x-begin-drag '("text/uri-list" + "text/x-dnd-username") + (if (eq 'dired-mouse-drag-files 'link) + 'XdndActionLink + 'XdndActionCopy) + nil nil t))) (error (when (eq (event-basic-type new-event) 'mouse-1) (push new-event unread-command-events))))))))) commit 62c779cbde658d29498c3f0b6ccc4f63ba9c5413 Author: Po Lu Date: Wed Mar 30 11:25:50 2022 +0800 Disallow building with non-toolkit scroll bars on non-X systems * configure.ac: Prevent building without toolkit scroll bars on non-X systems, where they're not implemented. (bug#54629) diff --git a/configure.ac b/configure.ac index 10358c2b64..93c821eda0 100644 --- a/configure.ac +++ b/configure.ac @@ -3357,6 +3357,8 @@ if test "${with_toolkit_scroll_bars}" != "no"; then AC_DEFINE(USE_TOOLKIT_SCROLL_BARS) USE_TOOLKIT_SCROLL_BARS=yes fi +elif test "${window_system}" != "x11"; then + AC_MSG_ERROR(Non-toolkit scroll bars are not implemented for your system) fi dnl See if XIM is available. commit c4a1e8bd7a3c6582c036df98248ac3d37ad55835 Author: Po Lu Date: Wed Mar 30 09:17:58 2022 +0800 Avoid calling XGetAtomName in a loop when fetching monitor attributes * src/xfns.c (x_get_monitor_attributes_xrandr): Avoid syncing on each monitor when waiting for XGetAtomName when built with XCB. diff --git a/src/xfns.c b/src/xfns.c index 37e0628464..4fa919f36a 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -5768,6 +5768,12 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo) #if RANDR_MAJOR > 1 || (RANDR_MAJOR == 1 && RANDR_MINOR >= 5) XRRMonitorInfo *rr_monitors; +#ifdef USE_XCB + xcb_get_atom_name_cookie_t *atom_name_cookies; + xcb_get_atom_name_reply_t *reply; + xcb_generic_error_t *error; + int length; +#endif /* If RandR 1.5 or later is available, use that instead, as some video drivers don't report correct dimensions via other versions @@ -5786,6 +5792,9 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo) goto fallback; monitors = xzalloc (n_monitors * sizeof *monitors); +#ifdef USE_XCB + atom_name_cookies = alloca (n_monitors * sizeof *atom_name_cookies); +#endif for (int i = 0; i < n_monitors; ++i) { @@ -5796,6 +5805,7 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo) monitors[i].mm_width = rr_monitors[i].mwidth; monitors[i].mm_height = rr_monitors[i].mheight; +#ifndef USE_XCB name = XGetAtomName (dpyinfo->display, rr_monitors[i].name); if (name) { @@ -5804,6 +5814,11 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo) } else monitors[i].name = xstrdup ("Unknown Monitor"); +#else + atom_name_cookies[i] + = xcb_get_atom_name (dpyinfo->xcb_connection, + (xcb_atom_t) rr_monitors[i].name); +#endif if (rr_monitors[i].primary) primary = i; @@ -5821,6 +5836,29 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo) monitors[i].work = monitors[i].geom; } +#ifdef USE_XCB + for (int i = 0; i < n_monitors; ++i) + { + reply = xcb_get_atom_name_reply (dpyinfo->xcb_connection, + atom_name_cookies[i], &error); + + if (!reply) + { + monitors[i].name = xstrdup ("Unknown monitor"); + free (error); + } + else + { + length = xcb_get_atom_name_name_length (reply); + name = xmalloc (length + 1); + memcpy (name, xcb_get_atom_name_name (reply), length); + name[length] = '\0'; + monitors[i].name = name; + free (reply); + } + } +#endif + XRRFreeMonitors (rr_monitors); randr15_p = true; goto out; commit c52b58d2903e3ff212dc1b9e9316ee26fae5aa66 Author: Po Lu Date: Wed Mar 30 08:57:23 2022 +0800 Add some optimizations to ShapeNotify handling * src/xterm.c (handle_one_xevent): Do bounding rect optimizations on ShapeNotify events as well. diff --git a/src/xterm.c b/src/xterm.c index 28311f94e9..a92c34396c 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -15987,6 +15987,20 @@ handle_one_xevent (struct x_display_info *dpyinfo, tem->n_input_rects = -1; } + /* And the common case where there is no input rect and the + bouding rect equals the window dimensions. */ + + if (tem->n_input_rects == -1 + && tem->n_bounding_rects == 1 + && tem->bounding_rects[0].width == tem->width + && tem->bounding_rects[0].height == tem->height + && tem->bounding_rects[0].x == -tem->border_width + && tem->bounding_rects[0].y == -tem->border_width) + { + xfree (tem->bounding_rects); + tem->n_bounding_rects = -1; + } + break; } } commit 973608e35895a8f89a3abcac43dfaf89598b0c82 Author: Michael Albinus Date: Tue Mar 29 19:36:28 2022 +0200 Handle process property `remote-command' in Tramp * doc/misc/tramp.texi (Remote processes): New subsection "Process properties of asynchronous remote processes". * lisp/net/tramp.el (tramp-handle-make-process): * lisp/net/tramp-adb.el (tramp-adb-handle-make-process): * lisp/net/tramp-smb.el (tramp-smb-handle-start-file-process): * lisp/net/tramp-sh.el (tramp-sh-handle-make-process) Set `remote-command' process property. (tramp-scp-direct-remote-copying): Rename connection property. * test/lisp/net/tramp-tests.el (tramp-test29-start-file-process) (tramp-test30-make-process, tramp-test31-interrupt-process) (tramp--test-async-shell-command): Check process property `remote-command'. diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 62bcf9c73b..c527f3e806 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -2913,6 +2913,7 @@ Additionally, it declares also the arguments for running remote processes, using the @command{ssh} command. These don't need to be changed. + @node Android shell setup @section Android shell setup hints @cindex android shell setup for ssh @@ -4019,6 +4020,34 @@ using the @code{:connection-type} keyword. If this keyword is not used, the value of @code{process-connection-type} is applied instead. +@subsection Process properties of asynchronous remote processes +@cindex Asynchronous remote processes + +When available, @value{tramp} adds process properties to process +objects of asynchronous properties. However, it is not guaranteed +that all these properties are set. + +@itemize +@item @code{remote-tty} + +This is the name of the terminal a @var{process} uses on the remote +host, i.e., it reads and writes on. + +@item @code{remote-pid} + +The process id of the command executed on the remote host. This is +used when sending signals remotely. + +@item @code{remote-command} + +The remote command which has been invoked via @code{make-process} or +@code{start-file-process}, a list of strings (program and its +arguments). This does not show the additional shell sugar +@value{tramp} makes around the commands, in order to see this you must +inspect @value{tramp} @ref{Traces and Profiles, traces}. +@end itemize + + @anchor{Improving performance of asynchronous remote processes} @subsection Improving performance of asynchronous remote processes @cindex Asynchronous remote processes diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index ce90943d9a..ab20185d5a 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -973,6 +973,7 @@ implementation will be used." (tramp-make-tramp-temp-file v)))) (remote-tmpstderr (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) + (orig-command command) (program (car command)) (args (cdr command)) (command @@ -1030,6 +1031,9 @@ implementation will be used." (set-process-sentinel p sentinel)) (when filter (set-process-filter p filter)) + (process-put p 'remote-command orig-command) + (tramp-set-connection-property + p "remote-command" orig-command) ;; Set query flag and process marker for ;; this process. We ignore errors, because ;; the process could have finished already. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 805be8270a..3ab5e4d169 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2856,6 +2856,7 @@ implementation will be used." stderr (tramp-make-tramp-temp-name v))))) (remote-tmpstderr (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) + (orig-command command) (program (car command)) (args (cdr command)) ;; When PROGRAM matches "*sh", and the first arg is @@ -3012,6 +3013,9 @@ implementation will be used." (set-process-sentinel p sentinel)) (when filter (set-process-filter p filter)) + (process-put p 'remote-command orig-command) + (tramp-set-connection-property + p "remote-command" orig-command) ;; Set query flag and process marker for this ;; process. We ignore errors, because the ;; process could have finished already. @@ -4877,7 +4881,8 @@ Goes through the list `tramp-inline-compress-commands'." "\\(illegal\\|unknown\\) option -- R" nil 'noerror))))) ;; Check, that RemoteCommand is not used. - (with-tramp-connection-property (tramp-get-process vec1) "remote-command" + (with-tramp-connection-property + (tramp-get-process vec1) "ssh-remote-command" (let ((command `("ssh" "-G" ,(tramp-file-name-host vec1)))) (with-temp-buffer (tramp-call-process diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index bbc5499ae7..db6b0fc174 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -1544,7 +1544,8 @@ component is used as the target of the symlink." (command (string-join (cons program args) " ")) (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) (name1 name) - (i 0)) + (i 0) + p) (unwind-protect (save-excursion (save-restriction @@ -1567,8 +1568,13 @@ component is used as the target of the symlink." host (file-name-directory localname)))) (tramp-message v 6 "(%s); exit" command) (tramp-send-string v command))) + (setq p (tramp-get-connection-process v)) + (when program + (process-put p 'remote-command (cons program args)) + (tramp-set-connection-property + p "remote-command" (cons program args))) ;; Return value. - (tramp-get-connection-process v))) + p)) ;; Save exit. (with-current-buffer (tramp-get-connection-buffer v) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 580cfea1f8..4e5eed9d99 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -4316,6 +4316,7 @@ substitution. SPEC-LIST is a list of char/value pairs used for (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. (generate-new-buffer tramp-temp-buffer-name))) + (orig-command command) (env (mapcar (lambda (elt) (when (tramp-compat-string-search "=" elt) elt)) @@ -4391,6 +4392,8 @@ substitution. SPEC-LIST is a list of char/value pairs used for ;; t. See Bug#51177. (when filter (set-process-filter p filter)) + (process-put p 'remote-command orig-command) + (tramp-set-connection-property p "remote-command" orig-command) (tramp-message v 6 "%s" (string-join (process-command p) " ")) p)))))) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index f34fdbdaf7..94ff12bab4 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -4540,14 +4540,17 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) (tmp-name (tramp--test-make-temp-name nil quoted)) - kill-buffer-query-functions proc) + kill-buffer-query-functions command proc) ;; Simple process. (unwind-protect (with-temp-buffer - (setq proc (start-file-process "test1" (current-buffer) "cat")) + (setq command '("cat") + proc + (apply #'start-file-process "test1" (current-buffer) command)) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. @@ -4564,11 +4567,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-temp-buffer (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) - (setq proc - (start-file-process - "test2" (current-buffer) - "cat" (file-name-nondirectory tmp-name))) + (setq command `("cat" ,(file-name-nondirectory tmp-name)) + proc + (apply #'start-file-process "test2" (current-buffer) command)) (should (processp proc)) + (should (equal (process-get proc 'remote-command) command)) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) @@ -4583,9 +4586,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Process filter. (unwind-protect (with-temp-buffer - (setq proc (start-file-process "test3" (current-buffer) "cat")) + (setq command '("cat") + proc + (apply #'start-file-process "test3" (current-buffer) command)) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (set-process-filter proc (lambda (p s) (with-current-buffer (process-buffer p) (insert s)))) @@ -4604,9 +4610,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (unless (tramp--test-sshfs-p) (unwind-protect (with-temp-buffer - (setq proc (start-file-process "test3" (current-buffer) "cat")) + (setq command '("cat") + proc + (apply #'start-file-process "test4" (current-buffer) command)) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (set-process-filter proc t) (process-send-string proc "foo\n") (process-send-eof proc) @@ -4632,12 +4641,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (dolist (process-connection-type '(nil pipe t pty)) (unwind-protect (with-temp-buffer - (setq proc - (start-file-process - (format "test4-%s" process-connection-type) - (current-buffer) "hexdump" "-v" "-e" "/1 \"%02X\n\"")) + (setq command '("hexdump" "-v" "-e" "/1 \"%02X\n\"") + proc + (apply #'start-file-process + (format "test5-%s" process-connection-type) + (current-buffer) command)) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (process-send-string proc "foo\r\n") (process-send-eof proc) ;; Read output. @@ -4665,12 +4676,13 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; It works only for tramp-sh.el, and not direct async processes. (if (or (not (tramp--test-sh-p)) (tramp-direct-async-process-p)) (should-error - (start-file-process "test5" (current-buffer) nil) + (start-file-process "test6" (current-buffer) nil) :type 'wrong-type-argument) - (setq proc (start-file-process "test5" (current-buffer) nil)) + (setq proc (start-file-process "test6" (current-buffer) nil)) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should-not (process-get proc 'remote-command)) ;; On MS Windows, `process-tty-name' returns nil. (unless (tramp--test-windows-nt-p) (should (stringp (process-tty-name proc)))))) @@ -4724,19 +4736,21 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) (tmp-name (tramp--test-make-temp-name nil quoted)) - kill-buffer-query-functions proc) + kill-buffer-query-functions command proc) (with-no-warnings (should-not (make-process))) ;; Simple process. (unwind-protect (with-temp-buffer - (setq proc + (setq command '("cat") + proc (with-no-warnings (make-process - :name "test1" :buffer (current-buffer) :command '("cat") + :name "test1" :buffer (current-buffer) :command command :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. @@ -4753,13 +4767,14 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (with-temp-buffer (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) - (setq proc + (setq command `("cat" ,(file-name-nondirectory tmp-name)) + proc (with-no-warnings (make-process - :name "test2" :buffer (current-buffer) - :command `("cat" ,(file-name-nondirectory tmp-name)) + :name "test2" :buffer (current-buffer) :command command :file-handler t))) (should (processp proc)) + (should (equal (process-get proc 'remote-command) command)) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) @@ -4774,16 +4789,18 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Process filter. (unwind-protect (with-temp-buffer - (setq proc + (setq command '("cat") + proc (with-no-warnings (make-process - :name "test3" :buffer (current-buffer) :command '("cat") + :name "test3" :buffer (current-buffer) :command command :filter (lambda (p s) (with-current-buffer (process-buffer p) (insert s))) :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. @@ -4799,14 +4816,16 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (unless (tramp--test-sshfs-p) (unwind-protect (with-temp-buffer - (setq proc + (setq command '("cat") + proc (with-no-warnings (make-process - :name "test3" :buffer (current-buffer) :command '("cat") + :name "test4" :buffer (current-buffer) :command command :filter t :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. There shouldn't be any. @@ -4822,16 +4841,18 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Process sentinel. (unwind-protect (with-temp-buffer - (setq proc + (setq command '("cat") + proc (with-no-warnings (make-process - :name "test4" :buffer (current-buffer) :command '("cat") + :name "test5" :buffer (current-buffer) :command command :sentinel (lambda (p s) (with-current-buffer (process-buffer p) (insert s))) :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (process-send-string proc "foo\n") (process-send-eof proc) (delete-process proc) @@ -4850,14 +4871,15 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (let ((stderr (generate-new-buffer "*stderr*"))) (unwind-protect (with-temp-buffer - (setq proc + (setq command '("cat" "/does-not-exist") + proc (with-no-warnings (make-process - :name "test5" :buffer (current-buffer) - :command '("cat" "/does-not-exist") + :name "test6" :buffer (current-buffer) :command command :stderr stderr :file-handler t))) (should (processp proc)) + (should (equal (process-get proc 'remote-command) command)) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) (while (accept-process-output proc 0 nil t))) @@ -4881,14 +4903,15 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (unless (tramp-direct-async-process-p) (unwind-protect (with-temp-buffer - (setq proc + (setq command '("cat" "/does-not-exist") + proc (with-no-warnings (make-process - :name "test6" :buffer (current-buffer) - :command '("cat" "/does-not-exist") + :name "test7" :buffer (current-buffer) :command command :stderr tmp-name :file-handler t))) (should (processp proc)) + (should (equal (process-get proc 'remote-command) command)) ;; Read stderr. (with-timeout (10 (tramp--test-timeout-handler)) (while (accept-process-output proc nil nil t))) @@ -4919,18 +4942,20 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (unless connection-type '(nil pipe t pty))) (unwind-protect (with-temp-buffer - (setq proc + (setq command '("hexdump" "-v" "-e" "/1 \"%02X\n\"") + proc (with-no-warnings (make-process :name - (format "test7-%s-%s" + (format "test8-%s-%s" connection-type process-connection-type) :buffer (current-buffer) :connection-type connection-type - :command '("hexdump" "-v" "-e" "/1 \"%02X\n\"") + :command command :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (process-send-string proc "foo\r\n") (process-send-eof proc) ;; Read output. @@ -4970,16 +4995,19 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; process. (let ((default-directory (file-truename tramp-test-temporary-file-directory)) (delete-exited-processes t) - kill-buffer-query-functions proc) + kill-buffer-query-functions command proc) (unwind-protect (with-temp-buffer - (setq proc (start-file-process-shell-command - "test" (current-buffer) - "trap 'echo boom; exit 1' 2; sleep 100")) + (setq command "trap 'echo boom; exit 1' 2; sleep 100" + proc (start-file-process-shell-command + "test" (current-buffer) command)) (should (processp proc)) (should (process-live-p proc)) (should (equal (process-status proc) 'run)) (should (numberp (process-get proc 'remote-pid))) + (should (equal (process-get proc 'remote-command) + (with-connection-local-variables + `(,shell-file-name ,shell-command-switch ,command)))) (should (interrupt-process proc)) ;; Let the process accept the interrupt. (with-timeout (10 (tramp--test-timeout-handler)) @@ -5000,6 +5028,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." INPUT, if non-nil, is a string sent to the process." (let ((proc (async-shell-command command output-buffer error-buffer)) (delete-exited-processes t)) + (should (equal (process-get proc 'remote-command) + (with-connection-local-variables + `(,shell-file-name ,shell-command-switch ,command)))) (cl-letf (((symbol-function #'shell-command-sentinel) #'ignore)) (when (stringp input) (process-send-string proc input)) commit fbf2ed9a648d9c0f64519900acf1574d0d74692b Author: Lars Ingebrigtsen Date: Tue Mar 29 17:12:01 2022 +0200 ipv6 addresses aren't suspicious * lisp/international/textsec.el (textsec--ipvx-address-p): New function. (textsec-domain-suspicious-p): Use it to say that ipv6 addresses aren't suspicious (bug#54624). diff --git a/lisp/international/textsec.el b/lisp/international/textsec.el index 6985f4f3ef..cca49986fc 100644 --- a/lisp/international/textsec.el +++ b/lisp/international/textsec.el @@ -231,6 +231,15 @@ The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)." (textsec-single-script-p string1) (textsec-single-script-p string2))) +(defun textsec--ipvx-address-p (domain) + "Return non-nil if DOMAIN is an ipv4 or ipv6 address." + (or (string-match-p "\\`\\([0-9]\\{1,3\\}\\.?\\)\\{1,4\\}\\'" domain) + (let ((ipv6 "\\([0-9a-f]\\{0,4\\}:?\\)\\{1,8\\}")) + ;; With brackets. + (or (string-match-p (format "\\`\\[%s\\]\\'" ipv6) domain) + ;; Without. + (string-match-p (format "\\`%s\\'" ipv6) domain))))) + (defun textsec-domain-suspicious-p (domain) "Say whether DOMAIN's name looks suspicious. Return nil if it isn't suspicious. If it is, return a string explaining @@ -241,6 +250,9 @@ that can look similar to other characters when displayed, or use characters that are not allowed by Unicode's IDNA mapping, or use certain other unusual mixtures of characters." (catch 'found + ;; Plain domains aren't suspicious. + (when (textsec--ipvx-address-p domain) + (throw 'found nil)) (seq-do (lambda (char) (when (eq (elt idna-mapping-table char) t) diff --git a/test/lisp/international/textsec-tests.el b/test/lisp/international/textsec-tests.el index 5bf9a3dcfb..9216d334f8 100644 --- a/test/lisp/international/textsec-tests.el +++ b/test/lisp/international/textsec-tests.el @@ -117,7 +117,16 @@ (should (textsec-domain-suspicious-p "f\N{LEFT-TO-RIGHT ISOLATE}oo.org")) (should (textsec-domain-suspicious-p "Сгсе.ru")) - (should-not (textsec-domain-suspicious-p "фСгсе.ru"))) + (should-not (textsec-domain-suspicious-p "фСгсе.ru")) + + (should-not (textsec-domain-suspicious-p + "21a:34aa:c782:3ad2:1bf8:73f8:141:66e8")) + (should (textsec-domain-suspicious-p + "21a:34aa:c782:3ad2:1bf8:73f8:141:66e8:66e8")) + (should-not (textsec-domain-suspicious-p + "[21a:34aa:c782:3ad2:1bf8:73f8:141:66e8]")) + (should (textsec-domain-suspicious-p + "[21a:34aa:c782:3ad2:1bf8:73f8:141:66e8"))) (ert-deftest test-suspicious-local () (should-not (textsec-local-address-suspicious-p "larsi")) commit 283c419f9a3d8ecf2721c24d9c593a1a5f1b12a2 Author: Jim Porter Date: Sat Mar 26 15:12:48 2022 -0700 Don't use 'eshell-convert' when all we want is a number * lisp/eshell/em-hist.el (eshell/history): Use 'string-to-number' instead of 'eshell-convert'. * lisp/eshell/em-basic.el (eshell/umask): Simplify implementation and be more careful about parsing numeric umasks to set. diff --git a/lisp/eshell/em-basic.el b/lisp/eshell/em-basic.el index ba868cee59..448b6787ee 100644 --- a/lisp/eshell/em-basic.el +++ b/lisp/eshell/em-basic.el @@ -155,39 +155,37 @@ or `eshell-printn' for display." "umask" args '((?S "symbolic" nil symbolic-p "display umask symbolically") (?h "help" nil nil "display this usage message") + :preserve-args :usage "[-S] [mode]") - (if (or (not args) symbolic-p) - (let ((modstr - (concat "000" - (format "%o" - (logand (lognot (default-file-modes)) - 511))))) - (setq modstr (substring modstr (- (length modstr) 3))) - (when symbolic-p - (let ((mode (default-file-modes))) - (setq modstr - (format - "u=%s,g=%s,o=%s" - (concat (and (= (logand mode 64) 64) "r") - (and (= (logand mode 128) 128) "w") - (and (= (logand mode 256) 256) "x")) - (concat (and (= (logand mode 8) 8) "r") - (and (= (logand mode 16) 16) "w") - (and (= (logand mode 32) 32) "x")) - (concat (and (= (logand mode 1) 1) "r") - (and (= (logand mode 2) 2) "w") - (and (= (logand mode 4) 4) "x")))))) - (eshell-printn modstr)) - (setcar args (eshell-convert (car args))) - (if (numberp (car args)) - (set-default-file-modes - (- 511 (car (read-from-string - (concat "?\\" (number-to-string (car args))))))) - (error "Setting umask symbolically is not yet implemented")) + (cond + (symbolic-p + (let ((mode (default-file-modes))) + (eshell-printn + (format "u=%s,g=%s,o=%s" + (concat (and (= (logand mode 64) 64) "r") + (and (= (logand mode 128) 128) "w") + (and (= (logand mode 256) 256) "x")) + (concat (and (= (logand mode 8) 8) "r") + (and (= (logand mode 16) 16) "w") + (and (= (logand mode 32) 32) "x")) + (concat (and (= (logand mode 1) 1) "r") + (and (= (logand mode 2) 2) "w") + (and (= (logand mode 4) 4) "x")))))) + ((not args) + (eshell-printn (format "%03o" (logand (lognot (default-file-modes)) + #o777)))) + (t + (when (stringp (car args)) + (if (string-match "^[0-7]+$" (car args)) + (setcar args (string-to-number (car args) 8)) + (error "Setting umask symbolically is not yet implemented"))) + (set-default-file-modes (- #o777 (car args))) (eshell-print - "Warning: umask changed for all new files created by Emacs.\n")) + "Warning: umask changed for all new files created by Emacs.\n"))) nil)) +(put 'eshell/umask 'eshell-no-numeric-conversions t) + (provide 'em-basic) ;; Local Variables: diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index 16abf04489..a18127a547 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -341,7 +341,7 @@ unless a different file is specified on the command line.") (error "No history")) (let (length file) (when (and args (string-match "^[0-9]+$" (car args))) - (setq length (min (eshell-convert (car args)) + (setq length (min (string-to-number (car args)) (ring-length eshell-history-ring)) args (cdr args))) (and length commit 705de330725715c355b63cf49d56aa13132a5f3c Author: Jim Porter Date: Sat Mar 26 15:09:51 2022 -0700 Add tests for Eshell's umask command 'em-basic-test/umask-set' fails when passing an actual number to the command, but this is fixed in the subsequent commit. test/lisp/eshell/em-basic-tests.el: New file. diff --git a/test/lisp/eshell/em-basic-tests.el b/test/lisp/eshell/em-basic-tests.el new file mode 100644 index 0000000000..7a24f8b46c --- /dev/null +++ b/test/lisp/eshell/em-basic-tests.el @@ -0,0 +1,71 @@ +;;; em-basic-tests.el --- em-basic test suite -*- lexical-binding:t -*- + +;; Copyright (C) 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 . + +;;; Commentary: + +;; Tests for basic Eshell commands. + +;;; Code: + +(require 'ert) +(require 'em-basic) + +(require 'eshell-tests-helpers + (expand-file-name "eshell-tests-helpers" + (file-name-directory (or load-file-name + default-directory)))) + +;;; Tests: + +(ert-deftest em-basic-test/umask-print-numeric () + "Test printing umask numerically." + (cl-letf (((symbol-function 'default-file-modes) (lambda () #o775))) + (should (equal (eshell-test-command-result "umask") "002\n"))) + (cl-letf (((symbol-function 'default-file-modes) (lambda () #o654))) + (should (equal (eshell-test-command-result "umask") "123\n"))) + ;; Make sure larger numbers don't cause problems. + (cl-letf (((symbol-function 'default-file-modes) (lambda () #o1775))) + (should (equal (eshell-test-command-result "umask") "002\n")))) + +(ert-deftest em-basic-test/umask-read-symbolic () + "Test printing umask symbolically." + (cl-letf (((symbol-function 'default-file-modes) (lambda () #o775))) + (should (equal (eshell-test-command-result "umask -S") + "u=rwx,g=rwx,o=rx\n"))) + (cl-letf (((symbol-function 'default-file-modes) (lambda () #o654))) + (should (equal (eshell-test-command-result "umask -S") + "u=wx,g=rx,o=x\n"))) + ;; Make sure larger numbers don't cause problems. + (cl-letf (((symbol-function 'default-file-modes) (lambda () #o1775))) + (should (equal (eshell-test-command-result "umask -S") + "u=rwx,g=rwx,o=rx\n")))) + +(ert-deftest em-basic-test/umask-set () + "Test setting umask." + (let ((file-modes 0)) + (cl-letf (((symbol-function 'set-default-file-modes) + (lambda (mode) (setq file-modes mode)))) + (eshell-test-command-result "umask 002") + (should (= file-modes #o775)) + (eshell-test-command-result "umask 123") + (should (= file-modes #o654)) + (eshell-test-command-result "umask $(identity #o222)") + (should (= file-modes #o555))))) + +;; em-basic-tests.el ends here commit 271c03d89f3b1f67b44a46ee43447e25f5eef1a8 Author: Thomas Fitzsimmons Date: Tue Mar 29 14:34:38 2022 +0200 Fix eww bookmark writing * lisp/net/eww.el (eww-write-bookmarks): Ensure that the complete bookmarks are written (bug#54612). diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 700a6c3e82..75dc679a3d 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -2053,7 +2053,9 @@ If CHARSET is nil then use UTF-8." (defun eww-write-bookmarks () (with-temp-file (expand-file-name "eww-bookmarks" eww-bookmarks-directory) (insert ";; Auto-generated file; don't edit -*- mode: lisp-data -*-\n") - (pp eww-bookmarks (current-buffer)))) + (let ((print-length nil) + (print-level nil)) + (pp eww-bookmarks (current-buffer))))) (defun eww-read-bookmarks (&optional error-out) "Read bookmarks from `eww-bookmarks'. commit 0e662f33e1a5b1c88fb3e0bf8be906c1937114d3 Author: Po Lu Date: Tue Mar 29 18:31:24 2022 +0800 Rewrite desktop workarea computation to avoid too many calls to XSync * src/xfns.c (x_get_net_workarea): Rewrite using XCB without using long_offset and long_length, since the data transfer is usually negligible compared to the roundtrip delay. diff --git a/src/xfns.c b/src/xfns.c index 534fb7c544..37e0628464 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -5459,6 +5459,7 @@ On MS Windows, this just returns nil. */) static bool x_get_net_workarea (struct x_display_info *dpyinfo, XRectangle *rect) { +#ifndef USE_XCB Display *dpy = dpyinfo->display; long offset, max_len; Atom target_type, actual_type; @@ -5512,6 +5513,69 @@ x_get_net_workarea (struct x_display_info *dpyinfo, XRectangle *rect) x_uncatch_errors (); return result; +#else + xcb_get_property_cookie_t current_desktop_cookie; + xcb_get_property_cookie_t workarea_cookie; + xcb_get_property_reply_t *reply; + xcb_generic_error_t *error; + bool rc; + uint32_t current_workspace, *values; + + current_desktop_cookie + = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) dpyinfo->root_window, + (xcb_atom_t) dpyinfo->Xatom_net_current_desktop, + XCB_ATOM_CARDINAL, 0, 1); + + workarea_cookie + = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) dpyinfo->root_window, + (xcb_atom_t) dpyinfo->Xatom_net_workarea, + XCB_ATOM_CARDINAL, 0, UINT32_MAX); + + reply = xcb_get_property_reply (dpyinfo->xcb_connection, + current_desktop_cookie, &error); + rc = true; + + if (!reply) + free (error), rc = false; + else + { + if (xcb_get_property_value_length (reply) != 4 + || reply->type != XCB_ATOM_CARDINAL || reply->format != 32) + rc = false; + else + current_workspace = *(uint32_t *) xcb_get_property_value (reply); + + free (reply); + } + + reply = xcb_get_property_reply (dpyinfo->xcb_connection, + workarea_cookie, &error); + + if (!reply) + free (error), rc = false; + else + { + if (rc && reply->type == XCB_ATOM_CARDINAL && reply->format == 32 + && (xcb_get_property_value_length (reply) / sizeof (uint32_t) + >= current_workspace + 4)) + { + values = xcb_get_property_value (reply); + + rect->x = values[current_workspace]; + rect->y = values[current_workspace + 1]; + rect->width = values[current_workspace + 2]; + rect->height = values[current_workspace + 3]; + } + else + rc = false; + + free (reply); + } + + return rc; +#endif } #endif /* !(USE_GTK && HAVE_GTK3) */ commit 9aecc241e6e78d90f894e4ca196f84a6b4dea71a Author: Mattias Engdegård Date: Tue Mar 29 11:14:11 2022 +0200 Fix typo in ERC DCC code in verbose mode * lisp/erc/erc-dcc.el (erc-dcc-send-block): Typo causing incorrect message when `erc-dcc-verbose` is set. diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index cc4143bfa2..59bfd24603 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -768,7 +768,7 @@ the matching regexp, or nil if none found." PROC is the process-object of the DCC connection. Returns the number of bytes sent." (let* ((elt (erc-dcc-member :peer proc)) - (confirmed-marker (plist-get elt :sent)) + (confirmed-marker (plist-get elt :confirmed)) (sent-marker (plist-get elt :sent))) (with-current-buffer (process-buffer proc) (when erc-dcc-verbose commit 2b5ea36ce9659ee16ebff36e2642927691c391ee Author: Stefan Monnier Date: Tue Mar 29 03:23:38 2022 -0400 * lisp/emacs-lisp/oclosure.el (oclosure--define): Autoload diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 0c504e5d82..f5a21151f1 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -321,6 +321,7 @@ list of slot properties. The currently known properties are the following: ,@(oclosure--defstruct-make-copiers copiers slotdescs name)))) +;;;###autoload (defun oclosure--define (name docstring parent-names slots &rest props) (let* ((class (oclosure--build-class name docstring parent-names slots)) commit 080d29d52ecc6919517b7ee45cbdcc7444d8d025 Author: Po Lu Date: Tue Mar 29 06:35:09 2022 +0000 Specially decode more selection types on Haiku * src/haiku_select.cc (be_get_point_data, be_add_point_data): New functions. * src/haikuselect.c (haiku_message_to_lisp, lisp_to_type_code) (haiku_lisp_to_message): Accept new types `size_t', `ssize_t' and `point'. (Fhaiku_drag_message): Update doc string. (syms_of_haikuselect): New defsyms. * src/haikuselect.h: Update prototypes. diff --git a/src/haiku_select.cc b/src/haiku_select.cc index e047b9b513..be8026b6a1 100644 --- a/src/haiku_select.cc +++ b/src/haiku_select.cc @@ -28,7 +28,6 @@ along with GNU Emacs. If not, see . */ #include "haikuselect.h" - static BClipboard *primary = NULL; static BClipboard *secondary = NULL; static BClipboard *system_clipboard = NULL; @@ -318,6 +317,26 @@ be_get_refs_data (void *message, const char *name, return 0; } +int +be_get_point_data (void *message, const char *name, + int32 index, float *x, float *y) +{ + status_t rc; + BMessage *msg; + BPoint point; + + msg = (BMessage *) message; + rc = msg->FindPoint (name, index, &point); + + if (rc != B_OK) + return 1; + + *x = point.x; + *y = point.y; + + return 0; +} + int be_get_message_data (void *message, const char *name, int32 type_code, int32 index, @@ -398,6 +417,15 @@ be_add_refs_data (void *message, const char *name, return msg->AddRef (name, &ref) != B_OK; } +int +be_add_point_data (void *message, const char *name, + float x, float y) +{ + BMessage *msg = (BMessage *) message; + + return msg->AddPoint (name, BPoint (x, y)) != B_OK; +} + int be_add_message_message (void *message, const char *name, void *data) diff --git a/src/haikuselect.c b/src/haikuselect.c index c1c619ee8c..38d4933948 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -213,25 +213,8 @@ same as `SECONDARY'. */) return value ? Qt : Qnil; } -/* Return the Lisp representation of MESSAGE. - - It is an alist of strings, denoting message field names, to a list - of the form (TYPE DATA ...), where TYPE is an integer denoting the - system data type of DATA, and DATA is in the general case a unibyte - string. - - If TYPE is a symbol instead of an integer, then DATA was specially - decoded. If TYPE is `ref', then DATA is the absolute file name of - a file, or nil if decoding the file name failed. If TYPE is - `string', then DATA is a unibyte string. If TYPE is `short', then - DATA is a 16-bit signed integer. If TYPE is `long', then DATA is a - 32-bit signed integer. If TYPE is `llong', then DATA is a 64-bit - signed integer. If TYPE is `byte' or `char', then DATA is an 8-bit - signed integer. If TYPE is `bool', then DATA is a boolean. - - If the field name is not a string but the symbol `type', then it - associates to a 32-bit unsigned integer describing the type of the - system message. */ +/* Return the Lisp representation of MESSAGE. See Fhaiku_drag_message + for the format of the object returned. */ Lisp_Object haiku_message_to_lisp (void *message) { @@ -243,6 +226,7 @@ haiku_message_to_lisp (void *message) int32 i, j, count, type_code; int rc; void *msg; + float point_x, point_y; for (i = 0; !be_enum_message (message, &type_code, i, &count, &name); ++i) @@ -287,9 +271,22 @@ haiku_message_to_lisp (void *message) t1 = build_string (pbuf); - block_input (); free (pbuf); - unblock_input (); + break; + + case 'BPNT': + rc = be_get_point_data (message, name, + j, &point_x, + &point_y); + + if (rc) + { + t1 = Qnil; + break; + } + + t1 = Fcons (make_float (point_x), + make_float (point_y)); break; case 'SHRT': @@ -309,6 +306,14 @@ haiku_message_to_lisp (void *message) t1 = make_fixnum (*(int8 *) buf); break; + case 'SIZT': + t1 = make_uint ((uintmax_t) *(size_t *) buf); + break; + + case 'SSZT': + t1 = make_int ((intmax_t) *(ssize_t *) buf); + break; + default: t1 = make_uninit_string (buf_size); memcpy (SDATA (t1), buf, buf_size); @@ -355,6 +360,18 @@ haiku_message_to_lisp (void *message) t2 = Qmessage; break; + case 'SIZT': + t2 = Qsize_t; + break; + + case 'SSZT': + t2 = Qssize_t; + break; + + case 'BPNT': + t2 = Qpoint; + break; + default: t2 = make_int (type_code); } @@ -394,6 +411,12 @@ lisp_to_type_code (Lisp_Object obj) return 'BOOL'; else if (EQ (obj, Qmessage)) return 'MSGG'; + else if (EQ (obj, Qsize_t)) + return 'SIZT'; + else if (EQ (obj, Qssize_t)) + return 'SSZT'; + else if (EQ (obj, Qpoint)) + return 'BPNT'; else return -1; } @@ -408,8 +431,11 @@ haiku_lisp_to_message (Lisp_Object obj, void *message) int8 char_data; bool bool_data; void *msg_data; + size_t sizet_data; + ssize_t ssizet_data; intmax_t t4; uintmax_t t5; + float t6, t7; int rc; specpdl_ref ref; @@ -498,6 +524,19 @@ haiku_lisp_to_message (Lisp_Object obj, void *message) signal_error ("Invalid file name", data); break; + case 'BPNT': + CHECK_CONS (data); + CHECK_NUMBER (XCAR (data)); + CHECK_NUMBER (XCDR (data)); + + t6 = XFLOATINT (XCAR (data)); + t7 = XFLOATINT (XCDR (data)); + + if (be_add_point_data (message, SSDATA (name), + t6, t7)) + signal_error ("Invalid point", data); + break; + case 'SHRT': if (!TYPE_RANGED_FIXNUMP (int16, data)) signal_error ("Invalid value", data); @@ -572,6 +611,63 @@ haiku_lisp_to_message (Lisp_Object obj, void *message) signal_error ("Failed to add llong", data); break; + case 'SIZT': + if (BIGNUMP (data)) + { + t4 = bignum_to_intmax (data); + + if (!t4 || t4 > TYPE_MAXIMUM (size_t)) + signal_error ("Value too large", data); + + sizet_data = (size_t) t4; + } + else + { + if (!TYPE_RANGED_FIXNUMP (size_t, data)) + signal_error ("Invalid value", data); + + sizet_data = (int64) XFIXNUM (data); + } + + block_input (); + rc = be_add_message_data (message, SSDATA (name), + type_code, &sizet_data, + sizeof sizet_data); + unblock_input (); + + if (rc) + signal_error ("Failed to add sizet", data); + break; + + case 'SSZT': + if (BIGNUMP (data)) + { + t4 = bignum_to_intmax (data); + + if (!t4 || t4 > TYPE_MINIMUM (ssize_t) + || t4 < TYPE_MAXIMUM (ssize_t)) + signal_error ("Value too large", data); + + ssizet_data = (ssize_t) t4; + } + else + { + if (!TYPE_RANGED_FIXNUMP (ssize_t, data)) + signal_error ("Invalid value", data); + + ssizet_data = (int64) XFIXNUM (data); + } + + block_input (); + rc = be_add_message_data (message, SSDATA (name), + type_code, &ssizet_data, + sizeof ssizet_data); + unblock_input (); + + if (rc) + signal_error ("Failed to add ssizet", data); + break; + case 'CHAR': case 'BYTE': if (!TYPE_RANGED_FIXNUMP (int8, data)) @@ -641,7 +737,13 @@ then DATA is a unibyte string. If TYPE is `short', then DATA is a 16-bit signed integer. If TYPE is `long', then DATA is a 32-bit signed integer. If TYPE is `llong', then DATA is a 64-bit signed integer. If TYPE is `byte' or `char', then DATA is an 8-bit signed -integer. If TYPE is `bool', then DATA is a boolean. +integer. If TYPE is `bool', then DATA is a boolean. If TYPE is +`size_t', then DATA is an integer that can hold between 0 and the +maximum value returned by the `sizeof' C operator on the current +system. If TYPE is `ssize_t', then DATA is an integer that can hold +values from -1 to the maximum value of the C data type `ssize_t' on +the current system. If TYPE is `point', then DATA is a cons of float +values describing the X and Y coordinates of an on-screen location. If the field name is not a string but the symbol `type', then it associates to a 32-bit unsigned integer describing the type of the @@ -701,6 +803,9 @@ syms_of_haikuselect (void) DEFSYM (Qchar, "char"); DEFSYM (Qbool, "bool"); DEFSYM (Qtype, "type"); + DEFSYM (Qsize_t, "size_t"); + DEFSYM (Qssize_t, "ssize_t"); + DEFSYM (Qpoint, "point"); defsubr (&Shaiku_selection_data); defsubr (&Shaiku_selection_put); diff --git a/src/haikuselect.h b/src/haikuselect.h index 5d1dd33c8c..bac9663c70 100644 --- a/src/haikuselect.h +++ b/src/haikuselect.h @@ -94,6 +94,8 @@ extern "C" ssize_t *size_return); extern int be_get_refs_data (void *message, const char *name, int32 index, char **path_buffer); + extern int be_get_point_data (void *message, const char *name, + int32 index, float *x, float *y); extern uint32 be_get_message_type (void *message); extern void be_set_message_type (void *message, uint32 what); extern void *be_get_message_message (void *message, const char *name, @@ -104,6 +106,8 @@ extern "C" ssize_t buf_size); extern int be_add_refs_data (void *message, const char *name, const char *filename); + extern int be_add_point_data (void *message, const char *name, + float x, float y); extern int be_add_message_message (void *message, const char *name, void *data); extern int be_lock_clipboard_message (enum haiku_clipboard clipboard, commit 55932a65ed719d4277e0e781ca5e323b189d7f63 Author: Po Lu Date: Tue Mar 29 13:58:40 2022 +0800 Temporarily fix the oclosure bootstrap * lisp/emacs-lisp/oclosure.el (oclosure-define): Load oclosure from source if `oclosure--define' is not defined during byte compilation. diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 3d17c6c668..0c504e5d82 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -248,6 +248,8 @@ list of slot properties. The currently known properties are the following: ,(when options (macroexp-warn-and-return name (format "Ignored options: %S" options) nil)) + (eval-when-compile (unless (fboundp 'oclosure--define) + (load "oclosure.el"))) (eval-and-compile (oclosure--define ',name ,docstring ',parent-names ',slots ,@(when predicate `(:predicate ',predicate)))) commit d96db7b2e8c35ec2970d12c96e2328b684626f24 Author: Po Lu Date: Tue Mar 29 09:08:22 2022 +0800 Don't loop through useless region when searching for DND toplevel * src/xterm.c (x_dnd_compute_toplevels): Optimize for the bounding rect being the window dimensions. diff --git a/src/xterm.c b/src/xterm.c index 443009c0db..28311f94e9 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1278,6 +1278,30 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) xfree (tem->input_rects); tem->n_input_rects = -1; } + + /* And the common case where there is no input rect and the + bouding rect equals the window dimensions. */ + + if (tem->n_input_rects == -1 + && tem->n_bounding_rects == 1 +#ifdef USE_XCB + && tem->bounding_rects[0].width == (geometry_reply->width + + geometry_reply->border_width) + && tem->bounding_rects[0].height == (geometry_reply->height + + geometry_reply->border_width) + && tem->bounding_rects[0].x == -geometry_reply->border_width + && tem->bounding_rects[0].y == -geometry_reply->border_width +#else + && tem->bounding_rects[0].width == attrs.width + attrs.border_width + && tem->bounding_rects[0].height == attrs.height + attrs.border_width + && tem->bounding_rects[0].x == -attrs.border_width + && tem->bounding_rects[0].y == -attrs.border_width +#endif + ) + { + xfree (tem->bounding_rects); + tem->n_bounding_rects = -1; + } #endif x_catch_errors (dpyinfo->display); commit 935cc42795686710f82b8928b6802f20be8f27c0 Author: Juri Linkov Date: Mon Mar 28 21:00:32 2022 +0300 Add search function to search within filenames in Dired and WDired (bug#14013) * lisp/dired-aux.el (dired-isearch-filenames-mode): Use dired-isearch-search-filenames on isearch-search-fun-function instead of dired-isearch-filter-filenames on isearch-filter-predicate. (dired-isearch-filter-filenames): Remove function. (dired-isearch-search-filenames): Add function. * lisp/isearch.el (isearch-message-prefix): Add isearch-search-fun-function to the list of supported advice-functions along with isearch-filter-predicate. * lisp/replace.el (replace-search): Add comment. * lisp/wdired.el (wdired-search-replace-filenames): New defcustom. (wdired-isearch-filter-read-only): Remove function. (wdired-change-to-wdired-mode, wdired-change-to-dired-mode): Add and remove dired-isearch-search-filenames on isearch-search-fun-function instead of wdired-isearch-filter-read-only on isearch-filter-predicate. Also set/unset replace-search-function and replace-re-search-function. Remove and restore isearch-mode-hook with dired-isearch-filenames-setup. The problem is that dired-isearch-filenames-setup adds dired-isearch-filenames-end to isearch-mode-end-hook that removes dired-isearch-search-filenames added to isearch-search-fun-function in wdired-change-to-wdired-mode. Then replace-highlight can't use dired-isearch-search-filenames. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 956899c205..c49e4e91d8 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -3155,16 +3155,16 @@ a file name. Otherwise, it searches the whole buffer without restrictions." (define-minor-mode dired-isearch-filenames-mode "Toggle file names searching on or off. -When on, Isearch skips matches outside file names using the predicate -`dired-isearch-filter-filenames' that matches only at file names. -When off, it uses the original predicate." +When on, Isearch skips matches outside file names using the search function +`dired-isearch-search-filenames' that matches only at file names. +When off, it uses the default search function." :lighter nil (if dired-isearch-filenames-mode - (add-function :before-while (local 'isearch-filter-predicate) - #'dired-isearch-filter-filenames + (add-function :around (local 'isearch-search-fun-function) + #'dired-isearch-search-filenames '((isearch-message-prefix . "filename "))) - (remove-function (local 'isearch-filter-predicate) - #'dired-isearch-filter-filenames)) + (remove-function (local 'isearch-search-fun-function) + #'dired-isearch-search-filenames)) (when isearch-mode (setq isearch-success t isearch-adjusted t) (isearch-update))) @@ -3188,12 +3188,46 @@ Intended to be added to `isearch-mode-hook'." (unless isearch-suspended (kill-local-variable 'dired-isearch-filenames))) -(defun dired-isearch-filter-filenames (beg end) - "Test whether some part of the current search match is inside a file name. -This function returns non-nil if some part of the text between BEG and END -is part of a file name (i.e., has the text property `dired-filename')." - (text-property-not-all (min beg end) (max beg end) - 'dired-filename nil)) +(defun dired-isearch-search-filenames (orig-fun) + "Return the function that searches inside file names. +The returned function narrows the search to match the search string +only as part of a file name enclosed by the text property `dired-filename'. +It's intended to override the default search function." + (let ((search-fun (funcall orig-fun)) + (property 'dired-filename)) + (lambda (string &optional bound noerror count) + (let* ((old (point)) + ;; Check if point is already on the property. + (beg (when (get-text-property + (if isearch-forward old (max (1- old) (point-min))) + property) + old)) + end found) + ;; Otherwise, try to search for the next property. + (unless beg + (setq beg (if isearch-forward + (next-single-property-change old property) + (previous-single-property-change old property))) + (when beg (goto-char beg))) + ;; Non-nil `beg' means there are more properties. + (while (and beg (not found)) + ;; Search for the end of the current property. + (setq end (if isearch-forward + (next-single-property-change beg property) + (previous-single-property-change beg property))) + (setq found (funcall + search-fun string (if bound (if isearch-forward + (min bound end) + (max bound end)) + end) + noerror count)) + (unless found + (setq beg (if isearch-forward + (next-single-property-change end property) + (previous-single-property-change end property))) + (when beg (goto-char beg)))) + (unless found (goto-char old)) + found)))) ;;;###autoload (defun dired-isearch-filenames () diff --git a/lisp/isearch.el b/lisp/isearch.el index 05a73edead..956b115ce4 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -3457,11 +3457,13 @@ the word mode." (if (and (not isearch-success) (not isearch-case-fold-search)) "case-sensitive ") (let ((prefix "")) - (advice-function-mapc - (lambda (_ props) - (let ((np (cdr (assq 'isearch-message-prefix props)))) - (if np (setq prefix (concat np prefix))))) - isearch-filter-predicate) + (dolist (advice-function (list isearch-filter-predicate + isearch-search-fun-function)) + (advice-function-mapc + (lambda (_ props) + (let ((np (cdr (assq 'isearch-message-prefix props)))) + (if np (setq prefix (concat np prefix))))) + advice-function)) prefix) (isearch--describe-regexp-mode isearch-regexp-function) (cond diff --git a/lisp/replace.el b/lisp/replace.el index 06be597855..e6f565d802 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -2685,6 +2685,11 @@ to a regexp that is actually used for the search.") (or (if regexp-flag replace-re-search-function replace-search-function) + ;; `isearch-search-fun' can't be used here because + ;; when buffer-local `isearch-search-fun-function' + ;; searches e.g. the minibuffer history, then + ;; `query-replace' should not operate on the whole + ;; history, but only on the minibuffer contents. (isearch-search-fun-default)))) (funcall search-function search-string limit t))) diff --git a/lisp/wdired.el b/lisp/wdired.el index ab3b91bbe5..d2a6bad0f2 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -155,6 +155,11 @@ nonexistent directory will fail." :version "26.1" :type 'boolean) +(defcustom wdired-search-replace-filenames t + "Non-nil to search and replace in file names only." + :version "29.1" + :type 'boolean) + (defvar-keymap wdired-mode-map :doc "Keymap used in `wdired-mode'." "C-x C-s" #'wdired-finish-edit @@ -217,6 +222,7 @@ symbolic link targets, and filenames permission." (error "This mode can be enabled only by `wdired-change-to-wdired-mode'")) (put 'wdired-mode 'mode-class 'special) +(declare-function dired-isearch-search-filenames "dired-aux") ;;;###autoload (defun wdired-change-to-wdired-mode () @@ -237,9 +243,16 @@ See `wdired-mode'." (dired-remember-marks (point-min) (point-max))) (setq-local wdired--old-point (point)) (wdired--set-permission-bounds) - (setq-local query-replace-skip-read-only t) - (add-function :after-while (local 'isearch-filter-predicate) - #'wdired-isearch-filter-read-only) + (when wdired-search-replace-filenames + (add-function :around (local 'isearch-search-fun-function) + #'dired-isearch-search-filenames + '((isearch-message-prefix . "filename "))) + (setq-local replace-search-function + (setq-local replace-re-search-function + (funcall isearch-search-fun-function))) + ;; Original dired hook removes dired-isearch-search-filenames that + ;; is needed outside isearch for lazy-highlighting in query-replace. + (remove-hook 'isearch-mode-hook #'dired-isearch-filenames-setup t)) (use-local-map wdired-mode-map) (force-mode-line-update) (setq buffer-read-only nil) @@ -319,11 +332,6 @@ or \\[wdired-abort-changes] to abort changes"))) ;; Is this good enough? Assumes no extra white lines from dired. (put-text-property (1- (point-max)) (point-max) 'read-only t))))))) -(defun wdired-isearch-filter-read-only (beg end) - "Skip matches that have a read-only property." - (not (text-property-not-all (min beg end) (max beg end) - 'read-only nil))) - ;; Protect the buffer so only the filenames can be changed, and put ;; properties so filenames (old and new) can be easily found. (defun wdired--preprocess-files () @@ -438,8 +446,13 @@ non-nil means return old filename." (remove-text-properties (point-min) (point-max) '(front-sticky nil rear-nonsticky nil read-only nil keymap nil))) - (remove-function (local 'isearch-filter-predicate) - #'wdired-isearch-filter-read-only) + (when wdired-search-replace-filenames + (remove-function (local 'isearch-search-fun-function) + #'dired-isearch-search-filenames) + (kill-local-variable 'replace-search-function) + (kill-local-variable 'replace-re-search-function) + ;; Restore dired hook + (add-hook 'isearch-mode-hook #'dired-isearch-filenames-setup nil t)) (use-local-map dired-mode-map) (force-mode-line-update) (setq buffer-read-only t) commit 52d5771e0a803f57b8cdd7675bf15f2f9b946039 Author: Stefan Monnier Date: Mon Mar 28 10:53:14 2022 -0400 Add OClosures, a cross between functions and structs We here just add the new type. It is not fully self-contained. It requires cooperation from `cconv.el` on the one hand, and it hijacks the docstring info to hold the type of OClosure objects. This does imply that OClosures can't have docstrings, tho this limitation will be lifted in subsequent patches. * lisp/emacs-lisp/oclosure.el: New file. * test/lisp/emacs-lisp/oclosure-tests.el: New file. * doc/lispref/functions.texi (OClosures): New section. * src/eval.c (Ffunction): Accept symbols instead of strings for docstrings. * src/doc.c (store_function_docstring): Avoid overwriting an OClosure type. * lisp/emacs-lisp/cconv.el (cconv--convert-function): Tweak ordering of captured variables. (cconv-convert): Add case for `oclosure--fix-type`. diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index 207919ea64..70337d4c4a 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -22,6 +22,7 @@ define them. * Function Cells:: Accessing or setting the function definition of a symbol. * Closures:: Functions that enclose a lexical environment. +* OClosures:: Function objects * Advising Functions:: Adding to the definition of a function. * Obsolete Functions:: Declaring functions obsolete. * Inline Functions:: Functions that the compiler will expand inline. @@ -1509,6 +1510,116 @@ exposed to the rest of the Lisp world is considered an internal implementation detail. For this reason, we recommend against directly examining or altering the structure of closure objects. +@node OClosures +@section Open Closures + +Traditionally, functions are opaque objects which offer no other +functionality but to call them. Emacs Lisp functions aren't fully +opaque since you can extract some info out of them such as their +docstring, their arglist, or their interactive spec, but they are +mostly opaque. This is usually what we want, but occasionally we need +functions to expose a bit more information about themselves. + +OClosures are functions which carry additional type information, +and expose some information in the form of slots which you can access +via accessor functions. + +They are defined in two steps: first @code{oclosure-define} is used to +define new OClosure types by specifying the slots carried by those +OClosures, and then @code{oclosure-lambda} is used to create an +OClosure object of a given type. + +Say we want to define keyboard macros, i.e. interactive functions +which re-execute a sequence of key events. You could do it with +a plain function as follows: +@example +(defun kbd-macro (key-sequence) + (lambda (&optional arg) + (interactive "P") + (execute-kbd-macro key-sequence arg))) +@end example +But with such a definition there is no easy way to extract the +@var{key-sequence} from that function, for example to print it. + +We can solve this problem using OClosures as follows. First we define +the type of our keyboard macros (to which we decided to add +a @code{counter} slot while at it): +@example +(oclosure-define kbd-macro + "Keyboard macro." + keys (counter :mutable t)) +@end example +After which we can rewrite our @code{kbd-macro} function: +@example +(defun kbd-macro (key-sequence) + (oclosure-lambda (kbd-macro (keys key-sequence) (counter 0)) + (&optional arg) + (interactive "p") + (execute-kbd-macro keys arg) + (setq counter (1+ counter)))) +@end example +As you can see, the @code{keys} and @code{counter} slots of the +OClosure can be accessed as local variables from within the body +of the OClosure. But we can now also access them from outside of the +body of the OClosure, for example to describe a keyboard macro: +@example +(defun describe-kbd-macro (km) + (if (not (eq 'kbd-macro (oclosure-type km))) + (message "Not a keyboard macro") + (let ((keys (kbd-macro--keys km)) + (counter (kbd-macro--counter km))) + (message "Keys=%S, called %d times" keys counter)))) +@end example +Where @code{kbd-macro--keys} and @code{kbd-macro--counter} are +accessor functions generated by the @code{oclosure-define} macro. + +@defmac oclosure-define name &optional docstring &rest slots +This macro defines a new OClosure type along with accessor functions +for its slots. @var{name} can be a symbol (the name of +the new type), or a list of the form @code{(@var{name} . @var{type-props})} in +which case @var{type-props} is a list of additional properties. +@var{slots} is a list of slot descriptions where each slot can be +either a symbol (the name of the slot) or it can be of the form +@code{(@var{slot-name} . @var{slot-props})} where @var{slot-props} is +a property list. + +For each slot, the macro creates an accessor function named +@code{@var{name}--@var{slot-name}}. By default slots are immutable. +If you need a slot to be mutable, you need to specify it with the +@code{:mutable} slot property, after which it can be mutated for +example with @code{setf}. + +Beside slot accessors, the macro can create a predicate and +functional update functions according to @var{type-props}: +a @code{(:predicate @var{pred-name})} in the @var{type-props} causes +the definition of a predicate function under the name @var{pred-name}, +and @code{(:copier @var{copier-name} @var{copier-arglist})} causes the +definition of a functional update function which takes an OClosure of +type @var{name} as first argument and returns a copy of it with the +slots named in @var{copier-arglist} modified to the value passed in the +corresponding argument. +@end defmac + +@defmac oclosure-lambda (type . slots) arglist &rest body +This macro creates an anonymous OClosure of type @var{type}. +@var{slots} should be a list of elements of the form @code{(@var{slot-name} +@var{exp})}. +At run time, each @var{exp} is evaluated, in order, after which +the OClosure is created with its slots initialized with the +resulting values. + +When called as a function, the OClosure will accept arguments +according to @var{arglist} and will execute the code in @var{body}. +@var{body} can refer to the value of any of its slot directly as if it +were a local variable that had been captured by static scoping. +@end defmac + +@defun oclosure-type object +This function returns the OClosure type (a symbol) of @var{object} if it is an +OClosure, and nil otherwise. +@end defun + + @node Advising Functions @section Advising Emacs Lisp Functions @cindex advising functions diff --git a/etc/NEWS b/etc/NEWS index b6ae8bb9cf..e684ee30f0 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1156,6 +1156,11 @@ It is believed to no longer be useful. * New Modes and Packages in Emacs 29.1 ++++ +** New package 'oclosure'. +Allows the creation of "functions with slots" or "function objects" +via the macros `oclosure-define` and `oclosure-lambda`. + --- ** New theme 'leuven-dark'. This is a dark version of the 'leuven' theme. diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index c16619bc45..be4fea7be1 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -201,7 +201,10 @@ Returns a form where all lambdas don't have any free variables." (i 0) (new-env ())) ;; Build the "formal and actual envs" for the closure-converted function. - (dolist (fv fvs) + ;; Hack for OClosure: `nreverse' here intends to put the captured vars + ;; in the closure such that the first one is the one that is bound + ;; most closely. + (dolist (fv (nreverse fvs)) (let ((exp (or (cdr (assq fv env)) fv))) (pcase exp ;; If `fv' is a variable that's wrapped in a cons-cell, @@ -240,7 +243,7 @@ Returns a form where all lambdas don't have any free variables." ;; this case better, we'd need to traverse the tree one more time to ;; collect this data, and I think that it's not worth it. (mapcar (lambda (mapping) - (if (not (eq (cadr mapping) 'apply-partially)) + (if (not (eq (cadr mapping) #'apply-partially)) mapping (cl-assert (eq (car mapping) (nth 2 mapping))) `(,(car mapping) @@ -449,6 +452,9 @@ places where they originally did not directly appear." (let ((var-def (cconv--lifted-arg var env)) (closedsym (make-symbol (format "closed-%s" var)))) (setq new-env (cconv--remap-llv new-env var closedsym)) + ;; FIXME: `closedsym' doesn't need to be added to `extend' + ;; but adding it makes it easier to write the assertion at + ;; the beginning of this function. (setq new-extend (cons closedsym (remq var new-extend))) (push `(,closedsym ,var-def) binders-new))) @@ -604,6 +610,14 @@ places where they originally did not directly appear." (`(declare . ,_) form) ;The args don't contain code. + (`(oclosure--fix-type (ignore . ,vars) ,exp) + (dolist (var vars) + (let ((x (assq var env))) + (pcase (cdr x) + (`(car-safe . ,_) (error "Slot %S should not be mutated" var)) + (_ (cl-assert (null (cdr x))))))) + (cconv-convert exp env extend)) + (`(,func . ,forms) ;; First element is function or whatever function-like forms are: or, and, ;; if, catch, progn, prog1, while, until diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el new file mode 100644 index 0000000000..3d17c6c668 --- /dev/null +++ b/lisp/emacs-lisp/oclosure.el @@ -0,0 +1,522 @@ +;;; oclosure.el --- Open Closures -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; Author: Stefan Monnier + +;; 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: + +;; An OClosure is an object that combines the properties of records +;; with those of a function. More specifically it is a function extended +;; with a notion of type (e.g. for defmethod dispatch) as well as the +;; ability to have some fields that are accessible from the outside. + +;; See "Open closures", ELS'2022 (https://zenodo.org/record/6228797). + +;; Here are some cases of "callable objects" where OClosures have found use: +;; - nadvice.el (the original motivation) +;; - kmacros (for cl-print and for `kmacro-extract-lambda') +;; - cl-generic: turn `cl--generic-isnot-nnm-p' into a mere type test +;; (by putting the no-next-methods into their own class). +;; - Slot accessor functions, where the type-dispatch can be used to +;; dynamically compute the docstring, and also to pretty print them. +;; - `save-some-buffers-function' +;; Here are other cases of "callable objects" where OClosures could be used: +;; - Use the type to distinguish macros from functions. +;; - Use a `name' and `depth' property from the function passed to +;; `add-function' (or `add-hook') instead of passing it via "props". +;; - iterators (generator.el), thunks (thunk.el), streams (stream.el). +;; - PEG rules: they're currently just functions, but they should carry +;; their original (macro-expanded) definition (and should be printed +;; differently from functions)! +;; - auto-generate docstrings for cl-defstruct slot accessors instead of +;; storing them in the accessor itself? +;; - SRFI-17's `setter'. +;; - coercion wrappers, as in "Threesomes, with and without blame" +;; https://dl.acm.org/doi/10.1145/1706299.1706342, or +;; "On the Runtime Complexity of Type-Directed Unboxing" +;; http://sv.c.titech.ac.jp/minamide/papers.html +;; - An efficient `negate' operation such that +;; (negate (negate f)) returns just `f' and (negate #'<) returns #'>=. +;; - Autoloads (tho currently our bytecode functions (and hence OClosures) +;; are too fat for that). + +;; Related constructs: +;; - `funcallable-standard-object' (FSO) in Common-Lisp. These are different +;; from OClosures in that they involve an additional indirection to get +;; to the actual code, and that they offer the possibility of +;; changing (via mutation) the code associated with +;; an FSO. Also the FSO's function can't directly access the FSO's +;; other fields, contrary to the case with OClosures where those are directly +;; available as local variables. +;; - Function objects in Javascript. +;; - Function objects in Python. +;; - Callable/Applicable classes in OO languages, i.e. classes with +;; a single method called `apply' or `call'. The most obvious +;; difference with OClosures (beside the fact that Callable can be +;; extended with additional methods) is that all instances of +;; a given Callable class have to use the same method, whereas every +;; OClosure object comes with its own code, so two OClosure objects of the +;; same type can have different code. Of course, you can get the +;; same result by turning every `oclosure-lambda' into its own class +;; declaration creating an ad-hoc subclass of the specified type. +;; In this sense, OClosures are just a generalization of `lambda' which brings +;; some of the extra feature of Callable objects. +;; - Apply hooks and "entities" in MIT Scheme +;; https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref/Application-Hooks.html +;; Apply hooks are basically the same as Common-Lisp's FSOs, and "entities" +;; are a variant of it where the inner function gets the FSO itself as +;; additional argument (a kind of "self" arg), thus making it easier +;; for the code to get data from the object's extra info, tho still +;; not as easy as with OClosures. +;; - "entities" in Lisp Machine Lisp (LML) +;; https://hanshuebner.github.io/lmman/fd-clo.xml +;; These are arguably identical to OClosures, modulo the fact that LML doesn't +;; have lexically-scoped closures and uses a form of closures based on +;; capturing (and reinstating) dynamically scoped bindings instead. + +;; Naming: OClosures were originally named FunCallableRecords (FCR), but +;; that name suggested these were fundamentally records that happened +;; to be called, whereas OClosures are really just closures that happen +;; to enjoy some characteristics of records. +;; The "O" comes from "Open" because OClosures aren't completely opaque +;; (for that same reason, an alternative name suggested at the time was +;; "disclosures"). +;; The "O" can also be understood to mean "Object" since you have notions +;; of inheritance, and the ability to associate methods with particular +;; OClosure types, just as is the case for OO classes. + +;;; Code: + +;; TODO: +;; - `oclosure-(cl-)defun', `oclosure-(cl-)defsubst', `oclosure-define-inline'? +;; - Use accessor in cl-defstruct. +;; - Add pcase patterns for OClosures. +;; - anonymous OClosure types. +;; - copiers for mixins +;; - class-allocated slots? +;; - code-allocated slots? +;; The `where' slot of `advice' would like to be code-allocated, and the +;; interactive-spec of commands is currently code-allocated but would like +;; to be instance-allocated. Their scoping rules are a bit odd, so maybe +;; it's best to avoid them. + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) ;For `named-let'. + +(defun oclosure--index-table (slotdescs) + (let ((i -1) + (it (make-hash-table :test #'eq))) + (dolist (desc slotdescs) + (let* ((slot (cl--slot-descriptor-name desc))) + (cl-incf i) + (when (gethash slot it) + (error "Duplicate slot name: %S" slot)) + (setf (gethash slot it) i))) + it)) + +(cl-defstruct (oclosure--class + (:constructor nil) + (:constructor oclosure--class-make + ( name docstring slots parents + &aux (index-table (oclosure--index-table slots)))) + (:include cl--class) + (:copier nil)) + "Metaclass for OClosure classes.") + +(setf (cl--find-class 'oclosure) + (oclosure--class-make 'oclosure + "The root parent of all OClosure classes" + nil nil)) +(defun oclosure--p (oclosure) + (not (not (oclosure-type oclosure)))) + +(cl-deftype oclosure () '(satisfies oclosure--p)) + +(defun oclosure--slot-mutable-p (slotdesc) + (not (alist-get :read-only (cl--slot-descriptor-props slotdesc)))) + +(defun oclosure--defstruct-make-copiers (copiers slotdescs name) + (require 'cl-macs) ;`cl--arglist-args' is not autoloaded. + (let* ((mutables '()) + (slots (mapcar + (lambda (desc) + (let ((name (cl--slot-descriptor-name desc))) + (when (oclosure--slot-mutable-p desc) + (push name mutables)) + name)) + slotdescs))) + (mapcar + (lambda (copier) + (pcase-let* + ((cname (pop copier)) + (args (or (pop copier) `(&key ,@slots))) + (inline (and (eq :inline (car copier)) (pop copier))) + (doc (or (pop copier) + (format "Copier for objects of type `%s'." name))) + (obj (make-symbol "obj")) + (absent (make-symbol "absent")) + (anames (cl--arglist-args args)) + (mnames + (let ((res '()) + (tmp args)) + (while (and tmp + (not (memq (car tmp) + cl--lambda-list-keywords))) + (push (pop tmp) res)) + res)) + (index -1) + (mutlist '()) + (argvals + (mapcar + (lambda (slot) + (setq index (1+ index)) + (let* ((mutable (memq slot mutables)) + (get `(oclosure--get ,obj ,index ,(not (not mutable))))) + (push mutable mutlist) + (cond + ((not (memq slot anames)) get) + ((memq slot mnames) slot) + (t + `(if (eq ',absent ,slot) + ,get + ,slot))))) + slots))) + `(,(if inline 'cl-defsubst 'cl-defun) ,cname + (&cl-defs (',absent) ,obj ,@args) + ,doc + (declare (side-effect-free t)) + (oclosure--copy ,obj ',(if (remq nil mutlist) (nreverse mutlist)) + ,@argvals)))) + copiers))) + + +(defmacro oclosure-define (name &optional docstring &rest slots) + "Define a new OClosure type. +NAME should be a symbol which is the name of the new type. +It can also be of the form (NAME . PROPS) in which case PROPS +is a list of additional properties among the following: + (:predicate PRED): asks to create a predicate function named PRED. + (:parent TYPE): make TYPE (another OClosure type) be a parent of NAME. + (:copier COPIER ARGS): asks to create a \"copier\" (i.e. functional update + 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 +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: + `:mutable': A non-nil value mean the slot can be mutated. + `:type': Specifies the type of the values expected to appear in the slot." + (declare (doc-string 2) (indent 1)) + (unless (stringp docstring) + (push docstring slots) + (setq docstring nil)) + (let* ((options (when (consp name) + (prog1 (copy-sequence (cdr name)) + (setq name (car name))))) + (get-opt (lambda (opt &optional all) + (let ((val (assq opt options)) + tmp) + (when val (setq options (delq val options))) + (if (not all) + (cdr val) + (when val + (setq val (list (cdr val))) + (while (setq tmp (assq opt options)) + (push (cdr tmp) val) + (setq options (delq tmp options))) + (nreverse val)))))) + (predicate (car (funcall get-opt :predicate))) + (parent-names (or (funcall get-opt :parent) + (funcall get-opt :include))) + (copiers (funcall get-opt :copier 'all))) + `(progn + ,(when options (macroexp-warn-and-return name + (format "Ignored options: %S" options) + nil)) + (eval-and-compile + (oclosure--define ',name ,docstring ',parent-names ',slots + ,@(when predicate `(:predicate ',predicate)))) + (oclosure--define-functions ,name ,copiers)))) + +(defun oclosure--build-class (name docstring parent-names slots) + (cl-assert (null (cdr parent-names))) + (let* ((parent-class (let ((name (or (car parent-names) 'oclosure))) + (or (cl--find-class name) + (error "Unknown class: %S" name)))) + (slotdescs + (append + (oclosure--class-slots parent-class) + (mapcar (lambda (field) + (if (not (consp field)) + (cl--make-slot-descriptor field nil nil + '((:read-only . t))) + (let ((name (pop field)) + (type nil) + (read-only t) + (props '())) + (while field + (pcase (pop field) + (:mutable (setq read-only (not (car field)))) + (:type (setq type (car field))) + (p (message "Unknown property: %S" p) + (push (cons p (car field)) props))) + (setq field (cdr field))) + (cl--make-slot-descriptor name nil type + `((:read-only . ,read-only) + ,@props))))) + slots)))) + (oclosure--class-make name docstring slotdescs + (if (cdr parent-names) + (oclosure--class-parents parent-class) + (list parent-class))))) + +(defmacro oclosure--define-functions (name copiers) + (let* ((class (cl--find-class name)) + (slotdescs (oclosure--class-slots class))) + `(progn + ,@(let ((i -1)) + (mapcar (lambda (desc) + (let* ((slot (cl--slot-descriptor-name desc)) + (mutable (oclosure--slot-mutable-p desc)) + ;; Always use a double hyphen: if users wants to + ;; make it public, they can do so with an alias. + (aname (intern (format "%S--%S" name slot)))) + (cl-incf i) + (if (not mutable) + `(defalias ',aname + ;; We use `oclosure--copy' instead of + ;; `oclosure--accessor-copy' here to circumvent + ;; bootstrapping problems. + (oclosure--copy + oclosure--accessor-prototype + nil ',name ',slot ,i)) + (require 'gv) ;For `gv-setter'. + `(progn + (defalias ',aname + (oclosure--accessor-copy + oclosure--mut-getter-prototype + ',name ',slot ,i)) + (defalias ',(gv-setter aname) + (oclosure--accessor-copy + oclosure--mut-setter-prototype + ',name ',slot ,i)))))) + slotdescs)) + ,@(oclosure--defstruct-make-copiers + copiers slotdescs name)))) + +(defun oclosure--define (name docstring parent-names slots + &rest props) + (let* ((class (oclosure--build-class name docstring parent-names slots)) + (pred (lambda (oclosure) + (eq name (oclosure-type oclosure)))) + (predname (or (plist-get props :predicate) + (intern (format "%s--internal-p" name))))) + (setf (cl--find-class name) class) + (dolist (slot (oclosure--class-slots class)) + (put (cl--slot-descriptor-name slot) 'slot-name t)) + (defalias predname pred) + (put name 'cl-deftype-satisfies predname))) + +(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) +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," + (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 + ;; looks like "normal code" in order to avoid backward compatibility + ;; issues with third party macros that do "code walks" and would + ;; likely mishandle such a new special form (e.g. `generator.el'). + ;; But don't be fooled: this macro is tightly bound to `cconv.el'. + (pcase-let* + ((`(,prebody . ,body) (macroexp-parse-body body)) + (rovars (mapcar #'car bindings))) + (dolist (mutable mutables) + (setq rovars (delq mutable rovars))) + `(let ,(mapcar (lambda (bind) + (if (cdr bind) bind + ;; Bind to something that doesn't look + ;; like a value to avoid the "Variable + ;; ‘foo’ left uninitialized" warning. + `(,(car bind) (progn nil)))) + (reverse bindings)) + ;; FIXME: Make sure the slotbinds whose value is duplicable aren't + ;; just value/variable-propagated by the optimizer (tho I think our + ;; optimizer is too naive to be a problem currently). + (oclosure--fix-type + ;; This `oclosure--fix-type' + `ignore' call is used by the compiler (in + ;; `cconv.el') to detect and signal an error in case of + ;; store-conversion (i.e. if a variable/slot is mutated). + (ignore ,@rovars) + (lambda ,args + (:documentation ,type) + ,@prebody + ;; Add dummy code which accesses the field's vars to make sure + ;; they're captured in the closure. + (if t nil ,@rovars ,@(mapcar (lambda (m) `(setq ,m ,m)) mutables)) + ,@body))))) + +(defmacro oclosure-lambda (type-and-slots args &rest body) + "Define anonymous OClosure function. +TYPE-AND-SLOTS should be of the form (TYPE . SLOTS) +where TYPE is an OClosure type name (defined by `oclosure-define') +and SLOTS is a let-style list of bindings for the various slots of TYPE. +ARGS and BODY are the same as for `lambda'." + (declare (indent 2) (debug ((sexp &rest (sexp form)) sexp def-body))) + ;; FIXME: Should `oclosure-define' distinguish "optional" from + ;; "mandatory" slots, and/or provide default values for slots missing + ;; from `fields'? + (pcase-let* + ((`(,type . ,fields) type-and-slots) + (class (or (cl--find-class type) + (error "Unknown class: %S" type))) + (slots (oclosure--class-slots class)) + (mutables '()) + (slotbinds (mapcar (lambda (slot) + (let ((name (cl--slot-descriptor-name slot))) + (when (oclosure--slot-mutable-p slot) + (push name mutables)) + (list name))) + slots)) + (tempbinds (mapcar + (lambda (field) + (let* ((name (car field)) + (bind (assq name slotbinds))) + (cond + ;; FIXME: Should we also warn about missing slots? + ((not bind) + (error "Unknown slot: %S" name)) + ((cdr bind) + (error "Duplicate slot: %S" name)) + (t + (let ((temp (gensym "temp"))) + (setcdr bind (list temp)) + (cons temp (cdr field))))))) + fields))) + ;; FIXME: Optimize temps away when they're provided in the right order? + `(let ,tempbinds + (oclosure--lambda ',type ,slotbinds ,mutables ,args ,@body)))) + +(defun oclosure--fix-type (_ignore oclosure) + "Helper function to implement `oclosure-lambda' via a macro. +This has 2 uses: +- For interpreted code, this converts the representation of type information + by moving it from the docstring to the environment. +- For compiled code, this is used as a marker which cconv uses to check that + immutable fields are indeed not mutated." + (if (byte-code-function-p oclosure) + ;; Actually, this should never happen since the `cconv.el' should have + ;; optimized away the call to this function. + oclosure + ;; For byte-coded functions, we store the type as a symbol in the docstring + ;; slot. For interpreted functions, there's no specific docstring slot + ;; so `Ffunction' turns the symbol into a string. + ;; We thus have convert it back into a symbol (via `intern') and then + ;; stuff it into the environment part of the closure with a special + ;; marker so we can distinguish this entry from actual variables. + (cl-assert (eq 'closure (car-safe oclosure))) + (let ((typename (nth 3 oclosure))) ;; The "docstring". + (cl-assert (stringp typename)) + (push (cons :type (intern typename)) + (cadr oclosure)) + oclosure))) + +(defun oclosure--copy (oclosure mutlist &rest args) + (if (byte-code-function-p oclosure) + (apply #'make-closure oclosure + (if (null mutlist) + args + (mapcar (lambda (arg) (if (pop mutlist) (list arg) arg)) args))) + (cl-assert (eq 'closure (car-safe oclosure)) + nil "oclosure not closure: %S" oclosure) + (cl-assert (eq :type (caar (cadr oclosure)))) + (let ((env (cadr oclosure))) + `(closure + (,(car env) + ,@(named-let loop ((env (cdr env)) (args args)) + (when args + (cons (cons (caar env) (car args)) + (loop (cdr env) (cdr args))))) + ,@(nthcdr (1+ (length args)) env)) + ,@(nthcdr 2 oclosure))))) + +(defun oclosure--get (oclosure index mutable) + (if (byte-code-function-p oclosure) + (let* ((csts (aref oclosure 2)) + (v (aref csts index))) + (if mutable (car v) v)) + (cl-assert (eq 'closure (car-safe oclosure))) + (cl-assert (eq :type (caar (cadr oclosure)))) + (cdr (nth (1+ index) (cadr oclosure))))) + +(defun oclosure--set (v oclosure index) + (if (byte-code-function-p oclosure) + (let* ((csts (aref oclosure 2)) + (cell (aref csts index))) + (setcar cell v)) + (cl-assert (eq 'closure (car-safe oclosure))) + (cl-assert (eq :type (caar (cadr oclosure)))) + (setcdr (nth (1+ index) (cadr oclosure)) v))) + +(defun oclosure-type (oclosure) + "Return the type of OCLOSURE, or nil if the arg is not a OClosure." + (if (byte-code-function-p oclosure) + (let ((type (and (> (length oclosure) 4) (aref oclosure 4)))) + (if (symbolp type) type)) + (and (eq 'closure (car-safe oclosure)) + (let* ((env (car-safe (cdr oclosure))) + (first-var (car-safe env))) + (and (eq :type (car-safe first-var)) + (cdr first-var)))))) + +(defconst oclosure--accessor-prototype + ;; Use `oclosure--lambda' to circumvent a bootstrapping problem: + ;; `oclosure-accessor' is not yet defined at this point but + ;; `oclosure--accessor-prototype' is needed when defining `oclosure-accessor'. + (oclosure--lambda 'oclosure-accessor ((type) (slot) (index)) nil + (oclosure) (oclosure--get oclosure index nil))) + +(oclosure-define accessor + "OClosure function to access a specific slot of an object." + type slot) + +(oclosure-define (oclosure-accessor + (:parent accessor) + (:copier oclosure--accessor-copy (type slot index))) + "OClosure function to access a specific slot of an OClosure function." + index) + +(defconst oclosure--mut-getter-prototype + (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (oclosure) + (oclosure--get oclosure index t))) +(defconst oclosure--mut-setter-prototype + ;; FIXME: The generated docstring is wrong. + (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (val oclosure) + (oclosure--set val oclosure index))) + +;; Ideally, this should be in `files.el', but that file is loaded +;; before `oclosure.el'. +(oclosure-define (save-some-buffers-function + (:predicate save-some-buffers-function--p))) + + +(provide 'oclosure) +;;; oclosure.el ends here diff --git a/src/doc.c b/src/doc.c index a9f77b25bf..e361a86c1a 100644 --- a/src/doc.c +++ b/src/doc.c @@ -514,11 +514,19 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) { /* This bytecode object must have a slot for the docstring, since we've found a docstring for it. */ - if (PVSIZE (fun) > COMPILED_DOC_STRING) + if (PVSIZE (fun) > COMPILED_DOC_STRING + /* Don't overwrite a non-docstring value placed there, + * such as the symbols used for Oclosures. */ + && (FIXNUMP (AREF (fun, COMPILED_DOC_STRING)) + || STRINGP (AREF (fun, COMPILED_DOC_STRING)) + || CONSP (AREF (fun, COMPILED_DOC_STRING)))) ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset)); else { - AUTO_STRING (format, "No docstring slot for %s"); + AUTO_STRING (format, + (PVSIZE (fun) > COMPILED_DOC_STRING + ? "Docstring slot busy for %s" + : "No docstring slot for %s")); CALLN (Fmessage, format, (SYMBOLP (obj) ? SYMBOL_NAME (obj) diff --git a/src/eval.c b/src/eval.c index 39c328ea1f..a4449b18f9 100644 --- a/src/eval.c +++ b/src/eval.c @@ -559,6 +559,10 @@ usage: (function ARG) */) { /* Handle the special (:documentation
) to build the docstring dynamically. */ Lisp_Object docstring = eval_sub (Fcar (XCDR (tmp))); + if (SYMBOLP (docstring) && !NILP (docstring)) + /* Hack for OClosures: Allow the docstring to be a symbol + * (the OClosure's type). */ + docstring = Fsymbol_name (docstring); CHECK_STRING (docstring); cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (cdr)))); } diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el new file mode 100644 index 0000000000..e7e76fa4bd --- /dev/null +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -0,0 +1,113 @@ +;;; oclosure-tests.e; --- Tests for Open Closures -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-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 . + +;;; Code: + +(require 'ert) +(require 'oclosure) +(require 'cl-lib) + +(oclosure-define (oclosure-test + (:copier oclosure-test-copy) + (:copier oclosure-test-copy1 (fst))) + "Simple OClosure." + fst snd name) + +(ert-deftest oclosure-test () + (let* ((i 42) + (ocl1 (oclosure-lambda (oclosure-test (fst 1) (snd 2) (name "hi")) + () + (list fst snd i))) + (ocl2 (oclosure-lambda (oclosure-test (name (cl-incf i)) (fst (cl-incf i))) + () + (list fst snd 152 i)))) + (should (equal (list (oclosure-test--fst ocl1) + (oclosure-test--snd ocl1) + (oclosure-test--name ocl1)) + '(1 2 "hi"))) + (should (equal (list (oclosure-test--fst ocl2) + (oclosure-test--snd ocl2) + (oclosure-test--name ocl2)) + '(44 nil 43))) + (should (equal (funcall ocl1) '(1 2 44))) + (should (equal (funcall ocl2) '(44 nil 152 44))) + (should (equal (funcall (oclosure-test-copy ocl1 :fst 7)) '(7 2 44))) + (should (equal (funcall (oclosure-test-copy1 ocl1 9)) '(9 2 44))) + (should (cl-typep ocl1 'oclosure-test)) + (should (cl-typep ocl1 'oclosure)) + )) + +(ert-deftest oclosure-test-limits () + (should + (condition-case err + (let ((lexical-binding t) + (byte-compile-debug t)) + (byte-compile '(lambda () + (let ((inc-fst nil)) + (oclosure-lambda (oclosure-test (fst 'foo)) () + (setq inc-fst (lambda () (setq fst (1+ fst)))) + fst)))) + nil) + (error + (and (eq 'error (car err)) + (string-match "fst.*mutated" (cadr err)))))) + (should + (condition-case err + (progn (macroexpand-all '(oclosure-define oclosure--foo a a)) + nil) + (error + (and (eq 'error (car err)) + (string-match "Duplicate slot name: a$" (cadr err)))))) + (should + (condition-case err + (progn (macroexpand-all + '(oclosure-define (oclosure--foo (:parent oclosure-test)) fst)) + nil) + (error + (and (eq 'error (car err)) + (string-match "Duplicate slot name: fst$" (cadr err)))))) + (should + (condition-case err + (progn (macroexpand '(oclosure-lambda (oclosure-test (fst 1) (fst 2)) + () fst)) + nil) + (error + (and (eq 'error (car err)) + (string-match "Duplicate slot: fst$" (cadr err))))))) + +(oclosure-define (oclosure-test-mut + (:parent oclosure-test) + (:copier oclosure-test-mut-copy)) + "Simple OClosure with a mutable field." + (mut :mutable t)) + +(ert-deftest oclosure-test-mutate () + (let* ((f (oclosure-lambda (oclosure-test-mut (fst 0) (mut 3)) + (x) + (+ x fst mut))) + (f2 (oclosure-test-mut-copy f :fst 50))) + (should (equal (oclosure-test-mut--mut f) 3)) + (should (equal (funcall f 5) 8)) + (should (equal (funcall f2 5) 58)) + (cl-incf (oclosure-test-mut--mut f) 7) + (should (equal (oclosure-test-mut--mut f) 10)) + (should (equal (funcall f 5) 15)) + (should (equal (funcall f2 15) 68)))) + +;;; oclosure-tests.el ends here. commit 3f19a23c1f60757c54a0ec7d84c625d83766ee08 Author: Po Lu Date: Mon Mar 28 20:34:03 2022 +0800 Fix doc of `gui-get-selection' as to what is really valid as `data' * doc/lispref/frames.texi (Window System Selections): * lisp/select.el (gui-set-selection): Don't say `data' can be a cons or list of two integers, since that's not supported. diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index 90924cf47b..ebf426fe50 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -3918,11 +3918,11 @@ upper-case names, in accord with X Window System conventions. If @var{type} is @code{nil}, that stands for @code{PRIMARY}. If @var{data} is @code{nil}, it means to clear out the selection. -Otherwise, @var{data} may be a string, a symbol, an integer (or a cons -of two integers or list of two integers), an overlay, or a cons of two -markers pointing to the same buffer. An overlay or a pair of markers -stands for text in the overlay or between the markers. The argument -@var{data} may also be a vector of valid non-vector selection values. +Otherwise, @var{data} may be a string, a symbol, an integer, an +overlay, or a cons of two markers pointing to the same buffer. An +overlay or a pair of markers stands for text in the overlay or between +the markers. The argument @var{data} may also be a vector of valid +non-vector selection values. This function returns @var{data}. @end deffn diff --git a/lisp/select.el b/lisp/select.el index 90970f989a..7b9475a640 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -350,10 +350,10 @@ the formats available in the clipboard if TYPE is `CLIPBOARD'." (defun gui-set-selection (type data) "Make an X selection of type TYPE and value DATA. The argument TYPE (nil means `PRIMARY') says which selection, and -DATA specifies the contents. TYPE must be a symbol. \(It can also -be a string, which stands for the symbol with that name, but this -is considered obsolete.) DATA may be a string, a symbol, an -integer (or a cons of two integers or list of two integers). +DATA specifies the contents. TYPE must be a symbol. \(It can +also be a string, which stands for the symbol with that name, but +this is considered obsolete.) DATA may be a string, a symbol, or +an integer. The selection may also be a cons of two markers pointing to the same buffer, or an overlay. In these cases, the selection is considered to be the text commit fbbb9148ccb63f0eccd032f9e7c8e585997d4185 Author: Po Lu Date: Mon Mar 28 12:28:53 2022 +0000 Minor fixes to Haiku selection support * lisp/term/haiku-win.el (haiku-selection-bounds): New function. (haiku-dnd-convert-string, haiku-select-encode-xstring) (haiku-select-encode-utf-8-string): Handle position pairs correctly. (gui-backend-set-selection): Adjust for new airity. * src/haikuselect.c (Fhaiku_selection_put): Fix arity. diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index fcf3c4e383..f9dcd0d192 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -72,10 +72,40 @@ content that is being put into the selection by `gui-set-selection'. See the doc string of `haiku-drag-message' for more details on the structure of the associations.") +(defun haiku-selection-bounds (value) + "Return bounds of selection value VALUE. +The return value is a list (BEG END BUF) if VALUE is a cons of +two markers or an overlay. Otherwise, it is nil." + (cond ((bufferp value) + (with-current-buffer value + (when (mark t) + (list (mark t) (point) value)))) + ((and (consp value) + (markerp (car value)) + (markerp (cdr value))) + (when (and (marker-buffer (car value)) + (buffer-name (marker-buffer (car value))) + (eq (marker-buffer (car value)) + (marker-buffer (cdr value)))) + (list (marker-position (car value)) + (marker-position (cdr value)) + (marker-buffer (car value))))) + ((overlayp value) + (when (overlay-buffer value) + (list (overlay-start value) + (overlay-end value) + (overlay-buffer value)))))) + (defun haiku-dnd-convert-string (value) "Convert VALUE to a UTF-8 string and appropriate MIME type. Return a list of the appropriate MIME type, and UTF-8 data of VALUE as a unibyte string, or nil if VALUE was not a string." + (unless (stringp value) + (when-let ((bounds (haiku-selection-bounds value))) + (setq value (ignore-errors + (with-current-buffer (nth 2 bounds) + (buffer-substring (nth 0 bounds) + (nth 1 bounds))))))) (when (stringp value) (list "text/plain" (string-to-unibyte (encode-coding-string value 'utf-8))))) @@ -143,7 +173,13 @@ CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or "Convert VALUE to a system message association. VALUE will be encoded as Latin-1 (like on X Windows) and stored under the type `text/plain;charset=iso-8859-1'." - (when (stringp value) + (unless (stringp value) + (when-let ((bounds (haiku-selection-bounds value))) + (setq value (ignore-errors + (with-current-buffer (nth 2 bounds) + (buffer-substring (nth 0 bounds) + (nth 1 bounds))))))) + (when (and (stringp value) (not (string-empty-p value))) (list "text/plain;charset=iso-8859-1" 1296649541 (encode-coding-string value 'iso-latin-1)))) @@ -151,7 +187,13 @@ under the type `text/plain;charset=iso-8859-1'." "Convert VALUE to a system message association. VALUE will be encoded as UTF-8 and stored under the type `text/plain'." - (when (stringp value) + (unless (stringp value) + (when-let ((bounds (haiku-selection-bounds value))) + (setq value (ignore-errors + (with-current-buffer (nth 2 bounds) + (buffer-substring (nth 0 bounds) + (nth 1 bounds))))))) + (when (and (stringp value) (not (string-empty-p value))) (list "text/plain" 1296649541 (encode-coding-string value 'utf-8-unix)))) @@ -173,7 +215,7 @@ VALUE will be encoded as UTF-8 and stored under the type (let ((result (funcall encoder type value))) (when result (push result message)))) - (haiku-selection-put type message nil)))) + (haiku-selection-put type message)))) (cl-defmethod gui-backend-selection-exists-p (selection &context (window-system haiku)) diff --git a/src/haikuselect.c b/src/haikuselect.c index 461482fea1..c1c619ee8c 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -112,7 +112,7 @@ haiku_unwind_clipboard_lock (int clipboard) } DEFUN ("haiku-selection-put", Fhaiku_selection_put, Shaiku_selection_put, - 3, 4, 0, + 2, 4, 0, doc: /* Add or remove content from the clipboard CLIPBOARD. CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'. NAME is a MIME type denoting the type of the data to add. DATA is the commit dc0ee78d93c36606e7e8502d8ccff5f8c6116550 Author: Po Lu Date: Mon Mar 28 18:41:12 2022 +0800 Improve portability of XCB configure checks * configure.ac: Look for xcb_aux_sync in -lxcb-aux if it's not in -lxcb-util. diff --git a/configure.ac b/configure.ac index 35ebbb2db0..10358c2b64 100644 --- a/configure.ac +++ b/configure.ac @@ -3747,6 +3747,14 @@ if test "${HAVE_X11}" = "yes"; then [Define to 1 if you have the XCB library and X11-XCB library for mixed X11/XCB programming.]) XCB_LIBS="-lX11-xcb -lxcb -lxcb-util" + else + AC_CHECK_LIB(xcb-aux, xcb_aux_sync, HAVE_XCB_AUX=yes) + if test "${HAVE_XCB_AUX}" = "yes"; then + AC_DEFINE(USE_XCB, 1, +[Define to 1 if you have the XCB library and X11-XCB library for mixed + X11/XCB programming.]) + XCB_LIBS="-lX11-xcb -lxcb -lxcb-aux" + fi fi fi fi commit a5841b196f12894df4c1bb073f28ddadb6faa3cf Author: Michael Albinus Date: Mon Mar 28 12:02:23 2022 +0200 Do not register Tramp file name handlers twice * lisp/net/tramp.el (tramp-register-autoload-file-name-handlers): * lisp/net/tramp-archive.el (tramp-register-archive-file-name-handler): Check, whether the real file name handler is already registered. diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 788e457367..890c8dbb75 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -374,7 +374,9 @@ arguments to pass to the OPERATION." ;;;###autoload (progn (defun tramp-register-archive-file-name-handler () "Add archive file name handler to `file-name-handler-alist'." - (when tramp-archive-enabled + (when (and tramp-archive-enabled + (not + (rassq #'tramp-archive-file-name-handler file-name-handler-alist))) (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 0192a63a10..580cfea1f8 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2756,10 +2756,11 @@ Falls back to normal file name handler if no Tramp file name handler exists." ;;;###autoload (progn (defun tramp-register-autoload-file-name-handlers () "Add Tramp file name handlers to `file-name-handler-alist' during autoload." - (add-to-list 'file-name-handler-alist - (cons tramp-autoload-file-name-regexp - #'tramp-autoload-file-name-handler)) - (put #'tramp-autoload-file-name-handler 'safe-magic t))) + (unless (rassq #'tramp-file-name-handler file-name-handler-alist) + (add-to-list 'file-name-handler-alist + (cons tramp-autoload-file-name-regexp + #'tramp-autoload-file-name-handler)) + (put #'tramp-autoload-file-name-handler 'safe-magic t)))) (put #'tramp-register-autoload-file-name-handlers 'tramp-autoload t) ;;;###autoload (tramp-register-autoload-file-name-handlers) commit 0e7314f6f15a20cb2ae712c09bb201f571823a6f Author: Po Lu Date: Mon Mar 28 13:52:17 2022 +0800 Avoid extra sync when fetching DND proxy window * src/xterm.c (x_dnd_get_proxy_proto): New function. (x_dnd_get_target_window): Use it on XCB to determine window proxy and proto for toplevel window. diff --git a/src/xterm.c b/src/xterm.c index 97dfbc5add..443009c0db 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1343,9 +1343,76 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) #define X_DND_SUPPORTED_VERSION 5 + static int x_dnd_get_window_proto (struct x_display_info *, Window); static Window x_dnd_get_window_proxy (struct x_display_info *, Window); +#ifdef USE_XCB +static void +x_dnd_get_proxy_proto (struct x_display_info *dpyinfo, Window wdesc, + Window *proxy_out, int *proto_out) +{ + xcb_get_property_cookie_t xdnd_proto_cookie; + xcb_get_property_cookie_t xdnd_proxy_cookie; + xcb_get_property_reply_t *reply; + xcb_generic_error_t *error; + + if (proxy_out) + *proxy_out = None; + + if (proto_out) + *proto_out = -1; + + if (proxy_out) + xdnd_proxy_cookie = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) wdesc, + (xcb_atom_t) dpyinfo->Xatom_XdndProxy, + XCB_ATOM_WINDOW, 0, 1); + + if (proto_out) + xdnd_proto_cookie = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) wdesc, + (xcb_atom_t) dpyinfo->Xatom_XdndAware, + XCB_ATOM_ATOM, 0, 1); + + if (proxy_out) + { + reply = xcb_get_property_reply (dpyinfo->xcb_connection, + xdnd_proxy_cookie, &error); + + if (!reply) + free (error); + else + { + if (reply->format == 32 + && reply->type == XCB_ATOM_WINDOW + && (xcb_get_property_value_length (reply) >= 4)) + *proxy_out = *(xcb_window_t *) xcb_get_property_value (reply); + + free (reply); + } + } + + if (proto_out) + { + reply = xcb_get_property_reply (dpyinfo->xcb_connection, + xdnd_proto_cookie, &error); + + if (!reply) + free (error); + else + { + if (reply->format == 32 + && reply->type == XCB_ATOM_ATOM + && (xcb_get_property_value_length (reply) >= 4)) + *proto_out = (int) *(xcb_atom_t *) xcb_get_property_value (reply); + + free (reply); + } + } +} +#endif + #ifdef HAVE_XSHAPE static bool x_dnd_get_target_window_2 (XRectangle *rects, int nrects, @@ -1433,7 +1500,11 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo, if (child != None) { - proxy = x_dnd_get_window_proxy (dpyinfo, child_return); +#ifndef USE_XCB + proxy = x_dnd_get_window_proxy (dpyinfo, child); +#else + x_dnd_get_proxy_proto (dpyinfo, child, &proxy, proto_out); +#endif if (proxy != None) { @@ -1446,7 +1517,9 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo, } } +#ifndef USE_XCB *proto_out = x_dnd_get_window_proto (dpyinfo, child); +#endif return child; } commit f5adb2584a9e25e3bbf01d1ca1c7fc6e511a4012 Author: Po Lu Date: Mon Mar 28 08:59:50 2022 +0800 Clean up some uses of XInternAtom * src/xfns.c (x_set_undecorated, x_set_no_focus_on_map, x_window) (set_machine_and_pid_properties): Move calls to XInternAtom for static string to use previously interned atoms. (Fx_change_window_property): Use XCB if available to avoid extra call to XSync. * src/xterm.c (x_term_init): * src/xterm.h (struct x_display_info): New atoms _MOTIF_WM_HINTS and _NET_WM_PID. diff --git a/src/xfns.c b/src/xfns.c index 3f3054422a..534fb7c544 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -867,7 +867,7 @@ x_set_undecorated (struct frame *f, Lisp_Object new_value, Lisp_Object old_value #else Display *dpy = FRAME_X_DISPLAY (f); PropMotifWmHints hints; - Atom prop = XInternAtom (dpy, "_MOTIF_WM_HINTS", False); + Atom prop = FRAME_DISPLAY_INFO (f)->Xatom_MOTIF_WM_HINTS; memset (&hints, 0, sizeof(hints)); hints.flags = MWM_HINTS_DECORATIONS; @@ -979,7 +979,7 @@ x_set_no_focus_on_map (struct frame *f, Lisp_Object new_value, Lisp_Object old_v xg_set_no_focus_on_map (f, new_value); #else /* not USE_GTK */ Display *dpy = FRAME_X_DISPLAY (f); - Atom prop = XInternAtom (dpy, "_NET_WM_USER_TIME", False); + Atom prop = FRAME_DISPLAY_INFO (f)->Xatom_net_wm_user_time; Time timestamp = NILP (new_value) ? CurrentTime : 0; XChangeProperty (dpy, FRAME_OUTER_WINDOW (f), prop, @@ -3918,7 +3918,7 @@ x_window (struct frame *f, long window_prompting) { Display *dpy = FRAME_X_DISPLAY (f); PropMotifWmHints hints; - Atom prop = XInternAtom (dpy, "_MOTIF_WM_HINTS", False); + Atom prop = FRAME_DISPLAY_INFO (f)->Xatom_MOTIF_WM_HINTS; memset (&hints, 0, sizeof(hints)); hints.flags = MWM_HINTS_DECORATIONS; @@ -4097,7 +4097,7 @@ x_window (struct frame *f) { Display *dpy = FRAME_X_DISPLAY (f); PropMotifWmHints hints; - Atom prop = XInternAtom (dpy, "_MOTIF_WM_HINTS", False); + Atom prop = FRAME_DISPLAY_INFO (f)->Xatom_MOTIF_WM_HINTS; memset (&hints, 0, sizeof(hints)); hints.flags = MWM_HINTS_DECORATIONS; @@ -4435,9 +4435,7 @@ set_machine_and_pid_properties (struct frame *f) unsigned long xpid = pid; XChangeProperty (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), - XInternAtom (FRAME_X_DISPLAY (f), - "_NET_WM_PID", - False), + FRAME_DISPLAY_INFO (f)->Xatom_net_wm_pid, XA_CARDINAL, 32, PropModeReplace, (unsigned char *) &xpid, 1); } @@ -7073,6 +7071,13 @@ If WINDOW-ID is non-nil, change the property of that window instead unsigned char *data; int nelements; Window target_window; +#ifdef USE_XCB + xcb_intern_atom_cookie_t prop_atom_cookie; + xcb_intern_atom_cookie_t target_type_cookie; + xcb_intern_atom_reply_t *reply; + xcb_generic_error_t *generic_error; + bool rc; +#endif CHECK_STRING (prop); @@ -7136,12 +7141,61 @@ If WINDOW-ID is non-nil, change the property of that window instead } block_input (); +#ifndef USE_XCB prop_atom = XInternAtom (FRAME_X_DISPLAY (f), SSDATA (prop), False); if (! NILP (type)) { CHECK_STRING (type); target_type = XInternAtom (FRAME_X_DISPLAY (f), SSDATA (type), False); } +#else + rc = true; + prop_atom_cookie + = xcb_intern_atom (FRAME_DISPLAY_INFO (f)->xcb_connection, + 0, SBYTES (prop), SSDATA (prop)); + + if (!NILP (type)) + { + CHECK_STRING (type); + target_type_cookie + = xcb_intern_atom (FRAME_DISPLAY_INFO (f)->xcb_connection, + 0, SBYTES (type), SSDATA (type)); + } + + reply = xcb_intern_atom_reply (FRAME_DISPLAY_INFO (f)->xcb_connection, + prop_atom_cookie, &generic_error); + + if (reply) + { + prop_atom = (Atom) reply->atom; + free (reply); + } + else + { + free (generic_error); + rc = false; + } + + if (!NILP (type)) + { + reply = xcb_intern_atom_reply (FRAME_DISPLAY_INFO (f)->xcb_connection, + target_type_cookie, &generic_error); + + if (reply) + { + target_type = (Atom) reply->atom; + free (reply); + } + else + { + free (generic_error); + rc = false; + } + } + + if (!rc) + error ("Failed to intern type or property atom"); +#endif XChangeProperty (FRAME_X_DISPLAY (f), target_window, prop_atom, target_type, element_format, PropModeReplace, diff --git a/src/xterm.c b/src/xterm.c index fbd6fadf1d..97dfbc5add 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -20233,6 +20233,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) ATOM_REFS_INIT ("CLIPBOARD_MANAGER", Xatom_CLIPBOARD_MANAGER) ATOM_REFS_INIT ("XATOM_COUNTER", Xatom_XEMBED_INFO) ATOM_REFS_INIT ("_XEMBED_INFO", Xatom_XEMBED_INFO) + ATOM_REFS_INIT ("_MOTIF_WM_HINTS", Xatom_MOTIF_WM_HINTS) /* For properties of font. */ ATOM_REFS_INIT ("PIXEL_SIZE", Xatom_PIXEL_SIZE) ATOM_REFS_INIT ("AVERAGE_WIDTH", Xatom_AVERAGE_WIDTH) @@ -20282,6 +20283,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) ATOM_REFS_INIT ("_NET_WM_STATE_BELOW", Xatom_net_wm_state_below) ATOM_REFS_INIT ("_NET_WM_OPAQUE_REGION", Xatom_net_wm_opaque_region) ATOM_REFS_INIT ("_NET_WM_PING", Xatom_net_wm_ping) + ATOM_REFS_INIT ("_NET_WM_PID", Xatom_net_wm_pid) #ifdef HAVE_XKB ATOM_REFS_INIT ("Meta", Xatom_Meta) ATOM_REFS_INIT ("Super", Xatom_Super) diff --git a/src/xterm.h b/src/xterm.h index a155245f81..57b55ecf0d 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -433,6 +433,8 @@ struct x_display_info /* Atom used to determine whether or not the screen is composited. */ Atom Xatom_NET_WM_CM_Sn; + Atom Xatom_MOTIF_WM_HINTS; + /* The frame (if any) which has the X window that has keyboard focus. Zero if none. This is examined by Ffocus_frame in xfns.c. Note that a mere EnterNotify event can set this; if you need to know the @@ -551,7 +553,8 @@ struct x_display_info Xatom_net_workarea, Xatom_net_wm_opaque_region, Xatom_net_wm_ping, Xatom_net_wm_sync_request, Xatom_net_wm_sync_request_counter, Xatom_net_wm_frame_drawn, Xatom_net_wm_user_time, - Xatom_net_wm_user_time_window, Xatom_net_client_list_stacking; + Xatom_net_wm_user_time_window, Xatom_net_client_list_stacking, + Xatom_net_wm_pid; /* XSettings atoms and windows. */ Atom Xatom_xsettings_sel, Xatom_xsettings_prop, Xatom_xsettings_mgr; commit 45a1bb0efbdd827e91cf80d0c93f60c311e85255 Author: Po Lu Date: Mon Mar 28 08:39:37 2022 +0800 ; * src/xterm.c (x_dnd_compute_toplevels): Use right enum on XCB. diff --git a/src/xterm.c b/src/xterm.c index a77b90a4b5..fbd6fadf1d 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1108,6 +1108,7 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) tem->y = dest_y; tem->width = attrs.width + attrs.border_width; tem->height = attrs.height + attrs.border_width; + tem->mapped_p = (attrs.map_state != IsUnmapped); #else tem->x = (coordinates_reply->dst_x - geometry_reply->border_width); @@ -1117,8 +1118,8 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) + geometry_reply->border_width); tem->height = (geometry_reply->height + geometry_reply->border_width); + tem->mapped_p = (attrs.map_state != XCB_MAP_STATE_UNMAPPED); #endif - tem->mapped_p = (attrs.map_state != IsUnmapped); tem->next = x_dnd_toplevels; tem->previous_event_mask = attrs.your_event_mask; tem->wm_state = wmstate[0]; @@ -1311,8 +1312,8 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) && dpyinfo->xshape_minor >= 1))) { input_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection, - input_rect_cookies[i], - &error); + input_rect_cookies[i], + &error); if (input_rect_reply) free (input_rect_reply); commit be21c95842f37e164606a6b392f5396d91506f61 Author: Po Lu Date: Sun Mar 27 13:36:45 2022 +0000 Store latin-1 content into the Haiku clipboard as well * lisp/term/haiku-win.el (haiku-normal-selection-encoders): New variable. (haiku-select-encode-utf-8-string, haiku-select-encode-xstring): New functions. (gui-backend-set-selection): Use new selection encoder functions instead of hard-coding UTF-8. (haiku-dnd-handle-drag-n-drop-event): Rename to `haiku-drag-and-drop'. * src/haiku_select.cc (be_lock_clipboard_message): Accept new argument `clear'. (be_unlock_clipboard): Accept new argument `discard'. * src/haikuselect.c (Fhaiku_selection_data): Change calls to `be_lock_clipboard_message' and `be_unlock_clipboard'. (haiku_unwind_clipboard_lock): New function. (Fhaiku_selection_put): Accept new meaning of `name' which means to set the selection message. * src/haikuselect.h: Update prototypes. diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index 2f106825c3..fcf3c4e383 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -61,6 +61,17 @@ DATA can optionally have a text property `type', which specifies the type of DATA inside the system message (see the doc string of `haiku-drag-message' for more details).") +(defvar haiku-normal-selection-encoders '(haiku-select-encode-xstring + haiku-select-encode-utf-8-string) + "List of functions which act as selection encoders. +These functions accept two arguments SELECTION and VALUE, and +return an association appropriate for a serialized system +message (or nil if VALUE is not applicable to the encoder) that +will be put into the system selection SELECTION. VALUE is the +content that is being put into the selection by +`gui-set-selection'. See the doc string of `haiku-drag-message' +for more details on the structure of the associations.") + (defun haiku-dnd-convert-string (value) "Convert VALUE to a UTF-8 string and appropriate MIME type. Return a list of the appropriate MIME type, and UTF-8 data of @@ -128,6 +139,22 @@ CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'. Return the available types as a list of strings." (mapcar #'car (haiku-selection-data clipboard nil))) +(defun haiku-select-encode-xstring (_selection value) + "Convert VALUE to a system message association. +VALUE will be encoded as Latin-1 (like on X Windows) and stored +under the type `text/plain;charset=iso-8859-1'." + (when (stringp value) + (list "text/plain;charset=iso-8859-1" 1296649541 + (encode-coding-string value 'iso-latin-1)))) + +(defun haiku-select-encode-utf-8-string (_selection value) + "Convert VALUE to a system message association. +VALUE will be encoded as UTF-8 and stored under the type +`text/plain'." + (when (stringp value) + (list "text/plain" 1296649541 + (encode-coding-string value 'utf-8-unix)))) + (cl-defmethod gui-backend-get-selection (type data-type &context (window-system haiku)) (if (eq data-type 'TARGETS) @@ -141,7 +168,12 @@ CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or &context (window-system haiku)) (if (eq type 'XdndSelection) (setq haiku-dnd-selection-value value) - (haiku-selection-put type "text/plain" value t))) + (let ((message nil)) + (dolist (encoder haiku-normal-selection-encoders) + (let ((result (funcall encoder type value))) + (when result + (push result message)))) + (haiku-selection-put type message nil)))) (cl-defmethod gui-backend-selection-exists-p (selection &context (window-system haiku)) @@ -165,7 +197,7 @@ CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or (file-name-nondirectory default-filename)) (error "x-file-dialog on a tty frame"))) -(defun haiku-dnd-handle-drag-n-drop-event (event) +(defun haiku-drag-and-drop (event) "Handle specified drag-n-drop EVENT." (interactive "e") (let* ((string (caddr event)) @@ -189,7 +221,7 @@ CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or (t (message "Don't know how to drop any of: %s" (mapcar #'car string)))))) (define-key special-event-map [drag-n-drop] - 'haiku-dnd-handle-drag-n-drop-event) + 'haiku-drag-and-drop) (defvaralias 'haiku-use-system-tooltips 'use-system-tooltips) diff --git a/src/haiku_select.cc b/src/haiku_select.cc index 373ad321c4..e047b9b513 100644 --- a/src/haiku_select.cc +++ b/src/haiku_select.cc @@ -413,7 +413,7 @@ be_add_message_message (void *message, const char *name, int be_lock_clipboard_message (enum haiku_clipboard clipboard, - void **message_return) + void **message_return, bool clear) { BClipboard *board; @@ -427,12 +427,15 @@ be_lock_clipboard_message (enum haiku_clipboard clipboard, if (!board->Lock ()) return 1; + if (clear) + board->Clear (); + *message_return = board->Data (); return 0; } void -be_unlock_clipboard (enum haiku_clipboard clipboard) +be_unlock_clipboard (enum haiku_clipboard clipboard, bool discard) { BClipboard *board; @@ -443,5 +446,10 @@ be_unlock_clipboard (enum haiku_clipboard clipboard) else board = system_clipboard; + if (discard) + board->Revert (); + else + board->Commit (); + board->Unlock (); } diff --git a/src/haikuselect.c b/src/haikuselect.c index f1aa4f20d9..461482fea1 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -27,6 +27,8 @@ along with GNU Emacs. If not, see . */ #include +static void haiku_lisp_to_message (Lisp_Object, void *); + DEFUN ("haiku-selection-data", Fhaiku_selection_data, Shaiku_selection_data, 2, 2, 0, doc: /* Retrieve content typed as NAME from the clipboard @@ -88,7 +90,7 @@ message in the format accepted by `haiku-drag-message', which see. */) clipboard_name = CLIPBOARD_CLIPBOARD; block_input (); - rc = be_lock_clipboard_message (clipboard_name, &message); + rc = be_lock_clipboard_message (clipboard_name, &message, false); unblock_input (); if (rc) @@ -96,13 +98,19 @@ message in the format accepted by `haiku-drag-message', which see. */) block_input (); str = haiku_message_to_lisp (message); - be_unlock_clipboard (clipboard_name); + be_unlock_clipboard (clipboard_name, true); unblock_input (); } return str; } +static void +haiku_unwind_clipboard_lock (int clipboard) +{ + be_unlock_clipboard (clipboard, false); +} + DEFUN ("haiku-selection-put", Fhaiku_selection_put, Shaiku_selection_put, 3, 4, 0, doc: /* Add or remove content from the clipboard CLIPBOARD. @@ -110,18 +118,53 @@ CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'. NAME is a MIME type denoting the type of the data to add. DATA is the string that will be placed in the clipboard, or nil if the content is to be removed. CLEAR, if non-nil, means to erase all the previous -contents of the clipboard. */) +contents of the clipboard. + +Alternatively, NAME can be a system message in the format accepted by +`haiku-drag-message', which will replace the contents of CLIPBOARD. +In that case, the arguments after NAME are ignored. */) (Lisp_Object clipboard, Lisp_Object name, Lisp_Object data, Lisp_Object clear) { + enum haiku_clipboard clipboard_name; + specpdl_ref ref; + char *dat; + ptrdiff_t len; + int rc; + void *message; + + if (CONSP (name) || NILP (name)) + { + if (EQ (clipboard, QPRIMARY)) + clipboard_name = CLIPBOARD_PRIMARY; + else if (EQ (clipboard, QSECONDARY)) + clipboard_name = CLIPBOARD_SECONDARY; + else if (EQ (clipboard, QCLIPBOARD)) + clipboard_name = CLIPBOARD_CLIPBOARD; + else + signal_error ("Invalid clipboard", clipboard); + + rc = be_lock_clipboard_message (clipboard_name, + &message, true); + + if (rc) + signal_error ("Couldn't open clipboard", clipboard); + + ref = SPECPDL_INDEX (); + record_unwind_protect_int (haiku_unwind_clipboard_lock, + clipboard_name); + haiku_lisp_to_message (name, message); + + return unbind_to (ref, Qnil); + } + CHECK_SYMBOL (clipboard); CHECK_STRING (name); if (!NILP (data)) CHECK_STRING (data); - block_input (); - char *dat = !NILP (data) ? SSDATA (data) : NULL; - ptrdiff_t len = !NILP (data) ? SBYTES (data) : 0; + dat = !NILP (data) ? SSDATA (data) : NULL; + len = !NILP (data) ? SBYTES (data) : 0; if (EQ (clipboard, QPRIMARY)) BClipboard_set_primary_selection_data (SSDATA (name), dat, len, @@ -136,7 +179,6 @@ contents of the clipboard. */) unblock_input (); signal_error ("Bad clipboard", clipboard); } - unblock_input (); return Qnil; } diff --git a/src/haikuselect.h b/src/haikuselect.h index 01e4ca327d..5d1dd33c8c 100644 --- a/src/haikuselect.h +++ b/src/haikuselect.h @@ -107,8 +107,10 @@ extern "C" extern int be_add_message_message (void *message, const char *name, void *data); extern int be_lock_clipboard_message (enum haiku_clipboard clipboard, - void **message_return); - extern void be_unlock_clipboard (enum haiku_clipboard clipboard); + void **message_return, + bool clear); + extern void be_unlock_clipboard (enum haiku_clipboard clipboard, + bool discard); #ifdef __cplusplus }; #endif commit 46863b7dfa210e73244af9bc790222dd66d5051d Author: Po Lu Date: Sun Mar 27 19:53:49 2022 +0800 Clean up PGTK cursor blanking code * src/pgtkterm.c (XTframe_rehighlight): Rename to `pgtk_frame_rehighlight_hook'. All callers changed. (x_toggle_visible_pointer): Rename to `pgtk_toggle_visible_pointer'. All callers changed. (x_setup_pointer_blanking, XTtoggle_invisible_pointer): Delete functions. (pgtk_create_terminal): Use new names for various hooks. (pgtk_term_init): Set up blank cursor directly. * src/pgtkterm.h (struct pgtk_display_info): Remove `toggle_visible_pointer'. diff --git a/src/pgtkterm.c b/src/pgtkterm.c index e00ed7fa85..216b5ee7dd 100644 --- a/src/pgtkterm.c +++ b/src/pgtkterm.c @@ -4697,16 +4697,17 @@ pgtk_frame_rehighlight (struct pgtk_display_info *dpyinfo) the appropriate X display info. */ static void -XTframe_rehighlight (struct frame *frame) +pgtk_frame_rehighlight_hook (struct frame *frame) { pgtk_frame_rehighlight (FRAME_DISPLAY_INFO (frame)); } -/* Toggle mouse pointer visibility on frame F by using invisible cursor. */ +/* Set whether or not the mouse pointer should be visible on frame + F. */ static void -x_toggle_visible_pointer (struct frame *f, bool invisible) +pgtk_toggle_invisible_pointer (struct frame *f, bool invisible) { Emacs_Cursor cursor; if (invisible) @@ -4718,22 +4719,6 @@ x_toggle_visible_pointer (struct frame *f, bool invisible) f->pointer_invisible = invisible; } -static void -x_setup_pointer_blanking (struct pgtk_display_info *dpyinfo) -{ - dpyinfo->toggle_visible_pointer = x_toggle_visible_pointer; - dpyinfo->invisible_cursor = - gdk_cursor_new_for_display (dpyinfo->gdpy, GDK_BLANK_CURSOR); -} - -static void -XTtoggle_invisible_pointer (struct frame *f, bool invisible) -{ - block_input (); - FRAME_DISPLAY_INFO (f)->toggle_visible_pointer (f, invisible); - unblock_input (); -} - /* The focus has changed. Update the frames as necessary to reflect the new situation. Note that we can't change the selected frame here, because the Lisp code we are interrupting might become confused. @@ -4790,13 +4775,13 @@ pgtk_create_terminal (struct pgtk_display_info *dpyinfo) terminal->clear_frame_hook = pgtk_clear_frame; terminal->ring_bell_hook = pgtk_ring_bell; - terminal->toggle_invisible_pointer_hook = XTtoggle_invisible_pointer; + terminal->toggle_invisible_pointer_hook = pgtk_toggle_invisible_pointer; terminal->update_begin_hook = pgtk_update_begin; terminal->update_end_hook = pgtk_update_end; terminal->read_socket_hook = pgtk_read_socket; terminal->frame_up_to_date_hook = pgtk_frame_up_to_date; terminal->mouse_position_hook = pgtk_mouse_position; - terminal->frame_rehighlight_hook = XTframe_rehighlight; + terminal->frame_rehighlight_hook = pgtk_frame_rehighlight_hook; terminal->buffer_flipping_unblocked_hook = pgtk_buffer_flipping_unblocked_hook; terminal->frame_raise_lower_hook = pgtk_frame_raise_lower; terminal->frame_visible_invisible_hook = pgtk_make_frame_visible_invisible; @@ -5772,7 +5757,7 @@ x_focus_changed (gboolean is_enter, int state, } if (frame->pointer_invisible) - XTtoggle_invisible_pointer (frame, false); + pgtk_toggle_invisible_pointer (frame, false); } } @@ -6754,7 +6739,8 @@ pgtk_term_init (Lisp_Object display_name, char *resource_name) init_sigio (dpyinfo->connection); } - x_setup_pointer_blanking (dpyinfo); + dpyinfo->invisible_cursor + = gdk_cursor_new_for_display (dpyinfo->gdpy, GDK_BLANK_CURSOR); xsettings_initialize (dpyinfo); diff --git a/src/pgtkterm.h b/src/pgtkterm.h index 4d2285cdb0..8803b482cc 100644 --- a/src/pgtkterm.h +++ b/src/pgtkterm.h @@ -212,9 +212,6 @@ struct pgtk_display_info Unused if this display supports Xfixes extension. */ Emacs_Cursor invisible_cursor; - /* Function used to toggle pointer visibility on this display. */ - void (*toggle_visible_pointer) (struct frame *, bool); - /* The GDK cursor for scroll bars and popup menus. */ GdkCursor *xg_cursor; commit 9f43549cdfaeb26392f6b99524ae35c4101d0eb7 Author: Po Lu Date: Sun Mar 27 15:51:41 2022 +0800 Don't wait for XdndFinished messages if the target did not send status * src/xterm.c (x_dnd_send_leave): Return if we should wait for a XdndFinished message. (handle_one_xevent): Use that value for `x_dnd_waiting_for_finish'. diff --git a/src/xterm.c b/src/xterm.c index 099b992d08..a77b90a4b5 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1785,7 +1785,7 @@ x_dnd_send_leave (struct frame *f, Window target) x_uncatch_errors (); } -static void +static bool x_dnd_send_drop (struct frame *f, Window target, Time timestamp, int supported) { @@ -1824,7 +1824,7 @@ x_dnd_send_drop (struct frame *f, Window target, Time timestamp, x_dnd_n_targets, atom_names)) { XFree (name); - return; + return false; } for (i = x_dnd_n_targets; i != 0; --i) @@ -1844,9 +1844,14 @@ x_dnd_send_drop (struct frame *f, Window target, Time timestamp, XFree (name); kbd_buffer_store_event (&ie); - return; + return false; } } + else if (x_dnd_action == None) + { + x_dnd_send_leave (f, target); + return false; + } msg.xclient.type = ClientMessage; msg.xclient.message_type = dpyinfo->Xatom_XdndDrop; @@ -1864,6 +1869,7 @@ x_dnd_send_drop (struct frame *f, Window target, Time timestamp, x_catch_errors (dpyinfo->display); XSendEvent (FRAME_X_DISPLAY (f), target, False, 0, &msg); x_uncatch_errors (); + return true; } void @@ -13451,16 +13457,13 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1) { - /* Crazy hack to make dragging from one frame to - another work. */ - x_dnd_waiting_for_finish = !x_any_window_to_frame (dpyinfo, - x_dnd_last_seen_window); x_dnd_pending_finish_target = x_dnd_last_seen_window; x_dnd_waiting_for_finish_proto = x_dnd_last_protocol_version; - x_dnd_send_drop (x_dnd_frame, x_dnd_last_seen_window, - x_dnd_selection_timestamp, - x_dnd_last_protocol_version); + x_dnd_waiting_for_finish + = x_dnd_send_drop (x_dnd_frame, x_dnd_last_seen_window, + x_dnd_selection_timestamp, + x_dnd_last_protocol_version); } x_dnd_last_protocol_version = -1; @@ -14453,14 +14456,13 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1) { - x_dnd_waiting_for_finish = !x_any_window_to_frame (dpyinfo, - x_dnd_last_seen_window); x_dnd_pending_finish_target = x_dnd_last_seen_window; x_dnd_waiting_for_finish_proto = x_dnd_last_protocol_version; - x_dnd_send_drop (x_dnd_frame, x_dnd_last_seen_window, - x_dnd_selection_timestamp, - x_dnd_last_protocol_version); + x_dnd_waiting_for_finish + = x_dnd_send_drop (x_dnd_frame, x_dnd_last_seen_window, + x_dnd_selection_timestamp, + x_dnd_last_protocol_version); } x_dnd_last_protocol_version = -1; commit d361144f61198fbc914472d6e0714371178b33ec Author: Augusto Stoffel Date: Fri Mar 25 08:46:57 2022 +0100 Always run 'isearch-lazy-count-update-hook' with point at match * lisp/isearch.el (isearch-lazy-highlight-buffer-update): Run 'isearch-lazy-count-update-hook' outside of save-excursion, so point is at the current match. diff --git a/lisp/isearch.el b/lisp/isearch.el index 9b311cb49e..05a73edead 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -4342,11 +4342,12 @@ Attempt to do the search exactly the way the pending Isearch would." (setq isearch-lazy-count-current (gethash opoint isearch-lazy-count-hash 0)) (when (and isearch-mode (null isearch-message-function)) - (isearch-message)) - (run-hooks 'lazy-count-update-hook)) + (isearch-message))) (setq isearch-lazy-highlight-timer (run-at-time lazy-highlight-interval nil - 'isearch-lazy-highlight-buffer-update))))))))) + 'isearch-lazy-highlight-buffer-update))))) + (when (and nomore isearch-lazy-count) + (run-hooks 'lazy-count-update-hook)))))) ;; Reading from minibuffer with lazy highlight and match count commit ef94f325577d5eda968b9f22ff2a4a19f7943b10 Author: Po Lu Date: Sun Mar 27 13:01:18 2022 +0800 Fix processing of DND grab on non-XI2 builds * src/xterm.c (handle_one_xevent): Process DND grab flag correctly. diff --git a/src/xterm.c b/src/xterm.c index a990893029..099b992d08 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -13443,7 +13443,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, dnd_grab = true; } - if (dnd_grab && event->xbutton.type == ButtonRelease) + if (!dnd_grab && event->xbutton.type == ButtonRelease) { x_dnd_end_window = x_dnd_last_seen_window; x_dnd_in_progress = false; commit 8ff41237ba443deb47a11a5146411eaae870e707 Merge: 0bdbea654d 1bef52ce73 Author: Stefan Kangas Date: Sun Mar 27 06:30:16 2022 +0200 Merge from origin/emacs-28 1bef52ce73 * doc/emacs/anti.texi (Antinews): Unannounce removal of Mo... commit 0bdbea654d3762a55ee23cbeb1ef6f14167acaba Author: Po Lu Date: Sun Mar 27 09:48:37 2022 +0800 Fix no-toolkit build * src/xterm.c (x_top_window_to_frame): Declare correctly on no-toolkit builds. diff --git a/src/xterm.c b/src/xterm.c index 3be5733215..a990893029 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -7657,7 +7657,12 @@ x_top_window_to_frame (struct x_display_info *dpyinfo, int wdesc) #else /* !USE_X_TOOLKIT && !USE_GTK */ #define x_any_window_to_frame(d, i) x_window_to_frame (d, i) -#define x_top_window_to_frame(d, i) x_window_to_frame (d, i) + +struct frame * +x_top_window_to_frame (struct x_display_info *dpyinfo, int wdesc) +{ + return x_window_to_frame (dpyinfo, wdesc); +} #endif /* USE_X_TOOLKIT || USE_GTK */ commit a4a44d7ee1f63736c2a180317336b7ed13d9c34b Author: Po Lu Date: Sun Mar 27 08:53:12 2022 +0800 Avoid excessive synchronization when handling ShapeNotify events * src/xterm.c (handle_one_xevent): Use XCB to handle ShapeNotify events when we want both the bounding and input rects. diff --git a/src/xterm.c b/src/xterm.c index fb201f8506..3be5733215 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -15699,8 +15699,20 @@ handle_one_xevent (struct x_display_info *dpyinfo, { XEvent xevent; XShapeEvent *xse = (XShapeEvent *) event; +#if defined HAVE_XCB_SHAPE && defined HAVE_XCB_SHAPE_INPUT_RECTS + xcb_shape_get_rectangles_cookie_t bounding_rect_cookie; + xcb_shape_get_rectangles_reply_t *bounding_rect_reply; + xcb_rectangle_iterator_t bounding_rect_iterator; + + xcb_shape_get_rectangles_cookie_t input_rect_cookie; + xcb_shape_get_rectangles_reply_t *input_rect_reply; + xcb_rectangle_iterator_t input_rect_iterator; + + xcb_generic_error_t *error; +#else XRectangle *rects; int rc, ordering; +#endif while (XPending (dpyinfo->display)) { @@ -15729,6 +15741,86 @@ handle_one_xevent (struct x_display_info *dpyinfo, tem->n_input_rects = -1; tem->n_bounding_rects = -1; +#if defined HAVE_XCB_SHAPE && defined HAVE_XCB_SHAPE_INPUT_RECTS + bounding_rect_cookie = xcb_shape_get_rectangles (dpyinfo->xcb_connection, + (xcb_window_t) xse->window, + XCB_SHAPE_SK_BOUNDING); + if (dpyinfo->xshape_major > 1 + || (dpyinfo->xshape_major == 1 + && dpyinfo->xshape_minor >= 1)) + input_rect_cookie + = xcb_shape_get_rectangles (dpyinfo->xcb_connection, + (xcb_window_t) xse->window, + XCB_SHAPE_SK_INPUT); + + bounding_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection, + bounding_rect_cookie, + &error); + + if (bounding_rect_reply) + { + bounding_rect_iterator + = xcb_shape_get_rectangles_rectangles_iterator (bounding_rect_reply); + tem->n_bounding_rects = bounding_rect_iterator.rem + 1; + tem->bounding_rects = xmalloc (tem->n_bounding_rects + * sizeof *tem->bounding_rects); + tem->n_bounding_rects = 0; + + for (; bounding_rect_iterator.rem; xcb_rectangle_next (&bounding_rect_iterator)) + { + tem->bounding_rects[tem->n_bounding_rects].x + = bounding_rect_iterator.data->x; + tem->bounding_rects[tem->n_bounding_rects].y + = bounding_rect_iterator.data->y; + tem->bounding_rects[tem->n_bounding_rects].width + = bounding_rect_iterator.data->width; + tem->bounding_rects[tem->n_bounding_rects].height + = bounding_rect_iterator.data->height; + + tem->n_bounding_rects++; + } + + free (bounding_rect_reply); + } + else + free (error); + + if (dpyinfo->xshape_major > 1 + || (dpyinfo->xshape_major == 1 + && dpyinfo->xshape_minor >= 1)) + { + input_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection, + input_rect_cookie, &error); + + if (input_rect_reply) + { + input_rect_iterator + = xcb_shape_get_rectangles_rectangles_iterator (input_rect_reply); + tem->n_input_rects = input_rect_iterator.rem + 1; + tem->input_rects = xmalloc (tem->n_input_rects + * sizeof *tem->input_rects); + tem->n_input_rects = 0; + + for (; input_rect_iterator.rem; xcb_rectangle_next (&input_rect_iterator)) + { + tem->input_rects[tem->n_input_rects].x + = input_rect_iterator.data->x; + tem->input_rects[tem->n_input_rects].y + = input_rect_iterator.data->y; + tem->input_rects[tem->n_input_rects].width + = input_rect_iterator.data->width; + tem->input_rects[tem->n_input_rects].height + = input_rect_iterator.data->height; + + tem->n_input_rects++; + } + + free (input_rect_reply); + } + else + free (error); + } +#else x_catch_errors (dpyinfo->display); rects = XShapeGetRectangles (dpyinfo->display, xse->window, @@ -15775,6 +15867,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, XFree (rects); } } +#endif #endif /* Handle the common case where the input shape equals the commit 9f7e620bb5902250cf35b252e2e0f03b7347ab04 Author: Po Lu Date: Sun Mar 27 00:34:25 2022 +0000 ; * src/haikuimage.c (syms_of_haikuimage): Remove duplicate DEFSYM. diff --git a/src/haikuimage.c b/src/haikuimage.c index fe960bbc29..1207fb32d3 100644 --- a/src/haikuimage.c +++ b/src/haikuimage.c @@ -107,5 +107,4 @@ haiku_load_image (struct frame *f, struct image *img, void syms_of_haikuimage (void) { - DEFSYM (Qbmp, "bmp"); } commit 2dfeea8962751718168494c0560d69e678794b39 Author: Mattias Engdegård Date: Sat Mar 26 16:44:18 2022 +0100 Fix reader infinite recursion for circular mixed-type values Make sure that the value added to the `read_objects_completed` set is the one we actually return; previously this wasn't the case for conses because of an optimisation (bug#54501). Also add a check for vacuous self-references such as #1=#1# instead of returning a nonsense value from thin air. * src/lread.c (read1): Treat numbered conses correctly as described above. Detect vacuous self-references. * test/src/lread-tests.el (lread-test-read-and-print) (lread-test-circle-cases, lread-circle): Add tests. diff --git a/src/lread.c b/src/lread.c index 6130300b0a..2538851bac 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3488,6 +3488,29 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms) /* Read the object itself. */ Lisp_Object tem = read0 (readcharfun, locate_syms); + if (CONSP (tem)) + { + if (BASE_EQ (tem, placeholder)) + /* Catch silly games like #1=#1# */ + invalid_syntax ("nonsensical self-reference", + readcharfun); + + /* Optimisation: since the placeholder is already + a cons, repurpose it as the actual value. + This allows us to skip the substition below, + since the placeholder is already referenced + inside TEM at the appropriate places. */ + Fsetcar (placeholder, XCAR (tem)); + Fsetcdr (placeholder, XCDR (tem)); + + struct Lisp_Hash_Table *h2 + = XHASH_TABLE (read_objects_completed); + ptrdiff_t i = hash_lookup (h2, placeholder, &hash); + eassert (i < 0); + hash_put (h2, placeholder, Qnil, hash); + return placeholder; + } + /* If it can be recursive, remember it for future substitutions. */ if (! SYMBOLP (tem) @@ -3502,24 +3525,15 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms) } /* Now put it everywhere the placeholder was... */ - if (CONSP (tem)) - { - Fsetcar (placeholder, XCAR (tem)); - Fsetcdr (placeholder, XCDR (tem)); - return placeholder; - } - else - { - Flread__substitute_object_in_subtree - (tem, placeholder, read_objects_completed); + Flread__substitute_object_in_subtree + (tem, placeholder, read_objects_completed); - /* ...and #n# will use the real value from now on. */ - i = hash_lookup (h, number, &hash); - eassert (i >= 0); - set_hash_value_slot (h, i, tem); + /* ...and #n# will use the real value from now on. */ + i = hash_lookup (h, number, &hash); + eassert (i >= 0); + set_hash_value_slot (h, i, tem); - return tem; - } + return tem; } /* #n# returns a previously read object. */ diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index 862f6a6595..9ec54c719c 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -258,5 +258,27 @@ literals (Bug#20852)." (should (equal (read "-0.e-5") -0.0)) ) +(defun lread-test-read-and-print (str) + (let* ((read-circle t) + (print-circle t) + (val (read-from-string str))) + (if (consp val) + (prin1-to-string (car val)) + (error "reading %S failed: %S" str val)))) + +(defconst lread-test-circle-cases + '("#1=(#1# . #1#)" + "#1=[#1# a #1#]" + "#1=(#2=[#1# #2#] . #1#)" + "#1=(#2=[#1# #2#] . #2#)" + "#1=[#2=(#1# . #2#)]" + "#1=(#2=[#3=(#1# . #2#) #4=(#3# . #4#)])" + )) + +(ert-deftest lread-circle () + (dolist (str lread-test-circle-cases) + (ert-info (str :prefix "input: ") + (should (equal (lread-test-read-and-print str) str)))) + (should-error (read-from-string "#1=#1#") :type 'invalid-read-syntax)) ;;; lread-tests.el ends here commit e96061de95d053a4c5e303c7f75e0e928e474938 Author: Eli Zaretskii Date: Sat Mar 26 15:29:11 2022 +0300 ; * src/image.c (syms_of_image): Fix whitespace. diff --git a/src/image.c b/src/image.c index 07f1426ffd..519eafb904 100644 --- a/src/image.c +++ b/src/image.c @@ -11556,15 +11556,15 @@ non-numeric, there is no explicit limit on the size of images. */); #if HAVE_NATIVE_IMAGE_API DEFSYM (Qnative_image, "native-image"); -#if defined HAVE_NTGUI || defined HAVE_HAIKU +# if defined HAVE_NTGUI || defined HAVE_HAIKU DEFSYM (Qbmp, "bmp"); add_image_type (Qbmp); -#endif +# endif -#ifdef HAVE_NTGUI +# ifdef HAVE_NTGUI DEFSYM (Qgdiplus, "gdiplus"); DEFSYM (Qshlwapi, "shlwapi"); -#endif +# endif #endif defsubr (&Sinit_image_library); commit b1e9151915d370cb638bb707ff1afdfd9a0d1eab Author: Po Lu Date: Sat Mar 26 12:16:46 2022 +0000 Enable the native display of BMP images on Haiku * src/image.c (syms_of_image): Also register `bmp' image type on Haiku when native image APIs are enabled. diff --git a/src/image.c b/src/image.c index d44d689084..07f1426ffd 100644 --- a/src/image.c +++ b/src/image.c @@ -11555,12 +11555,16 @@ non-numeric, there is no explicit limit on the size of images. */); #if HAVE_NATIVE_IMAGE_API DEFSYM (Qnative_image, "native-image"); -# ifdef HAVE_NTGUI - DEFSYM (Qgdiplus, "gdiplus"); - DEFSYM (Qshlwapi, "shlwapi"); + +#if defined HAVE_NTGUI || defined HAVE_HAIKU DEFSYM (Qbmp, "bmp"); add_image_type (Qbmp); -# endif +#endif + +#ifdef HAVE_NTGUI + DEFSYM (Qgdiplus, "gdiplus"); + DEFSYM (Qshlwapi, "shlwapi"); +#endif #endif defsubr (&Sinit_image_library); commit 0549adb4bb7c31c99f99bd295a7cb65b380b83f8 Author: Po Lu Date: Sat Mar 26 12:01:58 2022 +0000 Fix crash when timer signals or throws inside a popup menu on Haiku * src/haikumenu.c (haiku_process_pending_signals_for_menu_1) (haiku_process_pending_signals_for_menu_2): New functions. (haiku_process_pending_signals_for_menu): Catch non local exits around `timer_check'. diff --git a/src/haikumenu.c b/src/haikumenu.c index 8da00ffcb0..4cee69826d 100644 --- a/src/haikumenu.c +++ b/src/haikumenu.c @@ -29,6 +29,7 @@ along with GNU Emacs. If not, see . */ #include "haiku_support.h" static Lisp_Object *volatile menu_item_selection; +static struct timespec menu_timer_timespec; int popup_activated_p = 0; @@ -340,12 +341,35 @@ haiku_menu_show_help (void *help, void *data) show_help_echo (Qnil, Qnil, Qnil, Qnil); } +static Lisp_Object +haiku_process_pending_signals_for_menu_1 (void *ptr) +{ + menu_timer_timespec = timer_check (); + + return Qnil; +} + +static Lisp_Object +haiku_process_pending_signals_for_menu_2 (enum nonlocal_exit exit, Lisp_Object error) +{ + menu_timer_timespec.tv_sec = 0; + menu_timer_timespec.tv_nsec = -1; + + return Qnil; +} + static struct timespec haiku_process_pending_signals_for_menu (void) { process_pending_signals (); - return timer_check (); + /* The original idea was to let timers throw so that timeouts can + work correctly, but there's no way to pop down a BPopupMenu + that's currently popped up. */ + internal_catch_all (haiku_process_pending_signals_for_menu_1, NULL, + haiku_process_pending_signals_for_menu_2); + + return menu_timer_timespec; } Lisp_Object commit a3ed1d2590c2acd041dfc9a783daa240fddfc11d Author: Po Lu Date: Sat Mar 26 19:38:30 2022 +0800 ; * src/xterm.c (x_dnd_compute_toplevels): Fix cookie leak if rc is 0. diff --git a/src/xterm.c b/src/xterm.c index 9d66181de4..fb201f8506 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1288,6 +1288,39 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) x_dnd_toplevels = tem; } + else + { +#ifdef HAVE_XCB_SHAPE + if (dpyinfo->xshape_supported_p) + { + bounding_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection, + bounding_rect_cookies[i], + &error); + + if (bounding_rect_reply) + free (bounding_rect_reply); + else + free (error); + } +#endif + +#ifdef HAVE_XCB_SHAPE_INPUT_RECTS + if (dpyinfo->xshape_supported_p + && (dpyinfo->xshape_major > 1 + || (dpyinfo->xshape_major == 1 + && dpyinfo->xshape_minor >= 1))) + { + input_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection, + input_rect_cookies[i], + &error); + + if (input_rect_reply) + free (input_rect_reply); + else + free (error); + } +#endif + } #ifdef USE_XCB if (attrs_reply) commit 0594e9126167c64c8315c1e44d3f61c530259755 Author: Po Lu Date: Sat Mar 26 10:13:47 2022 +0000 Fix processing of emacs:window_id inside DND messages if it already exists * src/haiku_support.cc (MessageReceived): Use DropPoint instead of getting it manually. (be_drag_message): Replace window_id if it already exists. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index a1616258bc..39df06e436 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -725,17 +725,16 @@ class EmacsWindow : public BWindow && windowid == this->window_id) return; - if (msg->FindPoint ("_drop_point_", &whereto) == B_OK) - { - this->ConvertFromScreen (&whereto); + whereto = msg->DropPoint (); - rq.window = this; - rq.message = DetachCurrentMessage (); - rq.x = whereto.x; - rq.y = whereto.y; + this->ConvertFromScreen (&whereto); - haiku_write (DRAG_AND_DROP_EVENT, &rq); - } + rq.window = this; + rq.message = DetachCurrentMessage (); + rq.x = whereto.x; + rq.y = whereto.y; + + haiku_write (DRAG_AND_DROP_EVENT, &rq); } else if (msg->GetPointer ("menuptr")) { @@ -4084,7 +4083,9 @@ be_drag_message (void *view, void *message, bool allow_same_view, block_input_function (); - if (!allow_same_view) + if (!allow_same_view && + (msg->ReplaceInt32 ("emacs:window_id", window->window_id) + == B_NAME_NOT_FOUND)) msg->AddInt32 ("emacs:window_id", window->window_id); if (!vw->LockLooper ()) commit f8ff5689a2003d51e7ebc8229fceb6703e293961 Author: Michael Albinus Date: Sat Mar 26 10:40:16 2022 +0100 ; Improve readablity in grep.el * lisp/progmodes/grep.el (grep-compute-defaults): Set a more readable value for `grep-quoting-style'. diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index 388ff1a43d..17905dec2e 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -797,7 +797,7 @@ The value depends on `grep-command', `grep-template', (format "%s -H -type f -print | \"%s\" %s" find-program xargs-program gcmd)))))) - (setq grep-quoting-style remote))) + (setq grep-quoting-style (and remote 'posix)))) ;; Save defaults for this host. (setq grep-host-defaults-alist commit 6aafb92167565b13598a71635a1474645de0d5d4 Author: Michael Albinus Date: Sat Mar 26 10:39:39 2022 +0100 Don't let Tramp block dired (Bug#54542) * lisp/dired.el (dired-find-buffer-nocreate): Avoid avoid hangs in remote buffers with a blocked connection. (Bug#54542) * lisp/net/tramp-sh.el (tramp-maybe-open-connection): Extend suppression rules. diff --git a/lisp/dired.el b/lisp/dired.el index 3c37a887ba..409a312d0d 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1282,39 +1282,42 @@ The return value is the target column for the file names." ;; This differs from dired-buffers-for-dir in that it does not consider ;; subdirs of default-directory and searches for the first match only. ;; Also, the major mode must be MODE. - (if (and (featurep 'dired-x) - dired-find-subdir - ;; Don't try to find a wildcard as a subdirectory. - (string-equal dirname (file-name-directory dirname))) - (let* ((cur-buf (current-buffer)) - (buffers (nreverse (dired-buffers-for-dir dirname))) - (cur-buf-matches (and (memq cur-buf buffers) - ;; Wildcards must match, too: - (equal dired-directory dirname)))) - ;; We don't want to switch to the same buffer--- - (setq buffers (delq cur-buf buffers)) - (or (car (sort buffers #'dired-buffer-more-recently-used-p)) - ;; ---unless it's the only possibility: - (and cur-buf-matches cur-buf))) - ;; No dired-x, or dired-find-subdir nil. - (setq dirname (expand-file-name dirname)) - (let (found (blist dired-buffers)) ; was (buffer-list) - (or mode (setq mode 'dired-mode)) - (while blist - (if (null (buffer-name (cdr (car blist)))) - (setq blist (cdr blist)) - (with-current-buffer (cdr (car blist)) - (if (and (eq major-mode mode) - dired-directory ;; nil during find-alternate-file - (equal dirname - (expand-file-name - (if (consp dired-directory) - (car dired-directory) - dired-directory)))) - (setq found (cdr (car blist)) - blist nil) - (setq blist (cdr blist)))))) - found))) + ;; We bind `non-essential' in order to avoid hangs in remote buffers + ;; with a blocked connection. (Bug#54542) + (let ((non-essential t)) + (if (and (featurep 'dired-x) + dired-find-subdir + ;; Don't try to find a wildcard as a subdirectory. + (string-equal dirname (file-name-directory dirname))) + (let* ((cur-buf (current-buffer)) + (buffers (nreverse (dired-buffers-for-dir dirname))) + (cur-buf-matches (and (memq cur-buf buffers) + ;; Wildcards must match, too: + (equal dired-directory dirname)))) + ;; We don't want to switch to the same buffer--- + (setq buffers (delq cur-buf buffers)) + (or (car (sort buffers #'dired-buffer-more-recently-used-p)) + ;; ---unless it's the only possibility: + (and cur-buf-matches cur-buf))) + ;; No dired-x, or dired-find-subdir nil. + (setq dirname (expand-file-name dirname)) + (let (found (blist dired-buffers)) ; was (buffer-list) + (or mode (setq mode 'dired-mode)) + (while blist + (if (null (buffer-name (cdr (car blist)))) + (setq blist (cdr blist)) + (with-current-buffer (cdr (car blist)) + (if (and (eq major-mode mode) + dired-directory ;; nil during find-alternate-file + (equal dirname + (expand-file-name + (if (consp dired-directory) + (car dired-directory) + dired-directory)))) + (setq found (cdr (car blist)) + blist nil) + (setq blist (cdr blist)))))) + found)))) ;;; Read in a new dired buffer diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index fd18b3f05c..805be8270a 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -4957,6 +4957,7 @@ connection if a previous connection has died for some reason." ;; If Tramp opens the same connection within a short time frame, ;; there is a problem. We shall signal this. (unless (or (process-live-p p) + (and (processp p) (not non-essential)) (not (tramp-file-name-equal-p vec (car tramp-current-connection))) (time-less-p commit 78f99be6753735a096c488e4940384aab75c3256 Author: Po Lu Date: Sat Mar 26 17:12:34 2022 +0800 Minor fixes to last change * src/Makefile.in: Add XSHAPE_LIBS and XSHAPE_CFLAGS. (LIBES, EMACS_CFLAGS): Likewise. * src/xterm.c (x_dnd_compute_toplevels): Fix build without HAVE_XCB_SHAPE. diff --git a/src/Makefile.in b/src/Makefile.in index 0ec2d34264..69c4c44d1a 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -274,6 +274,9 @@ XDBE_CFLAGS = @XDBE_CFLAGS@ XCOMPOSITE_LIBS = @XCOMPOSITE_LIBS@ XCOMPOSITE_CFLAGS = @XCOMPOSITE_CFLAGS@ +XSHAPE_LIBS = @XSHAPE_LIBS@ +XSHAPE_CFLAGS = @XSHAPE_CFLAGS@ + ## widget.o if USE_X_TOOLKIT, otherwise empty. WIDGET_OBJ=@WIDGET_OBJ@ @@ -405,7 +408,7 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \ $(HARFBUZZ_CFLAGS) $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) $(XSYNC_CFLAGS) \ $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \ - $(WERROR_CFLAGS) $(HAIKU_CFLAGS) $(XCOMPOSITE_CFLAGS) + $(WERROR_CFLAGS) $(HAIKU_CFLAGS) $(XCOMPOSITE_CFLAGS) $(XSHAPE_CFLAGS) ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS) ALL_OBJC_CFLAGS = $(EMACS_CFLAGS) \ $(filter-out $(NON_OBJC_CFLAGS),$(WARN_CFLAGS)) $(CFLAGS) \ @@ -562,7 +565,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(PGTK_LIBS) $(LIBX_BASE) $(LIBIMAGE $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \ $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ $(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT_LIBS) $(XINPUT_LIBS) $(HAIKU_LIBS) \ - $(SQLITE3_LIBS) $(XCOMPOSITE_LIBS) + $(SQLITE3_LIBS) $(XCOMPOSITE_LIBS) $(XSHAPE_LIBS) ## FORCE it so that admin/unidata can decide whether this file is ## up-to-date. Although since charprop depends on bootstrap-emacs, diff --git a/src/xterm.c b/src/xterm.c index e448c177c0..9d66181de4 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -966,8 +966,11 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) = alloca (sizeof *get_property_cookies * nitems); get_geometry_cookies = alloca (sizeof *get_geometry_cookies * nitems); + +#ifdef HAVE_XCB_SHAPE bounding_rect_cookies = alloca (sizeof *bounding_rect_cookies * nitems); +#endif #ifdef HAVE_XCB_SHAPE_INPUT_RECTS input_rect_cookies commit a4d45f1efd669bae3ea21a0c2cf0e3302a8379f2 Author: Po Lu Date: Sat Mar 26 17:10:42 2022 +0800 Also fetch shapes via XCB for drag and drop * configure.ac: Also look for xcb-shape. * src/xterm.c (HAVE_XCB_SHAPE_INPUT_RECTS): New define. (x_dnd_compute_toplevels): Use XCB for input shapes if possible. diff --git a/configure.ac b/configure.ac index 4ac8c143e5..35ebbb2db0 100644 --- a/configure.ac +++ b/configure.ac @@ -4540,6 +4540,7 @@ AC_SUBST(XDBE_LIBS) ### Use the Nonrectangular Window Shape extension if available. HAVE_XSHAPE=no +HAVE_XCB_SHAPE=no if test "${HAVE_X11}" = "yes"; then AC_CHECK_HEADER(X11/extensions/shape.h, [AC_CHECK_LIB(Xext, XShapeQueryVersion, HAVE_XSHAPE=yes)], @@ -4548,6 +4549,14 @@ if test "${HAVE_X11}" = "yes"; then ]) if test $HAVE_XSHAPE = yes; then XSHAPE_LIBS=-lXext + AC_CHECK_HEADER(xcb/shape.h, + [AC_CHECK_LIB(xcb-shape, xcb_shape_combine, HAVE_XCB_SHAPE=yes)], [], + [#include ]) + + if test $HAVE_XCB_SHAPE = yes && test "$XCB_LIBS" != ""; then + XSHAPE_LIBS="$XSHAPE_LIBS -lxcb-shape" + AC_DEFINE(HAVE_XCB_SHAPE, 1, [Define to 1 if XCB supports the Nonrectangular Window Shape extension.]) + fi fi if test $HAVE_XSHAPE = yes; then AC_DEFINE(HAVE_XSHAPE, 1, [Define to 1 if you have the Nonrectangular Window Shape extension.]) diff --git a/src/xterm.c b/src/xterm.c index 7edec2cd40..e448c177c0 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -550,6 +550,10 @@ along with GNU Emacs. If not, see . */ #include #endif +#ifdef HAVE_XCB_SHAPE +#include +#endif + /* Load sys/types.h if not already loaded. In some systems loading it twice is suicidal. */ #ifndef makedev @@ -658,6 +662,12 @@ bool use_xim = true; bool use_xim = false; /* configure --without-xim */ #endif +#if XCB_SHAPE_MAJOR_VERSION > 1 \ + || (XCB_SHAPE_MAJOR_VERSION == 1 && \ + XCB_SHAPE_MINOR_VERSION >= 1) +#define HAVE_XCB_SHAPE_INPUT_RECTS +#endif + #ifdef USE_GTK /* GTK can't tolerate a call to `handle_interrupt' inside an event signal handler, but we have to store input events inside the @@ -912,8 +922,21 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) xcb_get_geometry_reply_t *geometry_reply; xcb_generic_error_t *error; #endif + +#ifdef HAVE_XCB_SHAPE + xcb_shape_get_rectangles_cookie_t *bounding_rect_cookies; + xcb_shape_get_rectangles_reply_t *bounding_rect_reply; + xcb_rectangle_iterator_t bounding_rect_iterator; +#endif + +#ifdef HAVE_XCB_SHAPE_INPUT_RECTS + xcb_shape_get_rectangles_cookie_t *input_rect_cookies; + xcb_shape_get_rectangles_reply_t *input_rect_reply; + xcb_rectangle_iterator_t input_rect_iterator; +#endif + struct x_client_list_window *tem; -#ifdef HAVE_XSHAPE +#if defined HAVE_XSHAPE && !defined HAVE_XCB_SHAPE_INPUT_RECTS int count, ordering; XRectangle *rects; #endif @@ -943,6 +966,13 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) = alloca (sizeof *get_property_cookies * nitems); get_geometry_cookies = alloca (sizeof *get_geometry_cookies * nitems); + bounding_rect_cookies + = alloca (sizeof *bounding_rect_cookies * nitems); + +#ifdef HAVE_XCB_SHAPE_INPUT_RECTS + input_rect_cookies + = alloca (sizeof *input_rect_cookies * nitems); +#endif for (i = 0; i < nitems; ++i) { @@ -960,6 +990,23 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) 0, 2); get_geometry_cookies[i] = xcb_get_geometry (dpyinfo->xcb_connection, (xcb_window_t) toplevels[i]); + +#ifdef HAVE_XCB_SHAPE + bounding_rect_cookies[i] + = xcb_shape_get_rectangles (dpyinfo->xcb_connection, + (xcb_window_t) toplevels[i], + XCB_SHAPE_SK_BOUNDING); +#endif + +#ifdef HAVE_XCB_SHAPE_INPUT_RECTS + if (dpyinfo->xshape_major > 1 + || (dpyinfo->xshape_major == 1 + && dpyinfo->xshape_minor >= 1)) + input_rect_cookies[i] + = xcb_shape_get_rectangles (dpyinfo->xcb_connection, + (xcb_window_t) toplevels[i], + XCB_SHAPE_SK_INPUT); +#endif } #endif @@ -1094,6 +1141,7 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) ShapeNotifyMask); x_uncatch_errors (); +#ifndef HAVE_XCB_SHAPE x_catch_errors (dpyinfo->display); rects = XShapeGetRectangles (dpyinfo->display, toplevels[i], @@ -1114,7 +1162,78 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) XFree (rects); } +#else + bounding_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection, + bounding_rect_cookies[i], + &error); + if (bounding_rect_reply) + { + bounding_rect_iterator + = xcb_shape_get_rectangles_rectangles_iterator (bounding_rect_reply); + tem->n_bounding_rects = bounding_rect_iterator.rem + 1; + tem->bounding_rects = xmalloc (tem->n_bounding_rects + * sizeof *tem->bounding_rects); + tem->n_bounding_rects = 0; + + for (; bounding_rect_iterator.rem; xcb_rectangle_next (&bounding_rect_iterator)) + { + tem->bounding_rects[tem->n_bounding_rects].x + = bounding_rect_iterator.data->x; + tem->bounding_rects[tem->n_bounding_rects].y + = bounding_rect_iterator.data->y; + tem->bounding_rects[tem->n_bounding_rects].width + = bounding_rect_iterator.data->width; + tem->bounding_rects[tem->n_bounding_rects].height + = bounding_rect_iterator.data->height; + + tem->n_bounding_rects++; + } + + free (bounding_rect_reply); + } + else + free (error); +#endif + +#ifdef HAVE_XCB_SHAPE_INPUT_RECTS + if (dpyinfo->xshape_major > 1 + || (dpyinfo->xshape_major == 1 + && dpyinfo->xshape_minor >= 1)) + { + input_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection, + input_rect_cookies[i], + &error); + + if (input_rect_reply) + { + input_rect_iterator + = xcb_shape_get_rectangles_rectangles_iterator (input_rect_reply); + tem->n_input_rects = input_rect_iterator.rem + 1; + tem->input_rects = xmalloc (tem->n_input_rects + * sizeof *tem->input_rects); + tem->n_input_rects = 0; + + for (; input_rect_iterator.rem; xcb_rectangle_next (&input_rect_iterator)) + { + tem->input_rects[tem->n_input_rects].x + = input_rect_iterator.data->x; + tem->input_rects[tem->n_input_rects].y + = input_rect_iterator.data->y; + tem->input_rects[tem->n_input_rects].width + = input_rect_iterator.data->width; + tem->input_rects[tem->n_input_rects].height + = input_rect_iterator.data->height; + + tem->n_input_rects++; + } + + free (input_rect_reply); + } + else + free (error); + } +#else #ifdef ShapeInput if (dpyinfo->xshape_major > 1 || (dpyinfo->xshape_major == 1 @@ -1140,6 +1259,7 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) XFree (rects); } } +#endif #endif } commit 4525b4911834a95850e70c48de4c71de44af53de Author: Eli Zaretskii Date: Sat Mar 26 11:52:41 2022 +0300 Use native image APIs on MS-Windows by default * src/w32term.c (syms_of_w32term) : Now t by default on W2K and later systems, but only on WINDOWSNT builds. * etc/NEWS: Announce the change. diff --git a/etc/NEWS b/etc/NEWS index f726b0a2e8..b6ae8bb9cf 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1821,6 +1821,19 @@ follow the system's dark mode: GUI frames use the appropriate light or dark title bar and scroll bars, based on the user's Windows-wide color settings. +--- +*** Emacs now uses native image APIs to display some image formats. +On Windows 2000 and later, Emacs now defaults to using the native +image APIs for displaying the BMP, GIF, JPEG, PNG, and TIFF images. +This means Emacs on MS-Windows needs no longer use external image +support libraries to display those images. Other image types -- XPM, +SVG, and WEBP -- still need support libraries for Emacs to be able to +display them. + +The use of native image APIs is controlled by the variable +'w32-use-native-image-API', whose value now defaults to t on systems +where those APIs are available. + +++ *** Emacs now supports display of BMP images using native image APIs. When 'w32-use-native-image-API' is non-nil, Emacs on MS-Windows now diff --git a/src/w32term.c b/src/w32term.c index 9094843f60..7837032304 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -7744,9 +7744,10 @@ The native image API library used is GDI+ via GDIPLUS.DLL. This library is available only since W2K, therefore this variable is unconditionally set to nil on older systems. */); - /* For now, disabled by default, since this is an experimental feature. */ -#if 0 && HAVE_NATIVE_IMAGE_API - if (os_subtype == OS_9X) + /* Disabled for Cygwin/w32 builds, since they don't link against + -lgdiplus, see configure.ac. */ +#if defined WINDOWSNT && HAVE_NATIVE_IMAGE_API + if (os_subtype == OS_SUBTYPE_9X) w32_use_native_image_api = 0; else w32_use_native_image_api = 1; commit a6abb6f5cdd5a44bce2e42c340a6c6b83579de93 Author: Eli Zaretskii Date: Sat Mar 26 11:31:46 2022 +0300 Support display of BMP images on MS-Windows * src/w32image.c (w32_can_use_native_image_api): Support BMP images. * src/image.c (syms_of_image) : New symbol. [HAVE_NTGUI]: Add 'bmp' to list of supported image types. * doc/lispref/display.texi (Image Formats): Document built-in support for BMP images. * etc/NEWS: Announce the change. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 3aec06e13d..2dc0ef4c0b 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -5507,6 +5507,12 @@ symbol}. The symbols for the above formats are, respectively, @code{pbm}, @code{xbm}, @code{xpm}, @code{gif}, @code{jpeg}, @code{tiff}, @code{png}, @code{svg}, and @code{webp}. + On some platforms, the built-in image support that doesn't require +any optional libraries includes BMP images.@footnote{ +On MS-Windows, this requires @code{w32-use-native-image-API} to be set +non-@code{nil}. +} + Furthermore, if you build Emacs with ImageMagick (@code{libMagickWand}) support, Emacs can display any image format that ImageMagick can. @xref{ImageMagick Images}. All images diff --git a/etc/NEWS b/etc/NEWS index d26c6568b9..f726b0a2e8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1821,6 +1821,11 @@ follow the system's dark mode: GUI frames use the appropriate light or dark title bar and scroll bars, based on the user's Windows-wide color settings. ++++ +*** Emacs now supports display of BMP images using native image APIs. +When 'w32-use-native-image-API' is non-nil, Emacs on MS-Windows now +has built-in support for displaying BMP images. + ---------------------------------------------------------------------- This file is part of GNU Emacs. diff --git a/src/image.c b/src/image.c index c412dc9029..d44d689084 100644 --- a/src/image.c +++ b/src/image.c @@ -11558,6 +11558,8 @@ non-numeric, there is no explicit limit on the size of images. */); # ifdef HAVE_NTGUI DEFSYM (Qgdiplus, "gdiplus"); DEFSYM (Qshlwapi, "shlwapi"); + DEFSYM (Qbmp, "bmp"); + add_image_type (Qbmp); # endif #endif diff --git a/src/w32image.c b/src/w32image.c index f3374dcfd3..1f7c4921b3 100644 --- a/src/w32image.c +++ b/src/w32image.c @@ -253,6 +253,7 @@ w32_can_use_native_image_api (Lisp_Object type) || EQ (type, Qpng) || EQ (type, Qgif) || EQ (type, Qtiff) + || EQ (type, Qbmp) || EQ (type, Qnative_image))) { /* GDI+ can also display BMP, Exif, ICON, WMF, and EMF images. commit de953a6fe39d8e547ce4d40f39cd2c10b71a1e3c Author: Eli Zaretskii Date: Sat Mar 26 10:28:52 2022 +0300 Improve 'desktop--emacs-pid-running-p' * lisp/desktop.el (desktop--emacs-pid-running-p): Avoid false negatives on MS-Windows and with some symlinks to Emacs executables. (Bug#1474) diff --git a/lisp/desktop.el b/lisp/desktop.el index 773f0f050f..7e3d66bdf1 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -673,10 +673,26 @@ DIRNAME omitted or nil means use `desktop-dirname'." owner))) (defun desktop--emacs-pid-running-p (pid) - "Return t if an Emacs process with PID exists." + "Return non-nil if an Emacs process whose ID is PID might still be running." (when-let ((attr (process-attributes pid))) - (equal (alist-get 'comm attr) - (file-name-nondirectory (car command-line-args))))) + (let ((proc-cmd (alist-get 'comm attr)) + (my-cmd (file-name-nondirectory (car command-line-args))) + (case-fold-search t)) + (or (equal proc-cmd my-cmd) + (and (eq system-type 'windows-nt) + (eq t (compare-strings proc-cmd + nil + (if (string-suffix-p ".exe" proc-cmd t) + -4) + my-cmd + nil + (if (string-suffix-p ".exe" my-cmd t) + -4)))) + ;; We should err on the safe side here: if any of the + ;; executables is something like "emacs-nox" or "emacs-42.1" + ;; or "gemacs" or "xemacs", let's recognize them as well. + (and (string-match-p "emacs" proc-cmd) + (string-match-p "emacs" my-cmd)))))) (defun desktop--load-locked-desktop-p (owner) "Return t if a locked desktop should be loaded. commit 1bef52ce73d61c827677edde60639fd2b8d74d92 Author: Po Lu Date: Sat Mar 26 14:46:00 2022 +0800 * doc/emacs/anti.texi (Antinews): Unannounce removal of Motif. diff --git a/doc/emacs/anti.texi b/doc/emacs/anti.texi index bb88fddc04..b86037f2a6 100644 --- a/doc/emacs/anti.texi +++ b/doc/emacs/anti.texi @@ -30,10 +30,6 @@ Fancy text shaping and display is becoming less important as you move back in time. The @code{ftx} font backend is again part of Emacs, for the same reasons. -@item -As Motif becomes more and more important with moving farther into the -past, we've reinstated the code which supports Motif in Emacs. - @item Emacs once again supports versions 5.3 and older OpenBSD systems, which will be needed as you move back in time. commit f7e83d9673609817d23d6ddeea863deaac8842f0 Merge: c16b296939 4ec9f9edd1 Author: Stefan Kangas Date: Sat Mar 26 06:30:21 2022 +0100 Merge from origin/emacs-28 4ec9f9edd1 Fix eshell-explicit-command-char doc string typo commit c16b296939c9048c6031ce4cb66e5903488fd063 Author: Po Lu Date: Sat Mar 26 12:20:23 2022 +0800 Fix crash when windows are destroyed by faulty clients * src/xterm.c (x_dnd_compute_toplevels): Make sure property_reply is non-NULL before testing its format and length. diff --git a/src/xterm.c b/src/xterm.c index e20efd67c7..7edec2cd40 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1025,8 +1025,9 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) free (error); } - if (xcb_get_property_value_length (property_reply) != 8 - || property_reply->format != 32) + if (property_reply + && (xcb_get_property_value_length (property_reply) != 8 + || property_reply->format != 32)) rc = false; geometry_reply = xcb_get_geometry_reply (dpyinfo->xcb_connection, commit 98952340bd225d34a0f2f5f32a385dda30e87909 Author: Po Lu Date: Sat Mar 26 12:14:52 2022 +0800 Avoid excessive synchronization when initiating drag-and-drop * src/xterm.c (x_dnd_compute_toplevels): Use XCB to get WM state, attributes, geometry and to translate coordinates. This avoids 4 calls to XSync. diff --git a/src/xterm.c b/src/xterm.c index deb6d62a27..e20efd67c7 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -887,12 +887,31 @@ static int x_dnd_compute_toplevels (struct x_display_info *dpyinfo) { Atom type; - Window *toplevels, child; - int format, rc, dest_x, dest_y; - unsigned long nitems, wmstate_items, bytes_after, *wmstate; - unsigned char *data = NULL, *wmstate_data = NULL; + Window *toplevels; + int format, rc; + unsigned long nitems, bytes_after; unsigned long i; + unsigned char *data = NULL; + +#ifndef USE_XCB + int dest_x, dest_y; + unsigned long *wmstate; + unsigned long wmstate_items; + unsigned char *wmstate_data = NULL; XWindowAttributes attrs; + Window child; +#else + uint32_t *wmstate; + xcb_get_window_attributes_cookie_t *window_attribute_cookies; + xcb_translate_coordinates_cookie_t *translate_coordinate_cookies; + xcb_get_property_cookie_t *get_property_cookies; + xcb_get_geometry_cookie_t *get_geometry_cookies; + xcb_get_window_attributes_reply_t attrs, *attrs_reply; + xcb_translate_coordinates_reply_t *coordinates_reply; + xcb_get_property_reply_t *property_reply; + xcb_get_geometry_reply_t *geometry_reply; + xcb_generic_error_t *error; +#endif struct x_client_list_window *tem; #ifdef HAVE_XSHAPE int count, ordering; @@ -915,10 +934,40 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) toplevels = (Window *) data; +#ifdef USE_XCB + window_attribute_cookies + = alloca (sizeof *window_attribute_cookies * nitems); + translate_coordinate_cookies + = alloca (sizeof *translate_coordinate_cookies * nitems); + get_property_cookies + = alloca (sizeof *get_property_cookies * nitems); + get_geometry_cookies + = alloca (sizeof *get_geometry_cookies * nitems); + + for (i = 0; i < nitems; ++i) + { + window_attribute_cookies[i] + = xcb_get_window_attributes (dpyinfo->xcb_connection, + (xcb_window_t) toplevels[i]); + translate_coordinate_cookies[i] + = xcb_translate_coordinates (dpyinfo->xcb_connection, + (xcb_window_t) toplevels[i], + (xcb_window_t) dpyinfo->root_window, + 0, 0); + get_property_cookies[i] + = xcb_get_property (dpyinfo->xcb_connection, 0, (xcb_window_t) toplevels[i], + (xcb_atom_t) dpyinfo->Xatom_wm_state, XCB_ATOM_ANY, + 0, 2); + get_geometry_cookies[i] + = xcb_get_geometry (dpyinfo->xcb_connection, (xcb_window_t) toplevels[i]); + } +#endif + /* Actually right because _NET_CLIENT_LIST_STACKING has bottom-up order. */ for (i = 0; i < nitems; ++i) { +#ifndef USE_XCB x_catch_errors (dpyinfo->display); rc = (XGetWindowAttributes (dpyinfo->display, toplevels[i], &attrs) @@ -941,27 +990,98 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) && !x_had_errors_p (dpyinfo->display) && wmstate_data && wmstate_items == 2 && format == 32); x_uncatch_errors_after_check (); +#else + rc = true; + + attrs_reply + = xcb_get_window_attributes_reply (dpyinfo->xcb_connection, + window_attribute_cookies[i], + &error); + + if (!attrs_reply) + { + rc = false; + free (error); + } + + coordinates_reply + = xcb_translate_coordinates_reply (dpyinfo->xcb_connection, + translate_coordinate_cookies[i], + &error); + + if (!coordinates_reply) + { + rc = false; + free (error); + } + + property_reply = xcb_get_property_reply (dpyinfo->xcb_connection, + get_property_cookies[i], + &error); + + if (!property_reply) + { + rc = false; + free (error); + } + + if (xcb_get_property_value_length (property_reply) != 8 + || property_reply->format != 32) + rc = false; + + geometry_reply = xcb_get_geometry_reply (dpyinfo->xcb_connection, + get_geometry_cookies[i], + &error); + + if (!geometry_reply) + { + rc = false; + free (error); + } +#endif if (rc) { +#ifdef USE_XCB + wmstate = (uint32_t *) xcb_get_property_value (property_reply); + attrs = *attrs_reply; +#else wmstate = (unsigned long *) wmstate_data; +#endif tem = xmalloc (sizeof *tem); tem->window = toplevels[i]; tem->dpy = dpyinfo->display; +#ifndef USE_XCB tem->x = dest_x; tem->y = dest_y; tem->width = attrs.width + attrs.border_width; tem->height = attrs.height + attrs.border_width; +#else + tem->x = (coordinates_reply->dst_x + - geometry_reply->border_width); + tem->y = (coordinates_reply->dst_y + - geometry_reply->border_width); + tem->width = (geometry_reply->width + + geometry_reply->border_width); + tem->height = (geometry_reply->height + + geometry_reply->border_width); +#endif tem->mapped_p = (attrs.map_state != IsUnmapped); tem->next = x_dnd_toplevels; tem->previous_event_mask = attrs.your_event_mask; tem->wm_state = wmstate[0]; +#ifndef USE_XCB XFree (wmstate_data); +#endif #ifdef HAVE_XSHAPE +#ifndef USE_XCB tem->border_width = attrs.border_width; +#else + tem->border_width = geometry_reply->border_width; +#endif tem->n_bounding_rects = -1; tem->n_input_rects = -1; @@ -1044,6 +1164,20 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) x_dnd_toplevels = tem; } + +#ifdef USE_XCB + if (attrs_reply) + free (attrs_reply); + + if (coordinates_reply) + free (coordinates_reply); + + if (property_reply) + free (property_reply); + + if (geometry_reply) + free (geometry_reply); +#endif } return 0; commit 66f6324a58a9580f8a3f2f53532838c463581999 Author: Po Lu Date: Sat Mar 26 10:17:12 2022 +0800 Fix compiler warning in x-dnd.el * lisp/x-dnd.el (x-dnd-xdnd-to-action): Move declaration earlier. diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index e801c4fdfc..17e65adc64 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -118,6 +118,14 @@ any protocol specific data.") (declare-function x-get-selection-internal "xselect.c" (selection-symbol target-type &optional time-stamp terminal)) +(defconst x-dnd-xdnd-to-action + '(("XdndActionPrivate" . private) + ("XdndActionCopy" . copy) + ("XdndActionMove" . move) + ("XdndActionLink" . link) + ("XdndActionAsk" . ask)) + "Mapping from XDND action types to Lisp symbols.") + (defvar x-dnd-empty-state [nil nil nil nil nil nil nil]) (declare-function x-register-dnd-atom "xselect.c") @@ -394,14 +402,6 @@ Currently XDND, Motif and old KDE 1.x protocols are recognized." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; XDND protocol. -(defconst x-dnd-xdnd-to-action - '(("XdndActionPrivate" . private) - ("XdndActionCopy" . copy) - ("XdndActionMove" . move) - ("XdndActionLink" . link) - ("XdndActionAsk" . ask)) - "Mapping from XDND action types to Lisp symbols.") - (declare-function x-change-window-property "xfns.c" (prop value &optional frame type format outer-P)) commit 5359062be603e22d1ee07c21b0840fdb98a704a3 Author: Po Lu Date: Sat Mar 26 10:15:53 2022 +0800 Avoid ClientMessage overhead when dragging stuff to other frames * lisp/dired.el (dired-mouse-drag): Handle correctly dragging from dired buffers in nonselected windows. * lisp/x-dnd.el (x-dnd-handle-drag-n-drop-event): Understand new client message type. * src/xterm.c (x_dnd_send_enter, x_dnd_send_position) (x_dnd_send_leave): Ignore if window is the top window of a frame. (x_dnd_send_drop): Send special DND event in that case. diff --git a/lisp/dired.el b/lisp/dired.el index c5e389c9ce..3c37a887ba 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1704,7 +1704,8 @@ see `dired-use-ls-dired' for more details.") (when mark-active (deactivate-mark)) (save-excursion - (goto-char (posn-point (event-end event))) + (with-selected-window (posn-window (event-end event)) + (goto-char (posn-point (event-end event)))) (track-mouse (let ((new-event (read-event))) (if (not (eq (event-basic-type new-event) 'mouse-movement)) @@ -1715,7 +1716,9 @@ see `dired-use-ls-dired' for more details.") (condition-case nil (progn (gui-backend-set-selection 'XdndSelection - (dired-file-name-at-point)) + (with-selected-window (posn-window + (event-end event)) + (dired-file-name-at-point))) (x-begin-drag '("text/uri-list" "text/x-dnd-username") (if (eq 'dired-mouse-drag-files 'link) diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index 0529d223db..e801c4fdfc 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -115,6 +115,9 @@ the type we want for the drop, the action we want for the drop, any protocol specific data.") +(declare-function x-get-selection-internal "xselect.c" + (selection-symbol target-type &optional time-stamp terminal)) + (defvar x-dnd-empty-state [nil nil nil nil nil nil nil]) (declare-function x-register-dnd-atom "xselect.c") @@ -336,21 +339,41 @@ nil if not." Currently XDND, Motif and old KDE 1.x protocols are recognized." (interactive "e") (let* ((client-message (car (cdr (cdr event)))) - (window (posn-window (event-start event))) - (message-atom (aref client-message 0)) - (frame (aref client-message 1)) - (format (aref client-message 2)) - (data (aref client-message 3))) - - (cond ((equal "DndProtocol" message-atom) ; Old KDE 1.x. - (x-dnd-handle-old-kde event frame window message-atom format data)) - - ((equal "_MOTIF_DRAG_AND_DROP_MESSAGE" message-atom) ; Motif - (x-dnd-handle-motif event frame window message-atom format data)) - - ((and (> (length message-atom) 4) ; XDND protocol. - (equal "Xdnd" (substring message-atom 0 4))) - (x-dnd-handle-xdnd event frame window message-atom format data))))) + (window (posn-window (event-start event)))) + (if (eq (and (consp client-message) + (car client-message)) + 'XdndSelection) + ;; This is an internal Emacs message caused by something being + ;; dropped on top of a frame. + (progn + (let ((action (cdr (assoc (symbol-name (cadr client-message)) + x-dnd-xdnd-to-action))) + (targets (cddr client-message))) + (x-dnd-save-state window nil nil + (apply #'vector targets)) + (x-dnd-maybe-call-test-function window action) + (unwind-protect + (x-dnd-drop-data event (if (framep window) window + (window-frame window)) + window + (x-get-selection-internal + 'XdndSelection + (intern (x-dnd-current-type window))) + (x-dnd-current-type window)) + (x-dnd-forget-drop window)))) + (let ((message-atom (aref client-message 0)) + (frame (aref client-message 1)) + (format (aref client-message 2)) + (data (aref client-message 3))) + (cond ((equal "DndProtocol" message-atom) ; Old KDE 1.x. + (x-dnd-handle-old-kde event frame window message-atom format data)) + + ((equal "_MOTIF_DRAG_AND_DROP_MESSAGE" message-atom) ; Motif + (x-dnd-handle-motif event frame window message-atom format data)) + + ((and (> (length message-atom) 4) ; XDND protocol. + (equal "Xdnd" (substring message-atom 0 4))) + (x-dnd-handle-xdnd event frame window message-atom format data))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -425,8 +448,6 @@ otherwise return the frame coordinates." (declare-function x-get-atom-name "xselect.c" (value &optional frame)) (declare-function x-send-client-message "xselect.c" (display dest from message-type format values)) -(declare-function x-get-selection-internal "xselect.c" - (selection-symbol target-type &optional time-stamp terminal)) (defun x-dnd-version-from-flags (flags) "Return the version byte from the 32 bit FLAGS in an XDndEnter message." diff --git a/src/xterm.c b/src/xterm.c index 6bd43511f8..deb6d62a27 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1396,6 +1396,9 @@ x_dnd_send_enter (struct frame *f, Window target, int supported) int i; XEvent msg; + if (x_top_window_to_frame (dpyinfo, target)) + return; + msg.xclient.type = ClientMessage; msg.xclient.message_type = dpyinfo->Xatom_XdndEnter; msg.xclient.format = 32; @@ -1443,6 +1446,9 @@ x_dnd_send_position (struct frame *f, Window target, int supported, return; } + if (x_top_window_to_frame (dpyinfo, target)) + return; + msg.xclient.type = ClientMessage; msg.xclient.message_type = dpyinfo->Xatom_XdndPosition; msg.xclient.format = 32; @@ -1470,6 +1476,9 @@ x_dnd_send_leave (struct frame *f, Window target) struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); XEvent msg; + if (x_top_window_to_frame (dpyinfo, target)) + return; + msg.xclient.type = ClientMessage; msg.xclient.message_type = dpyinfo->Xatom_XdndLeave; msg.xclient.format = 32; @@ -1491,6 +1500,62 @@ x_dnd_send_drop (struct frame *f, Window target, Time timestamp, { struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); XEvent msg; + struct input_event ie; + struct frame *self_frame; + int root_x, root_y, win_x, win_y, i; + unsigned int mask; + Window root, child; + Lisp_Object lval; + char **atom_names; + char *name; + + self_frame = x_top_window_to_frame (dpyinfo, target); + + if (self_frame) + { + /* Send a special drag-and-drop event when dropping on top of an + Emacs frame to avoid all the overhead involved with sending + client events. */ + EVENT_INIT (ie); + + if (XQueryPointer (dpyinfo->display, FRAME_X_WINDOW (self_frame), + &root, &child, &root_x, &root_y, &win_x, &win_y, + &mask)) + { + ie.kind = DRAG_N_DROP_EVENT; + XSETFRAME (ie.frame_or_window, self_frame); + + lval = Qnil; + atom_names = alloca (x_dnd_n_targets * sizeof *atom_names); + name = XGetAtomName (dpyinfo->display, x_dnd_wanted_action); + + if (!XGetAtomNames (dpyinfo->display, x_dnd_targets, + x_dnd_n_targets, atom_names)) + { + XFree (name); + return; + } + + for (i = x_dnd_n_targets; i != 0; --i) + { + lval = Fcons (intern (atom_names[i - 1]), lval); + XFree (atom_names[i - 1]); + } + + lval = Fcons (intern (name), lval); + lval = Fcons (QXdndSelection, lval); + ie.arg = lval; + ie.timestamp = CurrentTime; + + XSETINT (ie.x, win_x); + XSETINT (ie.y, win_y); + + XFree (name); + kbd_buffer_store_event (&ie); + + return; + } + } msg.xclient.type = ClientMessage; msg.xclient.message_type = dpyinfo->Xatom_XdndDrop; commit 21ecf6b24d0549a9f27bcab51dbd8c8b1a37ef86 Author: Po Lu Date: Sat Mar 26 08:45:08 2022 +0800 Fix minor issues with dired-mouse-drag-files * lisp/dired.el (dired-mouse-drag-files): Update doc string and add setter. (dired-insert-set-properties): Don't insert misleading tooltip if feature is not available. diff --git a/lisp/dired.el b/lisp/dired.el index b1208cec25..c5e389c9ce 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -248,17 +248,27 @@ The target is used in the prompt for file copy, rename etc." (other :tag "Try to guess" t)) :group 'dired) + (defcustom dired-mouse-drag-files nil "If non-nil, allow the mouse to drag files from inside a Dired buffer. Dragging the mouse and then releasing it over the window of another program will result in that program opening the file, or -creating a copy of it. +creating a copy of it. This feature is supported only on X +Windows and Haiku. If the value is `link', then a symbolic link will be created to the file instead by the other program (usually a file manager)." + :set (lambda (option value) + (set-default option value) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (derived-mode-p 'dired-mode) + (revert-buffer nil t))))) :type '(choice (const :tag "Don't allow dragging" nil) (const :tag "Copy file to other window" t) - (const :tag "Create symbolic link to file" link))) + (const :tag "Create symbolic link to file" link)) + :group 'dired + :version "29.1") (defcustom dired-copy-preserve-time t "If non-nil, Dired preserves the last-modified time in a file copy. @@ -1734,7 +1744,7 @@ see `dired-use-ls-dired' for more details.") 'invisible 'dired-hide-details-information)) (put-text-property (+ (line-beginning-position) 1) (1- (point)) 'invisible 'dired-hide-details-detail) - (when dired-mouse-drag-files + (when (and dired-mouse-drag-files (fboundp 'x-begin-drag)) (put-text-property (point) (save-excursion (dired-move-to-end-of-filename) @@ -1750,7 +1760,8 @@ see `dired-use-ls-dired' for more details.") `(mouse-face highlight dired-filename t - help-echo ,(if dired-mouse-drag-files + help-echo ,(if (and dired-mouse-drag-files + (fboundp 'x-begin-drag)) "down-mouse-1: drag this file to another program mouse-2: visit this file in other window" "mouse-2: visit this file in other window"))) commit 3b6e74f08edaa4bfe028cf91366f3a6798cb6abf Author: Andrew G Cohen Date: Sat Mar 26 06:58:23 2022 +0800 ; * lisp/gnus/nnselect.el (nnselect-get-artlist): Fix last change. diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 3a93c9e3dd..3aef1eb696 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -296,7 +296,7 @@ non-nil call this function with argument GROUP to get the artlist; if the group parameter 'nnselect-always-regenerate is non-nil, regenerate the artlist; otherwise retrieve the artlist directly from the group parameters." - `(when (gnus-nnselect-group-p group) + `(when (gnus-nnselect-group-p ,group) (let ((override (gnus-group-get-parameter ,group 'nnselect-get-artlist-override-function))) commit 413ef5a7e664d84415eae00e491e2a14a6018265 Author: Andrew G Cohen Date: Fri Mar 25 16:06:34 2022 +0800 ; Restore regexp-quote for gnus subject match * lisp/gnus/gnus-sum.el (gnus-summary-limit-include-thread): Restore regexp-quote that was inadvertently dropped in commit 2021-12-21 "Fix gnus subject matching when subject is empty". diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 769ad6d9eb..62efacfd6e 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -8663,7 +8663,7 @@ these articles." (when matching-subject (gnus-summary-limit-include-matching-articles "subject" - matching-subject) + (regexp-quote matching-subject)) ;; Each of the previous two limit calls push a limit onto ;; the limit stack. Presumably we want to think of the ;; thread and its associated subject matches as a single commit 4ec9f9edd130ced5b08e7bdb69b2841d082ca9f1 Author: Lars Ingebrigtsen Date: Fri Mar 25 19:01:51 2022 +0100 Fix eshell-explicit-command-char doc string typo * lisp/eshell/esh-ext.el (eshell-explicit-command-char): Fix typo in doc string (bug#54567). diff --git a/lisp/eshell/esh-ext.el b/lisp/eshell/esh-ext.el index fc023f23ce..98902fc6f2 100644 --- a/lisp/eshell/esh-ext.el +++ b/lisp/eshell/esh-ext.el @@ -163,7 +163,7 @@ by the user on the command line." (defcustom eshell-explicit-command-char ?* "If this char occurs before a command name, call it externally. -That is, although `vi' may be an alias, `\vi' will always call the +That is, although `vi' may be an alias, `*vi' will always call the external version." :type 'character :group 'eshell-ext) commit 4eabca26d3d17a87ff2548dd251b597d8b2d2c55 Author: Lars Ingebrigtsen Date: Fri Mar 25 17:32:40 2022 +0100 Fix (bounds-of-thing-at-point 'number) * lisp/thingatpt.el (number): Make (bounds-of-thing-at-point 'number) work (bug#54555). diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 5f9ccc094a..b3dca5890f 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -82,7 +82,7 @@ question. (defun forward-thing (thing &optional n) "Move forward to the end of the Nth next THING. THING should be a symbol specifying a type of syntactic entity. -Possibilities include `symbol', `list', `sexp', `defun', +Possibilities include `symbol', `list', `sexp', `defun', `number', `filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', and `page'." (let ((forward-op (or (get thing 'forward-op) @@ -97,7 +97,7 @@ Possibilities include `symbol', `list', `sexp', `defun', (defun bounds-of-thing-at-point (thing) "Determine the start and end buffer locations for the THING at point. THING should be a symbol specifying a type of syntactic entity. -Possibilities include `symbol', `list', `sexp', `defun', +Possibilities include `symbol', `list', `sexp', `defun', `number', `filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', and `page'. @@ -732,6 +732,7 @@ Signal an error if the entire string was not used." "Return the symbol at point, or nil if none is found." (let ((thing (thing-at-point 'symbol))) (if thing (intern thing)))) + ;;;###autoload (defun number-at-point () "Return the number at point, or nil if none is found. @@ -746,7 +747,9 @@ like \"0xBEEF09\" or \"#xBEEF09\", are recognized." (string-to-number (buffer-substring (match-beginning 0) (match-end 0)))))) +(put 'number 'forward-op 'forward-word) (put 'number 'thing-at-point 'number-at-point) + ;;;###autoload (defun list-at-point (&optional ignore-comment-or-string) "Return the Lisp list at point, or nil if none is found. commit ec2f2ed65ef5232c83ed84384b0f6230345c7d78 Author: Lars Ingebrigtsen Date: Fri Mar 25 17:20:35 2022 +0100 Fix reporting of read error line/columns in the init file * src/lread.c (invalid_syntax_lisp): The comments here said that we were supposed to be called with point in the readcharfun buffer. This was not the case (at least) when reading the Emacs init file, so the reported line/column was always wrong (1 and 0, respectively) (bug#54550). diff --git a/src/lread.c b/src/lread.c index d7b56c5087..6130300b0a 100644 --- a/src/lread.c +++ b/src/lread.c @@ -550,13 +550,21 @@ invalid_syntax_lisp (Lisp_Object s, Lisp_Object readcharfun) { if (BUFFERP (readcharfun)) { + ptrdiff_t line, column; + + /* Get the line/column in the readcharfun buffer. */ + { + specpdl_ref count = SPECPDL_INDEX (); + + record_unwind_protect_excursion (); + set_buffer_internal (XBUFFER (readcharfun)); + line = count_lines (BEGV_BYTE, PT_BYTE) + 1; + column = current_column (); + unbind_to (count, Qnil); + } + xsignal (Qinvalid_read_syntax, - list3 (s, - /* We should already be in the readcharfun - buffer when this error is called, so no need - to switch to it first. */ - make_fixnum (count_lines (BEGV_BYTE, PT_BYTE) + 1), - make_fixnum (current_column ()))); + list3 (s, make_fixnum (line), make_fixnum (column))); } else xsignal1 (Qinvalid_read_syntax, s); commit 3e7257c3ed3e7f5451d4dab0b222f93a2d1b2aa3 Author: Lars Ingebrigtsen Date: Fri Mar 25 16:44:01 2022 +0100 Improve pp-last-sexp ergonomics * lisp/emacs-lisp/pp.el (pp-last-sexp): Ignore ,@? before a sexp, because eval-ing that will always lead to an error (bug#54537). diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index e782cdb1da..ad693fa5a6 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -177,6 +177,10 @@ Also add the value to the front of the list in the variable `values'." (let ((pt (point))) (save-excursion (forward-sexp -1) + ;; Make `pp-eval-last-sexp' work the same way `eval-last-sexp' + ;; does. + (when (looking-at ",@?") + (goto-char (match-end 0))) (read ;; If first line is commented, ignore all leading comments: (if (save-excursion (beginning-of-line) (looking-at-p "[ \t]*;")) commit 4dfd42014b50aadd82b425747fe65fa97df28caa Author: Po Lu Date: Fri Mar 25 13:41:30 2022 +0000 Implement new drag and drop parameter on Haiku * lisp/term/haiku-win.el (x-begin-drag): Implement `allow-current-frame'. * src/haiku_support.cc (be_drag_message): New argument `allow_same_view'. * src/haiku_support.h: Update prototypes. * src/haikuselect.c (Fhaiku_drag_message): New parameter `allow-same-frame'. diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index d04da2fdae..2f106825c3 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -199,7 +199,7 @@ This is necessary because on Haiku `use-system-tooltip' doesn't take effect on menu items until the menu bar is updated again." (force-mode-line-update t)) -(defun x-begin-drag (targets &optional action frame _return-frame _allow-current-frame) +(defun x-begin-drag (targets &optional action frame _return-frame allow-current-frame) "SKIP: real doc in xfns.c." (unless haiku-dnd-selection-value (error "No local value for XdndSelection")) @@ -228,7 +228,7 @@ take effect on menu items until the menu bar is updated again." action) 'XdndActionCopy) (haiku-drag-message (or frame (selected-frame)) - message)))) + message allow-current-frame)))) (add-variable-watcher 'use-system-tooltips #'haiku-use-system-tooltips-watcher) diff --git a/src/haiku_support.cc b/src/haiku_support.cc index b58420fcb9..a1616258bc 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -4068,7 +4068,7 @@ be_drag_message_thread_entry (void *thread_data) } bool -be_drag_message (void *view, void *message, +be_drag_message (void *view, void *message, bool allow_same_view, void (*block_input_function) (void), void (*unblock_input_function) (void), void (*process_pending_signals_function) (void), @@ -4083,7 +4083,10 @@ be_drag_message (void *view, void *message, ssize_t stat; block_input_function (); - msg->AddInt32 ("emacs:window_id", window->window_id); + + if (!allow_same_view) + msg->AddInt32 ("emacs:window_id", window->window_id); + if (!vw->LockLooper ()) gui_abort ("Failed to lock view looper for drag"); diff --git a/src/haiku_support.h b/src/haiku_support.h index c978926e73..ae3ad6a68a 100644 --- a/src/haiku_support.h +++ b/src/haiku_support.h @@ -944,7 +944,7 @@ extern "C" BMessage_delete (void *message); extern bool - be_drag_message (void *view, void *message, + be_drag_message (void *view, void *message, bool allow_same_view, void (*block_input_function) (void), void (*unblock_input_function) (void), void (*process_pending_signals_function) (void), diff --git a/src/haikuselect.c b/src/haikuselect.c index 5540f467c0..f1aa4f20d9 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -585,7 +585,7 @@ haiku_should_quit_drag (void) } DEFUN ("haiku-drag-message", Fhaiku_drag_message, Shaiku_drag_message, - 2, 2, 0, + 2, 3, 0, doc: /* Begin dragging MESSAGE from FRAME. MESSAGE an alist of strings, denoting message field names, to a list @@ -606,8 +606,11 @@ associates to a 32-bit unsigned integer describing the type of the system message. FRAME is a window system frame that must be visible, from which the -drag will originate. */) - (Lisp_Object frame, Lisp_Object message) +drag will originate. + +ALLOW-SAME-FRAME, if nil or not specified, means that MESSAGE will be +ignored if it is dropped on top of FRAME. */) + (Lisp_Object frame, Lisp_Object message, Lisp_Object allow_same_frame) { specpdl_ref idx; void *be_message; @@ -625,6 +628,7 @@ drag will originate. */) record_unwind_protect_ptr (BMessage_delete, be_message); haiku_lisp_to_message (message, be_message); rc = be_drag_message (FRAME_HAIKU_VIEW (f), be_message, + !NILP (allow_same_frame), block_input, unblock_input, process_pending_signals, haiku_should_quit_drag); commit 8ba0f190642d20e8f9caa7472c12674c7ba65a69 Author: Po Lu Date: Fri Mar 25 21:24:03 2022 +0800 Allow dragging files from dired to windows on the same frame * doc/lispref/frames.texi (Drag and Drop): Document new parameter to `x-begin-drag'. * lisp/dired.el (dired-mouse-drag): Utilize new parameter. * lisp/term/haiku-win.el (x-begin-drag): Add new parameter. * src/xfns.c (Fx_begin_drag): New parameter `allow-current-frame'. Fix typo and update doc string. * src/xterm.c (x_dnd_get_window_proto): Respect `x_dnd_allow_current_frame'. (x_dnd_begin_drag_and_drop): New parameter `allow_current_frame'. * src/xterm.h: Update prototypes. diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index a031b25e47..90924cf47b 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -4042,12 +4042,13 @@ you want to alter Emacs behavior, you can customize these variables. On capable window systems, Emacs also supports dragging contents from its frames to windows of other applications. -@defun x-begin-drag targets &optional action frame return-frame +@defun x-begin-drag targets &optional action frame return-frame allow-current-frame This function begins a drag from @var{frame}, and returns when the drag-and-drop operation ends, either because the drop was successful, or because the drop was rejected. The drop occurs when all mouse buttons are released on top of an X window other than @var{frame} (the -@dfn{drop target}). +@dfn{drop target}), or any X window if @var{allow-current-frame} is +non-@code{nil}. @var{targets} is a list of strings describing selection targets, much like the @var{data-type} argument to @code{gui-get-selection}, that @@ -4070,7 +4071,8 @@ If @var{return-frame} is non-nil and the mouse moves over an Emacs frame after first moving out of @var{frame}, then the frame to which the mouse moves will be returned immediately. This is useful when you want to treat dragging content from one frame to another specially, -while also being able to drag content to other programs. +while also being able to drag content to other programs, but is not +guaranteed to work on all systems and window managers. If the drop was rejected or no drop target was found, this function returns @code{nil}. Otherwise, it returns a symbol describing the diff --git a/lisp/dired.el b/lisp/dired.el index d6c5721ca2..b1208cec25 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1710,7 +1710,8 @@ see `dired-use-ls-dired' for more details.") "text/x-dnd-username") (if (eq 'dired-mouse-drag-files 'link) 'XdndActionLink - 'XdndActionCopy))) + 'XdndActionCopy) + nil nil t)) (error (when (eq (event-basic-type new-event) 'mouse-1) (push new-event unread-command-events))))))))) diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index 1433620875..d04da2fdae 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -199,7 +199,7 @@ This is necessary because on Haiku `use-system-tooltip' doesn't take effect on menu items until the menu bar is updated again." (force-mode-line-update t)) -(defun x-begin-drag (targets &optional action frame _return-frame) +(defun x-begin-drag (targets &optional action frame _return-frame _allow-current-frame) "SKIP: real doc in xfns.c." (unless haiku-dnd-selection-value (error "No local value for XdndSelection")) diff --git a/src/xfns.c b/src/xfns.c index 52649b38dd..3f3054422a 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -6582,7 +6582,7 @@ The coordinates X and Y are interpreted in pixels relative to a position return Qnil; } -DEFUN ("x-begin-drag", Fx_begin_drag, Sx_begin_drag, 1, 4, 0, +DEFUN ("x-begin-drag", Fx_begin_drag, Sx_begin_drag, 1, 5, 0, doc: /* Begin dragging contents on FRAME, with targets TARGETS. TARGETS is a list of strings, which defines the X selection targets that will be available to the drop target. Block until the mouse @@ -6612,7 +6612,7 @@ Emacs. For that reason, they are not mentioned here. Consult If RETURN-FRAME is non-nil, this function will return the frame if the mouse pointer moves onto an Emacs frame, after first moving out of -FRAME. +FRAME. (This is not guaranteed to work on some systems.) If ACTION is a list and not nil, its elements are assumed to be a cons of (ITEM . STRING), where ITEM is the name of an action, and STRING is @@ -6620,9 +6620,13 @@ a string describing ITEM to the user. The drop target is expected to prompt the user to choose between any of the actions in the list. If ACTION is not specified or nil, `XdndActionCopy' is used -instead. */) +instead. + +If ALLOW-CURRENT-FRAME is not specified or nil, then the drop target +is allowed to be FRAME. Otherwise, no action will be taken if the +mouse buttons are released on top of FRAME. */) (Lisp_Object targets, Lisp_Object action, Lisp_Object frame, - Lisp_Object return_frame) + Lisp_Object return_frame, Lisp_Object allow_current_frame) { struct frame *f = decode_window_system_frame (frame); int ntargets = 0, nnames = 0; @@ -6650,7 +6654,7 @@ instead. */) scratch = SSDATA (XCAR (targets)); len = strlen (scratch); target_names[ntargets] = SAFE_ALLOCA (len + 1); - strncpy (target_names[ntargets], scratch, len + 1);; + strncpy (target_names[ntargets], scratch, len + 1); ntargets++; } else @@ -6725,7 +6729,8 @@ instead. */) x_set_dnd_targets (target_atoms, ntargets); lval = x_dnd_begin_drag_and_drop (f, FRAME_DISPLAY_INFO (f)->last_user_time, xaction, !NILP (return_frame), action_list, - (const char **) &name_list, nnames); + (const char **) &name_list, nnames, + !NILP (allow_current_frame)); SAFE_FREE (); return lval; diff --git a/src/xterm.c b/src/xterm.c index 968ea78c1a..6bd43511f8 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -799,6 +799,7 @@ static bool x_dnd_in_progress; static bool x_dnd_waiting_for_finish; static Window x_dnd_pending_finish_target; static int x_dnd_waiting_for_finish_proto; +static bool x_dnd_allow_current_frame; /* Whether or not to return a frame from `x_dnd_begin_drag_and_drop'. @@ -1368,7 +1369,8 @@ x_dnd_get_window_proto (struct x_display_info *dpyinfo, Window wdesc) unsigned long n, left; bool had_errors; - if (wdesc == None || wdesc == FRAME_OUTER_WINDOW (x_dnd_frame)) + if (wdesc == None || (!x_dnd_allow_current_frame + && wdesc == FRAME_OUTER_WINDOW (x_dnd_frame))) return -1; x_catch_errors (dpyinfo->display); @@ -7310,7 +7312,7 @@ Lisp_Object x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, bool return_frame_p, Atom *ask_action_list, const char **ask_action_names, - size_t n_ask_actions) + size_t n_ask_actions, bool allow_current_frame) { #ifndef USE_GTK XEvent next_event; @@ -7394,7 +7396,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, x_dnd_in_progress = true; x_dnd_frame = f; - x_dnd_last_seen_window = FRAME_OUTER_WINDOW (f); + x_dnd_last_seen_window = None; x_dnd_last_protocol_version = -1; x_dnd_mouse_rect_target = None; x_dnd_action = None; @@ -7405,6 +7407,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, x_dnd_use_toplevels = x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_client_list_stacking); x_dnd_toplevels = NULL; + x_dnd_allow_current_frame = allow_current_frame; if (x_dnd_use_toplevels) { diff --git a/src/xterm.h b/src/xterm.h index 5a7b09925e..a155245f81 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -1383,7 +1383,7 @@ extern void x_scroll_bar_configure (GdkEvent *); extern Lisp_Object x_dnd_begin_drag_and_drop (struct frame *, Time, Atom, bool, Atom *, const char **, - size_t); + size_t, bool); extern void x_set_dnd_targets (Atom *, int); INLINE int commit ab414c5661cc4db23f05f017ef81add2e502171f Author: Eli Zaretskii Date: Fri Mar 25 15:39:44 2022 +0300 Improve documentation of 'completion-auto-select' * lisp/simple.el (completion-auto-select): * doc/emacs/mini.texi (Completion Options): Improve documentation and description of customization options of 'completion-auto-select'. diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index dd78262aeb..eeb87972cc 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -643,11 +643,14 @@ completion list buffer, and like @code{always} when it decides whether to pop it down. @vindex completion-auto-select - The completions window can be automatically selected. To enable -this behavior, customize the user option @code{completion-auto-select} -to @code{t} and pressing @key{TAB} will switch to the completion list -buffer when it pops up that buffer. If the value is -@code{second-tab}, then the first @key{TAB} will pop up the + Emacs can optionally select the window showing the completions when +it shows that window. To enable this behavior, customize the user +option @code{completion-auto-select} to @code{t}, which changes the +behavior of @key{TAB} when Emacs pops up the completions: pressing +@kbd{@key{TAB}} will switch to the completion list buffer, and you can +then move to a candidate by cursor motion commands and select it with +@kbd{@key{RET}}. If the value of @code{completion-auto-select} is +@code{second-tab}, then the first @kbd{@key{TAB}} will pop up the completions list buffer, and the second one will switch to it. @vindex completion-cycle-threshold diff --git a/lisp/simple.el b/lisp/simple.el index 921fba3416..c60abcb1f4 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -9146,13 +9146,17 @@ This affects the commands `next-completion' and (defcustom completion-auto-select nil "Non-nil means to automatically select the *Completions* buffer. -When the value is t, then pressing TAB will switch to the completion list -buffer when it pops up that buffer. If the value is `second-tab', then the -first TAB will pop up the completions list buffer, and the second one will -switch to it." - :type '(choice (const :tag "Disabled" nil) - (const :tag "Select window on first tab" t) - (const :tag "Select window on second-tab" second-tab)) +When the value is t, pressing TAB will switch to the completion list +buffer when Emacs pops up a window showing that buffer. +If the value is `second-tab', then the first TAB will pop up the +window shwoing the completions list buffer, and the next TAB will +switch to that window. +See `completion-auto-help' for controlling when the window showing +the completions is popped up and down." + :type '(choice (const :tag "Don't auto-select completions window" nil) + (const :tag "Select completions window on first TAB" t) + (const :tag + "Select completions window on second TAB" second-tab)) :version "29.1" :group 'completion) commit 3fac06dfb8d11985e855d4243518095cbdfede05 Author: Po Lu Date: Fri Mar 25 20:33:23 2022 +0800 Make it easier to select text inside dired when mouse dragging is on * lisp/dired.el (dired-insert-set-properties): Only set drag keymap on the filename itself. diff --git a/lisp/dired.el b/lisp/dired.el index 3790197f66..d6c5721ca2 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1733,20 +1733,26 @@ see `dired-use-ls-dired' for more details.") 'invisible 'dired-hide-details-information)) (put-text-property (+ (line-beginning-position) 1) (1- (point)) 'invisible 'dired-hide-details-detail) + (when dired-mouse-drag-files + (put-text-property (point) + (save-excursion + (dired-move-to-end-of-filename) + (backward-char) + (point)) + 'keymap + dired-mouse-drag-files-map)) (add-text-properties (point) (progn (dired-move-to-end-of-filename) (point)) - (append `(mouse-face - highlight - dired-filename t - help-echo ,(if dired-mouse-drag-files - "down-mouse-1: drag this file to another program + `(mouse-face + highlight + dired-filename t + help-echo ,(if dired-mouse-drag-files + "down-mouse-1: drag this file to another program mouse-2: visit this file in other window" - "mouse-2: visit this file in other window")) - (when dired-mouse-drag-files - `(keymap ,dired-mouse-drag-files-map)))) + "mouse-2: visit this file in other window"))) (when (< (+ (point) 4) (line-end-position)) (put-text-property (+ (point) 4) (line-end-position) 'invisible 'dired-hide-details-link)))) commit 1b7a9753e105c5cc39b554c99bf93c7e2e9d6630 Author: Michael Albinus Date: Fri Mar 25 09:28:44 2022 +0100 * admin/notes/emba: Mention workflow rules for branches. diff --git a/admin/notes/emba b/admin/notes/emba index 99237ea5f6..90a9c9cc3c 100644 --- a/admin/notes/emba +++ b/admin/notes/emba @@ -8,7 +8,8 @@ NOTES FOR EMACS CONTINUOUS BUILD ON EMBA A continuous build for Emacs can be found at , a Gitlab instance. It watches the Emacs git repository and starts a pipeline (jobset) if there are new -changes. This happens for all Emacs branches. +changes. This happens for all Emacs branches which belong to the +defined workflow (see below). * Mail notifications @@ -32,6 +33,10 @@ The Emacs jobset is defined in the Emacs source tree, file 'test/infra'. They could be adapted for every Emacs branch, see . +Only branches which name start with 'master', 'emacs', 'feature', or +'fix' are considered. This is declared in the workflow rules of file +'test/infra/gitlab-ci.yml'. + A jobset on Gitlab is called pipeline. Emacs pipelines run through the stages 'build-images', 'platform-images' and 'native-comp-images' (create an Emacs instance by 'make bootstrap' with different commit 8ecde51972b92a538e8dbf4b4408f9e63783204d Author: Po Lu Date: Fri Mar 25 16:21:17 2022 +0800 Fix quitting DND while waiting for finish * src/xterm.c (x_dnd_begin_drag_and_drop): Always clear finish flag before quitting. diff --git a/src/xterm.c b/src/xterm.c index cd651f4667..968ea78c1a 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -7503,9 +7503,10 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, x_dnd_in_progress = false; x_dnd_frame = NULL; x_set_dnd_targets (NULL, 0); - x_dnd_waiting_for_finish = false; } + x_dnd_waiting_for_finish = false; + if (x_dnd_use_toplevels) x_dnd_free_toplevels (); commit f38bdb0327c5806286ab97687e2823d65d8e184a Author: Po Lu Date: Fri Mar 25 16:15:57 2022 +0800 Take window shapes into account when processing drag and drop * configure.ac: Test for the Nonrectangular Window Shape extension. * msdos/sed1v2.inp: Update. * src/xterm.c (struct x_client_list_window): New fields for shapes. (x_dnd_free_toplevels): Free shapes. (x_dnd_compute_toplevels): Populate window shapes. (x_dnd_get_target_window_2): New function. (x_dnd_get_target_window_1): Test WM state of window before taking it into account. (x_dnd_begin_drag_and_drop): Use outer window as the initial last seen window. (x_dnd_update_state): Small fixes to frame tracking. (handle_one_xevent): Handle ShapeNotify events correctly. (x_term_init): Test for the Nonrectangular Window Shape extension. * src/xterm.h (struct x_display_info): New atom `WM_STATE'. diff --git a/configure.ac b/configure.ac index 6e63747733..4ac8c143e5 100644 --- a/configure.ac +++ b/configure.ac @@ -4538,6 +4538,24 @@ fi AC_SUBST(XDBE_CFLAGS) AC_SUBST(XDBE_LIBS) +### Use the Nonrectangular Window Shape extension if available. +HAVE_XSHAPE=no +if test "${HAVE_X11}" = "yes"; then + AC_CHECK_HEADER(X11/extensions/shape.h, + [AC_CHECK_LIB(Xext, XShapeQueryVersion, HAVE_XSHAPE=yes)], + [], + [#include + ]) + if test $HAVE_XSHAPE = yes; then + XSHAPE_LIBS=-lXext + fi + if test $HAVE_XSHAPE = yes; then + AC_DEFINE(HAVE_XSHAPE, 1, [Define to 1 if you have the Nonrectangular Window Shape extension.]) + fi +fi +AC_SUBST(XSHAPE_CFLAGS) +AC_SUBST(XSHAPE_LIBS) + ### Use Xcomposite (-lXcomposite) if available HAVE_XCOMPOSITE=no if test "${HAVE_X11}" = "yes"; then diff --git a/msdos/sed1v2.inp b/msdos/sed1v2.inp index 24ae079db1..4cc733ee79 100644 --- a/msdos/sed1v2.inp +++ b/msdos/sed1v2.inp @@ -119,6 +119,8 @@ s/ *@WEBP_LIBS@// /^XDBE_CFLAGS *=/s/@XDBE_CFLAGS@// /^XCOMPOSITE_LIBS *=/s/@XCOMPOSITE_LIBS@// /^XCOMPOSITE_CFLAGS *=/s/@XCOMPOSITE_CFLAGS@// +/^XSHAPE_LIBS *=/s/@XSHAPE_LIBS@// +/^XSHAPE_CFLAGS *=/s/@XSHAPE_CFLAGS@// /^XINPUT_LIBS *=/s/@XINPUT_LIBS@// /^XINPUT_CFLAGS *=/s/@XINPUT_CFLAGS@// /^XSYNC_LIBS *=/s/@XSYNC_LIBS@// diff --git a/src/xterm.c b/src/xterm.c index 0267ba7ec1..cd651f4667 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -546,6 +546,10 @@ along with GNU Emacs. If not, see . */ #include #endif +#ifdef HAVE_XSHAPE +#include +#endif + /* Load sys/types.h if not already loaded. In some systems loading it twice is suicidal. */ #ifndef makedev @@ -826,10 +830,21 @@ struct x_client_list_window Display *dpy; int x, y; int width, height; - bool visible_p; + bool mapped_p; long previous_event_mask; + unsigned long wm_state; struct x_client_list_window *next; + +#ifdef HAVE_XSHAPE + int border_width; + + XRectangle *input_rects; + int n_input_rects; + + XRectangle *bounding_rects; + int n_bounding_rects; +#endif }; static struct x_client_list_window *x_dnd_toplevels = NULL; @@ -849,7 +864,18 @@ x_dnd_free_toplevels (void) x_catch_errors (last->dpy); XSelectInput (last->dpy, last->window, last->previous_event_mask); +#ifdef HAVE_XSHAPE + XShapeSelectInput (last->dpy, last->window, None); +#endif x_uncatch_errors (); + +#ifdef HAVE_XSHAPE + if (last->n_input_rects != -1) + xfree (last->input_rects); + if (last->n_bounding_rects != -1) + xfree (last->bounding_rects); +#endif + xfree (last); } @@ -862,11 +888,15 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) Atom type; Window *toplevels, child; int format, rc, dest_x, dest_y; - unsigned long nitems, bytes_after; - unsigned char *data = NULL; + unsigned long nitems, wmstate_items, bytes_after, *wmstate; + unsigned char *data = NULL, *wmstate_data = NULL; unsigned long i; XWindowAttributes attrs; struct x_client_list_window *tem; +#ifdef HAVE_XSHAPE + int count, ordering; + XRectangle *rects; +#endif rc = XGetWindowProperty (dpyinfo->display, dpyinfo->root_window, dpyinfo->Xatom_net_client_list_stacking, @@ -899,10 +929,22 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) -attrs.border_width, &dest_x, &dest_y, &child) && !x_had_errors_p (dpyinfo->display)); + if (rc) + rc = ((XGetWindowProperty (dpyinfo->display, + toplevels[i], + dpyinfo->Xatom_wm_state, + 0, 2, False, AnyPropertyType, + &type, &format, &wmstate_items, + &bytes_after, &wmstate_data) + == Success) + && !x_had_errors_p (dpyinfo->display) + && wmstate_data && wmstate_items == 2 && format == 32); x_uncatch_errors_after_check (); if (rc) { + wmstate = (unsigned long *) wmstate_data; + tem = xmalloc (sizeof *tem); tem->window = toplevels[i]; tem->dpy = dpyinfo->display; @@ -910,13 +952,93 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) tem->y = dest_y; tem->width = attrs.width + attrs.border_width; tem->height = attrs.height + attrs.border_width; - tem->visible_p = (attrs.map_state == IsViewable); + tem->mapped_p = (attrs.map_state != IsUnmapped); tem->next = x_dnd_toplevels; tem->previous_event_mask = attrs.your_event_mask; + tem->wm_state = wmstate[0]; + + XFree (wmstate_data); + +#ifdef HAVE_XSHAPE + tem->border_width = attrs.border_width; + tem->n_bounding_rects = -1; + tem->n_input_rects = -1; + + if (dpyinfo->xshape_supported_p) + { + x_catch_errors (dpyinfo->display); + XShapeSelectInput (dpyinfo->display, + toplevels[i], + ShapeNotifyMask); + x_uncatch_errors (); + + x_catch_errors (dpyinfo->display); + rects = XShapeGetRectangles (dpyinfo->display, + toplevels[i], + ShapeBounding, + &count, &ordering); + rc = x_had_errors_p (dpyinfo->display); + x_uncatch_errors_after_check (); + + /* Does XShapeGetRectangles allocate anything upon an + error? */ + if (!rc) + { + tem->n_bounding_rects = count; + tem->bounding_rects + = xmalloc (sizeof *tem->bounding_rects * count); + memcpy (tem->bounding_rects, rects, + sizeof *tem->bounding_rects * count); + + XFree (rects); + } + +#ifdef ShapeInput + if (dpyinfo->xshape_major > 1 + || (dpyinfo->xshape_major == 1 + && dpyinfo->xshape_minor >= 1)) + { + x_catch_errors (dpyinfo->display); + rects = XShapeGetRectangles (dpyinfo->display, + toplevels[i], ShapeInput, + &count, &ordering); + rc = x_had_errors_p (dpyinfo->display); + x_uncatch_errors_after_check (); + + /* Does XShapeGetRectangles allocate anything upon + an error? */ + if (!rc) + { + tem->n_input_rects = count; + tem->input_rects + = xmalloc (sizeof *tem->input_rects * count); + memcpy (tem->input_rects, rects, + sizeof *tem->input_rects * count); + + XFree (rects); + } + } +#endif + } + + /* Handle the common case where the input shape equals the + bounding shape. */ + + if (tem->n_input_rects != -1 + && tem->n_bounding_rects == tem->n_input_rects + && !memcmp (tem->bounding_rects, tem->input_rects, + tem->n_input_rects * sizeof *tem->input_rects)) + { + xfree (tem->input_rects); + tem->n_input_rects = -1; + } +#endif x_catch_errors (dpyinfo->display); XSelectInput (dpyinfo->display, toplevels[i], - attrs.your_event_mask | StructureNotifyMask); + (attrs.your_event_mask + | StructureNotifyMask + | PropertyChangeMask)); x_uncatch_errors (); x_dnd_toplevels = tem; @@ -931,6 +1053,28 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) static int x_dnd_get_window_proto (struct x_display_info *, Window); static Window x_dnd_get_window_proxy (struct x_display_info *, Window); +#ifdef HAVE_XSHAPE +static bool +x_dnd_get_target_window_2 (XRectangle *rects, int nrects, + int x, int y) +{ + int i; + XRectangle *tem; + + for (i = 0; i < nrects; ++i) + { + tem = &rects[i]; + + if (x >= tem->x && y >= tem->y + && x < tem->x + tem->width + && y < tem->y + tem->height) + return true; + } + + return false; +} +#endif + static Window x_dnd_get_target_window_1 (struct x_display_info *dpyinfo, int root_x, int root_y) @@ -942,13 +1086,33 @@ x_dnd_get_target_window_1 (struct x_display_info *dpyinfo, for (tem = x_dnd_toplevels; tem; tem = tem->next) { - if (!tem->visible_p) + if (!tem->mapped_p || tem->wm_state != NormalState) continue; if (root_x >= tem->x && root_y >= tem->y && root_x < tem->x + tem->width && root_y < tem->y + tem->height) - return tem->window; + { +#ifdef HAVE_XSHAPE + if (tem->n_bounding_rects == -1) +#endif + return tem->window; + +#ifdef HAVE_XSHAPE + if (x_dnd_get_target_window_2 (tem->bounding_rects, + tem->n_bounding_rects, + tem->border_width + root_x - tem->x, + tem->border_width + root_y - tem->y)) + { + if (tem->n_input_rects == -1 + || x_dnd_get_target_window_2 (tem->input_rects, + tem->n_input_rects, + tem->border_width + root_x - tem->x, + tem->border_width + root_y - tem->y)) + return tem->window; + } +#endif + } } return None; @@ -7230,7 +7394,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, x_dnd_in_progress = true; x_dnd_frame = f; - x_dnd_last_seen_window = FRAME_X_WINDOW (f); + x_dnd_last_seen_window = FRAME_OUTER_WINDOW (f); x_dnd_last_protocol_version = -1; x_dnd_mouse_rect_target = None; x_dnd_action = None; @@ -10983,10 +11147,10 @@ x_dnd_update_state (struct x_display_info *dpyinfo) { if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1 - && x_dnd_last_seen_window != FRAME_X_WINDOW (x_dnd_frame)) + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); - if (x_dnd_last_seen_window == FRAME_X_WINDOW (x_dnd_frame) + if (target != FRAME_OUTER_WINDOW (x_dnd_frame) && x_dnd_return_frame == 1) x_dnd_return_frame = 2; @@ -10999,6 +11163,8 @@ x_dnd_update_state (struct x_display_info *dpyinfo) x_dnd_return_frame_object = x_any_window_to_frame (dpyinfo, target); x_dnd_return_frame = 3; + x_dnd_waiting_for_finish = false; + target = None; } x_dnd_action = None; @@ -11018,7 +11184,7 @@ x_dnd_update_state (struct x_display_info *dpyinfo) x_dnd_wanted_action); } /* The pointer moved out of the screen. */ - else if (x_dnd_last_protocol_version) + else if (x_dnd_last_protocol_version != -1) { if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1) @@ -11028,6 +11194,7 @@ x_dnd_update_state (struct x_display_info *dpyinfo) x_dnd_end_window = x_dnd_last_seen_window; x_dnd_last_seen_window = None; x_dnd_in_progress = false; + x_dnd_waiting_for_finish = false; x_dnd_frame = NULL; } } @@ -11464,6 +11631,65 @@ handle_one_xevent (struct x_display_info *dpyinfo, break; case PropertyNotify: + if (x_dnd_in_progress && x_dnd_use_toplevels + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame) + && event->xproperty.atom == dpyinfo->Xatom_wm_state) + { + struct x_client_list_window *tem, *last; + + for (last = NULL, tem = x_dnd_toplevels; tem; + last = tem, tem = tem->next) + { + if (tem->window == event->xproperty.window) + { + Atom actual_type; + int actual_format, rc; + unsigned long nitems, bytesafter; + unsigned char *data = NULL; + + + if (event->xproperty.state == PropertyDelete) + { + if (!last) + x_dnd_toplevels = tem->next; + else + last->next = tem->next; + +#ifdef HAVE_XSHAPE + if (tem->n_input_rects != -1) + xfree (tem->input_rects); + if (tem->n_bounding_rects != -1) + xfree (tem->bounding_rects); +#endif + xfree (tem); + } + else + { + x_catch_errors (dpyinfo->display); + rc = XGetWindowProperty (dpyinfo->display, + event->xproperty.window, + dpyinfo->Xatom_wm_state, + 0, 2, False, AnyPropertyType, + &actual_type, &actual_format, + &nitems, &bytesafter, &data); + + if (!x_had_errors_p (dpyinfo->display) && rc == Success && data + && nitems == 2 && actual_format == 32) + { + tem->wm_state = ((unsigned long *) data)[0]; + XFree (data); + } + else + tem->wm_state = WithdrawnState; + x_uncatch_errors_after_check (); + } + + x_dnd_update_state (dpyinfo); + break; + } + } + } + f = x_top_window_to_frame (dpyinfo, event->xproperty.window); if (f && event->xproperty.atom == dpyinfo->Xatom_net_wm_state) { @@ -11697,14 +11923,15 @@ handle_one_xevent (struct x_display_info *dpyinfo, break; case UnmapNotify: - if (x_dnd_in_progress && x_dnd_use_toplevels) + if (x_dnd_in_progress && x_dnd_use_toplevels + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) { for (struct x_client_list_window *tem = x_dnd_toplevels; tem; tem = tem->next) { - if (tem->window == event->xmap.window) + if (tem->window == event->xunmap.window) { - tem->visible_p = false; + tem->mapped_p = false; break; } } @@ -11758,14 +11985,15 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (x_dnd_in_progress) x_dnd_update_state (dpyinfo); - if (x_dnd_in_progress && x_dnd_use_toplevels) + if (x_dnd_in_progress && x_dnd_use_toplevels + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) { for (struct x_client_list_window *tem = x_dnd_toplevels; tem; tem = tem->next) { if (tem->window == event->xmap.window) { - tem->visible_p = true; + tem->mapped_p = true; break; } } @@ -12389,10 +12617,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, { if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1 - && x_dnd_last_seen_window != FRAME_X_WINDOW (x_dnd_frame)) + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); - if (x_dnd_last_seen_window == FRAME_X_WINDOW (x_dnd_frame) + if (target != FRAME_OUTER_WINDOW (x_dnd_frame) && x_dnd_return_frame == 1) x_dnd_return_frame = 2; @@ -12405,6 +12633,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_dnd_return_frame_object = x_any_window_to_frame (dpyinfo, target); x_dnd_return_frame = 3; + x_dnd_waiting_for_finish = false; + target = None; } x_dnd_action = None; @@ -12547,7 +12777,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, configureEvent = next_event; } - if (x_dnd_in_progress && x_dnd_use_toplevels) + if (x_dnd_in_progress && x_dnd_use_toplevels + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) { int rc, dest_x, dest_y; Window child; @@ -12589,6 +12820,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, else last->next = tem->next; +#ifdef HAVE_XSHAPE + if (tem->n_input_rects != -1) + xfree (tem->input_rects); + if (tem->n_bounding_rects != -1) + xfree (tem->bounding_rects); +#endif xfree (tem); } @@ -13699,20 +13936,24 @@ handle_one_xevent (struct x_display_info *dpyinfo, { if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1 - && x_dnd_last_seen_window != FRAME_X_WINDOW (x_dnd_frame)) + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); - if (x_dnd_last_seen_window == FRAME_X_WINDOW (x_dnd_frame) + if (target != FRAME_OUTER_WINDOW (x_dnd_frame) && x_dnd_return_frame == 1) x_dnd_return_frame = 2; if (x_dnd_return_frame == 2 && x_any_window_to_frame (dpyinfo, target)) { + x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_last_seen_window = None; x_dnd_in_progress = false; x_dnd_return_frame_object = x_any_window_to_frame (dpyinfo, target); x_dnd_return_frame = 3; + x_dnd_waiting_for_finish = false; + target = None; } x_dnd_action = None; @@ -15043,7 +15284,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, default: #ifdef HAVE_XKB - if (event->type == dpyinfo->xkb_event_type) + if (dpyinfo->supports_xkb + && event->type == dpyinfo->xkb_event_type) { XkbEvent *xkbevent = (XkbEvent *) event; @@ -15088,6 +15330,109 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_find_modifier_meanings (dpyinfo); } } +#endif +#ifdef HAVE_XSHAPE + if (dpyinfo->xshape_supported_p + && event->type == dpyinfo->xshape_event_base + ShapeNotify + && x_dnd_in_progress && x_dnd_use_toplevels + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) + { + XEvent xevent; + XShapeEvent *xse = (XShapeEvent *) event; + XRectangle *rects; + int rc, ordering; + + while (XPending (dpyinfo->display)) + { + XNextEvent (dpyinfo->display, &xevent); + + if (xevent.type == dpyinfo->xshape_event_base + ShapeNotify + && ((XShapeEvent *) &xevent)->window == xse->window) + xse = (XShapeEvent *) &xevent; + else + { + XPutBackEvent (dpyinfo->display, &xevent); + break; + } + } + + for (struct x_client_list_window *tem = x_dnd_toplevels; tem; + tem = tem->next) + { + if (tem->window == xse->window) + { + if (tem->n_input_rects != -1) + xfree (tem->input_rects); + if (tem->n_bounding_rects != -1) + xfree (tem->bounding_rects); + + tem->n_input_rects = -1; + tem->n_bounding_rects = -1; + + x_catch_errors (dpyinfo->display); + rects = XShapeGetRectangles (dpyinfo->display, + xse->window, + ShapeBounding, + &count, &ordering); + rc = x_had_errors_p (dpyinfo->display); + x_uncatch_errors_after_check (); + + /* Does XShapeGetRectangles allocate anything upon an + error? */ + if (!rc) + { + tem->n_bounding_rects = count; + tem->bounding_rects + = xmalloc (sizeof *tem->bounding_rects * count); + memcpy (tem->bounding_rects, rects, + sizeof *tem->bounding_rects * count); + + XFree (rects); + } + +#ifdef ShapeInput + if (dpyinfo->xshape_major > 1 + || (dpyinfo->xshape_major == 1 + && dpyinfo->xshape_minor >= 1)) + { + x_catch_errors (dpyinfo->display); + rects = XShapeGetRectangles (dpyinfo->display, + xse->window, ShapeInput, + &count, &ordering); + rc = x_had_errors_p (dpyinfo->display); + x_uncatch_errors_after_check (); + + /* Does XShapeGetRectangles allocate anything upon + an error? */ + if (!rc) + { + tem->n_input_rects = count; + tem->input_rects + = xmalloc (sizeof *tem->input_rects * count); + memcpy (tem->input_rects, rects, + sizeof *tem->input_rects * count); + + XFree (rects); + } + } +#endif + + /* Handle the common case where the input shape equals the + bounding shape. */ + + if (tem->n_input_rects != -1 + && tem->n_bounding_rects == tem->n_input_rects + && !memcmp (tem->bounding_rects, tem->input_rects, + tem->n_input_rects * sizeof *tem->input_rects)) + { + xfree (tem->input_rects); + tem->n_input_rects = -1; + } + + break; + } + } + } #endif OTHER: #ifdef USE_X_TOOLKIT @@ -19011,6 +19356,19 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) &dpyinfo->composite_minor); #endif +#ifdef HAVE_XSHAPE + dpyinfo->xshape_supported_p + = XShapeQueryExtension (dpyinfo->display, + &dpyinfo->xshape_event_base, + &dpyinfo->xshape_error_base); + + if (dpyinfo->xshape_supported_p) + dpyinfo->xshape_supported_p + = XShapeQueryVersion (dpyinfo->display, + &dpyinfo->xshape_major, + &dpyinfo->xshape_minor); +#endif + /* Put the rdb where we can find it in a way that works on all versions. */ dpyinfo->rdb = xrdb; @@ -19391,6 +19749,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) ATOM_REFS_INIT ("WM_SAVE_YOURSELF", Xatom_wm_save_yourself) ATOM_REFS_INIT ("WM_DELETE_WINDOW", Xatom_wm_delete_window) ATOM_REFS_INIT ("WM_CHANGE_STATE", Xatom_wm_change_state) + ATOM_REFS_INIT ("WM_STATE", Xatom_wm_state) ATOM_REFS_INIT ("WM_CONFIGURE_DENIED", Xatom_wm_configure_denied) ATOM_REFS_INIT ("WM_MOVED", Xatom_wm_window_moved) ATOM_REFS_INIT ("WM_CLIENT_LEADER", Xatom_wm_client_leader) diff --git a/src/xterm.h b/src/xterm.h index 4a71968b04..5a7b09925e 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -396,6 +396,7 @@ struct x_display_info /* Atom for indicating window state to the window manager. */ Atom Xatom_wm_change_state; + Atom Xatom_wm_state; /* Other WM communication */ Atom Xatom_wm_configure_denied; /* When our config request is denied */ @@ -644,6 +645,14 @@ struct x_display_info int composite_major; int composite_minor; #endif + +#ifdef HAVE_XSHAPE + bool xshape_supported_p; + int xshape_major; + int xshape_minor; + int xshape_event_base; + int xshape_error_base; +#endif }; #ifdef HAVE_X_I18N commit 9d2dcd184125320014aee9cfa5dd72ebab107778 Merge: b4fc5bedb8 d3d6f1c9bd Author: Stefan Kangas Date: Fri Mar 25 06:30:16 2022 +0100 Merge from origin/emacs-28 d3d6f1c9bd Clarify the description of "selected tags table" commit b4fc5bedb8fa3fbc48731da6fced2ba04efad449 Author: Po Lu Date: Fri Mar 25 11:09:43 2022 +0800 Use _NET_CLIENT_LIST_STACKING to optimize drag and drop window discovery * src/xterm.c (struct x_client_list_window): New struct. (x_dnd_free_toplevels, x_dnd_compute_toplevels) (x_dnd_get_target_window_1): New functions. (x_dnd_get_target_window): Search in the toplevel list if it exists. (x_dnd_cleanup_drag_and_drop): Clean up toplevel list. (x_dnd_begin_drag_and_drop): Compute toplevel list if the window manager supports it. (handle_one_xevent): Update the toplevel list if prudent. diff --git a/src/xterm.c b/src/xterm.c index 7a16704d6e..0267ba7ec1 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -820,11 +820,140 @@ static struct frame *x_dnd_frame; static XWindowAttributes x_dnd_old_window_attrs; static bool x_dnd_unwind_flag; +struct x_client_list_window +{ + Window window; + Display *dpy; + int x, y; + int width, height; + bool visible_p; + long previous_event_mask; + + struct x_client_list_window *next; +}; + +static struct x_client_list_window *x_dnd_toplevels = NULL; +static bool x_dnd_use_toplevels; + +static void +x_dnd_free_toplevels (void) +{ + struct x_client_list_window *last; + struct x_client_list_window *tem = x_dnd_toplevels; + + while (tem) + { + last = tem; + tem = tem->next; + + x_catch_errors (last->dpy); + XSelectInput (last->dpy, last->window, + last->previous_event_mask); + x_uncatch_errors (); + xfree (last); + } + + x_dnd_toplevels = NULL; +} + +static int +x_dnd_compute_toplevels (struct x_display_info *dpyinfo) +{ + Atom type; + Window *toplevels, child; + int format, rc, dest_x, dest_y; + unsigned long nitems, bytes_after; + unsigned char *data = NULL; + unsigned long i; + XWindowAttributes attrs; + struct x_client_list_window *tem; + + rc = XGetWindowProperty (dpyinfo->display, dpyinfo->root_window, + dpyinfo->Xatom_net_client_list_stacking, + 0, LONG_MAX, False, XA_WINDOW, &type, + &format, &nitems, &bytes_after, &data); + + if (rc != Success) + return 1; + + if (format != 32 || type != XA_WINDOW) + { + XFree (data); + return 1; + } + + toplevels = (Window *) data; + + /* Actually right because _NET_CLIENT_LIST_STACKING has bottom-up + order. */ + for (i = 0; i < nitems; ++i) + { + x_catch_errors (dpyinfo->display); + rc = (XGetWindowAttributes (dpyinfo->display, + toplevels[i], &attrs) + && !x_had_errors_p (dpyinfo->display)); + + if (rc) + rc = (XTranslateCoordinates (dpyinfo->display, toplevels[i], + attrs.root, -attrs.border_width, + -attrs.border_width, &dest_x, + &dest_y, &child) + && !x_had_errors_p (dpyinfo->display)); + x_uncatch_errors_after_check (); + + if (rc) + { + tem = xmalloc (sizeof *tem); + tem->window = toplevels[i]; + tem->dpy = dpyinfo->display; + tem->x = dest_x; + tem->y = dest_y; + tem->width = attrs.width + attrs.border_width; + tem->height = attrs.height + attrs.border_width; + tem->visible_p = (attrs.map_state == IsViewable); + tem->next = x_dnd_toplevels; + tem->previous_event_mask = attrs.your_event_mask; + + x_catch_errors (dpyinfo->display); + XSelectInput (dpyinfo->display, toplevels[i], + attrs.your_event_mask | StructureNotifyMask); + x_uncatch_errors (); + + x_dnd_toplevels = tem; + } + } + + return 0; +} + #define X_DND_SUPPORTED_VERSION 5 static int x_dnd_get_window_proto (struct x_display_info *, Window); static Window x_dnd_get_window_proxy (struct x_display_info *, Window); +static Window +x_dnd_get_target_window_1 (struct x_display_info *dpyinfo, + int root_x, int root_y) +{ + struct x_client_list_window *tem; + + /* Loop through x_dnd_toplevels until we find the toplevel where + root_x and root_y are. */ + + for (tem = x_dnd_toplevels; tem; tem = tem->next) + { + if (!tem->visible_p) + continue; + + if (root_x >= tem->x && root_y >= tem->y + && root_x < tem->x + tem->width + && root_y < tem->y + tem->height) + return tem->window; + } + + return None; +} + static Window x_dnd_get_target_window (struct x_display_info *dpyinfo, int root_x, int root_y, int *proto_out) @@ -841,6 +970,76 @@ x_dnd_get_target_window (struct x_display_info *dpyinfo, proto = -1; + if (x_dnd_use_toplevels) + { + child = x_dnd_get_target_window_1 (dpyinfo, root_x, root_y); + + if (child != None) + { + proxy = x_dnd_get_window_proxy (dpyinfo, child_return); + + if (proxy != None) + { + proto = x_dnd_get_window_proto (dpyinfo, proxy); + + if (proto != -1) + { + *proto_out = proto; + return proxy; + } + } + + *proto_out = x_dnd_get_window_proto (dpyinfo, child); + return child; + } + + /* Then look at the composite overlay window. */ +#if defined HAVE_XCOMPOSITE && (XCOMPOSITE_MAJOR > 0 || XCOMPOSITE_MINOR > 2) + if (dpyinfo->composite_supported_p + && (dpyinfo->composite_major > 0 + || dpyinfo->composite_minor > 2)) + { + if (XGetSelectionOwner (dpyinfo->display, + dpyinfo->Xatom_NET_WM_CM_Sn) != None) + { + x_catch_errors (dpyinfo->display); + overlay_window = XCompositeGetOverlayWindow (dpyinfo->display, + dpyinfo->root_window); + XCompositeReleaseOverlayWindow (dpyinfo->display, + dpyinfo->root_window); + if (!x_had_errors_p (dpyinfo->display)) + { + XGetWindowAttributes (dpyinfo->display, overlay_window, &attrs); + + if (attrs.map_state == IsViewable) + { + proxy = x_dnd_get_window_proxy (dpyinfo, overlay_window); + + if (proxy != None) + { + proto = x_dnd_get_window_proto (dpyinfo, proxy); + + if (proto != -1) + { + *proto_out = proto; + x_uncatch_errors_after_check (); + + return proxy; + } + } + } + } + x_uncatch_errors_after_check (); + } + } +#endif + + /* No toplevel was found and the overlay window was not a proxy, + so return None. */ + *proto_out = -1; + return None; + } + /* Not strictly necessary, but satisfies GCC. */ child = dpyinfo->root_window; @@ -1005,7 +1204,7 @@ x_dnd_get_window_proto (struct x_display_info *dpyinfo, Window wdesc) unsigned long n, left; bool had_errors; - if (wdesc == None || wdesc == FRAME_X_WINDOW (x_dnd_frame)) + if (wdesc == None || wdesc == FRAME_OUTER_WINDOW (x_dnd_frame)) return -1; x_catch_errors (dpyinfo->display); @@ -1182,6 +1381,9 @@ x_dnd_cleanup_drag_and_drop (void *frame) x_dnd_waiting_for_finish = false; + if (x_dnd_use_toplevels) + x_dnd_free_toplevels (); + FRAME_DISPLAY_INFO (f)->grabbed = 0; #ifdef USE_GTK current_hold_quit = NULL; @@ -7036,6 +7238,18 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, x_dnd_return_frame = 0; x_dnd_waiting_for_finish = false; x_dnd_end_window = None; + x_dnd_use_toplevels + = x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_client_list_stacking); + x_dnd_toplevels = NULL; + + if (x_dnd_use_toplevels) + { + if (x_dnd_compute_toplevels (FRAME_DISPLAY_INFO (f))) + { + x_dnd_free_toplevels (); + x_dnd_use_toplevels = false; + } + } if (return_frame_p) x_dnd_return_frame = 1; @@ -7128,6 +7342,9 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, x_dnd_waiting_for_finish = false; } + if (x_dnd_use_toplevels) + x_dnd_free_toplevels (); + FRAME_DISPLAY_INFO (f)->grabbed = 0; #ifdef USE_GTK current_hold_quit = NULL; @@ -7162,6 +7379,8 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, return action; } + if (x_dnd_use_toplevels) + x_dnd_free_toplevels (); FRAME_DISPLAY_INFO (f)->grabbed = 0; /* Emacs can't respond to DND events inside the nested event @@ -11292,8 +11511,22 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (event->xproperty.window == dpyinfo->root_window && (event->xproperty.atom == dpyinfo->Xatom_net_client_list_stacking || event->xproperty.atom == dpyinfo->Xatom_net_current_desktop) - && x_dnd_in_progress) - x_dnd_update_state (dpyinfo); + && x_dnd_in_progress + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) + { + if (x_dnd_use_toplevels) + { + x_dnd_free_toplevels (); + + if (x_dnd_compute_toplevels (dpyinfo)) + { + x_dnd_free_toplevels (); + x_dnd_use_toplevels = false; + } + } + + x_dnd_update_state (dpyinfo); + } x_handle_property_notify (&event->xproperty); xft_settings_event (dpyinfo, event); @@ -11464,6 +11697,19 @@ handle_one_xevent (struct x_display_info *dpyinfo, break; case UnmapNotify: + if (x_dnd_in_progress && x_dnd_use_toplevels) + { + for (struct x_client_list_window *tem = x_dnd_toplevels; tem; + tem = tem->next) + { + if (tem->window == event->xmap.window) + { + tem->visible_p = false; + break; + } + } + } + /* Redo the mouse-highlight after the tooltip has gone. */ if (event->xunmap.window == tip_window) { @@ -11511,6 +11757,20 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (x_dnd_in_progress) x_dnd_update_state (dpyinfo); + + if (x_dnd_in_progress && x_dnd_use_toplevels) + { + for (struct x_client_list_window *tem = x_dnd_toplevels; tem; + tem = tem->next) + { + if (tem->window == event->xmap.window) + { + tem->visible_p = true; + break; + } + } + } + /* We use x_top_window_to_frame because map events can come for sub-windows and they don't mean that the frame is visible. */ @@ -12287,6 +12547,56 @@ handle_one_xevent (struct x_display_info *dpyinfo, configureEvent = next_event; } + if (x_dnd_in_progress && x_dnd_use_toplevels) + { + int rc, dest_x, dest_y; + Window child; + struct x_client_list_window *tem, *last = NULL; + + for (tem = x_dnd_toplevels; tem; last = tem, tem = tem->next) + { + /* Not completely right, since the parent could be + unmapped, but good enough. */ + + if (tem->window == configureEvent.xconfigure.window) + { + x_catch_errors (dpyinfo->display); + rc = (XTranslateCoordinates (dpyinfo->display, + configureEvent.xconfigure.window, + dpyinfo->root_window, + -configureEvent.xconfigure.border_width, + -configureEvent.xconfigure.border_width, + &dest_x, &dest_y, &child) + && !x_had_errors_p (dpyinfo->display)); + x_uncatch_errors_after_check (); + + if (rc) + { + tem->x = dest_x; + tem->y = dest_y; + tem->width = (configureEvent.xconfigure.width + + configureEvent.xconfigure.border_width); + tem->height = (configureEvent.xconfigure.height + + configureEvent.xconfigure.border_width); + } + else + { + /* The window was probably destroyed, so get rid + of it. */ + + if (!last) + x_dnd_toplevels = tem->next; + else + last->next = tem->next; + + xfree (tem); + } + + break; + } + } + } + #if defined HAVE_GTK3 && defined USE_TOOLKIT_SCROLL_BARS struct scroll_bar *bar = x_window_to_scroll_bar (dpyinfo->display, configureEvent.xconfigure.window, 2); commit 392d66f6f5d9962d0b0f96decbebd9db00cce1ab Author: Philip Kaludercic Date: Thu Mar 24 20:11:01 2022 +0200 Fix wrapping of 'previous-completion' at the beginning of buffer * lisp/simple.el (next-completion): Prevent an error of 'previous-completion' at the beginning of completions buffer. Also fix 'previous-completion' to wrap to the last completion. (bug#54374) diff --git a/lisp/simple.el b/lisp/simple.el index 6dd8d141ae..921fba3416 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -9168,6 +9168,13 @@ forward)." With prefix argument N, move N items (negative N means move backward)." (interactive "p") + (let ((prev (previous-single-property-change (point) 'mouse-face))) + (goto-char (cond + ((not prev) + (1- (next-single-property-change (point) 'mouse-face))) + ((/= prev (point)) + (point)) + (t prev)))) (let ((beg (point-min)) (end (point-max))) (catch 'bound (while (> n 0) @@ -9185,7 +9192,7 @@ backward)." (unless (get-text-property (point) 'mouse-face) (goto-char (next-single-property-change (point) 'mouse-face nil end))) (setq n (1- n))) - (while (< n 0) + (while (and (< n 0) (not (bobp))) (let ((prop (get-text-property (1- (point)) 'mouse-face))) ;; If in a completion, move to the start of it. (when (and prop (eq prop (get-text-property (point) 'mouse-face))) commit 71aec1d0444ab351a4f20ae1ed10dee7bc12af88 Author: Juri Linkov Date: Thu Mar 24 19:54:14 2022 +0200 Small fixes for the new feature 'second-tab' of 'completion-auto-select' * lisp/simple.el (completion-auto-select): Extend the docstring. diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index 181cade80b..dd78262aeb 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -643,12 +643,12 @@ completion list buffer, and like @code{always} when it decides whether to pop it down. @vindex completion-auto-select -The completions window can be automatically selected. To enable this -behavior, customize the user option @code{completion-auto-select} to -@code{t} and pressing @key{TAB} will switch to the completion list + The completions window can be automatically selected. To enable +this behavior, customize the user option @code{completion-auto-select} +to @code{t} and pressing @key{TAB} will switch to the completion list buffer when it pops up that buffer. If the value is -@code{second-tab}, then the first @key{TAB} will pops up the -completions list buffer and the second one will switch to it. +@code{second-tab}, then the first @key{TAB} will pop up the +completions list buffer, and the second one will switch to it. @vindex completion-cycle-threshold If @code{completion-cycle-threshold} is non-@code{nil}, completion diff --git a/etc/NEWS b/etc/NEWS index 9633a1ff6f..d26c6568b9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -585,11 +585,12 @@ value. ** Minibuffer and Completions ++++ *** The "*Completions*" buffer can now be automatically selected. To enable this behavior, customize the user option -'completion-auto-select' to t and pressing 'TAB' will switch to the -"*Completions*" buffer when it pops up that buffer. If the value is -'second-tab', then the first tab will display "*Completions*" and the +'completion-auto-select' to t, then pressing 'TAB' will switch to the +"*Completions*" buffer when it pops up that buffer. If the value is +'second-tab', then the first tab will display "*Completions*", and the second one will switch to the "*Completions*" buffer. *** New user option 'completion-wrap-movement'. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 742d39f2d2..d8df1799c9 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1413,20 +1413,20 @@ scroll the window of possible completions." (let ((window minibuffer-scroll-window)) (with-current-buffer (window-buffer window) (cond - ;; here this is possible only when second-tab, so jump now. + ;; Here this is possible only when second-tab, so jump now. (completion-auto-select (switch-to-completions)) - ;; reverse tab + ;; Reverse tab ((equal (this-command-keys) [backtab]) (if (pos-visible-in-window-p (point-min) window) - ;; If beginning is in view, scroll up to the end + ;; If beginning is in view, scroll up to the end. (set-window-point window (point-max)) ;; Else scroll down one screen. (with-selected-window window (scroll-down)))) - ;; normal tab + ;; Normal tab (t (if (pos-visible-in-window-p (point-max) window) - ;; If end is in view, scroll up to the end + ;; If end is in view, scroll up to the end. (set-window-start window (point-min) nil) ;; Else scroll down one screen. (with-selected-window window (scroll-up))))) diff --git a/lisp/simple.el b/lisp/simple.el index f229608690..6dd8d141ae 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -9145,9 +9145,13 @@ This affects the commands `next-completion' and :group 'completion) (defcustom completion-auto-select nil - "Non-nil means to automatically select the *Completions* buffer." - :type '(choice (const :tag "Select window" t) - (const :tag "Disabled" nil) + "Non-nil means to automatically select the *Completions* buffer. +When the value is t, then pressing TAB will switch to the completion list +buffer when it pops up that buffer. If the value is `second-tab', then the +first TAB will pop up the completions list buffer, and the second one will +switch to it." + :type '(choice (const :tag "Disabled" nil) + (const :tag "Select window on first tab" t) (const :tag "Select window on second-tab" second-tab)) :version "29.1" :group 'completion) @@ -9413,8 +9417,8 @@ Called from `temp-buffer-show-hook'." (insert (substitute-command-keys "In this buffer, type \\[choose-completion] to \ select the completion near point.\n\n"))))) - (if (eq completion-auto-select t) - (switch-to-completions))) + (when (eq completion-auto-select t) + (switch-to-completions))) (add-hook 'completion-setup-hook #'completion-setup-function) commit d3d6f1c9bd6e56b30534b8bede2c88b6bfb588b9 Author: Eli Zaretskii Date: Thu Mar 24 17:22:43 2022 +0200 Clarify the description of "selected tags table" * doc/emacs/maintaining.texi (Select Tags Table): Clarify the distinction between the "selected tags table" and the "current list of tags tables". (Bug#54543) diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index 7581fd83c9..0a813a85d4 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -2974,11 +2974,12 @@ etags --language=none \ @findex visit-tags-table Emacs has at any time at most one @dfn{selected} tags table. All -the commands for working with tags tables use the selected one. To -select a tags table, type @kbd{M-x visit-tags-table}, which reads the -tags table file name as an argument, with @file{TAGS} defaulting to -the first directory that contains a file named @file{TAGS} encountered -when recursively searching upward from the default directory. +the commands for working with tags tables use the selected one first. +To select a tags table, type @kbd{M-x visit-tags-table}, which reads +the tags table file name as an argument, with @file{TAGS} defaulting +to the first directory that contains a file named @file{TAGS} +encountered when recursively searching upward from the default +directory. @vindex tags-file-name Emacs does not actually read in the tags table contents until you @@ -2988,16 +2989,25 @@ variable's initial value is @code{nil}; that value tells all the commands for working with tags tables that they must ask for a tags table file name to use. - Using @code{visit-tags-table} when a tags table is already loaded -gives you a choice: you can add the new tags table to the current list -of tags tables, or start a new list. The tags commands use all the tags -tables in the current list. If you start a new list, the new tags table -is used @emph{instead} of others. If you add the new table to the -current list, it is used @emph{as well as} the others. + In addition to the selected tags table, Emacs maintains the list of +several tags tables that you use together. For example, if you are +working on a program that uses a library, you may wish to have the +tags tables of both the program and the library available, so that +Emacs could easily find identifiers from both. If the selected tags +table doesn't have the identifier or doesn't mention the source file a +tags command needs, the command will try using all the other tags +tables in the current list of tags tables. + + Using @code{visit-tags-table} to load a new tags table when another +tags table is already loaded gives you a choice: you can add the new +tags table to the current list of tags tables, or discard the current +list and start a new list. If you start a new list, the new tags +table is used @emph{instead} of others. If you add the new table to +the current list, it is used @emph{as well as} the others. @vindex tags-table-list You can specify a precise list of tags tables by setting the variable -@code{tags-table-list} to a list of strings, like this: +@code{tags-table-list} to a list of directory names, like this: @c keep this on two lines for formatting in smallbook @example commit 45978f97be89ae989ecf9e7129b88592e70a1f24 Author: Augusto Stoffel Date: Thu Mar 24 15:05:39 2022 +0000 Handle invisible text in Eldoc when calculating size Co-authored-by: João Távora * lisp/emacs-lisp/eldoc.el (eldoc--echo-area-substring, eldoc-display-in-echo-area): Take invisible text into consideration when counting lines to crop an echo-area message. (Version): Bump. diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 73713a3dec..74ffeb166d 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -5,7 +5,7 @@ ;; Author: Noah Friedman ;; Keywords: extensions ;; Created: 1995-10-06 -;; Version: 1.11.0 +;; Version: 1.11.1 ;; Package-Requires: ((emacs "26.3")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -102,7 +102,7 @@ put in the echo area. If a positive integer, the number is used directly, while a float specifies the number of lines as a proportion of the echo area frame's height. -If value is the symbol `truncate-sym-name-if-fit' t, the part of +If value is the symbol `truncate-sym-name-if-fit', the part of the doc string that represents a symbol's name may be truncated if it will enable the rest of the doc string to fit on a single line, without resizing the echo area. @@ -525,7 +525,8 @@ Helper for `eldoc-display-in-echo-area'." (goto-char (point-min)) (skip-chars-forward " \t\n") (point)) - (goto-char (line-end-position available)) + (forward-visible-line (1- available)) + (end-of-visible-line) (skip-chars-backward " \t\n"))) (truncated (save-excursion (skip-chars-forward " \t\n") @@ -535,7 +536,8 @@ Helper for `eldoc-display-in-echo-area'." ((and truncated (> available 1) eldoc-echo-area-display-truncation-message) - (goto-char (line-end-position 0)) + (forward-visible-line -1) + (end-of-visible-line) (concat (buffer-substring start (point)) (format "\n(Documentation truncated. Use `%s' to see rest)" @@ -610,7 +612,8 @@ Honor `eldoc-echo-area-use-multiline-p' and (let ((string (with-current-buffer (eldoc--format-doc-buffer docs) (buffer-substring (goto-char (point-min)) - (line-end-position 1))))) + (progn (end-of-visible-line) + (point)))))) (if (> (length string) width) ; truncation to happen (unless (eldoc--echo-area-prefer-doc-buffer-p t) (truncate-string-to-width string width)) commit 17d9830f469ac57838b04fc7e9fc0bed4f1f3191 Author: Eli Zaretskii Date: Thu Mar 24 16:55:28 2022 +0200 ; * etc/NEWS: Fix wording of a recently added entry. diff --git a/etc/NEWS b/etc/NEWS index 68eeee69cc..9633a1ff6f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -86,11 +86,14 @@ as was already the case for all the non-preloaded files. ** Emacs Sessions (Desktop) +++ -*** New option to load if locking Emacs not running locally. -The option 'desktop-load-locked-desktop' can now be set to value -'check-pid', which means to load the desktop only if the locking Emacs -process is not running on the local machine. See the "(emacs) Saving -Emacs Sessions" node in the Emacs manual for details. +*** New option to load a locked desktop if locking Emacs is not running. +The option 'desktop-load-locked-desktop' can now be set to the value +'check-pid', which means to allow loading a locked ".emacs.desktop" +file if the Emacs process which locked it is no longer running on the +local machine. This allows to avoid asking questions about locked +desktop files when the Emacs session which locked it crashes or was +otherwise interrupted and didn't exit gracefully. See the "(emacs) +Saving Emacs Sessions" node in the Emacs manual for more details. * Startup Changes in Emacs 29.1 commit 380f0443b288c68df3762ee20d78719f08dd92ff Author: Po Lu Date: Thu Mar 24 21:23:58 2022 +0800 Allow fetching events from other displays inside DND * src/xterm.c (x_dnd_begin_drag_and_drop): Get the next event from the app connection instead on Xt. diff --git a/src/xterm.c b/src/xterm.c index d271c7190d..7a16704d6e 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -7067,8 +7067,14 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, current_hold_quit = &hold_quit; #endif -#ifndef USE_GTK +#ifdef USE_GTK + gtk_main_iteration (); +#else +#ifdef USE_X_TOOLKIT + XtAppNextEvent (Xt_app_con, &next_event); +#else XNextEvent (FRAME_X_DISPLAY (f), &next_event); +#endif #ifdef HAVE_X_I18N #ifdef HAVE_XINPUT2 @@ -7091,8 +7097,6 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, handle_one_xevent (FRAME_DISPLAY_INFO (f), &next_event, &finish, &hold_quit); #endif -#else - gtk_main_iteration (); #endif if (hold_quit.kind != NO_EVENT) commit 4e0b0114f2273245a23ac8cfda190bc6e1411ac2 Author: Mauro Aranda Date: Thu Mar 24 09:41:20 2022 -0300 ; Fix filename in undigest-tests.el header diff --git a/test/lisp/mail/undigest-tests.el b/test/lisp/mail/undigest-tests.el index 24059aa349..5ad0da0fc0 100644 --- a/test/lisp/mail/undigest-tests.el +++ b/test/lisp/mail/undigest-tests.el @@ -1,4 +1,4 @@ -;;; undigest.el --- Tests for undigest.el -*- lexical-binding:t -*- +;;; undigest-tests.el --- Tests for undigest.el -*- lexical-binding:t -*- ;; Copyright (C) 2022 Free Software Foundation, Inc. commit 34c7f14668b8445e0a9bb0de2639481fc3bf6918 Author: Michael Albinus Date: Thu Mar 24 12:50:34 2022 +0100 Adapt Tramp to dired--insert-disk-space assumptions * lisp/net/tramp-sh.el (tramp-sh-handle-insert-directory): * lisp/net/tramp-smb.el (tramp-smb-handle-insert-directory): Do not modify disk space information when `dired--insert-disk-space' is available. (Bug#54512) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 7a2b884bad..fd18b3f05c 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2715,7 +2715,9 @@ The method used must be an out-of-band method." ;; Try to insert the amount of free space. (goto-char (point-min)) ;; First find the line to put it on. - (when (re-search-forward "^\\([[:space:]]*total\\)" nil t) + (when (and (re-search-forward "^\\([[:space:]]*total\\)" nil t) + ;; Emacs 29.1 or later. + (not (fboundp 'dired--insert-disk-space))) (when-let ((available (get-free-disk-space "."))) ;; Replace "total" with "total used", to avoid confusion. (replace-match "\\1 used in directory") diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 67c63e6ce7..bbc5499ae7 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -1129,7 +1129,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Insert size information. (when full-directory-p (insert - (if avail + (if (and avail + ;; Emacs 29.1 or later. + (not (fboundp 'dired--insert-disk-space))) (format "total used in directory %s available %s\n" used avail) (format "total %s\n" used)))) commit b97aa560ab225bb37cc00c385711825199687fdb Author: Lars Ingebrigtsen Date: Thu Mar 24 11:39:13 2022 +0100 Fix autoinsert.el byte compilation warning * lisp/autoinsert.el (sgml-tag): Fix a byte compilation warning. diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el index 879dc630c6..d25275e3ec 100644 --- a/lisp/autoinsert.el +++ b/lisp/autoinsert.el @@ -89,6 +89,7 @@ If this contains a %s, that will be replaced by the matching rule." :type 'string :version "28.1") +(declare-function sgml-tag "sgml-mode" (&optional str arg)) (defcustom auto-insert-alist `((("\\.\\([Hh]\\|hh\\|hpp\\|hxx\\|h\\+\\+\\)\\'" . "C / C++ header") commit 410675ce0e926dbf5a9f92a0d3de7eb2741daca7 Merge: 288ecdf90c acde5252d3 Author: Jimmy Aguilar Mena Date: Thu Mar 24 11:23:32 2022 +0100 Merge 'completion-auto-select new value secont-tab' This includes the second-tab value for completion-auto-select and documentation related. commit acde5252d37cf241a445da2eca509760727d9df6 Author: Jimmy Aguilar Mena Date: Thu Mar 24 11:05:26 2022 +0100 Add documentation entries for completion-auto-select user option. diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index ff0fa505a8..181cade80b 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -642,6 +642,14 @@ the completion. The value @code{visible} is a hybrid: it behaves like completion list buffer, and like @code{always} when it decides whether to pop it down. +@vindex completion-auto-select +The completions window can be automatically selected. To enable this +behavior, customize the user option @code{completion-auto-select} to +@code{t} and pressing @key{TAB} will switch to the completion list +buffer when it pops up that buffer. If the value is +@code{second-tab}, then the first @key{TAB} will pops up the +completions list buffer and the second one will switch to it. + @vindex completion-cycle-threshold If @code{completion-cycle-threshold} is non-@code{nil}, completion commands can cycle through completion alternatives. Normally, if diff --git a/etc/NEWS b/etc/NEWS index d979c625fd..68eeee69cc 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -584,8 +584,10 @@ value. *** The "*Completions*" buffer can now be automatically selected. To enable this behavior, customize the user option -'completion-auto-select' to t. Then pressing 'TAB' will switch to the -"*Completions*" buffer when it pops up that buffer. +'completion-auto-select' to t and pressing 'TAB' will switch to the +"*Completions*" buffer when it pops up that buffer. If the value is +'second-tab', then the first tab will display "*Completions*" and the +second one will switch to the "*Completions*" buffer. *** New user option 'completion-wrap-movement'. When non-nil, the commands 'next-completion' and 'previous-completion' commit 3a349ff6487982d9e3c427eda987aed452305d78 Author: Jimmy Aguilar Mena Date: Tue Mar 22 21:24:13 2022 +0100 Add completion-auto-select second-tab value. * lisp/minibuffer.el (completion--in-region-1) : Change if with cond and check if completion-auto-select. * lisp/simple.el (completion-auto-select) : Move before first use. (completion-setup-function) : Make a more precise check for when completion-auto-select is t. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index c4fb1c0039..742d39f2d2 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1410,18 +1410,26 @@ scroll the window of possible completions." ;; and this command is repeated, scroll that window. ((and (window-live-p minibuffer-scroll-window) (eq t (frame-visible-p (window-frame minibuffer-scroll-window)))) - (let ((window minibuffer-scroll-window) - (reverse (equal (this-command-keys) [backtab]))) + (let ((window minibuffer-scroll-window)) (with-current-buffer (window-buffer window) - (if (pos-visible-in-window-p (if reverse (point-min) (point-max)) window) - ;; If end or beginning is in view, scroll up to the - ;; beginning or end respectively. - (if reverse - (set-window-point window (point-max)) - (set-window-start window (point-min) nil)) - ;; Else scroll down one screen. - (with-selected-window window - (if reverse (scroll-down) (scroll-up)))) + (cond + ;; here this is possible only when second-tab, so jump now. + (completion-auto-select + (switch-to-completions)) + ;; reverse tab + ((equal (this-command-keys) [backtab]) + (if (pos-visible-in-window-p (point-min) window) + ;; If beginning is in view, scroll up to the end + (set-window-point window (point-max)) + ;; Else scroll down one screen. + (with-selected-window window (scroll-down)))) + ;; normal tab + (t + (if (pos-visible-in-window-p (point-max) window) + ;; If end is in view, scroll up to the end + (set-window-start window (point-min) nil) + ;; Else scroll down one screen. + (with-selected-window window (scroll-up))))) nil))) ;; If we're cycling, keep on cycling. ((and completion-cycling completion-all-sorted-completions) diff --git a/lisp/simple.el b/lisp/simple.el index 9a8ed0bb75..f229608690 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -9144,6 +9144,14 @@ This affects the commands `next-completion' and :version "29.1" :group 'completion) +(defcustom completion-auto-select nil + "Non-nil means to automatically select the *Completions* buffer." + :type '(choice (const :tag "Select window" t) + (const :tag "Disabled" nil) + (const :tag "Select window on second-tab" second-tab)) + :version "29.1" + :group 'completion) + (defun previous-completion (n) "Move to the previous item in the completion list. With prefix argument N, move back N items (negative N means move @@ -9365,12 +9373,6 @@ Called from `temp-buffer-show-hook'." :version "22.1" :group 'completion) -(defcustom completion-auto-select nil - "Non-nil means to automatically select the *Completions* buffer." - :type 'boolean - :version "29.1" - :group 'completion) - ;; This function goes in completion-setup-hook, so that it is called ;; after the text of the completion list buffer is written. (defun completion-setup-function () @@ -9411,8 +9413,8 @@ Called from `temp-buffer-show-hook'." (insert (substitute-command-keys "In this buffer, type \\[choose-completion] to \ select the completion near point.\n\n"))))) - (when completion-auto-select - (switch-to-completions))) + (if (eq completion-auto-select t) + (switch-to-completions))) (add-hook 'completion-setup-hook #'completion-setup-function) commit 288ecdf90cb971a3871f7e99e3948176ae4f0e85 Author: Stefan Monnier Date: Thu Mar 24 05:32:10 2022 -0400 * lisp/select.el (xselect-convert-to-targets): Use `delete-dups` and `delq` diff --git a/lisp/select.el b/lisp/select.el index 36452776e9..90970f989a 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -547,25 +547,18 @@ two markers or an overlay. Otherwise, it is nil." (xselect--int-to-cons len)))) (defun xselect-convert-to-targets (selection _type value) - ;; return a vector of atoms, but remove duplicates first. - (let* ((all (cons 'TIMESTAMP - (cons 'MULTIPLE - (mapcar (lambda (conv) - (if (or (not (consp (cdr conv))) - (funcall (cadr conv) selection - (car conv) value)) - (car conv) - '_EMACS_INTERNAL)) - selection-converter-alist)))) - (rest all)) - (while rest - (cond ((memq (car rest) (cdr rest)) - (setcdr rest (delq (car rest) (cdr rest)))) - ((eq (car (cdr rest)) '_EMACS_INTERNAL) - (setcdr rest (cdr (cdr rest)))) - (t - (setq rest (cdr rest))))) - (apply 'vector all))) + ;; Return a vector of atoms, but remove duplicates first. + (apply #'vector + (delete-dups + `( TIMESTAMP MULTIPLE + . ,(delq '_EMACS_INTERNAL + (mapcar (lambda (conv) + (if (or (not (consp (cdr conv))) + (funcall (cadr conv) selection + (car conv) value)) + (car conv) + '_EMACS_INTERNAL)) + selection-converter-alist)))))) (defun xselect-convert-to-delete (selection _type _value) (gui-backend-set-selection selection nil) commit f7a90cc85b470578133d6b143d2740995ad4496b Author: Stefan Monnier Date: Thu Mar 24 05:19:19 2022 -0400 * lisp/autoinsert.el (auto-insert-alist): Expose lambdas as code diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el index f60aa9be6f..879dc630c6 100644 --- a/lisp/autoinsert.el +++ b/lisp/autoinsert.el @@ -91,7 +91,7 @@ If this contains a %s, that will be replaced by the matching rule." (defcustom auto-insert-alist - '((("\\.\\([Hh]\\|hh\\|hpp\\|hxx\\|h\\+\\+\\)\\'" . "C / C++ header") + `((("\\.\\([Hh]\\|hh\\|hpp\\|hxx\\|h\\+\\+\\)\\'" . "C / C++ header") (replace-regexp-in-string "[^A-Z0-9]" "_" (string-replace @@ -113,7 +113,7 @@ If this contains a %s, that will be replaced by the matching rule." (("[Mm]akefile\\'" . "Makefile") . "makefile.inc") - (html-mode . (lambda () (sgml-tag "html"))) + (html-mode . ,(lambda () (sgml-tag "html"))) (plain-tex-mode . "tex-insert.tex") (bibtex-mode . "tex-insert.tex") @@ -128,9 +128,9 @@ If this contains a %s, that will be replaced by the matching rule." "\n\\end{document}") (("/bin/.*[^/]\\'" . "Shell-Script mode magic number") . - (lambda () - (if (eq major-mode (default-value 'major-mode)) - (sh-mode)))) + ,(lambda () + (if (eq major-mode (default-value 'major-mode)) + (sh-mode)))) (ada-mode . ada-header) @@ -171,7 +171,7 @@ If this contains a %s, that will be replaced by the matching rule." '(setq v1 (let (modes) (mapatoms (lambda (mode) (let ((name (symbol-name mode))) - (when (string-match "-mode$" name) + (when (string-match "-mode\\'" name) (push name modes))))) (sort modes 'string<))) (completing-read "Local variables for mode: " v1 nil t) @@ -210,7 +210,8 @@ If this contains a %s, that will be replaced by the matching rule." "\n")) ((let ((minibuffer-help-form v2)) (completing-read "Keyword, C-h: " v1 nil t)) - str ", ") & -2 " + str ", ") + & -2 " \;; 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 commit 774e007d90f879f8c94ab68fe588883e7e233ada Author: Stefan Monnier Date: Thu Mar 24 05:12:45 2022 -0400 (archive-*-write-file-member): Fix relative file name * lisp/arc-mode.el (archive-*-write-file-member): Set the pwd diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index 4f0edbbfa9..f1a3735d2c 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -1340,7 +1340,8 @@ NEW-NAME." t) (defun archive-*-write-file-member (archive descr command) - (let* ((ename (archive--file-desc-ext-file-name descr)) + (let* ((archive (expand-file-name archive)) + (ename (archive--file-desc-ext-file-name descr)) (tmpfile (expand-file-name ename archive-tmpdir)) (top (directory-file-name (file-name-as-directory archive-tmpdir))) (default-directory (file-name-as-directory top))) @@ -1364,6 +1365,7 @@ NEW-NAME." (setq ename (encode-coding-string ename archive-file-name-coding-system)) (let* ((coding-system-for-write 'no-conversion) + (default-directory (file-name-as-directory archive-tmpdir)) (exitcode (apply #'call-process (car command) nil commit f35dbb41cd22d20864afd266f8567bc7a80ff982 Author: Lars Ingebrigtsen Date: Thu Mar 24 10:09:47 2022 +0100 Do some NEWS tagging diff --git a/etc/NEWS b/etc/NEWS index 5ca1df4542..d979c625fd 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1201,6 +1201,7 @@ a weight of 'normal' and the font doesn't have this weight, Emacs won't find the font spec. In these cases, replacing ":weight 'normal" with ":weight 'medium" should fix the issue. +--- ** Keymap descriptions have changed. 'help--describe-command', 'C-h b' and associated functions that output keymap descriptions have changed. In particular, prefix commands are @@ -1267,6 +1268,7 @@ Use 'exif-parse-file' and 'exif-field' instead. ** 'insert-directory' alternatives should not change the free disk space line. This change is now applied in 'dired-insert-directory'. +--- ** Some functions and variables obsolete since Emacs 23 have been removed: 'find-emacs-lisp-shadows', 'newsticker-cache-filename', 'unify-8859-on-decoding-mode', 'unify-8859-on-encoding-mode', @@ -1587,6 +1589,7 @@ values passed as a single token, such as '-oVALUE' or '--option=VALUE'. ** XDG support +--- *** New function 'xdg-state-home' returns 'XDG_STATE_HOME' environment variable. This new location, introduced in the XDG Base Directory Specification version 0.8 (8th May 2021), "contains state data that should persist @@ -1749,6 +1752,7 @@ that should be displayed, and the xwidget that asked to display it. This function is used to control where and if an xwidget stores cookies set by web pages on disk. +--- ** New variable 'help-buffer-under-preparation'. This variable is bound to t during the preparation of a "*Help*" buffer. commit f09e68e1806904709adf4003146638aee718b980 Author: Po Lu Date: Thu Mar 24 16:59:03 2022 +0800 Avoid crashes if async input arrives when setting properties for DND * src/xterm.c (x_dnd_begin_drag_and_drop): Block input around non-async signal safe functions. diff --git a/src/xterm.c b/src/xterm.c index 33165c27a7..d271c7190d 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -7001,6 +7001,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, prop.format = 8; prop.nitems = end; + block_input (); XSetTextProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), &prop, FRAME_DISPLAY_INFO (f)->Xatom_XdndActionDescription); xfree (ask_actions); @@ -7009,6 +7010,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, FRAME_DISPLAY_INFO (f)->Xatom_XdndActionList, XA_ATOM, 32, PropModeReplace, (unsigned char *) ask_action_list, n_ask_actions); + unblock_input (); } else { @@ -7016,10 +7018,12 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, and not the action to decide whether or not the user should be prompted to select an action. */ + block_input (); XDeleteProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), FRAME_DISPLAY_INFO (f)->Xatom_XdndActionList); XDeleteProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), FRAME_DISPLAY_INFO (f)->Xatom_XdndActionDescription); + unblock_input (); } x_dnd_in_progress = true; commit 9856290806a449d35380135adabd607b6612dd98 Author: Lars Ingebrigtsen Date: Thu Mar 24 09:59:40 2022 +0100 Mention frame-text-* function in frame-pixel-* doc strings * src/frame.c (Fframe_native_width, Fframe_native_height): Link to `frame-text-*' functions. diff --git a/src/frame.c b/src/frame.c index 8f8df8f8e0..e531891a8a 100644 --- a/src/frame.c +++ b/src/frame.c @@ -3495,7 +3495,10 @@ DEFUN ("frame-native-width", Fframe_native_width, Sframe_native_width, 0, 1, 0, doc: /* Return FRAME's native width in pixels. For a terminal frame, the result really gives the width in characters. -If FRAME is omitted or nil, the selected frame is used. */) +If FRAME is omitted or nil, the selected frame is used. + +If you're interested only in the width of the text portion of the +frame, see `frame-text-width' instead. */) (Lisp_Object frame) { struct frame *f = decode_any_frame (frame); @@ -3519,6 +3522,9 @@ minibuffer or echo area), mode line, and header line. It does not include the tool bar or menu bar. With other graphical versions, it may also include the tool bar and the menu bar. +If you're interested only in the height of the text portion of the +frame, see `frame-text-height' instead. + For a text terminal, it includes the menu bar. In this case, the result is really in characters rather than pixels (i.e., is identical to `frame-height'). */) commit 0e739909abb679812484e2ddbe8483eb2dd5c815 Author: Lars Ingebrigtsen Date: Thu Mar 24 09:54:38 2022 +0100 Fix image-mode-fit-frame some more * lisp/image-mode.el (image-mode-fit-frame): Use frame-text-width and fit-frame-to-buffer instead of computing things ourselves (bug#37630). This makes things work better across platforms. diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 863d014cdc..d7dfb4336b 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -419,12 +419,10 @@ window configuration prior to the last `image-mode-fit-frame' call." (interactive (list nil t)) (let* ((buffer (current-buffer)) - (display (image-get-display-property)) - (size (image-display-size display t)) (saved (frame-parameter frame 'image-mode-saved-params)) (window-configuration (current-window-configuration frame)) - (frame-width (frame-pixel-width frame)) - (frame-height (frame-pixel-height frame))) + (frame-width (frame-text-width frame)) + (frame-height (frame-text-height frame))) (with-selected-frame (or frame (selected-frame)) (if (and toggle saved (= (caar saved) frame-width) @@ -436,24 +434,16 @@ call." (set-frame-parameter frame 'image-mode-saved-params nil)) (delete-other-windows) (switch-to-buffer buffer t t) - (let* ((edges (window-inside-pixel-edges)) - (inner-width (- (nth 2 edges) (nth 0 edges))) - (inner-height (- (nth 3 edges) (nth 1 edges)))) - (set-frame-width frame (+ (ceiling (car size)) - (- frame-width inner-width)) - nil t) - (set-frame-height frame (+ (ceiling (cdr size)) - (- frame-height inner-height)) - nil t) - ;; The frame size after the above `set-frame-*' calls may - ;; differ from what we specified, due to window manager - ;; interference. We have to call `frame-width' and - ;; `frame-height' to get the actual results. - (set-frame-parameter frame 'image-mode-saved-params - (list (cons (frame-pixel-width frame) - (frame-pixel-height frame)) - (cons frame-width frame-height) - window-configuration))))))) + (fit-frame-to-buffer frame) + ;; The frame size after the above `set-frame-*' calls may + ;; differ from what we specified, due to window manager + ;; interference. We have to call `frame-width' and + ;; `frame-height' to get the actual results. + (set-frame-parameter frame 'image-mode-saved-params + (list (cons (frame-text-width frame) + (frame-text-height frame)) + (cons frame-width frame-height) + window-configuration)))))) ;;; Image Mode setup commit cae187e430dc01a46ff719257368c7166eaa8ad1 Author: Po Lu Date: Thu Mar 24 16:36:47 2022 +0800 Fix some bugs with drag and drop and Mozilla * src/xfns.c (Fx_begin_drag): Call maybe_quit when iterating through potentially long lists. Also allow specifying XdndActionAsk manually again, since it's useful for debugging. * src/xterm.c (x_dnd_begin_drag_and_drop): Delete XdndActionList and XdndActionDescription if they were not specified. diff --git a/src/xfns.c b/src/xfns.c index c4b924e007..52649b38dd 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -6643,10 +6643,14 @@ instead. */) for (; CONSP (targets); targets = XCDR (targets)) { CHECK_STRING (XCAR (targets)); + maybe_quit (); if (ntargets < 2048) { - target_names[ntargets] = SSDATA (XCAR (targets)); + scratch = SSDATA (XCAR (targets)); + len = strlen (scratch); + target_names[ntargets] = SAFE_ALLOCA (len + 1); + strncpy (target_names[ntargets], scratch, len + 1);; ntargets++; } else @@ -6663,6 +6667,8 @@ instead. */) xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionLink; else if (EQ (action, QXdndActionPrivate)) xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionPrivate; + else if (EQ (action, QXdndActionAsk)) + xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionAsk; else if (CONSP (action)) { xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionAsk; @@ -6671,6 +6677,7 @@ instead. */) CHECK_LIST (action); for (; CONSP (action); action = XCDR (action)) { + maybe_quit (); tem = XCAR (action); CHECK_CONS (tem); t1 = XCAR (tem); @@ -6686,6 +6693,8 @@ instead. */) action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionMove; else if (EQ (t1, QXdndActionLink)) action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionLink; + else if (EQ (t1, QXdndActionAsk)) + action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionAsk; else if (EQ (t1, QXdndActionPrivate)) action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionPrivate; else diff --git a/src/xterm.c b/src/xterm.c index fcc1f55ccb..33165c27a7 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -7010,6 +7010,17 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, PropModeReplace, (unsigned char *) ask_action_list, n_ask_actions); } + else + { + /* Delete those two properties, since some clients look at them + and not the action to decide whether or not the user should + be prompted to select an action. */ + + XDeleteProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + FRAME_DISPLAY_INFO (f)->Xatom_XdndActionList); + XDeleteProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + FRAME_DISPLAY_INFO (f)->Xatom_XdndActionDescription); + } x_dnd_in_progress = true; x_dnd_frame = f; commit b4f504a0ea90eb7fed2f3c0291d0eab43ef483d6 Author: Stefan Kangas Date: Thu Mar 24 09:23:31 2022 +0100 Load desktop without prompting if process is dead * doc/emacs/misc.texi (Saving Emacs Sessions): Document the new 'check' value. * etc/NEWS: Announce the change (bug#1474). * lisp/desktop.el (desktop-load-locked-desktop): Add new value 'check' to load desktop file without prompting if locking Emacs process does not exist on the local machine. (Bug#1474) (desktop-read): Extract function from here... (desktop--load-locked-desktop-p): ...to here. New function handles the semantics of 'desktop-load-locked-desktop', including above new value 'check'. (desktop--emacs-pid-running-p): New function. * test/lisp/desktop-tests.el: New file with tests for the above. diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index 4710c05b62..a0d79711f1 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -2770,7 +2770,12 @@ will by default ask you whether to use the locked desktop file. You can avoid the question by customizing the variable @code{desktop-load-locked-desktop} to either @code{nil}, which means never load the desktop in this case, or @code{t}, which means load the -desktop without asking. +desktop without asking. Finally, the @code{check-pid} value means to +load the file if the Emacs process that has locked the desktop is not +running on the local machine. This should not be used in +circumstances where the locking Emacs might still be running on +another machine. This could be the case in multi-user environments +where your home directory is mounted remotely using NFS or similar. @cindex desktop restore in daemon mode When Emacs starts in daemon mode, it cannot ask you any questions, diff --git a/etc/NEWS b/etc/NEWS index ad0f7f1c05..5ca1df4542 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -83,6 +83,15 @@ input of sequences such as 'C-;' and 'C-S-u'. Instead, they're fetched as needed from the corresponding ".elc" file, as was already the case for all the non-preloaded files. +** Emacs Sessions (Desktop) + ++++ +*** New option to load if locking Emacs not running locally. +The option 'desktop-load-locked-desktop' can now be set to value +'check-pid', which means to load the desktop only if the locking Emacs +process is not running on the local machine. See the "(emacs) Saving +Emacs Sessions" node in the Emacs manual for details. + * Startup Changes in Emacs 29.1 diff --git a/lisp/desktop.el b/lisp/desktop.el index e7a368e21f..773f0f050f 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -230,16 +230,26 @@ Zero or nil means disable auto-saving due to idleness." (defcustom desktop-load-locked-desktop 'ask "Specifies whether the desktop should be loaded if locked. Possible values are: - t -- load anyway. - nil -- don't load. - ask -- ask the user. -If the value is nil, or `ask' and the user chooses not to load the desktop, -the normal hook `desktop-not-loaded-hook' is run." + t -- load anyway. + nil -- don't load. + ask -- ask the user. + check-pid -- load if locking Emacs process is missing locally. + +If the value is nil, or `ask' and the user chooses not to load +the desktop, the normal hook `desktop-not-loaded-hook' is run. + +If the value is `check-pid', load the desktop if the Emacs +process that has locked it is not running on the local machine. +This should not be used in circumstances where the locking Emacs +might still be running on another machine. That could be the +case if you have remotely mounted (NFS) paths in +`desktop-dirname'." :type '(choice (const :tag "Load anyway" t) (const :tag "Don't load" nil) - (const :tag "Ask the user" ask)) + (const :tag "Ask the user" ask) + (const :tag "Load if no local process" check-pid)) :group 'desktop :version "22.2") @@ -662,6 +672,28 @@ DIRNAME omitted or nil means use `desktop-dirname'." (integerp owner))) owner))) +(defun desktop--emacs-pid-running-p (pid) + "Return t if an Emacs process with PID exists." + (when-let ((attr (process-attributes pid))) + (equal (alist-get 'comm attr) + (file-name-nondirectory (car command-line-args))))) + +(defun desktop--load-locked-desktop-p (owner) + "Return t if a locked desktop should be loaded. +OWNER is the pid in the lock file. +The return value of this function depends on the value of +`desktop-load-locked-desktop'." + (pcase desktop-load-locked-desktop + ('ask + (unless (daemonp) + (y-or-n-p (format "Warning: desktop file appears to be in use by PID %s.\n\ +Using it may cause conflicts. Use it anyway? " owner)))) + ('check-pid + (or (eq (emacs-pid) owner) + (not (desktop--emacs-pid-running-p owner)))) + ('nil nil) + (_ t))) + (defun desktop-claim-lock (&optional dirname) "Record this Emacs process as the owner of the desktop file in DIRNAME. DIRNAME omitted or nil means use `desktop-dirname'." @@ -1263,11 +1295,7 @@ It returns t if a desktop file was loaded, nil otherwise. (desktop-save nil) (desktop-autosave-was-enabled)) (if (and owner - (memq desktop-load-locked-desktop '(nil ask)) - (or (null desktop-load-locked-desktop) - (daemonp) - (not (y-or-n-p (format "Warning: desktop file appears to be in use by PID %s.\n\ -Using it may cause conflicts. Use it anyway? " owner))))) + (not (desktop--load-locked-desktop-p owner))) (let ((default-directory desktop-dirname)) (setq desktop-dirname nil) (run-hooks 'desktop-not-loaded-hook) diff --git a/test/lisp/desktop-tests.el b/test/lisp/desktop-tests.el new file mode 100644 index 0000000000..d52fe39ed9 --- /dev/null +++ b/test/lisp/desktop-tests.el @@ -0,0 +1,50 @@ +;;; desktop-tests.el --- Tests for desktop.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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 . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'desktop) + +(ert-deftest desktop-tests--emacs-pid-running-p () + (should (desktop--emacs-pid-running-p (emacs-pid))) + (should-not (desktop--emacs-pid-running-p 1))) + +(ert-deftest desktop-tests--load-locked-desktop-p () + (let ((desktop-load-locked-desktop t)) + (should (desktop--load-locked-desktop-p (emacs-pid))))) + +(ert-deftest desktop-tests--load-locked-desktop-p-nil () + (let ((desktop-load-locked-desktop nil)) + (should-not (desktop--load-locked-desktop-p (emacs-pid))))) + +(ert-deftest desktop-tests--load-locked-desktop-p-ask () + (let ((desktop-load-locked-desktop 'ask)) + (cl-letf (((symbol-function 'y-or-n-p) (lambda (&rest _) t))) + (should (desktop--load-locked-desktop-p (emacs-pid)))) + (cl-letf (((symbol-function 'y-or-n-p) (lambda (&rest _) nil))) + (should-not (desktop--load-locked-desktop-p (emacs-pid)))))) + +(ert-deftest desktop-tests--load-locked-desktop-p-check () + (let ((desktop-load-locked-desktop 'check-pid)) + (desktop--load-locked-desktop-p (emacs-pid)))) + +(provide 'desktop-tests) commit 72ab6c4f141ce249c34933d1ebc91e2491e34b3a Author: Po Lu Date: Thu Mar 24 13:50:55 2022 +0800 Fix setter for hl-line-sticky-flag when hl-line is not loaded * lisp/hl-line.el (hl-line-sticky-flag): Wrap most of setter around (featurep 'hl-line). Reported by Michael Heerdegen . diff --git a/lisp/hl-line.el b/lisp/hl-line.el index e42d1d97d9..e5ca6819f0 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el @@ -105,12 +105,13 @@ For that, use `global-hl-line-sticky-flag'." :group 'hl-line :set (lambda (symbol value) (set-default symbol value) - (unless value - (let ((selected (window-buffer (selected-window)))) - (dolist (buffer (buffer-list)) - (unless (eq buffer selected) - (with-current-buffer buffer - (hl-line-unhighlight)))))))) + (when (featurep 'hl-line) + (unless value + (let ((selected (window-buffer (selected-window)))) + (dolist (buffer (buffer-list)) + (unless (eq buffer selected) + (with-current-buffer buffer + (hl-line-unhighlight))))))))) (defcustom global-hl-line-sticky-flag nil "Non-nil means the Global HL-Line mode highlight appears in all windows. commit 97f9eeaaefebf5f3852b062535f7c041831609bd Author: Po Lu Date: Thu Mar 24 05:32:34 2022 +0000 Allow holding down scroll bar buttons on Haiku when overscrolling * src/haiku_support.cc (EmacsWindow): Set appropriate pulse rate. (class EmacsScrollBar, ValueChanged): Don't send any part events here. (MouseDown): Set dragging to a value larger than 1 if the scroll bar is at the end. (Pulse): New method. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 5ad3c7c794..b58420fcb9 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -422,6 +422,10 @@ class EmacsWindow : public BWindow B_NORMAL_WINDOW_FEEL, B_NO_SERVER_SIDE_WINDOW_MODIFIERS) { window_id = current_window_id++; + + /* This pulse rate is used by scroll bars for repeating a button + action while a button is held down. */ + SetPulseRate (30000); } ~EmacsWindow () @@ -1765,11 +1769,36 @@ class EmacsScrollBar : public BScrollBar BScrollBar::MessageReceived (msg); } + void + Pulse (void) + { + struct haiku_scroll_bar_part_event rq; + BPoint point; + uint32 buttons; + + if (!dragging) + { + SetFlags (Flags () & ~B_PULSE_NEEDED); + return; + } + + GetMouse (&point, &buttons, false); + + if (ButtonRegionFor (current_part).Contains (point)) + { + rq.scroll_bar = this; + rq.window = Window (); + rq.part = current_part; + haiku_write (SCROLL_BAR_PART_EVENT, &rq); + } + + BScrollBar::Pulse (); + } + void ValueChanged (float new_value) { struct haiku_scroll_bar_value_event rq; - struct haiku_scroll_bar_part_event part; new_value = Value (); @@ -1780,11 +1809,7 @@ class EmacsScrollBar : public BScrollBar if (dragging > 1) { SetValue (old_value); - - part.scroll_bar = this; - part.window = Window (); - part.part = current_part; - haiku_write (SCROLL_BAR_PART_EVENT, &part); + SetFlags (Flags () | B_PULSE_NEEDED); } else dragging++; @@ -1924,6 +1949,12 @@ class EmacsScrollBar : public BScrollBar dragging = 1; current_part = HAIKU_SCROLL_BAR_DOWN_BUTTON; + if (Value () == max_value) + { + SetFlags (Flags () | B_PULSE_NEEDED); + dragging = 2; + } + haiku_write (SCROLL_BAR_PART_EVENT, &part); goto out; } @@ -1967,7 +1998,7 @@ class EmacsScrollBar : public BScrollBar rq.window = Window (); haiku_write (SCROLL_BAR_DRAG_EVENT, &rq); - dragging = false; + dragging = 0; BScrollBar::MouseUp (pt); } commit ebd5725e0b2f7e1dcf6dcb068bef638edd7f0cb4 Author: Po Lu Date: Thu Mar 24 11:41:29 2022 +0800 Fix an infinite loop if the window manager pings Emacs during DND * src/xterm.c (handle_one_xevent): Work around _NET_WM_PING infinite loop during drag and drop. diff --git a/src/xterm.c b/src/xterm.c index 0543f152ed..fcc1f55ccb 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -11014,7 +11014,19 @@ handle_one_xevent (struct x_display_info *dpyinfo, send_event.xclient.window = dpyinfo->root_window; XSendEvent (dpyinfo->display, dpyinfo->root_window, False, - SubstructureRedirectMask | SubstructureNotifyMask, + /* FIXME: handling window stacking changes + during drag-and-drop requires Emacs to + select for SubstructureNotifyMask, + which in turn causes the message to be + sent to Emacs itself using the event + mask specified by the EWMH. To avoid + an infinite loop, just use + SubstructureRedirectMask when a + drag-and-drop operation is in + progress. */ + ((x_dnd_in_progress || x_dnd_waiting_for_finish) + ? SubstructureRedirectMask + : SubstructureRedirectMask | SubstructureNotifyMask), &send_event); *finish = X_EVENT_DROP; commit d81df9e44933d5b4d386e29d953055dfc029e742 Author: Po Lu Date: Thu Mar 24 01:50:18 2022 +0000 Fix copying font names around on Haiku * src/haiku_font_support.cc (font_style_to_flags) (haiku_font_fill_pattern, BFont_open_pattern) (BFont_populate_fixed_family, BFont_populate_plain_family): * src/haiku_support.cc (be_get_version_string): * src/haikufont.c (haikufont_spec_or_entity_to_pattern): Stop assuming patterns were allocated by xzalloc. diff --git a/src/haiku_font_support.cc b/src/haiku_font_support.cc index 549c54d864..fd41ee71f0 100644 --- a/src/haiku_font_support.cc +++ b/src/haiku_font_support.cc @@ -289,6 +289,7 @@ font_style_to_flags (char *st, struct haiku_font_pattern *pattern) pattern->specified |= FSPEC_STYLE; std::strncpy ((char *) &pattern->style, st, sizeof pattern->style - 1); + pattern->style[sizeof pattern->style - 1] = '\0'; } free (style); @@ -411,6 +412,7 @@ haiku_font_fill_pattern (struct haiku_font_pattern *pattern, pattern->specified |= FSPEC_FAMILY; std::strncpy (pattern->family, family, sizeof pattern->family - 1); + pattern->family[sizeof pattern->family - 1] = '\0'; pattern->specified |= FSPEC_SPACING; pattern->mono_spacing_p = flags & B_IS_FIXED; } @@ -534,6 +536,8 @@ BFont_open_pattern (struct haiku_font_pattern *pat, void **font, float size) if (!(pat->specified & FSPEC_FAMILY)) return 1; strncpy (name, pat->family, sizeof name - 1); + name[sizeof name - 1] = '\0'; + sty_count = count_font_styles (name); if (!sty_count && @@ -603,6 +607,7 @@ BFont_populate_fixed_family (struct haiku_font_pattern *ptn) ptn->specified |= FSPEC_FAMILY; strncpy (ptn->family, f, sizeof ptn->family - 1); + ptn->family[sizeof ptn->family - 1] = '\0'; } void @@ -614,6 +619,7 @@ BFont_populate_plain_family (struct haiku_font_pattern *ptn) ptn->specified |= FSPEC_FAMILY; strncpy (ptn->family, f, sizeof ptn->family - 1); + ptn->family[sizeof ptn->family - 1] = '\0'; } int diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 24009c0ef6..5ad3c7c794 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -3395,6 +3395,8 @@ void be_get_version_string (char *version, int len) { std::strncpy (version, "Unknown Haiku release", len - 1); + version[len - 1] = '\0'; + BPath path; if (find_directory (B_BEOS_LIB_DIRECTORY, &path) == B_OK) { @@ -3408,7 +3410,10 @@ be_get_version_string (char *version, int len) && appFileInfo.GetVersionInfo (&versionInfo, B_APP_VERSION_KIND) == B_OK && versionInfo.short_info[0] != '\0') - std::strncpy (version, versionInfo.short_info, len - 1); + { + std::strncpy (version, versionInfo.short_info, len - 1); + version[len - 1] = '\0'; + } } } diff --git a/src/haikufont.c b/src/haikufont.c index 5099285f10..b9f6dc2fe8 100644 --- a/src/haikufont.c +++ b/src/haikufont.c @@ -437,6 +437,7 @@ haikufont_spec_or_entity_to_pattern (Lisp_Object ent, strncpy ((char *) &ptn->style, SSDATA (SYMBOL_NAME (tem)), sizeof ptn->style - 1); + ptn->style[sizeof ptn->style - 1] = '\0'; } tem = FONT_SLANT_SYMBOLIC (ent); @@ -475,6 +476,7 @@ haikufont_spec_or_entity_to_pattern (Lisp_Object ent, strncpy ((char *) &ptn->family, SSDATA (SYMBOL_NAME (tem)), sizeof ptn->family - 1); + ptn->family[sizeof ptn->family - 1] = '\0'; } tem = assq_no_quit (QCscript, AREF (ent, FONT_EXTRA_INDEX)); commit 17393c0db0fbd4ba9b7ddcdc668974ef8a65107d Author: Po Lu Date: Thu Mar 24 09:42:47 2022 +0800 Allow dragging and dropping multiple actions * doc/lispref/frames.texi (Drag and Drop): Document new meaning of `action'. * lisp/term/haiku-win.el (x-begin-drag): Correct for new meaning of `action'. * src/xfns.c (Fx_begin_drag): Handle new alist meaning of `action'. * src/xterm.c (x_dnd_begin_drag_and_drop): New parameters `ask_action_list', `ask_action_names' and `n_ask_actions'. * src/xterm.h: Update prototypes. diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index 9717fa2978..a031b25e47 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -4061,6 +4061,11 @@ the drop target; or @code{XdndActionMove}, which means copy as with @code{XdndActionCopy}, and in addition the caller should delete whatever was stored in that selection after copying it. +@var{action} may also be an alist which associates between symbols +describing the available actions, and strings that the drop target is +expected to present to the user to choose between the available +actions. + If @var{return-frame} is non-nil and the mouse moves over an Emacs frame after first moving out of @var{frame}, then the frame to which the mouse moves will be returned immediately. This is useful when you diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index 8ec959a758..1433620875 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -224,7 +224,9 @@ take effect on menu items until the menu bar is updated again." (push (cadr selection-result) (cdr (alist-get (car selection-result) message nil nil #'equal)))))))) - (prog1 (or action 'XdndActionCopy) + (prog1 (or (and (symbolp action) + action) + 'XdndActionCopy) (haiku-drag-message (or frame (selected-frame)) message)))) diff --git a/src/xfns.c b/src/xfns.c index eae409eed2..c4b924e007 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -6614,17 +6614,28 @@ If RETURN-FRAME is non-nil, this function will return the frame if the mouse pointer moves onto an Emacs frame, after first moving out of FRAME. +If ACTION is a list and not nil, its elements are assumed to be a cons +of (ITEM . STRING), where ITEM is the name of an action, and STRING is +a string describing ITEM to the user. The drop target is expected to +prompt the user to choose between any of the actions in the list. + If ACTION is not specified or nil, `XdndActionCopy' is used instead. */) (Lisp_Object targets, Lisp_Object action, Lisp_Object frame, Lisp_Object return_frame) { struct frame *f = decode_window_system_frame (frame); - int ntargets = 0; + int ntargets = 0, nnames = 0; + ptrdiff_t len; char *target_names[2048]; Atom *target_atoms; - Lisp_Object lval, original; + Lisp_Object lval, original, tem, t1, t2; Atom xaction; + Atom action_list[2048]; + char *name_list[2048]; + char *scratch; + + USE_SAFE_ALLOCA; CHECK_LIST (targets); original = targets; @@ -6650,10 +6661,48 @@ instead. */) xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionMove; else if (EQ (action, QXdndActionLink)) xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionLink; - else if (EQ (action, QXdndActionAsk)) - xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionAsk; else if (EQ (action, QXdndActionPrivate)) xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionPrivate; + else if (CONSP (action)) + { + xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionAsk; + original = action; + + CHECK_LIST (action); + for (; CONSP (action); action = XCDR (action)) + { + tem = XCAR (action); + CHECK_CONS (tem); + t1 = XCAR (tem); + t2 = XCDR (tem); + CHECK_SYMBOL (t1); + CHECK_STRING (t2); + + if (nnames < 2048) + { + if (EQ (t1, QXdndActionCopy)) + action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionCopy; + else if (EQ (t1, QXdndActionMove)) + action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionMove; + else if (EQ (t1, QXdndActionLink)) + action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionLink; + else if (EQ (t1, QXdndActionPrivate)) + action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionPrivate; + else + signal_error ("Invalid drag-and-drop action", tem); + + scratch = SSDATA (ENCODE_UTF_8 (t2)); + len = strlen (scratch); + name_list[nnames] = SAFE_ALLOCA (len + 1); + strncpy (name_list[nnames], scratch, len + 1); + + nnames++; + } + else + error ("Too many actions"); + } + CHECK_LIST_END (action, original); + } else signal_error ("Invalid drag-and-drop action", action); @@ -6666,8 +6715,10 @@ instead. */) x_set_dnd_targets (target_atoms, ntargets); lval = x_dnd_begin_drag_and_drop (f, FRAME_DISPLAY_INFO (f)->last_user_time, - xaction, !NILP (return_frame)); + xaction, !NILP (return_frame), action_list, + (const char **) &name_list, nnames); + SAFE_FREE (); return lval; } diff --git a/src/xterm.c b/src/xterm.c index e4c17644e4..0543f152ed 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -6942,7 +6942,9 @@ x_top_window_to_frame (struct x_display_info *dpyinfo, int wdesc) Lisp_Object x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, - bool return_frame_p) + bool return_frame_p, Atom *ask_action_list, + const char **ask_action_names, + size_t n_ask_actions) { #ifndef USE_GTK XEvent next_event; @@ -6951,9 +6953,11 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, XWindowAttributes root_window_attrs; struct input_event hold_quit; struct frame *any; - char *atom_name; + char *atom_name, *ask_actions; Lisp_Object action, ltimestamp; specpdl_ref ref; + ptrdiff_t i, end, fill; + XTextProperty prop; if (!FRAME_VISIBLE_P (f)) error ("Frame is invisible"); @@ -6972,6 +6976,41 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, else x_dnd_selection_timestamp = XFIXNUM (ltimestamp); + if (n_ask_actions) + { + ask_actions = NULL; + end = 0; + + for (i = 0; i < n_ask_actions; ++i) + { + fill = end; + end += strlen (ask_action_names[i]) + 1; + + if (ask_actions) + ask_actions = xrealloc (ask_actions, end); + else + ask_actions = xmalloc (end); + + strncpy (ask_actions + fill, + ask_action_names[i], + end - fill); + } + + prop.value = (unsigned char *) ask_actions; + prop.encoding = XA_STRING; + prop.format = 8; + prop.nitems = end; + + XSetTextProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + &prop, FRAME_DISPLAY_INFO (f)->Xatom_XdndActionDescription); + xfree (ask_actions); + + XChangeProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + FRAME_DISPLAY_INFO (f)->Xatom_XdndActionList, XA_ATOM, 32, + PropModeReplace, (unsigned char *) ask_action_list, + n_ask_actions); + } + x_dnd_in_progress = true; x_dnd_frame = f; x_dnd_last_seen_window = FRAME_X_WINDOW (f); diff --git a/src/xterm.h b/src/xterm.h index 2a11f87e16..4a71968b04 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -1373,7 +1373,8 @@ extern void x_scroll_bar_configure (GdkEvent *); #endif extern Lisp_Object x_dnd_begin_drag_and_drop (struct frame *, Time, Atom, - bool); + bool, Atom *, const char **, + size_t); extern void x_set_dnd_targets (Atom *, int); INLINE int commit ac3bb7e75413c1df60cf2de5c29e999df518a62d Author: Augusto Stoffel Date: Wed Mar 23 19:43:13 2022 +0100 Fix regression in isearch-yank-char-in-minibuffer * lisp/isearch.el (isearch-yank-char-in-minibuffer): Select the original window in order to restore point. This is needed when minibuffer lazy highlight is in effect. diff --git a/lisp/isearch.el b/lisp/isearch.el index 1a83586ef8..9b311cb49e 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -2670,7 +2670,7 @@ or it might return the position of the end of the line." (interactive "p") (if (eobp) (insert - (with-current-buffer (cadr (buffer-list)) + (with-minibuffer-selected-window (buffer-substring-no-properties (point) (progn (forward-char arg) (point))))) (forward-char arg))) commit 4ec23d922dc90ab697eb6f0ba119b1563abba111 Author: Mauro Aranda Date: Wed Mar 23 20:42:55 2022 +0100 Make undigest work with multipart/mixed messages * test/lisp/mail/undigest.el: New test file (bug#12873). * lisp/mail/undigest.el (rmail-digest-methods): Install rmail-digest-parse-mixed-mime. (rmail-content-type-boundary): New function, to get a specific Content-type boundary. (rmail-digest-parse-mixed-mime): New function, to search for a multipart/digest message inside a multipart/mixed message. diff --git a/lisp/mail/undigest.el b/lisp/mail/undigest.el index 03e77a83ce..c6d29bc4e7 100644 --- a/lisp/mail/undigest.el +++ b/lisp/mail/undigest.el @@ -41,7 +41,8 @@ You may need to customize it for local needs." (defconst rmail-digest-methods - '(rmail-digest-parse-mime + '(rmail-digest-parse-mixed-mime + rmail-digest-parse-mime rmail-digest-parse-rfc1153strict rmail-digest-parse-rfc1153sloppy rmail-digest-parse-rfc934) @@ -52,6 +53,53 @@ A function returns nil if it cannot parse the digest. If it can, it returns a list of cons pairs containing the start and end positions of each undigestified message as markers.") +(defun rmail-content-type-boundary (type) + "If Content-type is of type TYPE, return its boundary; otherwise, return nil." + (goto-char (point-min)) + (let ((head-end (save-excursion (search-forward "\n\n" nil t) (point)))) + (when (re-search-forward + (concat "^Content-type: " type ";" + "\\s-* boundary=\"?\\([^\";\n]+\\)[\";\n]") + head-end t) + (match-string 1)))) + +(defun rmail-digest-parse-mixed-mime () + "Like `rmail-digest-parse-mime', but for multipart/mixed messages." + (when-let ((boundary (rmail-content-type-boundary "multipart/mixed"))) + (let ((global-sep (concat "\n--" boundary)) + (digest (concat "^Content-type: multipart/digest;" + "\\s-* boundary=\"?\\([^\";\n]+\\)[\";\n]")) + result) + (search-forward global-sep nil t) + (while (not (or result (eobp))) + ;; For each part, see if it is a multipart/digest. + (let* ((limit (save-excursion (search-forward global-sep nil 'move) + (point))) + (beg (and (re-search-forward digest limit t) + (match-beginning 0))) + digest-sep) + (when (and beg + (setq digest-sep (concat "\n--" (match-string 1))) + ;; Search for 1st sep. + (search-forward digest-sep nil t)) + ;; Skip body part headers. + (search-forward "\n\n" nil t) + ;; Push the 1st message. + (push (cons (copy-marker beg) (copy-marker (point-marker) t)) + result) + ;; Push the rest of the messages. + (let ((start (make-marker)) + done) + (while (and (search-forward digest-sep limit 'move) (not done)) + (move-marker start (match-beginning 0)) + (and (looking-at "--$") (setq done t)) + (search-forward "\n\n") + (push (cons (copy-marker start) + (copy-marker (point-marker) t)) + result)))) + (goto-char limit))) + (nreverse result)))) + (defun rmail-digest-parse-mime () (goto-char (point-min)) (when (let ((head-end (progn (search-forward "\n\n" nil t) (point)))) diff --git a/test/lisp/mail/undigest-tests.el b/test/lisp/mail/undigest-tests.el new file mode 100644 index 0000000000..24059aa349 --- /dev/null +++ b/test/lisp/mail/undigest-tests.el @@ -0,0 +1,354 @@ +;;; undigest.el --- Tests for undigest.el -*- lexical-binding:t -*- + +;; Copyright (C) 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 . + +;;; Code: + +(require 'ert) +(require 'rmail) +(require 'undigest) + +;;; Variables: +;; Some digests for testing. +(defvar rmail-rfc934-digest "From tester Fri Jan 24 00:00:00 2022 +From: Digester +To: Undigester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Testing you + +Testing the undigester. + +------- Message sep + +From: NN1 +To: Digester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Message one + +This is message one. + +------- Message sep + +From: NN2 +To: Digester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Message two + +This is message two. +" + + "RFC 934 digest.") + +(defvar rmail-rfc1153-digest-strict "From tester Fri Jan 24 00:00:00 2022 +Date: ddd, dd mmm yy hh:mm:ss zzz +From: Digester +To: Undigester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Testing you + +Some mailing list information. + +Today's Topics: + + 1. Message One Subject (Sender) + 2. Message Two Subject (Sender) + +---------------------------------------------------------------------- + +Date: ddd, dd mmm yy hh:mm:ss zzz +From: NN1 +Subject: Message One Subject + +This is message one. + +------------------------------ + +Date: ddd, dd mmm yy hh:mm:ss zzz +From: NN2 +Subject: Message Two Subject + +This is message two. + +------------------------------ + +End of Digest. +************************************ +" + "RFC 1153 strict style digest.") + +(defvar rmail-rfc1153-digest-less-strict "From tester Fri Jan 24 00:00:00 2022 +From: Digester +To: Undigester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Testing you + +Some mailing list information. + +Today's Topics: + + 1. Message One Subject (Sender) + 2. Message Two Subject (Sender) + +---------------------------------------------------------------------- + +Date: ddd, dd mmm yy hh:mm:ss zzz +From: NN1 +Subject: Message One Subject + +This is message one. + +------------------------------ + +Date: ddd, dd mmm yy hh:mm:ss zzz +From: NN2 +Subject: Message Two Subject + +This is message two. + +------------------------------ + +Subject: Digest Footer + +End of Sbcl-help Digest, Vol 158, Issue 4 +***************************************** +" + "RFC 1153 style digest, with a Subject header.") + +(defvar rmail-rfc1153-digest-sloppy "From tester Fri Jan 24 00:00:00 2022 +From: Digester +To: Undigester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Testing you + +Some mailing list information. + +Today's Topics: + + 1. Message One Subject (Sender) + 2. Message Two Subject (Sender) + +---------------------------------------------------------------------- + +Date: ddd, dd mmm yy hh:mm:ss zzz +From: NN1 +Subject: Message One Subject + +This is message one. + +------------------------------ + +Date: ddd, dd mmm yy hh:mm:ss zzz +From: NN2 +Subject: Message Two Subject + +This is message two. + +------------------------------ + +Subject: Digest Footer + +______________________________________________ +Some blurb. + +End of Digest. +************************************ +" + "RFC 1153 sloppy style digest.") + +(defvar rmail-rfc1521-mime-digest "From tester Fri Jan 24 00:00:00 2022 +From: Digester +To: Undigester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Test digest +MIME-Version: 1.0 +Content-Type: multipart/digest; boundary=\"----- =_aaaaaaaaaa0\" + +------- =_aaaaaaaaaa0 +Content-Type: message/rfc822 + +From: NN1 +To: Digester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Message one + +Message one. + +------- =_aaaaaaaaaa0 + +From: NN2 +To: Digester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Message two + +Message two. + +------- =_aaaaaaaaaa0 +" + "RFC 1521 style MIME digest.") + +(defvar rmail-multipart-mixed-digest + "From tester Fri Jan 24 00:00:00 2022 +From: Digester +To: Undigester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Test digest +Content-Type: multipart/mixed; boundary=\"===============2529375068597856000==\" +MIME-Version: 1.0 + +--===============2529375068597856000== +Content-Type: text/plain; +MIME-Version: 1.0 +Content-Description: Today's Topics + +Some message. + +--===============2529375068597856000== +Content-Type: multipart/digest; boundary=\"===============6060050777038710134==\" +MIME-Version: 1.0 + +--===============6060050777038710134== +Content-Type: message/rfc822 +MIME-Version: 1.0 + +From: NN1 +To: Digester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Message one + +Message one. + +--===============6060050777038710134== +Content-Type: message/rfc822 +MIME-Version: 1.0 + +From: NN2 +To: Digester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Message two + +Message two. + +--===============6060050777038710134==-- + +--===============2529375068597856000== +Content-Type: text/plain; +MIME-Version: 1.0 +Content-Description: Digest Footer + +The footer. + +--===============2529375068597856000==--" + "RFC 1521 digest inside a multipart/mixed message.") + +;;; Utils: +(defun rmail-message-content (message) + "Return the content of the message numbered MESSAGE." + (rmail-show-message message) + (let ((beg (rmail-msgbeg rmail-current-message)) + (end (rmail-msgend rmail-current-message))) + (with-current-buffer rmail-view-buffer + (save-excursion + (goto-char beg) + (search-forward "\n\n" end nil) + (buffer-substring-no-properties (match-end 0) end))))) + +;;; Tests: +(ert-deftest rmail-undigest-test-rfc934-digest () + "Test that we can undigest a RFC 934 digest." + (let ((file (make-temp-file "undigest-test-"))) + (with-temp-file file + (insert rmail-rfc934-digest) + (write-region nil nil file) + (rmail file) + (undigestify-rmail-message) + (should (= rmail-total-messages 4)) + (should (string= (rmail-message-content 2) "Testing the undigester.\n\n")) + (should (string= (rmail-message-content 3) "This is message one.\n\n")) + (should (string= (rmail-message-content 4) "This is message two.\n"))))) + +(ert-deftest rmail-undigest-test-rfc1153-digest-strict () + "Test that we can undigest a strict RFC 1153 digest." + :expected-result :failed + (let ((file (make-temp-file "undigest-test-"))) + (with-temp-file file + (insert rmail-rfc1153-digest-strict) + (write-region nil nil file) + (rmail file) + (should + (condition-case nil + (progn + ;; This throws an error, because the Trailer is not recognized + ;; as a valid RFC 822 (or later) message. + (undigestify-rmail-message) + (should (string= (rmail-message-content 2) "Testing the undigester.\n\n")) + (should (string= (rmail-message-content 3) "This is message one.\n\n")) + (should (string= (rmail-message-content 4) "This is message two.\n")) + t) + (error nil)))))) + +(ert-deftest rmail-undigest-test-rfc1153-less-strict-digest () + "Test that we can undigest a RFC 1153 with a Subject header in its footer." + (let ((file (make-temp-file "undigest-test-"))) + (with-temp-file file + (insert rmail-rfc1153-digest-less-strict) + (write-region nil nil file) + (rmail file) + (undigestify-rmail-message) + (should (= rmail-total-messages 5)) + (should (string= (rmail-message-content 3) "This is message one.\n\n")) + (should (string= (rmail-message-content 4) "This is message two.\n\n"))))) + +(ert-deftest rmail-undigest-test-rfc1153-sloppy-digest () + "Test that we can undigest a sloppy RFC 1153 digest." + (let ((file (make-temp-file "undigest-test-"))) + (with-temp-file file + (insert rmail-rfc1153-digest-sloppy) + (write-region nil nil file) + (rmail file) + (undigestify-rmail-message) + (should (= rmail-total-messages 5)) + (should (string= (rmail-message-content 3) "This is message one.\n\n")) + (should (string= (rmail-message-content 4) "This is message two.\n\n"))))) + +;; This fails because `rmail-digest-parse-mime' combines the preamble with the +;; first message of the digest. And then, it doesn't get rid of the last +;; separator. +(ert-deftest rmail-undigest-test-rfc1521-mime-digest () + "Test that we can undigest a RFC 1521 MIME digest." + :expected-result :failed + (let ((file (make-temp-file "undigest-test-"))) + (with-temp-file file + (insert rmail-rfc1521-mime-digest) + (write-region nil nil file) + (rmail file) + (undigestify-rmail-message) + (should (= rmail-total-messages 3)) + (should (string= (rmail-message-content 2) "Message one.\n\n")) + (should (string= (rmail-message-content 3) "Message two.\n\n"))))) + +(ert-deftest rmail-undigest-test-multipart-mixed-digest () + "Test that we can undigest a digest inside a multipart/mixed digest." + (let ((file (make-temp-file "undigest-test-"))) + (with-temp-file file + (insert rmail-multipart-mixed-digest) + (write-region nil nil file) + (rmail file) + (undigestify-rmail-message) + (should (= rmail-total-messages 4)) + (should (string= (rmail-message-content 2) "Message one.\n\n")) + (should (string= (rmail-message-content 3) "Message two.\n\n"))))) commit ef0a0d30c5daf4c2d65d5e07212dcbb8489466ee Author: Michael Albinus Date: Wed Mar 23 19:54:53 2022 +0100 Make quoting of shell arguments in grep.el more robust * lisp/progmodes/grep.el (grep-apply-setting) (grep-compute-defaults): Adapt docstring. (grep-quoting-style): New variable. (grep-compute-defaults, grep-default-command) (grep-expand-keywords, lgrep, rgrep-default-command): Use it. diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index 3fbe4acd50..388ff1a43d 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -48,8 +48,8 @@ to avoid computing them again.") "Set SYMBOL to VALUE, and update `grep-host-defaults-alist'. SYMBOL should be one of `grep-command', `grep-template', `grep-use-null-device', `grep-find-command' `grep-find-template', -`grep-find-use-xargs', `grep-use-null-filename-separator', or -`grep-highlight-matches'." +`grep-find-use-xargs', `grep-use-null-filename-separator', +`grep-highlight-matches', or `grep-quoting-style'." (when grep-host-defaults-alist (let* ((host-id (intern (or (file-remote-p default-directory) "localhost"))) @@ -202,6 +202,9 @@ by `grep-compute-defaults'; to change the default value, use :set #'grep-apply-setting :version "22.1") +(defvar grep-quoting-style nil + "Whether to use POSIX-like shell argument quoting.") + (defcustom grep-files-aliases '(("all" . "* .*") ("el" . "*.el") @@ -616,8 +619,8 @@ This function is called from `compilation-filter-hook'." "Compute the defaults for the `grep' command. The value depends on `grep-command', `grep-template', `grep-use-null-device', `grep-find-command', `grep-find-template', -`grep-use-null-filename-separator', `grep-find-use-xargs' and -`grep-highlight-matches'." +`grep-use-null-filename-separator', `grep-find-use-xargs', +`grep-highlight-matches', and `grep-quoting-style'." ;; Keep default values. (unless grep-host-defaults-alist (add-to-list @@ -631,7 +634,8 @@ The value depends on `grep-command', `grep-template', (grep-use-null-filename-separator ,grep-use-null-filename-separator) (grep-find-use-xargs ,grep-find-use-xargs) - (grep-highlight-matches ,grep-highlight-matches))))) + (grep-highlight-matches ,grep-highlight-matches) + (grep-quoting-style ,grep-quoting-style))))) (let* ((remote (file-remote-p default-directory)) (host-id (intern (or remote "localhost"))) (host-defaults (assq host-id grep-host-defaults-alist)) @@ -791,8 +795,11 @@ The value depends on `grep-command', `grep-template', find-program gcmd null quot-braces)) (t (format "%s -H -type f -print | \"%s\" %s" - find-program xargs-program gcmd)))))))) - ;; Save defaults for this host. + find-program xargs-program gcmd)))))) + + (setq grep-quoting-style remote))) + + ;; Save defaults for this host. (setq grep-host-defaults-alist (delete (assq host-id grep-host-defaults-alist) grep-host-defaults-alist)) @@ -807,7 +814,8 @@ The value depends on `grep-command', `grep-template', (grep-use-null-filename-separator ,grep-use-null-filename-separator) (grep-find-use-xargs ,grep-find-use-xargs) - (grep-highlight-matches ,grep-highlight-matches)))))) + (grep-highlight-matches ,grep-highlight-matches) + (grep-quoting-style ,grep-quoting-style)))))) (defun grep-tag-default () (or (and transient-mark-mode mark-active @@ -821,8 +829,7 @@ The value depends on `grep-command', `grep-template', (defun grep-default-command () "Compute the default grep command for \\[universal-argument] \\[grep] to offer." (let ((tag-default - (shell-quote-argument - (grep-tag-default) (file-remote-p default-directory))) + (shell-quote-argument (grep-tag-default) grep-quoting-style)) ;; This a regexp to match single shell arguments. ;; Could someone please add comments explaining it? (sh-arg-re @@ -956,7 +963,6 @@ easily repeat a find command." ;;;###autoload (defalias 'find-grep #'grep-find) - ;; User-friendly interactive API. (defconst grep-expand-keywords @@ -965,8 +971,7 @@ easily repeat a find command." ("" . files) ("" . (null-device)) ("" . excl) - ("" . (shell-quote-argument - (or regexp "") (file-remote-p (expand-file-name (or dir ".")))))) + ("" . (shell-quote-argument (or regexp "") grep-quoting-style))) "List of substitutions performed by `grep-expand-template'. If car of an element matches, the cdr is evalled in order to get the substitution string. @@ -1118,12 +1123,11 @@ command before it's run." (unless (string-equal (file-remote-p dir) (file-remote-p default-directory)) (let ((default-directory dir)) (grep-compute-defaults))) - (let ((command regexp) remote) + (let ((command regexp)) (if (null files) (if (string= command grep-command) (setq command nil)) - (setq dir (file-name-as-directory (expand-file-name dir)) - remote (file-remote-p dir)) + (setq dir (file-name-as-directory (expand-file-name dir))) (unless (or (not grep-use-directories-skip) (eq grep-use-directories-skip t)) (setq grep-use-directories-skip @@ -1142,11 +1146,12 @@ command before it's run." (lambda (ignore) (cond ((stringp ignore) (shell-quote-argument - ignore remote)) + ignore grep-quoting-style)) ((consp ignore) (and (funcall (car ignore) dir) (shell-quote-argument - (cdr ignore) remote))))) + (cdr ignore) + grep-quoting-style))))) grep-find-ignored-files " --exclude="))) (and (eq grep-use-directories-skip t) @@ -1253,50 +1258,50 @@ command before it's run." (defun rgrep-default-command (regexp files dir) "Compute the command for \\[rgrep] to use by default." (require 'find-dired) ; for `find-name-arg' - (let ((remote (file-remote-p (or dir default-directory)))) - (grep-expand-template - grep-find-template - regexp - (concat (shell-quote-argument "(" remote) - " " find-name-arg " " - (mapconcat - (lambda (x) (shell-quote-argument x remote)) - (split-string files) - (concat " -o " find-name-arg " ")) - " " - (shell-quote-argument ")" remote)) - dir - (concat - (and grep-find-ignored-directories - (concat "-type d " - (shell-quote-argument "(" remote) - ;; we should use shell-quote-argument here - " -path " - (mapconcat - (lambda (d) (shell-quote-argument (concat "*/" d) remote)) - (rgrep-find-ignored-directories dir) - " -o -path ") - " " - (shell-quote-argument ")" remote) - " -prune -o ")) - (and grep-find-ignored-files - (concat (shell-quote-argument "!" remote) " -type d " - (shell-quote-argument "(" remote) - ;; we should use shell-quote-argument here - " -name " - (mapconcat - (lambda (ignore) - (cond ((stringp ignore) - (shell-quote-argument ignore remote)) - ((consp ignore) - (and (funcall (car ignore) dir) - (shell-quote-argument - (cdr ignore) remote))))) - grep-find-ignored-files - " -o -name ") - " " - (shell-quote-argument ")" remote) - " -prune -o ")))))) + (grep-expand-template + grep-find-template + regexp + (concat (shell-quote-argument "(" grep-quoting-style) + " " find-name-arg " " + (mapconcat + (lambda (x) (shell-quote-argument x grep-quoting-style)) + (split-string files) + (concat " -o " find-name-arg " ")) + " " + (shell-quote-argument ")" grep-quoting-style)) + dir + (concat + (and grep-find-ignored-directories + (concat "-type d " + (shell-quote-argument "(" grep-quoting-style) + ;; we should use shell-quote-argument here + " -path " + (mapconcat + (lambda (d) + (shell-quote-argument (concat "*/" d) grep-quoting-style)) + (rgrep-find-ignored-directories dir) + " -o -path ") + " " + (shell-quote-argument ")" grep-quoting-style) + " -prune -o ")) + (and grep-find-ignored-files + (concat (shell-quote-argument "!" grep-quoting-style) " -type d " + (shell-quote-argument "(" grep-quoting-style) + ;; we should use shell-quote-argument here + " -name " + (mapconcat + (lambda (ignore) + (cond ((stringp ignore) + (shell-quote-argument ignore grep-quoting-style)) + ((consp ignore) + (and (funcall (car ignore) dir) + (shell-quote-argument + (cdr ignore) grep-quoting-style))))) + grep-find-ignored-files + " -o -name ") + " " + (shell-quote-argument ")" grep-quoting-style) + " -prune -o "))))) (defun grep-find-toggle-abbreviation () "Toggle showing the hidden part of rgrep/lgrep/zrgrep command line." commit b8e8c83360b5e93af60ee8379921837e06d3325e Author: Glenn Morris Date: Wed Mar 23 08:44:18 2022 -0700 * doc/misc/eudc.texi (Inline Query Expansion): Unbreak it. diff --git a/doc/misc/eudc.texi b/doc/misc/eudc.texi index f61ce7012e..71e3e6b9ed 100644 --- a/doc/misc/eudc.texi +++ b/doc/misc/eudc.texi @@ -811,7 +811,7 @@ quoting the result if necessary. No @var{comment} part will be added in this case. This will produce any of the default formats @center @var{address} @center @var{first} @code{<}@var{address}@code{>} -@center @var{last} @code{<}@var{address}@code{> +@center @var{last} @code{<}@var{address}@code{>} @center @var{first} @var{last} @code{<}@var{address}@code{>} depending on whether a first and/or last name are returned by the query, or not. commit fdbee9bc4c3e1c8f4dfa358282bdb2e746918daa Author: Michael Albinus Date: Wed Mar 23 16:04:57 2022 +0100 Support changing remoteness of DIR in rgrep and lgrep * lisp/net/tramp-sh.el (tramp-get-remote-dev-tty): New defun. (tramp-sh-handle-make-process): Use it. * lisp/progmodes/grep.el: Prefer #' to quote named functions. (lgrep, rgrep): Recompute grep defaults when the remoteness of DIR changes. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 475d48cc30..7a2b884bad 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2865,8 +2865,10 @@ implementation will be used." (string-match-p "sh$" program) (= (length args) 2) (string-equal "-c" (car args)) - ;; Don't if there is a string. - (not (string-match-p "'\\|\"" (cadr args))))) + ;; Don't if there is a quoted string. + (not (string-match-p "'\\|\"" (cadr args))) + ;; Check, that /dev/tty is usable. + (tramp-get-remote-dev-tty v))) ;; When PROGRAM is nil, we just provide a tty. (args (if (not heredoc) args (let ((i 250)) @@ -5933,6 +5935,12 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." command)) (delete-file tmpfile))))) +(defun tramp-get-remote-dev-tty (vec) + "Check, whether remote /dev/tty is usable." + (with-tramp-connection-property vec "dev-tty" + (tramp-send-command-and-check + vec "echo (length regexp) 0)) (unless (and dir (file-accessible-directory-p dir)) (setq dir default-directory)) + (unless (string-equal (file-remote-p dir) (file-remote-p default-directory)) + (let ((default-directory dir)) + (grep-compute-defaults))) (let ((command regexp) remote) (if (null files) (if (string= command grep-command) @@ -1163,7 +1166,7 @@ command before it's run." (if (and grep-use-null-device null-device (null-device)) (concat command " " (null-device)) command) - 'grep-mode)) + #'grep-mode)) ;; Set default-directory if we started lgrep in the *grep* buffer. (if (eq next-error-last-buffer (current-buffer)) (setq default-directory dir)))))) @@ -1215,11 +1218,14 @@ command before it's run." (when (and (stringp regexp) (> (length regexp) 0)) (unless (and dir (file-accessible-directory-p dir)) (setq dir default-directory)) + (unless (string-equal (file-remote-p dir) (file-remote-p default-directory)) + (let ((default-directory dir)) + (grep-compute-defaults))) (if (null files) (if (not (string= regexp (if (consp grep-find-command) (car grep-find-command) grep-find-command))) - (compilation-start regexp 'grep-mode)) + (compilation-start regexp #'grep-mode)) (setq dir (file-name-as-directory (expand-file-name dir))) (let ((command (rgrep-default-command regexp files nil))) (when command @@ -1230,7 +1236,7 @@ command before it's run." (add-to-history 'grep-find-history command)) (grep--save-buffers) (let ((default-directory dir)) - (compilation-start command 'grep-mode)) + (compilation-start command #'grep-mode)) ;; Set default-directory if we started rgrep in the *grep* buffer. (if (eq next-error-last-buffer (current-buffer)) (setq default-directory dir))))))) @@ -1359,7 +1365,7 @@ The returned file name is relative." (caar (compilation--loc->file-struct loc)))) ;;;###autoload -(defalias 'rzgrep 'zrgrep) +(defalias 'rzgrep #'zrgrep) (provide 'grep) commit 7fa5d6c87d43926008c15a7f7ddc924bbf8d2e76 Author: Po Lu Date: Wed Mar 23 14:15:22 2022 +0000 Improvements to Haiku selection handling * lisp/term/haiku-win.el (haiku-selection-targets): Implement in Lisp. * src/haiku_select.cc (be_get_message_type): (be_set_message_type): (be_get_message_message): (be_add_message_message): New functions. * src/haiku_support.cc (MessageReceived): Fix typo. * src/haikuselect.c (haiku_selection_data_1) (Fhaiku_selection_targets): Delete functions. (haiku_message_to_lisp, lisp_to_type_code) (haiku_lisp_to_message): Correctly decode and encode nested messages, and fix encoding specially decoded types via numeric names. Also store and decode message types inside Lisp messages. (Fhaiku_drag_message): Update doc string. (syms_of_haikuselect): Update subrs. * src/haikuselect.h: Update prototypes. diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index 632177f843..8ec959a758 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -79,7 +79,6 @@ VALUE as a unibyte string, or nil if VALUE was not a string." (declare-function x-handle-args "common-win") (declare-function haiku-selection-data "haikuselect.c") (declare-function haiku-selection-put "haikuselect.c") -(declare-function haiku-selection-targets "haikuselect.c") (declare-function haiku-selection-owner-p "haikuselect.c") (declare-function haiku-put-resource "haikufns.c") (declare-function haiku-drag-message "haikuselect.c") @@ -123,6 +122,12 @@ If TYPE is nil, return \"text/plain\"." ((symbolp type) (symbol-name type)) (t "text/plain"))) +(defun haiku-selection-targets (clipboard) + "Find the types of data available from CLIPBOARD. +CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or +`CLIPBOARD'. Return the available types as a list of strings." + (mapcar #'car (haiku-selection-data clipboard nil))) + (cl-defmethod gui-backend-get-selection (type data-type &context (window-system haiku)) (if (eq data-type 'TARGETS) diff --git a/src/haiku_select.cc b/src/haiku_select.cc index bccc79da01..373ad321c4 100644 --- a/src/haiku_select.cc +++ b/src/haiku_select.cc @@ -330,6 +330,41 @@ be_get_message_data (void *message, const char *name, index, buf_return, size_return) != B_OK; } +uint32 +be_get_message_type (void *message) +{ + BMessage *msg = (BMessage *) message; + + return msg->what; +} + +void +be_set_message_type (void *message, uint32 what) +{ + BMessage *msg = (BMessage *) message; + + msg->what = what; +} + +void * +be_get_message_message (void *message, const char *name, + int32 index) +{ + BMessage *msg = (BMessage *) message; + BMessage *out = new (std::nothrow) BMessage; + + if (!out) + return NULL; + + if (msg->FindMessage (name, index, out) != B_OK) + { + delete out; + return NULL; + } + + return out; +} + void * be_create_simple_message (void) { @@ -363,6 +398,19 @@ be_add_refs_data (void *message, const char *name, return msg->AddRef (name, &ref) != B_OK; } +int +be_add_message_message (void *message, const char *name, + void *data) +{ + BMessage *msg = (BMessage *) message; + BMessage *data_message = (BMessage *) data; + + if (msg->AddMessage (name, data_message) != B_OK) + return 1; + + return 0; +} + int be_lock_clipboard_message (enum haiku_clipboard clipboard, void **message_return) diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 3ded7a80f4..24009c0ef6 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -726,7 +726,7 @@ class EmacsWindow : public BWindow this->ConvertFromScreen (&whereto); rq.window = this; - rq.message = DetachCurrentMessage ();; + rq.message = DetachCurrentMessage (); rq.x = whereto.x; rq.y = whereto.y; diff --git a/src/haikuselect.c b/src/haikuselect.c index d59b4512a4..5540f467c0 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -27,46 +27,6 @@ along with GNU Emacs. If not, see . */ #include -static Lisp_Object -haiku_selection_data_1 (Lisp_Object clipboard) -{ - Lisp_Object result = Qnil; - char *targets[256]; - - block_input (); - if (EQ (clipboard, QPRIMARY)) - BClipboard_primary_targets ((char **) &targets, 256); - else if (EQ (clipboard, QSECONDARY)) - BClipboard_secondary_targets ((char **) &targets, 256); - else if (EQ (clipboard, QCLIPBOARD)) - BClipboard_system_targets ((char **) &targets, 256); - else - { - unblock_input (); - signal_error ("Bad clipboard", clipboard); - } - - for (int i = 0; targets[i]; ++i) - { - result = Fcons (build_unibyte_string (targets[i]), - result); - free (targets[i]); - } - unblock_input (); - - return result; -} - -DEFUN ("haiku-selection-targets", Fhaiku_selection_targets, - Shaiku_selection_targets, 1, 1, 0, - doc: /* Find the types of data available from CLIPBOARD. -CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'. -Return the available types as a list of strings. */) - (Lisp_Object clipboard) -{ - return haiku_selection_data_1 (clipboard); -} - DEFUN ("haiku-selection-data", Fhaiku_selection_data, Shaiku_selection_data, 2, 2, 0, doc: /* Retrieve content typed as NAME from the clipboard @@ -225,7 +185,11 @@ same as `SECONDARY'. */) DATA is a 16-bit signed integer. If TYPE is `long', then DATA is a 32-bit signed integer. If TYPE is `llong', then DATA is a 64-bit signed integer. If TYPE is `byte' or `char', then DATA is an 8-bit - signed integer. If TYPE is `bool', then DATA is a boolean. */ + signed integer. If TYPE is `bool', then DATA is a boolean. + + If the field name is not a string but the symbol `type', then it + associates to a 32-bit unsigned integer describing the type of the + system message. */ Lisp_Object haiku_message_to_lisp (void *message) { @@ -236,6 +200,7 @@ haiku_message_to_lisp (void *message) ssize_t buf_size; int32 i, j, count, type_code; int rc; + void *msg; for (i = 0; !be_enum_message (message, &type_code, i, &count, &name); ++i) @@ -252,6 +217,15 @@ haiku_message_to_lisp (void *message) switch (type_code) { + case 'MSGG': + msg = be_get_message_message (message, name, j); + if (!msg) + memory_full (SIZE_MAX); + t1 = haiku_message_to_lisp (msg); + BMessage_delete (msg); + + break; + case 'BOOL': t1 = (*(bool *) buf) ? Qt : Qnil; break; @@ -335,6 +309,10 @@ haiku_message_to_lisp (void *message) t2 = Qbool; break; + case 'MSGG': + t2 = Qmessage; + break; + default: t2 = make_int (type_code); } @@ -343,7 +321,8 @@ haiku_message_to_lisp (void *message) list = Fcons (Fcons (build_string_from_utf8 (name), tem), list); } - return list; + tem = Fcons (Qtype, make_uint (be_get_message_type (message))); + return Fcons (tem, list); } static int32 @@ -371,6 +350,8 @@ lisp_to_type_code (Lisp_Object obj) return 'CHAR'; else if (EQ (obj, Qbool)) return 'BOOL'; + else if (EQ (obj, Qmessage)) + return 'MSGG'; else return -1; } @@ -384,8 +365,11 @@ haiku_lisp_to_message (Lisp_Object obj, void *message) int64 llong_data; int8 char_data; bool bool_data; + void *msg_data; intmax_t t4; + uintmax_t t5; int rc; + specpdl_ref ref; CHECK_LIST (obj); for (tem = obj; CONSP (tem); tem = XCDR (tem)) @@ -395,6 +379,35 @@ haiku_lisp_to_message (Lisp_Object obj, void *message) CHECK_CONS (t1); name = XCAR (t1); + + if (EQ (name, Qtype)) + { + t2 = XCDR (t1); + + if (BIGNUMP (t2)) + { + t5 = bignum_to_uintmax (t2); + + if (!t5 || t5 > TYPE_MAXIMUM (uint32)) + signal_error ("Value too large", t2); + + block_input (); + be_set_message_type (message, t5); + unblock_input (); + } + else + { + if (!TYPE_RANGED_FIXNUMP (uint32, t2)) + signal_error ("Invalid data type", t2); + + block_input (); + be_set_message_type (message, XFIXNAT (t2)); + unblock_input (); + } + + continue; + } + CHECK_STRING (name); t1 = XCDR (t1); @@ -412,8 +425,30 @@ haiku_lisp_to_message (Lisp_Object obj, void *message) maybe_quit (); data = XCAR (t2); + if (FIXNUMP (type_sym) || BIGNUMP (type_sym)) + goto decode_normally; + switch (type_code) { + case 'MSGG': + ref = SPECPDL_INDEX (); + + block_input (); + msg_data = be_create_simple_message (); + unblock_input (); + + record_unwind_protect_ptr (BMessage_delete, msg_data); + haiku_lisp_to_message (data, msg_data); + + block_input (); + rc = be_add_message_message (message, SSDATA (name), msg_data); + unblock_input (); + + if (rc) + signal_error ("Invalid message", msg_data); + unbind_to (ref, Qnil); + break; + case 'RREF': CHECK_STRING (data); @@ -525,6 +560,7 @@ haiku_lisp_to_message (Lisp_Object obj, void *message) break; default: + decode_normally: CHECK_STRING (data); block_input (); @@ -565,6 +601,10 @@ signed integer. If TYPE is `llong', then DATA is a 64-bit signed integer. If TYPE is `byte' or `char', then DATA is an 8-bit signed integer. If TYPE is `bool', then DATA is a boolean. +If the field name is not a string but the symbol `type', then it +associates to a 32-bit unsigned integer describing the type of the +system message. + FRAME is a window system frame that must be visible, from which the drag will originate. */) (Lisp_Object frame, Lisp_Object message) @@ -605,6 +645,7 @@ syms_of_haikuselect (void) DEFSYM (QUTF8_STRING, "UTF8_STRING"); DEFSYM (Qforeign_selection, "foreign-selection"); DEFSYM (QTARGETS, "TARGETS"); + DEFSYM (Qmessage, "message"); DEFSYM (Qstring, "string"); DEFSYM (Qref, "ref"); DEFSYM (Qshort, "short"); @@ -613,10 +654,10 @@ syms_of_haikuselect (void) DEFSYM (Qbyte, "byte"); DEFSYM (Qchar, "char"); DEFSYM (Qbool, "bool"); + DEFSYM (Qtype, "type"); defsubr (&Shaiku_selection_data); defsubr (&Shaiku_selection_put); - defsubr (&Shaiku_selection_targets); defsubr (&Shaiku_selection_owner_p); defsubr (&Shaiku_drag_message); } diff --git a/src/haikuselect.h b/src/haikuselect.h index 4278994918..01e4ca327d 100644 --- a/src/haikuselect.h +++ b/src/haikuselect.h @@ -94,12 +94,18 @@ extern "C" ssize_t *size_return); extern int be_get_refs_data (void *message, const char *name, int32 index, char **path_buffer); + extern uint32 be_get_message_type (void *message); + extern void be_set_message_type (void *message, uint32 what); + extern void *be_get_message_message (void *message, const char *name, + int32 index); extern void *be_create_simple_message (void); extern int be_add_message_data (void *message, const char *name, int32 type_code, const void *buf, ssize_t buf_size); extern int be_add_refs_data (void *message, const char *name, const char *filename); + extern int be_add_message_message (void *message, const char *name, + void *data); extern int be_lock_clipboard_message (enum haiku_clipboard clipboard, void **message_return); extern void be_unlock_clipboard (enum haiku_clipboard clipboard); commit 36810a8164db12766f532f268f322afe1e601b6a Author: Lars Ingebrigtsen Date: Wed Mar 23 14:29:03 2022 +0100 Reinstate `C-M-' * lisp/bindings.el (global-map): Reinstate `C-M-' and `C-M-' (bug#29430). These used to kill X, but that hasn't been the case in any common GNU/Linux distributions for decades. diff --git a/lisp/bindings.el b/lisp/bindings.el index 8ae8c3d60e..1913f82600 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -1402,10 +1402,8 @@ if `inhibit-field-text-motion' is non-nil." (define-key esc-map [?\C-\ ] 'mark-sexp) (define-key esc-map "\C-d" 'down-list) (define-key esc-map "\C-k" 'kill-sexp) -;;; These are dangerous in various situations, -;;; so let's not encourage anyone to use them. -;;;(define-key global-map [C-M-delete] 'backward-kill-sexp) -;;;(define-key global-map [C-M-backspace] 'backward-kill-sexp) +(define-key global-map [C-M-delete] 'backward-kill-sexp) +(define-key global-map [C-M-backspace] 'backward-kill-sexp) (define-key esc-map [C-delete] 'backward-kill-sexp) (define-key esc-map [C-backspace] 'backward-kill-sexp) (define-key esc-map "\C-n" 'forward-list) commit e5e5d85369cdae669af78feb22a924a2a493c48f Author: Lars Ingebrigtsen Date: Wed Mar 23 14:17:58 2022 +0100 Fix image-mode-fit-frame resizing * lisp/image-mode.el (image-mode-fit-frame): Use pixel sizes instead of lines/columns to get more accurate resizing (bug#37630). diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 38a5e7cdfd..863d014cdc 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -420,37 +420,39 @@ call." (interactive (list nil t)) (let* ((buffer (current-buffer)) (display (image-get-display-property)) - (size (image-display-size display)) + (size (image-display-size display t)) (saved (frame-parameter frame 'image-mode-saved-params)) (window-configuration (current-window-configuration frame)) - (width (frame-width frame)) - (height (frame-height frame))) + (frame-width (frame-pixel-width frame)) + (frame-height (frame-pixel-height frame))) (with-selected-frame (or frame (selected-frame)) (if (and toggle saved - (= (caar saved) width) - (= (cdar saved) height)) + (= (caar saved) frame-width) + (= (cdar saved) frame-height)) (progn - (set-frame-width frame (car (nth 1 saved))) - (set-frame-height frame (cdr (nth 1 saved))) + (set-frame-width frame (car (nth 1 saved)) nil t) + (set-frame-height frame (cdr (nth 1 saved)) nil t) (set-window-configuration (nth 2 saved)) (set-frame-parameter frame 'image-mode-saved-params nil)) (delete-other-windows) (switch-to-buffer buffer t t) - (let* ((edges (window-inside-edges)) - (inner-width (- (nth 2 edges) (nth 0 edges))) + (let* ((edges (window-inside-pixel-edges)) + (inner-width (- (nth 2 edges) (nth 0 edges))) (inner-height (- (nth 3 edges) (nth 1 edges)))) - (set-frame-width frame (+ (ceiling (car size)) - width (- inner-width))) + (set-frame-width frame (+ (ceiling (car size)) + (- frame-width inner-width)) + nil t) (set-frame-height frame (+ (ceiling (cdr size)) - height (- inner-height))) + (- frame-height inner-height)) + nil t) ;; The frame size after the above `set-frame-*' calls may ;; differ from what we specified, due to window manager ;; interference. We have to call `frame-width' and ;; `frame-height' to get the actual results. (set-frame-parameter frame 'image-mode-saved-params - (list (cons (frame-width) - (frame-height)) - (cons width height) + (list (cons (frame-pixel-width frame) + (frame-pixel-height frame)) + (cons frame-width frame-height) window-configuration))))))) ;;; Image Mode setup commit 59260ec59847ac4ee686c6e342e910c1d796aad9 Author: Andreas Schwab Date: Wed Mar 23 14:13:06 2022 +0100 * lisp/term/pgtk-win.el: Update header comment. diff --git a/lisp/term/pgtk-win.el b/lisp/term/pgtk-win.el index 114f98edb5..495b4a1111 100644 --- a/lisp/term/pgtk-win.el +++ b/lisp/term/pgtk-win.el @@ -1,4 +1,4 @@ -;;; xterm.el --- define function key sequences and standard colors for xterm -*- lexical-binding: t -*- +;;; pgtk-win.el --- parse relevant switches and set up for Pure-GTK -*- lexical-binding: t -*- ;; Copyright (C) 1995, 2001-2020, 2022 Free Software Foundation, Inc. commit 5811741eda764f4711031c90d2e7a3727f27d8a9 Author: Po Lu Date: Wed Mar 23 20:25:33 2022 +0800 Fix hl-line tests * lisp/hl-line.el (hl-line-mode): Restore old setter. * test/lisp/hl-line-tests.el (hl-line-tests-verify): Don't rely `cl-some' always returning t on success. (hl-line-tests-sticky-across-frames): Use correct global variable. diff --git a/lisp/hl-line.el b/lisp/hl-line.el index 20b3f4160f..e42d1d97d9 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el @@ -102,7 +102,15 @@ This variable has no effect in Global Highlight Line mode. For that, use `global-hl-line-sticky-flag'." :type 'boolean :version "22.1" - :group 'hl-line) + :group 'hl-line + :set (lambda (symbol value) + (set-default symbol value) + (unless value + (let ((selected (window-buffer (selected-window)))) + (dolist (buffer (buffer-list)) + (unless (eq buffer selected) + (with-current-buffer buffer + (hl-line-unhighlight)))))))) (defcustom global-hl-line-sticky-flag nil "Non-nil means the Global HL-Line mode highlight appears in all windows. diff --git a/test/lisp/hl-line-tests.el b/test/lisp/hl-line-tests.el index 6bff09135b..888351adda 100644 --- a/test/lisp/hl-line-tests.el +++ b/test/lisp/hl-line-tests.el @@ -22,12 +22,15 @@ (require 'hl-line) (defsubst hl-line-tests-verify (_label on-p) - (eq on-p (cl-some (apply-partially #'eq hl-line--overlay) - (overlays-at (point))))) + (if on-p + (cl-some (apply-partially #'eq hl-line-overlay) + (overlays-at (point))) + (not (cl-some (apply-partially #'eq hl-line-overlay) + (overlays-at (point)))))) (ert-deftest hl-line-tests-sticky-across-frames () (skip-unless (display-graphic-p)) - (customize-set-variable 'hl-line-sticky-flag t) + (customize-set-variable 'global-hl-line-sticky-flag t) (call-interactively #'global-hl-line-mode) (let ((first-frame (selected-frame)) (first-buffer "foo") commit b49d249ee546d360f1c85cc1cbf441b23dbddbd2 Author: Po Lu Date: Wed Mar 23 16:51:01 2022 +0800 * lisp/calendar/todo-mode.el: Restore old code. diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el index eed597a033..57fcd1b17e 100644 --- a/lisp/calendar/todo-mode.el +++ b/lisp/calendar/todo-mode.el @@ -1040,7 +1040,9 @@ empty line above the done items separator." (eval-and-compile (require 'hl-line)) (when (memq major-mode '(todo-mode todo-archive-mode todo-filtered-items-mode)) - (hl-line-mode 'toggle))) + (if hl-line-mode + (hl-line-mode -1) + (hl-line-mode 1)))) (defvar todo--item-headers-hidden nil "Non-nil if item date-time headers in current buffer are hidden.") @@ -6674,8 +6676,9 @@ Added to `window-configuration-change-hook' in Todo mode." (defun todo-hl-line-range () "Make `todo-toggle-item-highlighting' highlight entire item." (save-excursion - (when (and (todo-item-end) hl-line--overlay) - (move-overlay hl-line--overlay (todo-item-start) (todo-item-end))))) + (when (todo-item-end) + (cons (todo-item-start) + (todo-item-end))))) (defun todo-modes-set-2 () "Make some settings that apply to multiple Todo modes." @@ -6683,7 +6686,7 @@ Added to `window-configuration-change-hook' in Todo mode." (setq buffer-read-only t) (setq-local todo--item-headers-hidden nil) (setq-local desktop-save-buffer 'todo-desktop-save-buffer) - (add-hook 'hl-line-highlight-hook #'todo-hl-line-range nil t)) + (setq-local hl-line-range-function #'todo-hl-line-range)) (defun todo-modes-set-3 () "Make some settings that apply to multiple Todo modes." commit a34afbf2aea2fdaf691f4bf250a18991b21301d7 Author: Po Lu Date: Wed Mar 23 16:48:49 2022 +0800 Restore old hl-line code * lisp/hl-line.el: Restore old code to remove obsoletions. (hl-line-overlay-priority): Make defcustom. diff --git a/lisp/hl-line.el b/lisp/hl-line.el index f1c2e1ebf2..20b3f4160f 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el @@ -24,40 +24,58 @@ ;;; Commentary: -;; Proper scuttling of unsticky overlays relies on `post-command-hook` -;; being called on a buffer switch and the stationarity of -;; `hl-line--buffer` across switches. One could easily imagine -;; programatically defeating unsticky overlays by bypassing -;; `post-command-hook`. +;; Provides a local minor mode (toggled by M-x hl-line-mode) and +;; a global minor mode (toggled by M-x global-hl-line-mode) to +;; highlight, on a suitable terminal, the line on which point is. The +;; global mode highlights the current line in the selected window only +;; (except when the minibuffer window is selected). This was +;; implemented to satisfy a request for a feature of Lesser Editors. +;; The local mode is sticky: it highlights the line about the buffer's +;; point even if the buffer's window is not selected. Caveat: the +;; buffer's point might be different from the point of a non-selected +;; window. Set the variable `hl-line-sticky-flag' to nil to make the +;; local mode behave like the global mode. -;;; Code: +;; You probably don't really want to use the global mode; if the +;; cursor is difficult to spot, try changing its color, relying on +;; `blink-cursor-mode' or both. The hookery used might affect +;; response noticeably on a slow machine. The local mode may be +;; useful in non-editing buffers such as Gnus or PCL-CVS though. + +;; An overlay is used. In the non-sticky cases, this overlay is +;; active only on the selected window. A hook is added to +;; `post-command-hook' to activate the overlay and move it to the line +;; about point. + +;; You could make variable `global-hl-line-mode' buffer-local and set +;; it to nil to avoid highlighting specific buffers, when the global +;; mode is used. -(make-obsolete-variable 'hl-line-overlay 'hl-line--overlay "29.1") -(make-obsolete-variable 'global-hl-line-overlay nil "29.1") -(make-obsolete-variable 'global-hl-line-overlays nil "29.1") -(make-obsolete-variable 'global-hl-line-sticky-flag nil "29.1") -(make-obsolete-variable 'hl-line-overlay-buffer 'hl-line--buffer "29.1") -(make-obsolete-variable 'hl-line-range-function nil "29.1") +;; By default the whole line is highlighted. The range of highlighting +;; can be changed by defining an appropriate function as the +;; buffer-local value of `hl-line-range-function'. -(defvar-local hl-line--overlay nil - "The prevailing highlighting overlay per buffer.") +;;; Code: + +(defvar-local hl-line-overlay nil + "Overlay used by Hl-Line mode to highlight the current line.") -(defvar hl-line--buffer nil - "Used to track last buffer.") +(defvar-local global-hl-line-overlay nil + "Overlay used by Global-Hl-Line mode to highlight the current line.") -;; 1. define-minor-mode creates buffer-local hl-line--overlay -;; 2. overlay wiped by kill-all-local-variables -;; 3. post-command-hook dupes overlay -;; Solution: prevent step 2. -(put 'hl-line--overlay 'permanent-local t) +(defvar global-hl-line-overlays nil + "Overlays used by Global-Hl-Line mode in various buffers. +Global-Hl-Line keeps displaying one overlay in each buffer +when `global-hl-line-sticky-flag' is non-nil.") (defgroup hl-line nil "Highlight the current line." :version "21.1" :group 'convenience) -(defface hl-line '((t :inherit highlight :extend t)) - "Default face for highlighting the current line in hl-line-mode." +(defface hl-line + '((t :inherit highlight :extend t)) + "Default face for highlighting the current line in Hl-Line mode." :version "22.1" :group 'hl-line) @@ -69,77 +87,204 @@ (set symbol value) (dolist (buffer (buffer-list)) (with-current-buffer buffer - (when hl-line--overlay - (overlay-put hl-line--overlay 'face hl-line-face)))))) + (when (overlayp hl-line-overlay) + (overlay-put hl-line-overlay 'face hl-line-face)))) + (when (overlayp global-hl-line-overlay) + (overlay-put global-hl-line-overlay 'face hl-line-face)))) (defcustom hl-line-sticky-flag t - "Non-nil to preserve highlighting overlay when focus leaves window." + "Non-nil means the HL-Line mode highlight appears in all windows. +Otherwise Hl-Line mode will highlight only in the selected +window. Setting this variable takes effect the next time you use +the command `hl-line-mode' to turn Hl-Line mode on. + +This variable has no effect in Global Highlight Line mode. +For that, use `global-hl-line-sticky-flag'." :type 'boolean :version "22.1" - :group 'hl-line - :initialize #'custom-initialize-default - :set (lambda (symbol value) - (set-default symbol value) - (unless value - (let ((selected (window-buffer (selected-window)))) - (dolist (buffer (buffer-list)) - (unless (eq buffer selected) - (with-current-buffer buffer - (hl-line-unhighlight)))))))) + :group 'hl-line) + +(defcustom global-hl-line-sticky-flag nil + "Non-nil means the Global HL-Line mode highlight appears in all windows. +Otherwise Global Hl-Line mode will highlight only in the selected +window. Setting this variable takes effect the next time you use +the command `global-hl-line-mode' to turn Global Hl-Line mode on." + :type 'boolean + :version "24.1" + :group 'hl-line) + +(defvar hl-line-range-function nil + "If non-nil, function to call to return highlight range. +The function of no args should return a cons cell; its car value +is the beginning position of highlight and its cdr value is the +end position of highlight in the buffer. +It should return nil if there's no region to be highlighted. + +This variable is expected to be made buffer-local by modes.") + +(defvar hl-line-overlay-buffer nil + "Most recently visited buffer in which Hl-Line mode is enabled.") (defcustom hl-line-overlay-priority -50 "Priority used on the overlay used by hl-line." :type 'integer - :version "22.1" - :group 'hl-line) - -(defcustom hl-line-highlight-hook nil - "After hook for `hl-line-highlight'. -Currently used in calendar/todo-mode." - :type 'hook + :version "28.1" :group 'hl-line) ;;;###autoload (define-minor-mode hl-line-mode - "Toggle highlighting of the current line." + "Toggle highlighting of the current line (Hl-Line mode). + +Hl-Line mode is a buffer-local minor mode. If +`hl-line-sticky-flag' is non-nil, Hl-Line mode highlights the +line about the buffer's point in all windows. Caveat: the +buffer's point might be different from the point of a +non-selected window. Hl-Line mode uses the function +`hl-line-highlight' on `post-command-hook' in this case. + +When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the +line about point in the selected window only." :group 'hl-line (if hl-line-mode (progn - (hl-line-highlight) + ;; In case `kill-all-local-variables' is called. (add-hook 'change-major-mode-hook #'hl-line-unhighlight nil t) + (hl-line-highlight) + (setq hl-line-overlay-buffer (current-buffer)) (add-hook 'post-command-hook #'hl-line-highlight nil t)) (remove-hook 'post-command-hook #'hl-line-highlight t) - (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t) + (hl-line-unhighlight) + (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t))) + +(defun hl-line-make-overlay () + (let ((ol (make-overlay (point) (point)))) + (overlay-put ol 'priority hl-line-overlay-priority) ;(bug#16192) + (overlay-put ol 'face hl-line-face) + ol)) + +(defun hl-line-highlight () + "Activate the Hl-Line overlay on the current line." + (if hl-line-mode ; Might be changed outside the mode function. + (progn + (unless (overlayp hl-line-overlay) + (setq hl-line-overlay (hl-line-make-overlay))) ; To be moved. + (overlay-put hl-line-overlay + 'window (unless hl-line-sticky-flag (selected-window))) + (hl-line-move hl-line-overlay) + (hl-line-maybe-unhighlight)) (hl-line-unhighlight))) (defun hl-line-unhighlight () - (when hl-line--overlay - (delete-overlay hl-line--overlay) - (setq hl-line--overlay nil))) + "Deactivate the Hl-Line overlay on the current line." + (when (overlayp hl-line-overlay) + (delete-overlay hl-line-overlay) + (setq hl-line-overlay nil))) -(defun hl-line-highlight () - (unless (minibufferp) - (unless hl-line--overlay - (setq hl-line--overlay - (let ((ol (make-overlay (point) (point)))) - (prog1 ol - (overlay-put ol 'priority hl-line-overlay-priority) - (overlay-put ol 'face hl-line-face))))) - (move-overlay hl-line--overlay - (line-beginning-position) - (line-beginning-position 2)) - (when (and (not (eq hl-line--buffer (current-buffer))) +(defun hl-line-maybe-unhighlight () + "Maybe deactivate the Hl-Line overlay on the current line. +Specifically, when `hl-line-sticky-flag' is nil deactivate all +such overlays in all buffers except the current one." + (let ((hlob hl-line-overlay-buffer) + (curbuf (current-buffer))) + (when (and (buffer-live-p hlob) (not hl-line-sticky-flag) - (buffer-live-p hl-line--buffer)) - (with-current-buffer hl-line--buffer + (not (eq curbuf hlob)) + (not (minibufferp))) + (with-current-buffer hlob (hl-line-unhighlight))) - (setq hl-line--buffer (current-buffer)) - (run-hooks 'hl-line-highlight-hook))) + (when (and (overlayp hl-line-overlay) + (eq (overlay-buffer hl-line-overlay) curbuf)) + (setq hl-line-overlay-buffer curbuf)))) + +;;;###autoload +(define-minor-mode global-hl-line-mode + "Toggle line highlighting in all buffers (Global Hl-Line mode). + +If `global-hl-line-sticky-flag' is non-nil, Global Hl-Line mode +highlights the line about the current buffer's point in all live +windows. + +Global-Hl-Line mode uses the function `global-hl-line-highlight' +on `post-command-hook'." + :global t + :group 'hl-line + (if global-hl-line-mode + (progn + ;; In case `kill-all-local-variables' is called. + (add-hook 'change-major-mode-hook #'global-hl-line-unhighlight) + (global-hl-line-highlight-all) + (add-hook 'post-command-hook #'global-hl-line-highlight)) + (global-hl-line-unhighlight-all) + (remove-hook 'post-command-hook #'global-hl-line-highlight) + (remove-hook 'change-major-mode-hook #'global-hl-line-unhighlight))) + +(defun global-hl-line-highlight () + "Highlight the current line in the current window." + (when global-hl-line-mode ; Might be changed outside the mode function. + (unless (window-minibuffer-p) + (unless (overlayp global-hl-line-overlay) + (setq global-hl-line-overlay (hl-line-make-overlay))) ; To be moved. + (unless (member global-hl-line-overlay global-hl-line-overlays) + (push global-hl-line-overlay global-hl-line-overlays)) + (overlay-put global-hl-line-overlay 'window + (unless global-hl-line-sticky-flag + (selected-window))) + (hl-line-move global-hl-line-overlay) + (global-hl-line-maybe-unhighlight)))) + +(defun global-hl-line-highlight-all () + "Highlight the current line in all live windows." + (walk-windows (lambda (w) + (with-current-buffer (window-buffer w) + (global-hl-line-highlight))) + nil t)) + +(defun global-hl-line-unhighlight () + "Deactivate the Global-Hl-Line overlay on the current line." + (when (overlayp global-hl-line-overlay) + (delete-overlay global-hl-line-overlay) + (setq global-hl-line-overlay nil))) -(defun hl-line-turn-on () - (unless (minibufferp) - (let (inhibit-quit) - (hl-line-mode 1)))) +(defun global-hl-line-maybe-unhighlight () + "Maybe deactivate the Global-Hl-Line overlay on the current line. +Specifically, when `global-hl-line-sticky-flag' is nil deactivate +all such overlays in all buffers except the current one." + (mapc (lambda (ov) + (let ((ovb (overlay-buffer ov))) + (when (and (not global-hl-line-sticky-flag) + (bufferp ovb) + (not (eq ovb (current-buffer))) + (not (minibufferp))) + (with-current-buffer ovb + (global-hl-line-unhighlight))))) + global-hl-line-overlays)) + +(defun global-hl-line-unhighlight-all () + "Deactivate all Global-Hl-Line overlays." + (mapc (lambda (ov) + (let ((ovb (overlay-buffer ov))) + (when (bufferp ovb) + (with-current-buffer ovb + (global-hl-line-unhighlight))))) + global-hl-line-overlays) + (setq global-hl-line-overlays nil)) + +(defun hl-line-move (overlay) + "Move the Hl-Line overlay. +If `hl-line-range-function' is non-nil, move the OVERLAY to the position +where the function returns. If `hl-line-range-function' is nil, fill +the line including the point by OVERLAY." + (let (tmp b e) + (if hl-line-range-function + (setq tmp (funcall hl-line-range-function) + b (car tmp) + e (cdr tmp)) + (setq tmp t + b (line-beginning-position) + e (line-beginning-position 2))) + (if tmp + (move-overlay overlay b e) + (move-overlay overlay 1 1)))) (defun hl-line-unload-function () "Unload the Hl-Line library." @@ -151,12 +296,6 @@ Currently used in calendar/todo-mode." ;; continue standard unloading nil) -;;;###autoload -(define-globalized-minor-mode global-hl-line-mode - hl-line-mode hl-line-turn-on - :group 'hl-line - :version "29.1") - (provide 'hl-line) ;;; hl-line.el ends here commit fed9a353dbe79a7a6acc74c1e223c46e7541e627 Author: Po Lu Date: Wed Mar 23 08:17:49 2022 +0000 Allow retrieving some more kinds of clipboard data on Haiku * src/haiku_select.cc (BClipboard_find_data): Handle NULL characters inside data correctly. (be_lock_clipboard_message, be_unlock_clipboard): New functions. * src/haikuselect.c (Fhaiku_selection_data): Return entire clipboard contents as a message when clipboard is NULL. (haiku_lisp_to_message): Allow quitting when iterating through potentially large or circular lists. * src/haikuselect.h (enum haiku_clipboard): New enum. diff --git a/src/haiku_select.cc b/src/haiku_select.cc index 9012639d6a..bccc79da01 100644 --- a/src/haiku_select.cc +++ b/src/haiku_select.cc @@ -64,9 +64,17 @@ BClipboard_find_data (BClipboard *cb, const char *type, ssize_t *len) if (len) *len = bt; - cb->Unlock (); + void *data = malloc (bt); + + if (!data) + { + cb->Unlock (); + return NULL; + } - return strndup (ptr, bt); + memcpy (data, ptr, bt); + cb->Unlock (); + return (char *) data; } static void @@ -354,3 +362,38 @@ be_add_refs_data (void *message, const char *name, return msg->AddRef (name, &ref) != B_OK; } + +int +be_lock_clipboard_message (enum haiku_clipboard clipboard, + void **message_return) +{ + BClipboard *board; + + if (clipboard == CLIPBOARD_PRIMARY) + board = primary; + else if (clipboard == CLIPBOARD_SECONDARY) + board = secondary; + else + board = system_clipboard; + + if (!board->Lock ()) + return 1; + + *message_return = board->Data (); + return 0; +} + +void +be_unlock_clipboard (enum haiku_clipboard clipboard) +{ + BClipboard *board; + + if (clipboard == CLIPBOARD_PRIMARY) + board = primary; + else if (clipboard == CLIPBOARD_SECONDARY) + board = secondary; + else + board = system_clipboard; + + board->Unlock (); +} diff --git a/src/haikuselect.c b/src/haikuselect.c index 5a90fe37d2..d59b4512a4 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -71,43 +71,74 @@ DEFUN ("haiku-selection-data", Fhaiku_selection_data, Shaiku_selection_data, 2, 2, 0, doc: /* Retrieve content typed as NAME from the clipboard CLIPBOARD. CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or -`CLIPBOARD'. NAME is a MIME type denoting the type of the data to -fetch. */) +`CLIPBOARD'. NAME is a string describing the MIME type denoting the +type of the data to fetch. If NAME is nil, then the entire contents +of the clipboard will be returned instead, as a serialized system +message in the format accepted by `haiku-drag-message', which see. */) (Lisp_Object clipboard, Lisp_Object name) { - CHECK_SYMBOL (clipboard); - CHECK_STRING (name); char *dat; ssize_t len; + Lisp_Object str; + void *message; + enum haiku_clipboard clipboard_name; + int rc; - block_input (); - if (EQ (clipboard, QPRIMARY)) - dat = BClipboard_find_primary_selection_data (SSDATA (name), &len); - else if (EQ (clipboard, QSECONDARY)) - dat = BClipboard_find_secondary_selection_data (SSDATA (name), &len); - else if (EQ (clipboard, QCLIPBOARD)) - dat = BClipboard_find_system_data (SSDATA (name), &len); - else + CHECK_SYMBOL (clipboard); + + if (!EQ (clipboard, QPRIMARY) && !EQ (clipboard, QSECONDARY) + && !EQ (clipboard, QCLIPBOARD)) + signal_error ("Invalid clipboard", clipboard); + + if (!NILP (name)) { + CHECK_STRING (name); + + block_input (); + if (EQ (clipboard, QPRIMARY)) + dat = BClipboard_find_primary_selection_data (SSDATA (name), &len); + else if (EQ (clipboard, QSECONDARY)) + dat = BClipboard_find_secondary_selection_data (SSDATA (name), &len); + else + dat = BClipboard_find_system_data (SSDATA (name), &len); unblock_input (); - signal_error ("Bad clipboard", clipboard); - } - unblock_input (); - if (!dat) - return Qnil; + if (!dat) + return Qnil; - Lisp_Object str = make_unibyte_string (dat, len); + str = make_unibyte_string (dat, len); - /* `foreign-selection' just means that the selection has to be - decoded by `gui-get-selection'. It has no other meaning, - AFAICT. */ - Fput_text_property (make_fixnum (0), make_fixnum (len), - Qforeign_selection, Qt, str); + /* `foreign-selection' just means that the selection has to be + decoded by `gui-get-selection'. It has no other meaning, + AFAICT. */ + Fput_text_property (make_fixnum (0), make_fixnum (len), + Qforeign_selection, Qt, str); - block_input (); - BClipboard_free_data (dat); - unblock_input (); + block_input (); + BClipboard_free_data (dat); + unblock_input (); + } + else + { + if (EQ (clipboard, QPRIMARY)) + clipboard_name = CLIPBOARD_PRIMARY; + else if (EQ (clipboard, QSECONDARY)) + clipboard_name = CLIPBOARD_SECONDARY; + else + clipboard_name = CLIPBOARD_CLIPBOARD; + + block_input (); + rc = be_lock_clipboard_message (clipboard_name, &message); + unblock_input (); + + if (rc) + signal_error ("Couldn't open clipboard", clipboard); + + block_input (); + str = haiku_message_to_lisp (message); + be_unlock_clipboard (clipboard_name); + unblock_input (); + } return str; } @@ -359,6 +390,7 @@ haiku_lisp_to_message (Lisp_Object obj, void *message) CHECK_LIST (obj); for (tem = obj; CONSP (tem); tem = XCDR (tem)) { + maybe_quit (); t1 = XCAR (tem); CHECK_CONS (t1); @@ -377,6 +409,7 @@ haiku_lisp_to_message (Lisp_Object obj, void *message) CHECK_LIST (t1); for (t2 = XCDR (t1); CONSP (t2); t2 = XCDR (t2)) { + maybe_quit (); data = XCAR (t2); switch (type_code) diff --git a/src/haikuselect.h b/src/haikuselect.h index 4869d9d33c..4278994918 100644 --- a/src/haikuselect.h +++ b/src/haikuselect.h @@ -25,6 +25,13 @@ along with GNU Emacs. If not, see . */ #include +enum haiku_clipboard + { + CLIPBOARD_PRIMARY, + CLIPBOARD_SECONDARY, + CLIPBOARD_CLIPBOARD + }; + #ifdef __cplusplus #include extern "C" @@ -93,6 +100,9 @@ extern "C" ssize_t buf_size); extern int be_add_refs_data (void *message, const char *name, const char *filename); + extern int be_lock_clipboard_message (enum haiku_clipboard clipboard, + void **message_return); + extern void be_unlock_clipboard (enum haiku_clipboard clipboard); #ifdef __cplusplus }; #endif commit 5f8a3ca9af70af926b284c98c3995e0743256721 Merge: 64aabe706f c69a617742 Author: Stefan Kangas Date: Wed Mar 23 06:30:45 2022 +0100 ; Merge from origin/emacs-28 The following commit was skipped: c69a617742 Add notes about command modes and nativecomp interaction commit 64aabe706f139cce82a10d0c6d1fd9904c51cbcf Author: Po Lu Date: Wed Mar 23 04:01:01 2022 +0000 Fix crash in haiku_message_to_lisp * src/haikuselect.c (haiku_message_to_lisp): Block input around `free'. diff --git a/src/haikuselect.c b/src/haikuselect.c index 21407eedf0..5a90fe37d2 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -239,7 +239,10 @@ haiku_message_to_lisp (void *message) memory_full (SIZE_MAX); t1 = build_string (pbuf); + + block_input (); free (pbuf); + unblock_input (); break; case 'SHRT': commit 8aff4c0a366f060595dd6360e7a008585b7eb405 Author: Po Lu Date: Wed Mar 23 11:30:13 2022 +0800 Handle quitting correctly during interprogram drag-and-drop * lisp/mouse.el (mouse-drag-and-drop-region): Handle quit correctly by exiting the cross program drag and drop. diff --git a/lisp/mouse.el b/lisp/mouse.el index 30b19510a4..381fc0c47e 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -3119,13 +3119,15 @@ is copied instead of being cut." (mouse-drag-and-drop-region-hide-tooltip) (gui-set-selection 'XdndSelection value-selection) (let ((drag-action-or-frame - (x-begin-drag '("UTF8_STRING" "text/plain" - "text/plain;charset=utf-8" - "STRING" "TEXT" "COMPOUND_TEXT") - (if mouse-drag-and-drop-region-cut-when-buffers-differ - 'XdndActionMove - 'XdndActionCopy) - (posn-window (event-end event)) t))) + (condition-case nil + (x-begin-drag '("UTF8_STRING" "text/plain" + "text/plain;charset=utf-8" + "STRING" "TEXT" "COMPOUND_TEXT") + (if mouse-drag-and-drop-region-cut-when-buffers-differ + 'XdndActionMove + 'XdndActionCopy) + (posn-window (event-end event)) t) + (quit nil)))) (when (framep drag-action-or-frame) (throw 'drag-again nil)) commit 021dbdb1287de0f5502eac00fee8d43b8d22db55 Author: Po Lu Date: Wed Mar 23 11:14:13 2022 +0800 * src/xterm.c (x_dnd_begin_drag_and_drop): Fix test against DND frame. diff --git a/src/xterm.c b/src/xterm.c index 3d0d826409..e4c17644e4 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -6949,8 +6949,8 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, int finish; #endif XWindowAttributes root_window_attrs; - struct input_event hold_quit; + struct frame *any; char *atom_name; Lisp_Object action, ltimestamp; specpdl_ref ref; @@ -7110,8 +7110,9 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, loop, so when dragging items to itself, always return XdndActionPrivate. */ if (x_dnd_end_window != None - && (x_any_window_to_frame (FRAME_DISPLAY_INFO (f), - x_dnd_end_window) != f)) + && (any = x_any_window_to_frame (FRAME_DISPLAY_INFO (f), + x_dnd_end_window)) + && (any != f)) return QXdndActionPrivate; if (x_dnd_action != None) commit bd2734f0b6b4342f02ce18b5a950a41c3fa35a29 Author: Po Lu Date: Wed Mar 23 02:27:21 2022 +0000 Don't allocate duplicate cursors for each frame on Haiku * src/haikufns.c (haiku_create_frame) (haiku_free_frame_resources): Stop creating cursors. * src/haikuterm.c (haiku_delete_terminal, haiku_term_init): Create and free cursors here instead. * src/haikuterm.h (struct haiku_display_info): New fields for cursors. diff --git a/src/haikufns.c b/src/haikufns.c index 14d4c870c1..767f555317 100644 --- a/src/haikufns.c +++ b/src/haikufns.c @@ -761,38 +761,27 @@ haiku_create_frame (Lisp_Object parms) f->no_split = minibuffer_only || (!EQ (tem, Qunbound) && !NILP (tem)); block_input (); -#define ASSIGN_CURSOR(cursor, be_cursor) \ - (FRAME_OUTPUT_DATA (f)->cursor = be_cursor) - - ASSIGN_CURSOR (text_cursor, BCursor_create_i_beam ()); - ASSIGN_CURSOR (nontext_cursor, BCursor_create_default ()); - ASSIGN_CURSOR (modeline_cursor, BCursor_create_modeline ()); - ASSIGN_CURSOR (hand_cursor, BCursor_create_grab ()); - ASSIGN_CURSOR (hourglass_cursor, BCursor_create_progress_cursor ()); - ASSIGN_CURSOR (horizontal_drag_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_EAST_WEST)); - ASSIGN_CURSOR (vertical_drag_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_NORTH_SOUTH)); - ASSIGN_CURSOR (left_edge_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_WEST)); - ASSIGN_CURSOR (top_left_corner_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_NORTH_WEST)); - ASSIGN_CURSOR (top_edge_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_NORTH)); - ASSIGN_CURSOR (top_right_corner_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_NORTH_EAST)); - ASSIGN_CURSOR (right_edge_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_EAST)); - ASSIGN_CURSOR (bottom_right_corner_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_EAST)); - ASSIGN_CURSOR (bottom_edge_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_SOUTH)); - ASSIGN_CURSOR (bottom_left_corner_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_WEST)); - ASSIGN_CURSOR (no_cursor, - BCursor_from_id (CURSOR_ID_NO_CURSOR)); - - ASSIGN_CURSOR (current_cursor, FRAME_OUTPUT_DATA (f)->text_cursor); +#define ASSIGN_CURSOR(cursor) \ + (FRAME_OUTPUT_DATA (f)->cursor = dpyinfo->cursor) + + ASSIGN_CURSOR (text_cursor); + ASSIGN_CURSOR (nontext_cursor); + ASSIGN_CURSOR (modeline_cursor); + ASSIGN_CURSOR (hand_cursor); + ASSIGN_CURSOR (hourglass_cursor); + ASSIGN_CURSOR (horizontal_drag_cursor); + ASSIGN_CURSOR (vertical_drag_cursor); + ASSIGN_CURSOR (left_edge_cursor); + ASSIGN_CURSOR (top_left_corner_cursor); + ASSIGN_CURSOR (top_edge_cursor); + ASSIGN_CURSOR (top_right_corner_cursor); + ASSIGN_CURSOR (right_edge_cursor); + ASSIGN_CURSOR (bottom_right_corner_cursor); + ASSIGN_CURSOR (bottom_edge_cursor); + ASSIGN_CURSOR (bottom_left_corner_cursor); + ASSIGN_CURSOR (no_cursor); + + FRAME_OUTPUT_DATA (f)->current_cursor = dpyinfo->text_cursor; #undef ASSIGN_CURSOR f->terminal->reference_count++; @@ -1555,25 +1544,6 @@ haiku_free_frame_resources (struct frame *f) if (window) BWindow_quit (window); - /* Free cursors */ - - BCursor_delete (f->output_data.haiku->text_cursor); - BCursor_delete (f->output_data.haiku->nontext_cursor); - BCursor_delete (f->output_data.haiku->modeline_cursor); - BCursor_delete (f->output_data.haiku->hand_cursor); - BCursor_delete (f->output_data.haiku->hourglass_cursor); - BCursor_delete (f->output_data.haiku->horizontal_drag_cursor); - BCursor_delete (f->output_data.haiku->vertical_drag_cursor); - BCursor_delete (f->output_data.haiku->left_edge_cursor); - BCursor_delete (f->output_data.haiku->top_left_corner_cursor); - BCursor_delete (f->output_data.haiku->top_edge_cursor); - BCursor_delete (f->output_data.haiku->top_right_corner_cursor); - BCursor_delete (f->output_data.haiku->right_edge_cursor); - BCursor_delete (f->output_data.haiku->bottom_right_corner_cursor); - BCursor_delete (f->output_data.haiku->bottom_edge_cursor); - BCursor_delete (f->output_data.haiku->bottom_left_corner_cursor); - BCursor_delete (f->output_data.haiku->no_cursor); - xfree (FRAME_OUTPUT_DATA (f)); FRAME_OUTPUT_DATA (f) = NULL; diff --git a/src/haikuterm.c b/src/haikuterm.c index b0bbee9e3b..c2e8375a10 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -122,7 +122,26 @@ haiku_delete_terminal (struct terminal *terminal) return; block_input (); + be_app_quit (); + delete_port (port_application_to_emacs); + + BCursor_delete (dpyinfo->text_cursor); + BCursor_delete (dpyinfo->nontext_cursor); + BCursor_delete (dpyinfo->modeline_cursor); + BCursor_delete (dpyinfo->hand_cursor); + BCursor_delete (dpyinfo->hourglass_cursor); + BCursor_delete (dpyinfo->horizontal_drag_cursor); + BCursor_delete (dpyinfo->vertical_drag_cursor); + BCursor_delete (dpyinfo->left_edge_cursor); + BCursor_delete (dpyinfo->top_left_corner_cursor); + BCursor_delete (dpyinfo->top_edge_cursor); + BCursor_delete (dpyinfo->top_right_corner_cursor); + BCursor_delete (dpyinfo->right_edge_cursor); + BCursor_delete (dpyinfo->bottom_right_corner_cursor); + BCursor_delete (dpyinfo->bottom_edge_cursor); + BCursor_delete (dpyinfo->bottom_left_corner_cursor); + BCursor_delete (dpyinfo->no_cursor); /* Close all frames and delete the generic struct terminal. */ for (t = terminal_list; t; t = t->next_terminal) @@ -3911,6 +3930,37 @@ haiku_term_init (void) dpyinfo->smallest_char_width = 1; gui_init_fringe (terminal->rif); + +#define ASSIGN_CURSOR(cursor, be_cursor) (dpyinfo->cursor = be_cursor) + ASSIGN_CURSOR (text_cursor, BCursor_create_i_beam ()); + ASSIGN_CURSOR (nontext_cursor, BCursor_create_default ()); + ASSIGN_CURSOR (modeline_cursor, BCursor_create_modeline ()); + ASSIGN_CURSOR (hand_cursor, BCursor_create_grab ()); + ASSIGN_CURSOR (hourglass_cursor, BCursor_create_progress_cursor ()); + ASSIGN_CURSOR (horizontal_drag_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_EAST_WEST)); + ASSIGN_CURSOR (vertical_drag_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH_SOUTH)); + ASSIGN_CURSOR (left_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_WEST)); + ASSIGN_CURSOR (top_left_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH_WEST)); + ASSIGN_CURSOR (top_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH)); + ASSIGN_CURSOR (top_right_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH_EAST)); + ASSIGN_CURSOR (right_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_EAST)); + ASSIGN_CURSOR (bottom_right_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_EAST)); + ASSIGN_CURSOR (bottom_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_SOUTH)); + ASSIGN_CURSOR (bottom_left_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_WEST)); + ASSIGN_CURSOR (no_cursor, + BCursor_from_id (CURSOR_ID_NO_CURSOR)); +#undef ASSIGN_CURSOR + unblock_input (); return dpyinfo; diff --git a/src/haikuterm.h b/src/haikuterm.h index bce1c627eb..5f8052f0f9 100644 --- a/src/haikuterm.h +++ b/src/haikuterm.h @@ -107,6 +107,23 @@ struct haiku_display_info Time last_mouse_movement_time; Window root_window; + + Emacs_Cursor text_cursor; + Emacs_Cursor nontext_cursor; + Emacs_Cursor modeline_cursor; + Emacs_Cursor hand_cursor; + Emacs_Cursor hourglass_cursor; + Emacs_Cursor horizontal_drag_cursor; + Emacs_Cursor vertical_drag_cursor; + Emacs_Cursor left_edge_cursor; + Emacs_Cursor top_left_corner_cursor; + Emacs_Cursor top_edge_cursor; + Emacs_Cursor top_right_corner_cursor; + Emacs_Cursor right_edge_cursor; + Emacs_Cursor bottom_right_corner_cursor; + Emacs_Cursor bottom_edge_cursor; + Emacs_Cursor bottom_left_corner_cursor; + Emacs_Cursor no_cursor; }; struct haiku_output commit 9cef919692590e351f52ccee48246bd9d7f4873d Author: Po Lu Date: Wed Mar 23 09:26:23 2022 +0800 Improve DND documentation * doc/lispref/frames.texi (Drag and Drop): * src/xfns.c (Fx_begin_drag): Document meaning of `XdndActionPrivate'. diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index 31ebeb51b4..9717fa2978 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -4070,7 +4070,10 @@ while also being able to drag content to other programs. If the drop was rejected or no drop target was found, this function returns @code{nil}. Otherwise, it returns a symbol describing the action the target chose to perform, which can differ from @var{action} -if that isn't supported by the drop target. +if that isn't supported by the drop target. @code{XdndActionPrivate} +is also a valid return value in addition to @code{XdndActionCopy} and +@code{XdndActionMove}, and means that the drop target chose to perform +an unspecified action. @end defun @node Color Names diff --git a/src/xfns.c b/src/xfns.c index 9d30f2adee..eae409eed2 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -6601,6 +6601,9 @@ can be one of the following: `XdndSelection', and to delete whatever was saved into that selection afterwards. +`XdndActionPrivate' is also a valid return value, and means that the +drop target chose to perform an unspecified or unknown action. + There are also some other valid values of ACTION that depend on details of both the drop target's implementation details and that of Emacs. For that reason, they are not mentioned here. Consult commit dd242b49ec477c116a1f1a345970ceaf6920878d Author: Po Lu Date: Wed Mar 23 09:21:19 2022 +0800 ; * src/xterm.c (x_free_frame_resources): Fix typo in last change. diff --git a/src/xterm.c b/src/xterm.c index 550515aeff..3d0d826409 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -17596,7 +17596,7 @@ x_free_frame_resources (struct frame *f) x_dnd_send_leave (f, x_dnd_last_seen_window); unblock_input (); - x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_end_window = None; x_dnd_last_seen_window = None; x_dnd_in_progress = false; x_dnd_waiting_for_finish = false; commit 8b853b3f98a9e6a81a2d41a668d560cc9105836f Author: Po Lu Date: Wed Mar 23 09:21:04 2022 +0800 Reported taken action correctly when dragging to another frame on X * src/xterm.c (x_dnd_cleanup_drag_and_drop, x_dnd_update_state) (x_free_frame_resources, handle_one_xevent): Set `x_dnd_end_window'. (x_dnd_begin_drag_and_drop): Return `XdndActionPrivate' if the drop landed on one of our own frames. diff --git a/src/xterm.c b/src/xterm.c index a7d8445502..550515aeff 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -805,6 +805,7 @@ static int x_dnd_return_frame; static struct frame *x_dnd_return_frame_object; static Window x_dnd_last_seen_window; +static Window x_dnd_end_window; static int x_dnd_last_protocol_version; static Time x_dnd_selection_timestamp; @@ -1173,6 +1174,8 @@ x_dnd_cleanup_drag_and_drop (void *frame) x_dnd_last_seen_window); unblock_input (); + x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_last_seen_window = None; x_dnd_in_progress = false; x_set_dnd_targets (NULL, 0); } @@ -1194,184 +1197,6 @@ x_dnd_cleanup_drag_and_drop (void *frame) x_dnd_frame = NULL; } -Lisp_Object -x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, - bool return_frame_p) -{ -#ifndef USE_GTK - XEvent next_event; - int finish; -#endif - XWindowAttributes root_window_attrs; - - struct input_event hold_quit; - char *atom_name; - Lisp_Object action, ltimestamp; - specpdl_ref ref; - - if (!FRAME_VISIBLE_P (f)) - error ("Frame is invisible"); - - if (x_dnd_in_progress || x_dnd_waiting_for_finish) - error ("A drag-and-drop session is already in progress"); - - ltimestamp = x_timestamp_for_selection (FRAME_DISPLAY_INFO (f), - QXdndSelection); - - if (NILP (ltimestamp)) - error ("No local value for XdndSelection"); - - if (BIGNUMP (ltimestamp)) - x_dnd_selection_timestamp = bignum_to_intmax (ltimestamp); - else - x_dnd_selection_timestamp = XFIXNUM (ltimestamp); - - x_dnd_in_progress = true; - x_dnd_frame = f; - x_dnd_last_seen_window = FRAME_X_WINDOW (f); - x_dnd_last_protocol_version = -1; - x_dnd_mouse_rect_target = None; - x_dnd_action = None; - x_dnd_wanted_action = xaction; - x_dnd_return_frame = 0; - x_dnd_waiting_for_finish = false; - - if (return_frame_p) - x_dnd_return_frame = 1; - -#ifdef USE_GTK - current_count = 0; -#endif - - /* Now select for SubstructureNotifyMask and PropertyNotifyMask on - the root window, so we can get notified when window stacking - changes, a common operation during drag-and-drop. */ - - block_input (); - XGetWindowAttributes (FRAME_X_DISPLAY (f), - FRAME_DISPLAY_INFO (f)->root_window, - &root_window_attrs); - - XSelectInput (FRAME_X_DISPLAY (f), - FRAME_DISPLAY_INFO (f)->root_window, - root_window_attrs.your_event_mask - | SubstructureNotifyMask - | PropertyChangeMask); - - while (x_dnd_in_progress || x_dnd_waiting_for_finish) - { - hold_quit.kind = NO_EVENT; -#ifdef USE_GTK - current_finish = X_EVENT_NORMAL; - current_hold_quit = &hold_quit; -#endif - -#ifndef USE_GTK - XNextEvent (FRAME_X_DISPLAY (f), &next_event); - -#ifdef HAVE_X_I18N -#ifdef HAVE_XINPUT2 - if (next_event.type != GenericEvent - || !FRAME_DISPLAY_INFO (f)->supports_xi2 - || (next_event.xgeneric.extension - != FRAME_DISPLAY_INFO (f)->xi2_opcode)) - { -#endif - if (!x_filter_event (FRAME_DISPLAY_INFO (f), &next_event)) - handle_one_xevent (FRAME_DISPLAY_INFO (f), - &next_event, &finish, &hold_quit); -#ifdef HAVE_XINPUT2 - } - else - handle_one_xevent (FRAME_DISPLAY_INFO (f), - &next_event, &finish, &hold_quit); -#endif -#else - handle_one_xevent (FRAME_DISPLAY_INFO (f), - &next_event, &finish, &hold_quit); -#endif -#else - gtk_main_iteration (); -#endif - - if (hold_quit.kind != NO_EVENT) - { - if (hold_quit.kind == SELECTION_REQUEST_EVENT) - { - x_dnd_old_window_attrs = root_window_attrs; - x_dnd_unwind_flag = true; - - ref = SPECPDL_INDEX (); - record_unwind_protect_ptr (x_dnd_cleanup_drag_and_drop, f); - x_handle_selection_event ((struct selection_input_event *) &hold_quit); - x_dnd_unwind_flag = false; - unbind_to (ref, Qnil); - continue; - } - - if (x_dnd_in_progress) - { - if (x_dnd_last_seen_window != None - && x_dnd_last_protocol_version != -1) - x_dnd_send_leave (f, x_dnd_last_seen_window); - - x_dnd_in_progress = false; - x_dnd_frame = NULL; - x_set_dnd_targets (NULL, 0); - x_dnd_waiting_for_finish = false; - } - - FRAME_DISPLAY_INFO (f)->grabbed = 0; -#ifdef USE_GTK - current_hold_quit = NULL; -#endif - /* Restore the old event mask. */ - XSelectInput (FRAME_X_DISPLAY (f), - FRAME_DISPLAY_INFO (f)->root_window, - root_window_attrs.your_event_mask); - unblock_input (); - quit (); - } - } - x_set_dnd_targets (NULL, 0); - x_dnd_waiting_for_finish = false; - -#ifdef USE_GTK - current_hold_quit = NULL; -#endif - - /* Restore the old event mask. */ - XSelectInput (FRAME_X_DISPLAY (f), - FRAME_DISPLAY_INFO (f)->root_window, - root_window_attrs.your_event_mask); - - unblock_input (); - - if (x_dnd_return_frame == 3) - { - x_dnd_return_frame_object->mouse_moved = true; - - XSETFRAME (action, x_dnd_return_frame_object); - return action; - } - - FRAME_DISPLAY_INFO (f)->grabbed = 0; - - if (x_dnd_action != None) - { - block_input (); - atom_name = XGetAtomName (FRAME_X_DISPLAY (f), - x_dnd_action); - action = intern (atom_name); - XFree (atom_name); - unblock_input (); - - return action; - } - - return Qnil; -} - /* Flush display of frame F. */ static void @@ -7112,6 +6937,198 @@ x_top_window_to_frame (struct x_display_info *dpyinfo, int wdesc) #endif /* USE_X_TOOLKIT || USE_GTK */ +/* This function is defined far away from the rest of the XDND code so + it can utilize `x_any_window_to_frame'. */ + +Lisp_Object +x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, + bool return_frame_p) +{ +#ifndef USE_GTK + XEvent next_event; + int finish; +#endif + XWindowAttributes root_window_attrs; + + struct input_event hold_quit; + char *atom_name; + Lisp_Object action, ltimestamp; + specpdl_ref ref; + + if (!FRAME_VISIBLE_P (f)) + error ("Frame is invisible"); + + if (x_dnd_in_progress || x_dnd_waiting_for_finish) + error ("A drag-and-drop session is already in progress"); + + ltimestamp = x_timestamp_for_selection (FRAME_DISPLAY_INFO (f), + QXdndSelection); + + if (NILP (ltimestamp)) + error ("No local value for XdndSelection"); + + if (BIGNUMP (ltimestamp)) + x_dnd_selection_timestamp = bignum_to_intmax (ltimestamp); + else + x_dnd_selection_timestamp = XFIXNUM (ltimestamp); + + x_dnd_in_progress = true; + x_dnd_frame = f; + x_dnd_last_seen_window = FRAME_X_WINDOW (f); + x_dnd_last_protocol_version = -1; + x_dnd_mouse_rect_target = None; + x_dnd_action = None; + x_dnd_wanted_action = xaction; + x_dnd_return_frame = 0; + x_dnd_waiting_for_finish = false; + x_dnd_end_window = None; + + if (return_frame_p) + x_dnd_return_frame = 1; + +#ifdef USE_GTK + current_count = 0; +#endif + + /* Now select for SubstructureNotifyMask and PropertyNotifyMask on + the root window, so we can get notified when window stacking + changes, a common operation during drag-and-drop. */ + + block_input (); + XGetWindowAttributes (FRAME_X_DISPLAY (f), + FRAME_DISPLAY_INFO (f)->root_window, + &root_window_attrs); + + XSelectInput (FRAME_X_DISPLAY (f), + FRAME_DISPLAY_INFO (f)->root_window, + root_window_attrs.your_event_mask + | SubstructureNotifyMask + | PropertyChangeMask); + + while (x_dnd_in_progress || x_dnd_waiting_for_finish) + { + hold_quit.kind = NO_EVENT; +#ifdef USE_GTK + current_finish = X_EVENT_NORMAL; + current_hold_quit = &hold_quit; +#endif + +#ifndef USE_GTK + XNextEvent (FRAME_X_DISPLAY (f), &next_event); + +#ifdef HAVE_X_I18N +#ifdef HAVE_XINPUT2 + if (next_event.type != GenericEvent + || !FRAME_DISPLAY_INFO (f)->supports_xi2 + || (next_event.xgeneric.extension + != FRAME_DISPLAY_INFO (f)->xi2_opcode)) + { +#endif + if (!x_filter_event (FRAME_DISPLAY_INFO (f), &next_event)) + handle_one_xevent (FRAME_DISPLAY_INFO (f), + &next_event, &finish, &hold_quit); +#ifdef HAVE_XINPUT2 + } + else + handle_one_xevent (FRAME_DISPLAY_INFO (f), + &next_event, &finish, &hold_quit); +#endif +#else + handle_one_xevent (FRAME_DISPLAY_INFO (f), + &next_event, &finish, &hold_quit); +#endif +#else + gtk_main_iteration (); +#endif + + if (hold_quit.kind != NO_EVENT) + { + if (hold_quit.kind == SELECTION_REQUEST_EVENT) + { + x_dnd_old_window_attrs = root_window_attrs; + x_dnd_unwind_flag = true; + + ref = SPECPDL_INDEX (); + record_unwind_protect_ptr (x_dnd_cleanup_drag_and_drop, f); + x_handle_selection_event ((struct selection_input_event *) &hold_quit); + x_dnd_unwind_flag = false; + unbind_to (ref, Qnil); + continue; + } + + if (x_dnd_in_progress) + { + if (x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1) + x_dnd_send_leave (f, x_dnd_last_seen_window); + + x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_last_seen_window = None; + x_dnd_in_progress = false; + x_dnd_frame = NULL; + x_set_dnd_targets (NULL, 0); + x_dnd_waiting_for_finish = false; + } + + FRAME_DISPLAY_INFO (f)->grabbed = 0; +#ifdef USE_GTK + current_hold_quit = NULL; +#endif + /* Restore the old event mask. */ + XSelectInput (FRAME_X_DISPLAY (f), + FRAME_DISPLAY_INFO (f)->root_window, + root_window_attrs.your_event_mask); + unblock_input (); + quit (); + } + } + x_set_dnd_targets (NULL, 0); + x_dnd_waiting_for_finish = false; + +#ifdef USE_GTK + current_hold_quit = NULL; +#endif + + /* Restore the old event mask. */ + XSelectInput (FRAME_X_DISPLAY (f), + FRAME_DISPLAY_INFO (f)->root_window, + root_window_attrs.your_event_mask); + + unblock_input (); + + if (x_dnd_return_frame == 3) + { + x_dnd_return_frame_object->mouse_moved = true; + + XSETFRAME (action, x_dnd_return_frame_object); + return action; + } + + FRAME_DISPLAY_INFO (f)->grabbed = 0; + + /* Emacs can't respond to DND events inside the nested event + loop, so when dragging items to itself, always return + XdndActionPrivate. */ + if (x_dnd_end_window != None + && (x_any_window_to_frame (FRAME_DISPLAY_INFO (f), + x_dnd_end_window) != f)) + return QXdndActionPrivate; + + if (x_dnd_action != None) + { + block_input (); + atom_name = XGetAtomName (FRAME_X_DISPLAY (f), + x_dnd_action); + action = intern (atom_name); + XFree (atom_name); + unblock_input (); + + return action; + } + + return Qnil; +} + /* The focus may have changed. Figure out if it is a real focus change, by checking both FocusIn/Out and Enter/LeaveNotify events. @@ -10698,6 +10715,8 @@ x_dnd_update_state (struct x_display_info *dpyinfo) if (x_dnd_return_frame == 2 && x_any_window_to_frame (dpyinfo, target)) { + x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_last_seen_window = None; x_dnd_in_progress = false; x_dnd_return_frame_object = x_any_window_to_frame (dpyinfo, target); @@ -10728,6 +10747,8 @@ x_dnd_update_state (struct x_display_info *dpyinfo) x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_last_seen_window = None; x_dnd_in_progress = false; x_dnd_frame = NULL; } @@ -12047,6 +12068,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (x_dnd_return_frame == 2 && x_any_window_to_frame (dpyinfo, target)) { + x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_last_seen_window = None; x_dnd_in_progress = false; x_dnd_return_frame_object = x_any_window_to_frame (dpyinfo, target); @@ -12439,6 +12462,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (dnd_grab && event->xbutton.type == ButtonRelease) { + x_dnd_end_window = x_dnd_last_seen_window; x_dnd_in_progress = false; if (x_dnd_last_seen_window != None @@ -13436,6 +13460,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (!dnd_grab && xev->evtype == XI_ButtonRelease) { + x_dnd_end_window = x_dnd_last_seen_window; x_dnd_in_progress = false; if (x_dnd_last_seen_window != None @@ -17571,6 +17596,8 @@ x_free_frame_resources (struct frame *f) x_dnd_send_leave (f, x_dnd_last_seen_window); unblock_input (); + x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_last_seen_window = None; x_dnd_in_progress = false; x_dnd_waiting_for_finish = false; x_dnd_frame = NULL; commit eb25ae3f2db2543bc4c31fbddb4c719e43913ff8 Author: Andrew G Cohen Date: Tue Mar 22 12:11:14 2022 +0800 Refactor gnus/nnselect artlist saving and getting * lisp/gnus/nnselect.el (nnselect-generate-run): New function that replaces nnselect-run. (nnselect-store-artlist): New function. (nnselect-get-artlist): Update function. (nnselect-request-group, nnselect-request-thread) (nnselect-request-create-group, nnselect-request-group-scan): Use the new functions. * doc/misc/gnus.texi (Selection Groups): Document artlist storage and retrieval. diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index f87eab7e51..eb93269721 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -18078,6 +18078,17 @@ parameter of @code{nnselect-rescan} will allow automatic refreshing. A refresh can always be invoked manually through @code{gnus-group-get-new-news-this-group}. +By default a compressed version of the selection is stored (for +permanent groups) along with other group information in the newsrc. +For cases where this might be undesirable (for example if the +selection is a very long list that doesn't compress well) a +non-@code{nil} group parameter of @code{nnselect-always-regenerate} +will prevent the list from being stored, and instead regenerate the +list each time it is needed. If more flexibility is desired, +@code{nnselect-get-artlist-override-function} and +@code{nnselect-store-artlist-override-function} may be set to +functions that get and store the list of articles. + Gnus includes engines for searching a variety of backends. While the details of each search engine vary, the result of a search is always a vector of the sort used by the nnselect method, and the results of diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index d6289f1339..3a93c9e3dd 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -110,6 +110,7 @@ selection))) (make-obsolete 'nnselect-group-server 'gnus-group-server "28.1") +(make-obsolete 'nnselect-run 'nnselect-generate-artlist "29.1") ;; Data type article list. @@ -231,11 +232,6 @@ as `(keyfunc member)' and the corresponding element is just `(gnus-group-prefixed-name (gnus-group-short-name ,group) '(nnselect "nnselect"))) -(defmacro nnselect-get-artlist (group) - "Retrieve the list of articles for GROUP." - `(when (gnus-nnselect-group-p ,group) - (nnselect-uncompress-artlist - (gnus-group-get-parameter ,group 'nnselect-artlist t)))) (defmacro nnselect-add-novitem (novitem) "Add NOVITEM to the list of headers." @@ -271,6 +267,63 @@ If this variable is nil, or if the provided function returns nil, :version "28.1" :type '(repeat function)) +(defun nnselect-generate-artlist (group &optional specs) + "Generate the artlist for GROUP using SPECS. +SPECS should be an alist including an 'nnselect-function and an +'nnselect-args. The former applied to the latter should create +the artlist. If SPECS is nil retrieve the specs from the group +parameters." + (let* ((specs + (or specs (gnus-group-get-parameter group 'nnselect-specs t))) + (function (alist-get 'nnselect-function specs)) + (args (alist-get 'nnselect-args specs))) + (condition-case-unless-debug err + (funcall function args) + ;; Don't swallow gnus-search errors; the user should be made + ;; aware of them. + (gnus-search-error + (signal (car err) (cdr err))) + (error + (gnus-error + 3 + "nnselect-generate-artlist: %s on %s gave error %s" function args err) + [])))) + +(defmacro nnselect-get-artlist (group) + "Get the list of articles for GROUP. +If the group parameter 'nnselect-get-artlist-override-function is +non-nil call this function with argument GROUP to get the +artlist; if the group parameter 'nnselect-always-regenerate is +non-nil, regenerate the artlist; otherwise retrieve the artlist +directly from the group parameters." + `(when (gnus-nnselect-group-p group) + (let ((override (gnus-group-get-parameter + ,group + 'nnselect-get-artlist-override-function))) + (cond + (override (funcall override ,group)) + ((gnus-group-get-parameter ,group 'nnselect-always-regenerate) + (nnselect-generate-artlist ,group)) + (t + (nnselect-uncompress-artlist + (gnus-group-get-parameter ,group 'nnselect-artlist t))))))) + +(defmacro nnselect-store-artlist (group artlist) + "Store the ARTLIST for GROUP. +If the group parameter 'nnselect-store-artlist-override-function +is non-nil call this function on GROUP and ARTLIST; if the group +parameter 'nnselect-always-regenerate is non-nil don't store the +artlist; otherwise store the ARTLIST in the group parameters." + `(let ((override (gnus-group-get-parameter + ,group + 'nnselect-store-artlist-override-function))) + (cond + (override (funcall override ,group ,artlist)) + ((gnus-group-get-parameter ,group 'nnselect-always-regenerate) t) + (t + (gnus-group-set-parameter ,group 'nnselect-artlist + (nnselect-compress-artlist ,artlist)))))) + ;; Gnus backend interface functions. (deffoo nnselect-open-server (server &optional definitions) @@ -296,11 +349,8 @@ If this variable is nil, or if the provided function returns nil, ;; Check for cached select result or run the selection and cache ;; the result. (unless nnselect-artlist - (gnus-group-set-parameter - group 'nnselect-artlist - (nnselect-compress-artlist (setq nnselect-artlist - (nnselect-run - (gnus-group-get-parameter group 'nnselect-specs t))))) + (nnselect-store-artlist group + (setq nnselect-artlist (nnselect-generate-artlist group))) (nnselect-request-update-info group (or info (gnus-get-info group)))) (if (zerop (setq length (nnselect-artlist-length nnselect-artlist))) @@ -671,10 +721,7 @@ If this variable is nil, or if the provided function returns nil, (append (sort old-arts #'<) (number-sequence first last)) nil t)) - (gnus-group-set-parameter - group - 'nnselect-artlist - (nnselect-compress-artlist gnus-newsgroup-selection)) + (nnselect-store-artlist group gnus-newsgroup-selection) (when (>= last first) (let (new-marks) (pcase-dolist (`(,artgroup . ,artids) @@ -721,6 +768,7 @@ If this variable is nil, or if the provided function returns nil, (message "Creating nnselect group %s" group) (let* ((group (gnus-group-prefixed-name group '(nnselect "nnselect"))) (specs (assq 'nnselect-specs args)) + (otherargs (assq-delete-all 'nnselect-specs args)) (function-spec (or (alist-get 'nnselect-function specs) (intern (completing-read "Function: " obarray #'functionp)))) @@ -730,10 +778,12 @@ If this variable is nil, or if the provided function returns nil, (nnselect-specs (list (cons 'nnselect-function function-spec) (cons 'nnselect-args args-spec)))) (gnus-group-set-parameter group 'nnselect-specs nnselect-specs) - (gnus-group-set-parameter - group 'nnselect-artlist - (nnselect-compress-artlist (or (alist-get 'nnselect-artlist args) - (nnselect-run nnselect-specs)))) + (dolist (arg otherargs) + (gnus-group-set-parameter group (car arg) (cdr arg))) + (nnselect-store-artlist + group + (or (alist-get 'nnselect-artlist args) + (nnselect-generate-artlist group nnselect-specs))) (nnselect-request-update-info group (gnus-get-info group))) t) @@ -765,13 +815,10 @@ If this variable is nil, or if the provided function returns nil, (deffoo nnselect-request-group-scan (group &optional _server _info) (let* ((group (nnselect-add-prefix group)) - (artlist (nnselect-uncompress-artlist (nnselect-run - (gnus-group-get-parameter group 'nnselect-specs t))))) + (artlist (nnselect-generate-artlist group))) (gnus-set-active group (cons 1 (nnselect-artlist-length artlist))) - (gnus-group-set-parameter - group 'nnselect-artlist - (nnselect-compress-artlist artlist)))) + (nnselect-store-artlist group artlist))) ;; Add any undefined required backend functions @@ -786,20 +833,6 @@ If this variable is nil, or if the provided function returns nil, (eq 'nnselect (car gnus-command-method)))) -(defun nnselect-run (specs) - "Apply nnselect-function to nnselect-args from SPECS. -Return an article list." - (let ((func (alist-get 'nnselect-function specs)) - (args (alist-get 'nnselect-args specs))) - (condition-case-unless-debug err - (funcall func args) - ;; Don't swallow gnus-search errors; the user should be made - ;; aware of them. - (gnus-search-error - (signal (car err) (cdr err))) - (error (gnus-error 3 "nnselect-run: %s on %s gave error %s" func args err) - [])))) - (defun nnselect-search-thread (header) "Make an nnselect group containing the thread with article HEADER. The current server will be searched. If the registry is commit c14ce74f3316357489e8dc7de3a75648b6a12757 Author: Lars Ingebrigtsen Date: Tue Mar 22 23:48:34 2022 +0100 NEWS copy edits diff --git a/etc/NEWS b/etc/NEWS index 0cf11b741f..ad0f7f1c05 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1772,8 +1772,9 @@ The property ':position' now specifies the position of the underline when used as part of a property list specification for the ':underline' attribute. ++++ ** 'defalias' records a more precise history of definitions. -This is recorded in the `function-history` symbol property. +This is recorded in the 'function-history' symbol property. --- ** 'indian-tml-base-table' no longer translates digits. commit 601e0d992ed66196ebcec3ef9c65ee659c092c93 Author: Lars Ingebrigtsen Date: Tue Mar 22 23:44:16 2022 +0100 Mention highlight-confusing-reorderings in doc string * src/xdisp.c (Fbidi_find_overridden_directionality): Mention highlight-confusing-reorderings. diff --git a/etc/NEWS b/etc/NEWS index cddf011187..0cf11b741f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -450,6 +450,7 @@ the corresponding deleted frame. By default, it contains 'C-c ' and 'C-c ' to browse the history of tab window configurations back and forward. +--- ** Better detection of text suspiciously reordered on display. The function 'bidi-find-overridden-directionality' has been extended to detect reordering effects produced by embeddings and isolates diff --git a/src/xdisp.c b/src/xdisp.c index 1e766e4a19..62c8f9d4d9 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -25012,7 +25012,10 @@ function `get-char-code-property' for a way to inquire about the directionality is weak or neutral, such as numbers or punctuation characters, can be forced to display in a very different place with respect of its surrounding characters, so as to make the surrounding -text confuse the user regarding what the text says. */) +text confuse the user regarding what the text says. + +Also see the `highlight-confusing-reorderings' function, which can be +useful in similar circumstances as this function. */) (Lisp_Object from, Lisp_Object to, Lisp_Object object, Lisp_Object base_dir) { struct buffer *buf = current_buffer; commit 5e5bc0c0bcca5e7d33cc5f533d43db31d3856706 Author: Lars Ingebrigtsen Date: Tue Mar 22 23:40:08 2022 +0100 Mention the other-window-scroll-default user option * src/window.c (Fscroll_other_window): Link to other-window-scroll-default in the doc string. diff --git a/etc/NEWS b/etc/NEWS index 51df594a44..cddf011187 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -426,7 +426,9 @@ For example, a 'display-buffer-alist' entry of will make the body of the chosen window 40 columns wide. For the height use 'window-height' in combination with 'body-lines'. -*** 'other-window-scroll-default' can define the other window to scroll. +--- +*** You can customize which window 'scroll-other-window' operates on. +This is controlled by the new 'other-window-scroll-default' user option. ** Frames diff --git a/src/window.c b/src/window.c index 8f92b46afd..aed698d2a3 100644 --- a/src/window.c +++ b/src/window.c @@ -6334,7 +6334,9 @@ as argument a number, nil, or `-'. The next window is usually the one below the current one; or the one at the top if the current one is at the bottom. It is determined by the function `other-window-for-scrolling', -which see. */) +which see. + +Also see the `other-window-scroll-default' variable. */) (Lisp_Object arg) { specpdl_ref count = SPECPDL_INDEX (); commit 40def769fa9007f0a8da3f9e05063575c9a06be6 Author: Lars Ingebrigtsen Date: Tue Mar 22 23:36:24 2022 +0100 Document outline-default-state * doc/emacs/text.texi (Outline Visibility): Mention outline-default-state. diff --git a/doc/emacs/text.texi b/doc/emacs/text.texi index 9f152f1cc1..fa8eaf0924 100644 --- a/doc/emacs/text.texi +++ b/doc/emacs/text.texi @@ -1259,6 +1259,17 @@ and related functions treat hidden text, @pxref{Query Replace}.) You can also automatically make text visible as you navigate in it by using Reveal mode (@kbd{M-x reveal-mode}), a buffer-local minor mode. +@vindex outline-default-state + The @code{outline-default-state} variable controls what headings +will be visible after Outline mode is turned on. If non-@code{nil}, +some headings are initially outlined. If equal to a number, show only +headings up to and including the corresponding level. If equal to +@code{outline-show-all}, all text of buffer is shown. If equal to +@code{outline-show-only-headings}, show only headings, whatever their +level is. If equal to a lambda function or function name, this +function is expected to toggle headings visibility, and will be called +without arguments after the mode is enabled. + @node Outline Views @subsection Viewing One Outline in Multiple Views diff --git a/etc/NEWS b/etc/NEWS index 0223188acc..51df594a44 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -388,6 +388,7 @@ displayed, if any. ** Outline Mode ++++ *** Support for customizing the default visibility state of headings. Customize the user option 'outline-default-state' to define what headings will be visible after Outline mode is turned on. When equal commit 5fc84e0fb3a121ae45580e1ecd5731f5255407fc Author: Lars Ingebrigtsen Date: Tue Mar 22 23:31:05 2022 +0100 Do some NEWS tagging diff --git a/etc/NEWS b/etc/NEWS index fc039c5ed8..0223188acc 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -199,6 +199,7 @@ If set to nil, commands like 'find-library' will only include library files in the completion candidates. The default is t, which preserves previous behavior, whereby non-library files could also be included. ++++ ** New command 'sqlite-mode-open-file' for examining an sqlite3 file. This uses the new 'sqlite-mode' which allows listing the tables in a DB file, and examining and modifying the columns and the contents of @@ -325,6 +326,7 @@ When environment variable 'EMACS_TEST_JUNIT_REPORT' is set, ERT generates a JUnit test report under this file name. This is useful for Emacs integration into CI/CD test environments. +--- *** Unbound test symbols now signal an 'ert-test-unbound' error. This affects the 'ert-select-tests' function and its callers. @@ -358,6 +360,7 @@ inserted. This command will tell you the name of the Emoji at point. (This command also works for non-Emoji characters.) +--- *** New input method 'emoji'. ** Help commit 2de7fc4a2b9e4f5e8adb309046a17212f4205c5d Author: Lars Ingebrigtsen Date: Tue Mar 22 23:28:00 2022 +0100 Document sqlite-mode-open-file and do some NEWS tagging * doc/lispref/text.texi (Database): Mention sqlite-mode-open-file. diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index f76512c5a0..ab9abd0495 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -5408,6 +5408,12 @@ Extensions are usually shared-library files; on GNU and Unix systems, they have the @file{.so} file-name extension. @end defun +@findex sqlite-mode-open-file +If you wish to list the contents of an SQLite file, you can use the +@code{sqlite-mode-open-file} command. This will pop to a buffer using +@code{sqlite-mode}, which allows you to examine (and alter) the +contents of an SQLite database. + @node Parsing HTML/XML @section Parsing HTML and XML @cindex parsing html diff --git a/etc/NEWS b/etc/NEWS index 94f6674a18..fc039c5ed8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -29,6 +29,7 @@ applies, and please also update docstrings as needed. This uses the popular sqlite3 library, and can be disabled by using the '--without-sqlite3' option to the 'configure' script. ++++ ** Emacs has been ported to the Haiku operating system. The configuration process should automatically detect and build for Haiku. There is also an optional window-system port to Haiku, which @@ -50,6 +51,7 @@ Unlike X, there is no compile-time option to enable or disable double-buffering. If you wish to disable double-buffering, change the frame parameter 'inhibit-double-buffering' instead. +--- ** Emacs now installs the ".pdmp" file using a unique fingerprint in the name. The file is typically installed using a file name akin to "...dir/libexec/emacs/29.1/x86_64-pc-linux-gnu/emacs-.pdmp". @@ -64,6 +66,7 @@ this support. The named feature 'xinput2' can be used to test for the presence of XInput 2 support from Lisp programs. ++++ ** Emacs now supports being built with pure GTK. To use this option, make sure the GTK 3 and Cairo development files are installed, and configure Emacs with the option '--with-pgtk'. @@ -154,6 +157,7 @@ example, if point is before an Emoji sequence, pressing will delete the entire sequence, not just a single character at its beginning. ++++ ** 'load-history' does not treat autoloads specially any more. An autoload definition appears just as a '(defun . NAME)' and the '(t . NAME)' entries are not generated any more. commit 8dc85d1db4564f0d9df847b7884c920a0f8d7fe9 Author: Alexander Adolf Date: Mon Mar 14 21:23:18 2022 +0100 Enable Better Alignment of EUDC Inline Expansion With RFC5322 The format of EUDC inline expansion results is formatted according to the variable eudc-inline-expansion-format, which previously defaulted to '("%s %s <%s>" firstname name email). Since email address specifications need to comply with RFC 5322 in order to be useful in messages, there was little headroom for users to change this format anyway. Plus, if an EUDC back-end returned an empty first and last name, the result was the email address in angle brackets. Whilst this was standard with RFC 822, it is marked as obsolete syntax by its successor RFC 5322. Also, the first and last name part was never enclosed in double quotes, potentially producing invalid address specifications, which may be rejected by a receiving MTA. This commit updates the variable eudc-inline-expansion-format, so that it can, in addition to the current ("format" attributes) list, now alternatively be set to nil, or a formatting function. In both cases the resulting email address is formatted using the new function eudc-rfc5322-make-address, whose results fully comply with RFC 5322. If the value is nil (the new default value), eudc-rfc5322-make-address will be called to produce any of the default formats ADDRESS FIRST
LAST
FIRST LAST
depending on whether a first and/or last name are returned by the query, or not. If the value is a formatting function, that will be called to allow the user to supply content for the phrase and comment parts of the address (cf. RFC 5322). Thus one can produce any of the formats: ADDRESS PHRASE
ADDRESS (COMMENT) PHRASE
(COMMENT) This can for example be used to get "last, first
" instead of the default "first last
". In any case when using nil, or the formatting function, the phrase part of the result will be enclosed in double quotes if needed, and the comment part will be omitted if it contains characters not allowed by RFC 5322. When eudc-inline-expansion-format remains set to a list as previously, the old behaviour is fully retained. diff --git a/doc/misc/eudc.texi b/doc/misc/eudc.texi index 3b24dfb919..f61ce7012e 100644 --- a/doc/misc/eudc.texi +++ b/doc/misc/eudc.texi @@ -795,12 +795,73 @@ against the @code{cn} attribute of LDAP servers: @end defvar @defvar eudc-inline-expansion-format -This variable lets you control exactly what is inserted into the buffer -upon an inline expansion request. It is a list whose first element is a -string passed to @code{format}. Remaining elements are symbols -corresponding to directory attribute names. The corresponding attribute -values are passed as additional arguments to @code{format}. Default is -@code{("%s %s <%s>" firstname name email)}. +This variable lets you control exactly what is inserted into the +buffer upon an inline expansion request. It can be set to @code{nil}, +to a function, or to a list. Default is @code{nil}. + +When the value is a list, the first element is a string passed to +@code{format}. Remaining elements are symbols corresponding to +directory attribute names. The corresponding attribute values are +passed as additional arguments to @code{format}. + +When the value is @code{nil}, the expansion result will be formatted +according to @url{https://datatracker.ietf.org/doc/html/rfc5322, RFC +5322}. The @var{phrase} part will be formatted as ``firstname name'', +quoting the result if necessary. No @var{comment} part will be added +in this case. This will produce any of the default formats +@center @var{address} +@center @var{first} @code{<}@var{address}@code{>} +@center @var{last} @code{<}@var{address}@code{> +@center @var{first} @var{last} @code{<}@var{address}@code{>} +depending on whether a first and/or last name are returned by the +query, or not. + +When the value is a function, the expansion result will be formatted +according to @url{https://datatracker.ietf.org/doc/html/rfc5322, RFC +5322}, and the referenced function is called to format the +@var{phrase}, and @var{comment} parts, respectively. The formatted +@var{phrase} part will be quoted if necessary. Thus one can produce +any of the formats: +@center @var{address} +@center @var{phrase} @code{<}@var{address}@code{>} +@center @var{address} @code{(}@var{comment}@code{)} +@center @var{phrase} @code{<}@var{address}@code{>} @code{(}@var{comment}@code{)} + +Email address specifications, as are generated by inline expansion, +need to comply with RFC 5322 in order to be useful in email +messages. When an invalid address specification is present in an email +message header, the message is likely to be rejected by a receiving +MTA. It is hence recommended to switch old configurations, which use +a list value, to the new @code{nil}, or function value type since it +ensures that the inserted address specifications will be in line with +@url{https://datatracker.ietf.org/doc/html/rfc5322, RFC 5322}. At +minimum, and to achieve the same semantics as with the old list +default value, this variable should now be set to @code{nil}: +@lisp +(customize-set-variable 'eudc-inline-expansion-format nil) +@end lisp + +A function value can for example be used to get @emph{``last, first +
''} instead of the default @emph{``first last
''}: +@lisp +(defun my-phrase-last-comma-first (search-res-alist) + (let* (phrase + (my-attrs (eudc-translate-attribute-list '(firstname name))) + (first-name (cdr (assq (nth 0 my-attrs) search-res-alist))) + (last-name (cdr (assq (nth 1 my-attrs) search-res-alist))) + (comment nil)) + (setq phrase (concat last-name ", " first-name)) + (cons phrase comment))) + +(customize-set-variable 'eudc-inline-expansion-format + #'my-phrase-last-comma-first) +@end lisp +To set the @var{comment} part, too, instead of @code{nil} as in this +example, also provide a string as the @code{cdr} of the @code{cons} +being returned. Do not include any double quotes in the @var{phrase} +part, as they are added automatically if needed. Neither include +parentheses in the @var{comment} part as they, too, are added +automatically. @end defvar @defvar eudc-multiple-match-handling-method diff --git a/etc/NEWS b/etc/NEWS index abee5fcb99..94f6674a18 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -695,6 +695,26 @@ from all servers instead of just the matches from the first server to return any. This is useful for example, if one wants to search LDAP for a name that happens to match a contact in one's BBDB. ++++ +*** New behaviour and default for option 'eudc-inline-expansion-format' +EUDC inline expansion result formatting defaulted to + + '("%s %s <%s>" firstname name email) + +Since email address specifications need to comply with RFC 5322 in +order to be useful in messages, there was a risk to produce syntax +which was standard with RFC 822, but is marked as obsolete syntax by +its successor RFC 5322. Also, the first and last name part was never +enclosed in double quotes, potentially producing invalid address +specifications, which may be rejected by a receiving MTA. Thus, this +variable can now additionally be set to nil (the new default), or a +function. In both cases, the formatted result will be in compliance +with RFC 5322. When set to nil, a default format very similar to the +old default will be produced. When set to a function, that function +is called, and the returned values are used to populate the phrase and +comment parts (see RFC 5322 for definitions). In both cases, the +phrase part will be automatically quoted if necessary. + ** eww/shr +++ diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el index 997b9e30fd..d58fab896e 100644 --- a/lisp/net/eudc-vars.el +++ b/lisp/net/eudc-vars.el @@ -191,25 +191,51 @@ must be set in a protocol/server-local fashion, see `eudc-server-set' and :type 'boolean :version "25.1") -(defcustom eudc-inline-expansion-format '("%s %s <%s>" firstname name email) - "A list specifying the format of the expansion of inline queries. -This variable controls what `eudc-expand-inline' actually inserts in -the buffer. First element is a string passed to `format'. Remaining -elements are symbols indicating attribute names; the corresponding values -are passed as additional arguments to `format'." - :type '(list - (string :tag "Format String") - (repeat :inline t - :tag "Attributes" - (choice - :tag "Attribute" - (const :menu-tag "First Name" :tag "First Name" firstname) - (const :menu-tag "Surname" :tag "Surname" name) - (const :menu-tag "Email Address" :tag "Email Address" email) - (const :menu-tag "Phone" :tag "Phone" phone) - (symbol :menu-tag "Other") - (symbol :tag "Attribute name")))) - :version "25.1") +(defcustom eudc-inline-expansion-format nil + "Specify the format of the expansion of inline queries. +This variable controls what `eudc-expand-inline' actually inserts +in the buffer. It is either a list, or a function. + +When set to a list, the expansion result will be formatted +according to the first element of the list, a string, which is +passed as the first argument to `format'. The remaining elements +of the list are symbols indicating attribute names; the +corresponding values are passed as additional arguments to +`format'. + +When set to nil, the expansion result will be formatted using +`eudc-rfc5322-make-address', and the PHRASE part will be +formatted according to \"firstname name\", quoting the result if +necessary. No COMMENT will be added in this case. + +When set to a function, the expansion result will be formatted +using `eudc-rfc5322-make-address', and the referenced function is +used to format the PHRASE, and COMMENT parts, respectively. It +receives a single argument, which is an alist of +protocol-specific attributes describing the recipient. To access +the alist elements using generic EUDC attribute names, such as +for example name, or email, use `eudc-translate-attribute-list'. +The function should return a list, which should contain two +elements. If the first element is a string, it will be used as +the PHRASE part, quoting it if necessary. If the second element +is a string, it will be used as the COMMENT part, unless it +contains characters not allowed in the COMMENT part by RFC 5322, +in which case the COMMENT part will be omitted." + :type '(choice (const :tag "RFC 5322 formatted \"first last
\"" nil) + (function :tag "RFC 5322 phrase/comment formatting function") + (list :tag "Format string (deprecated)" + (string :tag "Format String") + (repeat :inline t + :tag "Attributes" + (choice + :tag "Attribute" + (const :menu-tag "First Name" :tag "First Name" firstname) + (const :menu-tag "Surname" :tag "Surname" name) + (const :menu-tag "Email Address" :tag "Email Address" email) + (const :menu-tag "Phone" :tag "Phone" phone) + (symbol :menu-tag "Other") + (symbol :tag "Attribute name"))))) + :version "29.1") (defcustom eudc-inline-expansion-servers 'server-then-hotlist "Which servers to contact for the expansion of inline queries. diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 7bbf54ee6c..6ce89ce5be 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -162,6 +162,75 @@ Value is the new string." newtext))) (concat rtn-str (substring str start)))) + +(defconst eudc-rfc5322-atext-token "[:alpha:][:digit:]!#$%&'*+/=?^_`{|}~-" + "Printable US-ASCII characters not including specials. Used for atoms.") + +(defconst eudc-rfc5322-wsp-token " \t" + "Non-folding white space.") + +(defconst eudc-rfc5322-fwsp-token + (concat eudc-rfc5322-wsp-token "\n") + "Folding white space.") + +(defconst eudc-rfc5322-cctext-token "\u005D-\u007E\u002A-\u005B\u0021-\u0027" + "Printable US-ASCII characters not including '(', ')', or '\\'.") + +(defun eudc-rfc5322-quote-phrase (string) + "Quote STRING if it needs quoting as a phrase in a header." + (if (string-match + (concat "[^" eudc-rfc5322-wsp-token eudc-rfc5322-atext-token "]") + string) + (concat "\"" string "\"") + string)) + +(defun eudc-rfc5322-valid-comment-p (string) + "Check if STRING can be used as comment in a header." + (if (string-match + (concat "[^" eudc-rfc5322-cctext-token eudc-rfc5322-fwsp-token "]") + string) + nil + t)) + +(defun eudc-rfc5322-make-address (address &optional firstname name comment) + "Create a valid address specification according to RFC5322. +RFC5322 address specifications are used in message header fields +to indicate senders and recipients of messages. They generally +have one of the forms: + +ADDRESS +ADDRESS (COMMENT) +PHRASE
+PHRASE
(COMMENT) + +The arguments FIRSTNAME and NAME are combined to form PHRASE. +PHRASE is enclosed in double quotes if necessary. + +COMMENT is omitted if it contains any symbols outside the +permitted set `eudc-rfc5322-cctext-token'." + (if (and address + (not (string-blank-p address))) + (let ((result address) + (name-given (and name + (not (string-blank-p name)))) + (firstname-given (and firstname + (not (string-blank-p firstname)))) + (valid-comment-given (and comment + (not (string-blank-p comment)) + (eudc-rfc5322-valid-comment-p comment)))) + (if (or name-given firstname-given) + (let ((phrase (string-trim (concat firstname " " name)))) + (setq result + (concat + (eudc-rfc5322-quote-phrase phrase) + " <" result ">")))) + (if valid-comment-given + (setq result + (concat result " (" comment ")"))) + result) + ;; nil or empty address, nothing to return + nil)) + ;;}}} ;;{{{ Server and Protocol Variable Routines @@ -797,6 +866,55 @@ non-nil, collect results from all servers." ((eq eudc-multiple-match-handling-method 'abort) (error "There is more than one match for the query")))))) +;;;###autoload +(defun eudc-format-inline-expansion-result (res query-attrs) + "Format a query result according to `eudc-inline-expansion-format'." + (cond + ;; format string + ((consp eudc-inline-expansion-format) + (string-trim (apply #'format + (car eudc-inline-expansion-format) + (mapcar + (lambda (field) + (or (cdr (assq field res)) + "")) + (eudc-translate-attribute-list + (cdr eudc-inline-expansion-format)))))) + + ;; formatting function + ((functionp eudc-inline-expansion-format) + (let ((addr (cdr (assq (nth 2 query-attrs) res))) + (ucontent (funcall eudc-inline-expansion-format res))) + (if (and ucontent + (listp ucontent)) + (let* ((phrase (car ucontent)) + (comment (cadr ucontent)) + (phrase-given + (and phrase + (stringp phrase) + (not (string-blank-p phrase)))) + (valid-comment-given + (and comment + (stringp comment) + (not (string-blank-p comment)) + (eudc-rfc5322-valid-comment-p + comment)))) + (eudc-rfc5322-make-address + addr nil + (if phrase-given phrase nil) + (if valid-comment-given comment nil))) + (progn + (error "Error: the function referenced by \ +`eudc-inline-expansion-format' is expected to return a list.") + nil)))) + + ;; fallback behaviour (nil function, or non-matching type) + (t + (let ((fname (cdr (assq (nth 0 query-attrs) res))) + (lname (cdr (assq (nth 1 query-attrs) res))) + (addr (cdr (assq (nth 2 query-attrs) res)))) + (eudc-rfc5322-make-address addr fname lname))))) + ;;;###autoload (defun eudc-query-with-words (query-words &optional try-all-servers) "Query the directory server, and return the matching responses. @@ -804,7 +922,7 @@ The variable `eudc-inline-query-format' controls how to associate the individual QUERY-WORDS with directory attribute names. After querying the server for the given string, the expansion specified by `eudc-inline-expansion-format' is applied to the -matches before returning them.inserted in the buffer at point. +matches before returning them. Multiple servers can be tried with the same query until one finds a match, see `eudc-inline-expansion-servers'. When TRY-ALL-SERVERS is non-nil, keep collecting results from subsequent servers after the first match." @@ -848,28 +966,25 @@ keep collecting results from subsequent servers after the first match." (unwind-protect (cl-flet ((run-query - (query-formats) - (let ((response - (eudc-query - (eudc-format-query query-words (car query-formats)) - (eudc-translate-attribute-list - (cdr eudc-inline-expansion-format))))) - (when response - ;; Process response through eudc-inline-expansion-format. - (dolist (r response) - (let ((response-string - (apply #'format - (car eudc-inline-expansion-format) - (mapcar - (lambda (field) - (or (cdr (assq field r)) - "")) - (eudc-translate-attribute-list - (cdr eudc-inline-expansion-format)))))) - (if (> (length response-string) 0) - (push response-string response-strings)))) - (when (not try-all-servers) - (throw 'found nil)))))) + (query-formats) + (let* ((query-attrs (eudc-translate-attribute-list + (if (consp eudc-inline-expansion-format) + (cdr eudc-inline-expansion-format) + '(firstname name email)))) + (response + (eudc-query + (eudc-format-query query-words (car query-formats)) + query-attrs))) + (when response + ;; Format response. + (dolist (r response) + (let ((response-string + (eudc-format-inline-expansion-result r query-attrs))) + (if response-string + (cl-pushnew response-string response-strings + :test #'equal)))) + (when (not try-all-servers) + (throw 'found nil)))))) (catch 'found ;; Loop on the servers. (dolist (server servers) commit c8bde5b0a3c7ac6c1d71c404977f83e2b4e94092 Author: Lars Ingebrigtsen Date: Tue Mar 22 21:14:21 2022 +0100 Fix two no-X compilation warnings * lisp/mouse.el (x-hide-tip, x-show-tip): Declare to avoid no-X build compilation warnings (bug#54524). * lisp/term/pgtk-win.el (window-system-initialization): Avoid no-X compilation warning. diff --git a/lisp/mouse.el b/lisp/mouse.el index 93c89de91c..30b19510a4 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -2998,6 +2998,9 @@ Call `tooltip-show-help-non-mode' instead on non-graphical displays." (x-show-tip tooltip) (tooltip-show-help-non-mode tooltip))) +(declare-function x-hide-tip "xfns.c") +(declare-function x-show-tip "xfns.c") + (defun mouse-drag-and-drop-region-hide-tooltip () "Hide any tooltip currently displayed. Call `tooltip-show-help-non-mode' to clear the echo area message diff --git a/lisp/term/pgtk-win.el b/lisp/term/pgtk-win.el index 8e17864284..114f98edb5 100644 --- a/lisp/term/pgtk-win.el +++ b/lisp/term/pgtk-win.el @@ -255,14 +255,15 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") (setq command-line-args (x-handle-args command-line-args)) ;; Make sure we have a valid resource name. - (or (stringp x-resource-name) + (when (boundp 'x-resource-name) + (unless (stringp x-resource-name) (let (i) (setq x-resource-name (copy-sequence invocation-name)) ;; Change any . or * characters in x-resource-name to hyphens, ;; so as not to choke when we use it in X resource queries. (while (setq i (string-match "[.*]" x-resource-name)) - (aset x-resource-name i ?-)))) + (aset x-resource-name i ?-))))) ;; Setup the default fontset. (create-default-fontset) commit a0e33850702e84ca747178b0eba0f43ef30c14fc Author: Lars Ingebrigtsen Date: Tue Mar 22 21:09:16 2022 +0100 Fix a keyboard.c no-X compilation warning * src/keyboard.c (make_lispy_position): Fix compilation warning in a --without-x build. diff --git a/src/keyboard.c b/src/keyboard.c index 218f9a86c8..8b451d834d 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -5247,12 +5247,12 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, Lisp_Object window_or_frame = f ? window_from_coordinates (f, mx, my, &part, true, true) : Qnil; +#ifdef HAVE_WINDOW_SYSTEM bool tool_bar_p = false; bool menu_bar_p = false; /* Report mouse events on the tab bar and (on GUI frames) on the tool bar. */ -#ifdef HAVE_WINDOW_SYSTEM if ((WINDOWP (f->tab_bar_window) && EQ (window_or_frame, f->tab_bar_window)) #ifndef HAVE_EXT_TOOL_BAR commit 5334e726d02473ecf441acb1501f44feb42a7325 Author: Lars Ingebrigtsen Date: Tue Mar 22 20:13:31 2022 +0100 Make mail-header-parse-addresses-lax more lax * lisp/mail/mail-parse.el (mail-header-parse-addresses-lax): Be more resilient (bug#54523). diff --git a/lisp/mail/mail-parse.el b/lisp/mail/mail-parse.el index 23894e59b7..ec719850e2 100644 --- a/lisp/mail/mail-parse.el +++ b/lisp/mail/mail-parse.el @@ -76,7 +76,8 @@ The return value is a list with mail/name pairs." (delq nil (mapcar (lambda (elem) - (or (mail-header-parse-address elem) + (or (ignore-errors + (mail-header-parse-address elem)) (mail-header-parse-address-lax elem))) (mail-header-parse-addresses string t)))) commit 29e310d60f7327f177bbaaa7fdaf14101cd0476f Author: Lars Ingebrigtsen Date: Tue Mar 22 19:18:13 2022 +0100 Fix Completion Options typo * doc/emacs/mini.texi (Completion Options): Fix typo. diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index 72a3cf2491..ff0fa505a8 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -687,7 +687,7 @@ The Emacs Lisp Reference Manual}). @vindex completions-highlight-face When @code{completions-highlight-face} names a face, the current completion candidate, the one that will be selected by typing -@kbd{@key}RET}} or clicking the mouse, will be highlighted using that +@kbd{@key{RET}} or clicking the mouse, will be highlighted using that face. The default value of this variable is @code{completions-highlight}; the value is @code{nil} disables this highlighting. This feature uses the special text property commit d0e457325d242466107e0c14f910eef0f1ae3599 Author: Lars Ingebrigtsen Date: Tue Mar 22 19:15:33 2022 +0100 Add a shell-filter-ring-bell function * lisp/shell.el (shell-mode): Mention it. (shell-filter-ring-bell): New function (bug#21652). diff --git a/lisp/shell.el b/lisp/shell.el index 565ededa1e..008fcc4c4e 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -570,7 +570,14 @@ the initialization of the input ring history, and history expansion. Variables `comint-output-filter-functions', a hook, and `comint-scroll-to-bottom-on-input' and `comint-scroll-to-bottom-on-output' control whether input and output cause the window to scroll to the end of the -buffer." +buffer. + +By default, shell mode does nothing special when it receives a +\"bell\" character (C-g or ^G). If you + (add-hook 'comint-output-filter-functions 'shell-filter-ring-bell nil t) +from `shell-mode-hook', Emacs will call the `ding' function +whenever it receives the bell character in output from a +command." :interactive nil (setq comint-prompt-regexp shell-prompt-pattern) (shell-completion-vars) @@ -681,6 +688,13 @@ This function can be put on `comint-preoutput-filter-functions'." (replace-regexp-in-string "[\C-a\C-b]" "" string t t) string)) +(defun shell-filter-ring-bell (string) + "Call `ding' if STRING contains a \"^G\" character. +This function can be put on `comint-output-filter-functions'." + (when (string-search "\a" string) + (ding)) + string) + (defun shell-write-history-on-exit (process event) "Called when the shell process is stopped. commit f2047fdca4f42cf0af568e1d62f286a91cce6d35 Author: Eli Zaretskii Date: Tue Mar 22 19:56:06 2022 +0200 Fix documentation of the new completion-related features * etc/NEWS: * lisp/minibuffer.el (completion-auto-help): * doc/lispref/text.texi (Special Properties): * doc/emacs/mini.texi (Completion Options): Fix wording of recently added documentation and customization options. diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index 24517262fa..72a3cf2491 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -628,14 +628,19 @@ commands never display the completion list buffer; you must type shows the completion list buffer on the second attempt to complete. In other words, if there is nothing to complete, the first @key{TAB} echoes @samp{Next char not unique}; the second @key{TAB} shows the -completion list buffer. With the previous values and the default -@code{t} the completions are hidden when some unique completion is -executed. If @code{completion-auto-help} is set to @code{always}, the -completion commands are always shown after a completion attempt, or -updated if they are already visible. If the value is @code{visible}, -then completions are not hidden, but updated if they are already -visible while the current behavior stays the same as default if they -are not. +completion list buffer. If the value is @code{always}, the completion +list buffer is always shown when completion is attempted. + +The display of the completion list buffer after it is shown for the +first time is also controlled by @code{completion-auto-help}. If the +value is @code{t} or @code{lazy}, the window showing the completions +pops down when Emacs is able to complete (and may pop up again if +Emacs is again unable to complete after you type some more text); if +the value is @code{always}, the window pops down only when you exit +the completion. The value @code{visible} is a hybrid: it behaves like +@code{t} when it decides whether to pop up the window showing the +completion list buffer, and like @code{always} when it decides whether +to pop it down. @vindex completion-cycle-threshold If @code{completion-cycle-threshold} is non-@code{nil}, completion @@ -668,21 +673,25 @@ Alists,,Action Alists for Buffer Display, elisp, The Emacs Lisp Reference Manual}). @vindex completions-header-format -The variable @code{completions-header-format} is a formatted string to +The variable @code{completions-header-format} is a format spec string to control the informative line shown before the completions list of -candidates. It may contain a @code{%s} to show the total number of -completions. When it is @code{nil}, the message is totally suppressed. -Text properties may be added to change the appearance, some useful -ones are @code{face} or @code{cursor-intangible} (@pxref{Special -Properties,,Properties with Special Meanings, elisp, The Emacs Lisp -Reference Manual}). +candidates. If it contains a @samp{%s} construct, that get replaced +by the number of completions shown in the completion list buffer. To +suppress the display of the heading line, customize this variable to +@code{nil}. The string that is the value of this variable can have +text properties to change the visual appearance of the heading line; +some useful properties @code{face} or @code{cursor-intangible} +(@pxref{Special Properties,,Properties with Special Meanings, elisp, +The Emacs Lisp Reference Manual}). @vindex completions-highlight-face -When @code{completions-highlight-face} is a face name, then the -current completion candidate will be highlighted with that face. The -default value is @code{completions-highlight}. When the value is -@code{nil}, no highlighting is performed. This feature sets the text -property @code{cursor-face}. +When @code{completions-highlight-face} names a face, the current +completion candidate, the one that will be selected by typing +@kbd{@key}RET}} or clicking the mouse, will be highlighted using that +face. The default value of this variable is +@code{completions-highlight}; the value is @code{nil} disables this +highlighting. This feature uses the special text property +@code{cursor-face}. @node Minibuffer History @section Minibuffer History diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index edb75b453c..f76512c5a0 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -3541,10 +3541,10 @@ special modes that implement their own highlighting. @item mouse-face @kindex mouse-face @r{(text property)} -This property is used instead of @code{face} when the mouse is on or -near the character. For this purpose, ``near'' means that all text -between the character and where the mouse is have the same -@code{mouse-face} property value. +This property is used instead of @code{face} when the mouse pointer +hovers over the text which has this property. When this happens, the +entire stretch of text that has the same @code{mouse-face} property +value, not just the character under the mouse, is highlighted. Emacs ignores all face attributes from the @code{mouse-face} property that alter the text size (e.g., @code{:height}, @code{:weight}, and @@ -3553,14 +3553,17 @@ unhighlighted text. @item cursor-face @kindex cursor-face @r{(text property)} -This property is similar to @code{mouse-face}, but the face is used if -the cursor (instead of mouse) is on or near the character. Near has -the same meaning that in @code{mouse-face} and the highlighting only -takes effect if the mode @code{cursor-face-highlight-mode} is enabled; -otherwise no highlighting is performed. When the variable +@findex cursor-face-highlight-mode +@vindex cursor-face-highlight-nonselected-window +This property is similar to @code{mouse-face}, but it is used when +point (not the mouse) is inside text that has this property. The +highlighting happens only if the mode +@code{cursor-face-highlight-mode} is enabled. When the variable @code{cursor-face-highlight-nonselected-window} is non-@code{nil}, the -text is highlighted even if the window is not selected that is similar -to @code{highlight-nonselected-windows} for the region. +text with this face is highlighted even if the window is not selected, +similarly to what @code{highlight-nonselected-windows} does for the +region (@pxref{Mark,, The Mark and the Region, emacs, The GNU Emacs +Manual}). @item fontified @kindex fontified @r{(text property)} diff --git a/etc/NEWS b/etc/NEWS index e64fe2d23b..abee5fcb99 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -579,28 +579,29 @@ alphabetical (the default), or a custom sort function. +++ *** New values for the 'completion-auto-help' user option. -There are two new values to control the way "*Completions*" behave after -a 'TAB' if completion is not unique. 'always' updates or shows -the "*Completions*" buffer after any attempt to complete. 'visual' is -like 'always', but only update the completions if they are already -visible. The default value 't' always hides the completion buffer after -some completion is made. +There are two new values to control the way the "*Completions*" buffer +behaves after pressing a 'TAB' if completion is not unique. The value +'always' updates or shows the "*Completions*" buffer after any attempt +to complete. The value 'visual' is like 'always', but only updates +the completions if they are already visible. The default value 't' +always hides the completion buffer after some completion is made. +++ *** New user option 'completions-max-height'. This option limits the height of the "*Completions*" buffer. +++ -*** New user option 'completions-header-format' -This is a string to control the message to show before completions. -It may contain a "%s" to show the total number of completions. If nil no -completions are shown. +*** New user option 'completions-header-format'. +This is a string to control the heading line to show in the +"*Completions*" buffer before the list of completions. +If it contains "%s", that is replaced with the number of completions. +If nil, the heading line is not shown. +++ *** New user option 'completions-highlight-face'. -When this user option is a face name, it highlights the current -candidate in the "*Completions*" buffer with that face. When the -value is nil, no highlighting is performed at all. +When this user option names a face, the current +candidate in the "*Completions*" buffer is highlighted with that face. +The nil value disables this highlighting. ** Isearch and Replace diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 00d4560865..c4fb1c0039 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -894,20 +894,23 @@ If the current buffer is not a minibuffer, erase its entire contents." (defcustom completion-auto-help t "Non-nil means automatically provide help for invalid completion input. -If the value is t the *Completions* buffer is displayed whenever completion +If the value is t, the *Completions* buffer is displayed whenever completion is requested but cannot be done. If the value is `lazy', the *Completions* buffer is only displayed after the second failed attempt to complete. -If the value is 'always', the completion commands are always shown -after a completion attempt, or updated if they are already visible. -If the value is 'visible', then completions are not hidden, but updated -if they are already visible while the current behavior stays the same -as default if they are not." - :type '(choice (const :tag "Disabled" nil) - (const :tag "Enabled legacy" t) - (const :tag "After a second attempt" lazy) - (const :tag "Visible update" visible) - (const :tag "Always update" always))) +If the value is 'always', the *Completions* buffer is always shown +after a completion attempt, and the list of completions is updated if +already visible. +If the value is 'visible', the *Completions* buffer is displayed +whenever completion is requested but cannot be done for the first time, +but remains visible thereafter, and the list of completions in it is +updated for subsequent attempts to complete.." + :type '(choice (const :tag "Don't show" nil) + (const :tag "Show only when cannot complete" t) + (const :tag "Show after second failed completion attempt" lazy) + (const :tag + "Leave visible after first failed completion" visible) + (const :tag "Always visible" always))) (defvar completion-styles-alist '((emacs21 commit da3af500ad490db5cded8dfca7f2ec713b52629c Author: Jimmy Aguilar Mena Date: Tue Mar 22 18:29:05 2022 +0100 Revert "Set cursor-face-highlight-nonselected-window in completions." This reverts commit 1641b5c04c383b5f53298d70776e3c18577b6f30. This fixes incorrect highlight in Completions. diff --git a/lisp/simple.el b/lisp/simple.el index 59c86cf778..9a8ed0bb75 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -9402,8 +9402,6 @@ Called from `temp-buffer-show-hook'." (setq tab-width completion-tab-width)) ;; Maybe enable cursor completions-highlight. (when completions-highlight-face - ;; Keep highlighting even if not selected. - (setq-local cursor-face-highlight-nonselected-window t) (cursor-face-highlight-mode 1)) ;; Maybe insert help string. (when completion-show-help commit 142478c0958a233d68616220a6ef49c13f6b28dc Author: Allen Li Date: Tue Mar 22 17:48:13 2022 +0100 Add user option for controlling dired-do-shell-command prompt * doc/emacs/dired.texi (Shell Commands in Dired): Document option * lisp/dired-aux.el (dired-confirm-shell-command): Add option (dired-do-shell-command): Check option before prompting (bug#29465). diff --git a/doc/emacs/dired.texi b/doc/emacs/dired.texi index e18c8b048b..27df269ce7 100644 --- a/doc/emacs/dired.texi +++ b/doc/emacs/dired.texi @@ -1007,6 +1007,7 @@ subdirectories whose names match @code{grep-find-ignored-directories}. @findex dired-do-shell-command @kindex ! @r{(Dired)} @kindex X @r{(Dired)} +@vindex dired-confirm-shell-command The Dired command @kbd{!} (@code{dired-do-shell-command}) reads a shell command string in the minibuffer, and runs that shell command on one or more files. The files that the shell command operates on are @@ -1043,7 +1044,8 @@ list of file names, putting them into one tar file @file{foo.tar}. If you want to use @samp{*} as a shell wildcard with whitespace around it, write @samp{*""}. In the shell, this is equivalent to @samp{*}; but since the @samp{*} is not surrounded by whitespace, Dired does not -treat it specially. +treat it specially. Emacs will prompt for confirmation if you do +this, unless @code{dired-confirm-shell-command} is @code{nil}. @item Otherwise, if the command string contains @samp{?} surrounded by diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 56897826cb..956899c205 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -795,6 +795,15 @@ offer a smarter default choice of shell command." (dired-mark-pop-up nil 'shell files 'read-shell-command prompt nil nil)))) +;;;###autoload +(defcustom dired-confirm-shell-command t + "Whether to prompt for confirmation for ‘dired-do-shell-command’. +If non-nil, prompt for confirmation if the command contains potentially +dangerous characters. If nil, never prompt for confirmation." + :type 'boolean + :group 'dired + :version "29.1") + ;;;###autoload (defun dired-do-async-shell-command (command &optional arg file-list) "Run a shell command COMMAND on the marked files asynchronously. @@ -873,7 +882,9 @@ can be produced by `dired-get-marked-files', for example. `dired-guess-shell-alist-default' and `dired-guess-shell-alist-user' are consulted when the user is -prompted for the shell command to use interactively." +prompted for the shell command to use interactively. + +Also see the `dired-confirm-shell-command' variable." ;; Functions dired-run-shell-command and dired-shell-stuff-it do the ;; actual work and can be redefined for customization. (interactive @@ -891,6 +902,8 @@ prompted for the shell command to use interactively." (ok (cond ((not (or on-each no-subst)) (error "You can not combine `*' and `?' substitution marks")) + ((not dired-confirm-shell-command) + t) ((setq confirmations (dired--need-confirm-positions command "*")) (dired--no-subst-confirm confirmations command)) ((setq confirmations (dired--need-confirm-positions command "?")) commit 1327593ce28f94c4ffe6bbf5fead8e820d3dbd41 Author: Lars Ingebrigtsen Date: Tue Mar 22 16:33:43 2022 +0100 Make eshell link faces more distinctive on 8-color displays * lisp/eshell/em-ls.el (eshell-ls-directory): (eshell-ls-symlink): Make the faces be distinctive on 8-colour displays (bug#43615). diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el index 846f3d5e29..874591d250 100644 --- a/lisp/eshell/em-ls.el +++ b/lisp/eshell/em-ls.el @@ -100,15 +100,14 @@ faster and conserves more memory." :type 'boolean) (defface eshell-ls-directory - '((((class color) (background light)) (:foreground "Blue" :weight bold)) - (((class color) (background dark)) (:foreground "SkyBlue" :weight bold)) - (t (:weight bold))) - "The face used for highlighting directories.") + '((t (:inherit font-lock-function-name-face))) + "The face used for highlighting directories." + :version "29.1") (defface eshell-ls-symlink - '((((class color) (background light)) (:foreground "Dark Cyan" :weight bold)) - (((class color) (background dark)) (:foreground "Cyan" :weight bold))) - "The face used for highlighting symbolic links.") + '((t (:inherit font-lock-keyword-face))) + "The face used for highlighting symbolic links." + :version "29.1") (defface eshell-ls-executable '((((class color) (background light)) (:foreground "ForestGreen" :weight bold)) commit 3054e70d76f71876c58497db04f55d7f413663d9 Author: dickmao Date: Tue Mar 22 15:59:11 2022 +0100 Restore hl-line--buffer tracking * lisp/hl-line.el (hl-line-overlay, hl-line-overlay-buffer): Correct replacement variable. (hl-line--overlay): Clearer doc. (hl-line--buffer): Nee hl-line-overlay-buffer (hl-line-sticky-flag): Custom initialization is unfathomable. (hl-line-mode, hl-line-unhighlight): Orthogonalize sticky. (hl-line-highlight): Remove highlight from previous buffer. * test/lisp/hl-line-tests.el (hl-line-sticky, hl-line-tests-verify): (hl-line-tests-sticky-across-frames, hl-line-tests-sticky): Test (bug#54481). diff --git a/lisp/hl-line.el b/lisp/hl-line.el index 70ba0fcfc2..f1c2e1ebf2 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el @@ -24,17 +24,26 @@ ;;; Commentary: +;; Proper scuttling of unsticky overlays relies on `post-command-hook` +;; being called on a buffer switch and the stationarity of +;; `hl-line--buffer` across switches. One could easily imagine +;; programatically defeating unsticky overlays by bypassing +;; `post-command-hook`. + ;;; Code: -(make-obsolete-variable 'hl-line-overlay nil "29.1") +(make-obsolete-variable 'hl-line-overlay 'hl-line--overlay "29.1") (make-obsolete-variable 'global-hl-line-overlay nil "29.1") (make-obsolete-variable 'global-hl-line-overlays nil "29.1") (make-obsolete-variable 'global-hl-line-sticky-flag nil "29.1") -(make-obsolete-variable 'hl-line-overlay-buffer nil "29.1") +(make-obsolete-variable 'hl-line-overlay-buffer 'hl-line--buffer "29.1") (make-obsolete-variable 'hl-line-range-function nil "29.1") (defvar-local hl-line--overlay nil - "Keep state else scan entire buffer in `post-command-hook'.") + "The prevailing highlighting overlay per buffer.") + +(defvar hl-line--buffer nil + "Used to track last buffer.") ;; 1. define-minor-mode creates buffer-local hl-line--overlay ;; 2. overlay wiped by kill-all-local-variables @@ -68,6 +77,7 @@ :type 'boolean :version "22.1" :group 'hl-line + :initialize #'custom-initialize-default :set (lambda (symbol value) (set-default symbol value) (unless value @@ -100,14 +110,12 @@ Currently used in calendar/todo-mode." (add-hook 'post-command-hook #'hl-line-highlight nil t)) (remove-hook 'post-command-hook #'hl-line-highlight t) (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t) - (let (hl-line-sticky-flag) - (hl-line-unhighlight)))) + (hl-line-unhighlight))) (defun hl-line-unhighlight () - (unless hl-line-sticky-flag - (when hl-line--overlay - (delete-overlay hl-line--overlay) - (setq hl-line--overlay nil)))) + (when hl-line--overlay + (delete-overlay hl-line--overlay) + (setq hl-line--overlay nil))) (defun hl-line-highlight () (unless (minibufferp) @@ -120,6 +128,12 @@ Currently used in calendar/todo-mode." (move-overlay hl-line--overlay (line-beginning-position) (line-beginning-position 2)) + (when (and (not (eq hl-line--buffer (current-buffer))) + (not hl-line-sticky-flag) + (buffer-live-p hl-line--buffer)) + (with-current-buffer hl-line--buffer + (hl-line-unhighlight))) + (setq hl-line--buffer (current-buffer)) (run-hooks 'hl-line-highlight-hook))) (defun hl-line-turn-on () diff --git a/test/lisp/hl-line-tests.el b/test/lisp/hl-line-tests.el index 422d4ddae7..6bff09135b 100644 --- a/test/lisp/hl-line-tests.el +++ b/test/lisp/hl-line-tests.el @@ -21,30 +21,90 @@ (require 'ert) (require 'hl-line) -(ert-deftest hl-line-sticky () - (should hl-line-sticky-flag) - (with-temp-buffer - (let ((from-buffer (current-buffer))) - (hl-line-mode 1) - (save-excursion - (insert "foo")) - (hl-line-highlight) - (should (cl-some (apply-partially #'eq hl-line--overlay) - (overlays-at (point)))) - (switch-to-buffer (get-buffer-create "*scratch*")) - (hl-line-mode 1) - (save-excursion - (insert "bar")) - (hl-line-highlight) - (should (cl-some (apply-partially #'eq hl-line--overlay) - (overlays-at (point)))) - (should (buffer-local-value 'hl-line--overlay from-buffer)) - (should-not (eq (buffer-local-value 'hl-line--overlay from-buffer) - hl-line--overlay)) - (customize-set-variable 'hl-line-sticky-flag nil) - (should hl-line--overlay) - (should (buffer-live-p from-buffer)) - (should-not (buffer-local-value 'hl-line--overlay from-buffer))))) +(defsubst hl-line-tests-verify (_label on-p) + (eq on-p (cl-some (apply-partially #'eq hl-line--overlay) + (overlays-at (point))))) + +(ert-deftest hl-line-tests-sticky-across-frames () + (skip-unless (display-graphic-p)) + (customize-set-variable 'hl-line-sticky-flag t) + (call-interactively #'global-hl-line-mode) + (let ((first-frame (selected-frame)) + (first-buffer "foo") + (second-buffer "bar") + second-frame) + (unwind-protect + (progn + (switch-to-buffer first-buffer) + (save-excursion + (insert (buffer-name))) + (run-hooks 'post-command-hook) + (should (hl-line-tests-verify 111 t)) + (select-frame (setq second-frame (make-frame))) + (switch-to-buffer second-buffer) + (save-excursion + (insert (buffer-name))) + (run-hooks 'post-command-hook) + (should (hl-line-tests-verify 762 t)) + (with-current-buffer first-buffer + (should (hl-line-tests-verify 534 t))) + (call-interactively #'global-hl-line-mode) + (should (hl-line-tests-verify 125 nil)) + (with-current-buffer first-buffer + (should (hl-line-tests-verify 892 nil))) + + ;; now do unsticky + (customize-set-variable 'hl-line-sticky-flag nil) + (call-interactively #'global-hl-line-mode) + (run-hooks 'post-command-hook) + (should (hl-line-tests-verify 467 t)) + (with-current-buffer first-buffer + (should (hl-line-tests-verify 765 nil))) + (select-frame first-frame) + (should (equal (buffer-name) first-buffer)) + (run-hooks 'post-command-hook) + (should (hl-line-tests-verify 423 t)) + (with-current-buffer second-buffer + (should (hl-line-tests-verify 897 nil)))) + (let (kill-buffer-query-functions) + (ignore-errors (kill-buffer first-buffer)) + (ignore-errors (kill-buffer second-buffer)) + (ignore-errors (delete-frame second-frame)))))) + +(ert-deftest hl-line-tests-sticky () + (customize-set-variable 'hl-line-sticky-flag t) + (let ((first-buffer "foo") + (second-buffer "bar")) + (unwind-protect + (progn + (switch-to-buffer first-buffer) + (hl-line-mode 1) + (save-excursion + (insert (buffer-name))) + (run-hooks 'post-command-hook) + (should (hl-line-tests-verify 123 t)) + (switch-to-buffer second-buffer) + (hl-line-mode 1) + (save-excursion + (insert (buffer-name))) + (run-hooks 'post-command-hook) + (should (hl-line-tests-verify 56 t)) + (with-current-buffer first-buffer + (should (hl-line-tests-verify 67 t))) + + ;; now do unsticky + (customize-set-variable 'hl-line-sticky-flag nil) + (should (hl-line-tests-verify 234 t)) + (with-current-buffer first-buffer + (should (hl-line-tests-verify 231 nil))) + (switch-to-buffer first-buffer) + (run-hooks 'post-command-hook) + (should (hl-line-tests-verify 257 t)) + (with-current-buffer second-buffer + (should (hl-line-tests-verify 999 nil))))) + (let (kill-buffer-query-functions) + (ignore-errors (kill-buffer first-buffer)) + (ignore-errors (kill-buffer second-buffer))))) (provide 'hl-line-tests) commit 9b47ccd72e107ee43fcd62362e7580dcfa50d008 Author: Lars Ingebrigtsen Date: Tue Mar 22 15:56:14 2022 +0100 Revert "Fix dependency problem in hl-line-sticky-flag" This reverts commit 46daf70c4a7ce208ab0b3a7893c042fed5f022c2. This is fixed differently in a subsequent patch. diff --git a/lisp/hl-line.el b/lisp/hl-line.el index 8c6b499f11..70ba0fcfc2 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el @@ -75,9 +75,7 @@ (dolist (buffer (buffer-list)) (unless (eq buffer selected) (with-current-buffer buffer - (when hl-line--overlay - (delete-overlay hl-line--overlay) - (setq hl-line--overlay nil))))))))) + (hl-line-unhighlight)))))))) (defcustom hl-line-overlay-priority -50 "Priority used on the overlay used by hl-line." commit 46daf70c4a7ce208ab0b3a7893c042fed5f022c2 Author: Lars Ingebrigtsen Date: Tue Mar 22 15:35:05 2022 +0100 Fix dependency problem in hl-line-sticky-flag * lisp/hl-line.el (hl-line-sticky-flag): Open-code hl-line-unhighlight to avoid recursive dependencies (bug#54481). diff --git a/lisp/hl-line.el b/lisp/hl-line.el index 70ba0fcfc2..8c6b499f11 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el @@ -75,7 +75,9 @@ (dolist (buffer (buffer-list)) (unless (eq buffer selected) (with-current-buffer buffer - (hl-line-unhighlight)))))))) + (when hl-line--overlay + (delete-overlay hl-line--overlay) + (setq hl-line--overlay nil))))))))) (defcustom hl-line-overlay-priority -50 "Priority used on the overlay used by hl-line." commit 656c2dd66e77a5fbeb99d358017e8327401fae05 Author: Lars Ingebrigtsen Date: Tue Mar 22 15:28:02 2022 +0100 Fix color-lighten-hsl logic * lisp/color.el (color-lighten-hsl): Lighten by percentage, instead of just adding the specified number to the luminance element (bug#54514). diff --git a/lisp/color.el b/lisp/color.el index 0fe663d97a..fe629f4f98 100644 --- a/lisp/color.el +++ b/lisp/color.el @@ -403,7 +403,7 @@ See `color-desaturate-hsl'." Given a color defined in terms of hue, saturation, and luminance \(arguments H, S, and L), return a color that is PERCENT lighter. Returns a list (HUE SATURATION LUMINANCE)." - (list H S (color-clamp (+ L (/ percent 100.0))))) + (list H S (color-clamp (+ L (* L (/ percent 100.0)))))) (defun color-lighten-name (name percent) "Make a color with a specified NAME lighter by PERCENT. diff --git a/test/lisp/color-tests.el b/test/lisp/color-tests.el index 49b632c841..e4e1eda26d 100644 --- a/test/lisp/color-tests.el +++ b/test/lisp/color-tests.el @@ -220,32 +220,32 @@ (ert-deftest color-tests-lighten-hsl () (should (equal (color-lighten-hsl 360 0.5 0.5 0) '(360 0.5 0.5))) - (should (equal (color-lighten-hsl 360 0.5 0.5 -10) '(360 0.5 0.4))) + (should (equal (color-lighten-hsl 360 0.5 0.5 -10) '(360 0.5 0.45))) (should (equal (color-lighten-hsl 360 0.5 0.5 -500) '(360 0.5 0.0))) (should (color-tests--approx-equal - (color-lighten-hsl 120 0.5 0.8 5) '(120 0.5 0.85))) + (color-lighten-hsl 120 0.5 0.8 5) '(120 0.5 0.84))) (should (equal (color-lighten-hsl 120 0.5 0.8 500) '(120 0.5 1.0)))) (ert-deftest color-tests-lighten-name () - (should (equal (color-lighten-name "black" 100) "#ffffffffffff")) + (should (equal (color-lighten-name "black" 100) "#000000000000")) (should (equal (color-lighten-name "white" 100) "#ffffffffffff")) (should (equal (color-lighten-name "red" 0) "#ffff00000000")) - (should (equal (color-lighten-name "red" 10) "#ffff33323332"))) + (should (equal (color-lighten-name "red" 10) "#ffff19991999"))) (ert-deftest color-tests-darken-hsl () (should (equal (color-darken-hsl 360 0.5 0.5 0) '(360 0.5 0.5))) - (should (equal (color-darken-hsl 360 0.5 0.5 -10) '(360 0.5 0.6))) + (should (equal (color-darken-hsl 360 0.5 0.5 -10) '(360 0.5 0.55))) (should (equal (color-darken-hsl 360 0.5 0.5 -500) '(360 0.5 1.0))) - (should (equal (color-darken-hsl 120 0.5 0.8 5) '(120 0.5 0.75))) + (should (equal (color-darken-hsl 120 0.5 0.8 5) '(120 0.5 0.76))) (should (equal (color-darken-hsl 120 0.5 0.8 500) '(120 0.5 0.0)))) (ert-deftest color-tests-darken-name () (should (equal (color-darken-name "black" 100) "#000000000000")) (should (equal (color-darken-name "white" 100) "#000000000000")) (should (equal (color-darken-name "red" 0) "#ffff00000000")) - (should (equal (color-darken-name "red" 10) "#cccc00000000"))) + (should (equal (color-darken-name "red" 10) "#e66500000000"))) (provide 'color-tests) ;;; color-tests.el ends here commit 54febab481644b213c6ea87e4922f398b73d7127 Author: Lars Ingebrigtsen Date: Tue Mar 22 15:04:37 2022 +0100 Revert todo-mode tests failing after todo-mode reversion diff --git a/test/lisp/calendar/todo-mode-tests.el b/test/lisp/calendar/todo-mode-tests.el index 8715a32b88..0102b62c10 100644 --- a/test/lisp/calendar/todo-mode-tests.el +++ b/test/lisp/calendar/todo-mode-tests.el @@ -130,8 +130,8 @@ In particular, all lines of a multiline item should be highlighted." (todo-toggle-item-highlighting) (let ((end (1- (todo-item-end))) (beg (todo-item-start))) - (should (eq (get-char-property beg 'face) 'hl-line-face)) - (should (eq (get-char-property end 'face) 'hl-line-face)) + (should (eq (get-char-property beg 'face) 'hl-line)) + (should (eq (get-char-property end 'face) 'hl-line)) (should (> (count-lines beg end) 1)) (should (eq (next-single-char-property-change beg 'face) (1+ end)))) (todo-toggle-item-highlighting))) ; Turn off highlighting (for test rerun). @@ -736,7 +736,7 @@ Subsequently moving to an item should show it highlighted." (todo-test--done-items-separator) (call-interactively #'todo-toggle-item-highlighting) (ert-simulate-command '(todo-previous-item)) - (should (eq 'hl-line-face (get-char-property (point) 'face))))) + (should (eq 'hl-line (get-char-property (point) 'face))))) (ert-deftest todo-test-done-items-separator06-eol () ; bug#32343 "Test enabling item highlighting at EOL of done items separator. @@ -746,7 +746,7 @@ Subsequently moving to an item should show it highlighted." (todo-toggle-item-highlighting) (forward-line -1) (ert-simulate-command '(todo-previous-item)) - (should (eq 'hl-line-face (get-char-property (point) 'face))))) + (should (eq 'hl-line (get-char-property (point) 'face))))) (ert-deftest todo-test-done-items-separator07 () ; bug#32343 "Test item highlighting when crossing done items separator. @@ -758,7 +758,7 @@ The highlighting should remain enabled." (todo-next-item) ; Now on empty line above separator. (forward-line) ; Now on separator. (ert-simulate-command '(forward-line)) ; Now on first done item. - (should (eq 'hl-line-face (get-char-property (point) 'face))))) + (should (eq 'hl-line (get-char-property (point) 'face))))) (ert-deftest todo-test-current-file-in-edit-mode () ; bug#32437 "Test the value of todo-current-todo-file in todo-edit-mode." commit fa55708b5597ac7f16910b611e755e4000f2f104 Author: Lars Ingebrigtsen Date: Tue Mar 22 15:02:08 2022 +0100 Add new function image-supported-file-p * lisp/image.el (image-type-from-file-name): Make obsolete. (image-supported-file-p): New function that has a more sensible value. (image-type): Adjust caller. * lisp/thumbs.el (thumbs-file-size, thumbs-show-image-num): Adjust callers. * lisp/mail/rmailmm.el (rmail-mime-set-bulk-data): Adjust caller and logic. diff --git a/lisp/image.el b/lisp/image.el index 7306f47627..1b684d5c57 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -380,6 +380,7 @@ be determined." "Determine the type of image file FILE from its name. Value is a symbol specifying the image type, or nil if type cannot be determined." + (declare (obsolete image-supported-file-p "29.1")) (let (type first (case-fold-search t)) (catch 'found (dolist (elem image-type-file-name-regexps first) @@ -389,6 +390,20 @@ be determined." ;; If nothing seems to be supported, return first type that matched. (or first (setq first type)))))))) + ;;;###autoload +(defun image-supported-file-p (file) + "Say whether Emacs has native support for displaying TYPE. +The value is a symbol specifying the image type, or nil if type +cannot be determined (or if Emacs doesn't have built-in support +for the image type)." + (let ((case-fold-search t) + type) + (catch 'found + (dolist (elem image-type-file-name-regexps) + (when (and (string-match-p (car elem) file) + (image-type-available-p (setq type (cdr elem)))) + (throw 'found type)))))) + (declare-function image-convert-p "image-converter.el" (source &optional image-format)) (declare-function image-convert "image-converter.el" @@ -417,7 +432,7 @@ type if we can't otherwise guess it." (require 'image-converter) (image-convert-p source data-p)))) (or (image-type-from-file-header source) - (image-type-from-file-name source) + (image-supported-file-p source) (and image-use-external-converter (progn (require 'image-converter) diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el index 76a32724c0..79f421bdcd 100644 --- a/lisp/mail/rmailmm.el +++ b/lisp/mail/rmailmm.el @@ -796,17 +796,14 @@ directly." ((string-match "text/" content-type) (setq type 'text)) ((string-match "image/\\(.*\\)" content-type) - (setq type (image-type-from-file-name + (setq type (image-supported-file-p (concat "." (match-string 1 content-type)))) - (if (and (boundp 'image-types) - (memq type image-types) - (image-type-available-p type)) - (if (and rmail-mime-show-images - (not (eq rmail-mime-show-images 'button)) - (or (not (numberp rmail-mime-show-images)) - (< size rmail-mime-show-images))) - (setq to-show t)) - (setq type nil)))) + (when (and type + rmail-mime-show-images + (not (eq rmail-mime-show-images 'button)) + (or (not (numberp rmail-mime-show-images)) + (< size rmail-mime-show-images))) + (setq to-show t)))) (setcar bulk-data size) (setcdr bulk-data type) to-show)) diff --git a/lisp/thumbs.el b/lisp/thumbs.el index 695fa8a856..3bf08dd6a5 100644 --- a/lisp/thumbs.el +++ b/lisp/thumbs.el @@ -296,7 +296,8 @@ smaller according to whether INCREMENT is 1 or -1." (defun thumbs-file-size (img) (let ((i (image-size - (find-image `((:type ,(image-type-from-file-name img) :file ,img))) t))) + (find-image `((:type ,(image-supported-file-p img) :file ,img))) + t))) (concat (number-to-string (round (car i))) "x" (number-to-string (round (cdr i)))))) @@ -399,7 +400,7 @@ and SAME-WINDOW to show thumbs in the same window." thumbs-image-num (or num 0)) (delete-region (point-min)(point-max)) (save-excursion - (thumbs-insert-image img (image-type-from-file-name img) 0))))) + (thumbs-insert-image img (image-supported-file-p img) 0))))) (defun thumbs-find-image-at-point (&optional img otherwin) "Display image IMG for thumbnail at point. @@ -533,7 +534,7 @@ Open another window." " - " (number-to-string num))) (let ((inhibit-read-only t)) (erase-buffer) - (thumbs-insert-image img (image-type-from-file-name img) 0) + (thumbs-insert-image img (image-supported-file-p img) 0) (goto-char (point-min)))) (setq thumbs-image-num num thumbs-current-image-filename img)))) @@ -765,7 +766,7 @@ ACTION and ARG should be a valid convert command." (define-key dired-mode-map "\C-tw" 'thumbs-dired-setroot) (define-obsolete-function-alias 'thumbs-image-type - #'image-type-from-file-name "29.1") + #'image-supported-file-p "29.1") (provide 'thumbs) commit c9c3d5d8304fcaf69e0de085d762b10b63779cb2 Author: Lars Ingebrigtsen Date: Tue Mar 22 14:45:19 2022 +0100 Revert "Allow using image-convert to view .bmp images" This reverts commit ede8ad507d06a336ce8202927f214aecbaf15d6b. This leads to failures for usages of the function where Emacs doesn't have support for the formats. diff --git a/lisp/image.el b/lisp/image.el index bad8ba7cd7..7306f47627 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -378,16 +378,16 @@ be determined." ;;;###autoload (defun image-type-from-file-name (file) "Determine the type of image file FILE from its name. -Value is a symbol specifying the image type, or nil if type -cannot be determined (or if Emacs doesn't have built-in support -for the image type)." - (let ((case-fold-search t) - type) +Value is a symbol specifying the image type, or nil if type cannot +be determined." + (let (type first (case-fold-search t)) (catch 'found - (dolist (elem image-type-file-name-regexps) - (when (and (string-match-p (car elem) file) - (image-type-available-p (setq type (cdr elem)))) - (throw 'found type)))))) + (dolist (elem image-type-file-name-regexps first) + (when (string-match-p (car elem) file) + (if (image-type-available-p (setq type (cdr elem))) + (throw 'found type) + ;; If nothing seems to be supported, return first type that matched. + (or first (setq first type)))))))) (declare-function image-convert-p "image-converter.el" (source &optional image-format)) commit 8757551da09bdccc0080208bfec7116f4330b3c5 Author: Po Lu Date: Tue Mar 22 11:26:46 2022 +0000 Simplify fullscreen management on Haiku * src/haiku_support.cc (class EmacsWindow, Zoom, UnZoom): Track zoom state manually instead of guessing what the system currently thinks it is. (MakeFullscreen): Always unzoom first. * src/haiku_support.h (struct haiku_zoom_event): Remove all fields and add a single field `zoomed'. * src/haikufns.c (haiku_create_frame, haiku_create_tip_frame): Remove use of pending_zoom fields. * src/haikuterm.c (haiku_read_socket): Simplify handling of zoom events. (haiku_fullscreen): Simplify handling of different zoom states. * src/haikuterm.h (struct haiku_output): Remove all pending_zoom fields since they are no longer required. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 5d0385f6d9..3ded7a80f4 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -37,6 +37,7 @@ along with GNU Emacs. If not, see . */ #include #include #include +#include #include @@ -403,9 +404,9 @@ class EmacsWindow : public BWindow BRect pre_zoom_rect; int x_before_zoom = INT_MIN; int y_before_zoom = INT_MIN; - int fullscreen_p = 0; - int zoomed_p = 0; - int shown_flag = 0; + bool fullscreen_p = false; + bool zoomed_p = false; + bool shown_flag = false; volatile int was_shown_p = 0; bool menu_bar_active_p = false; bool override_redirect_p = false; @@ -446,6 +447,77 @@ class EmacsWindow : public BWindow pthread_mutex_destroy (&menu_update_mutex); } + BRect + CalculateZoomRect (void) + { + BScreen screen (this); + BDeskbar deskbar; + BRect screen_frame; + BRect frame; + BRect deskbar_frame; + BRect window_frame; + BRect decorator_frame; + + if (!screen.IsValid ()) + gui_abort ("Failed to calculate screen rect"); + + screen_frame = frame = screen.Frame (); + deskbar_frame = deskbar.Frame (); + + if (!(modifiers () & B_SHIFT_KEY) + && !deskbar.IsAutoHide ()) + { + switch (deskbar.Location ()) + { + case B_DESKBAR_TOP: + frame.top = deskbar_frame.bottom + 2; + break; + + case B_DESKBAR_BOTTOM: + case B_DESKBAR_LEFT_BOTTOM: + case B_DESKBAR_RIGHT_BOTTOM: + frame.bottom = deskbar_frame.bottom - 2; + break; + + case B_DESKBAR_LEFT_TOP: + if (deskbar.IsExpanded ()) + frame.top = deskbar_frame.bottom + 2; + else + frame.left = deskbar_frame.right + 2; + break; + + default: + if (deskbar.IsExpanded () + && !deskbar.IsAlwaysOnTop () + && !deskbar.IsAutoRaise ()) + frame.right = deskbar_frame.left - 2; + } + } + + window_frame = Frame (); + decorator_frame = DecoratorFrame (); + + frame.top += (window_frame.top + - decorator_frame.top); + frame.bottom -= (decorator_frame.bottom + - window_frame.bottom); + frame.left += (window_frame.left + - decorator_frame.left); + frame.right -= (decorator_frame.right + - window_frame.right); + + if (frame.top > deskbar_frame.bottom + || frame.bottom < deskbar_frame.top) + { + frame.left = screen_frame.left + (window_frame.left + - decorator_frame.left); + frame.right = screen_frame.right - (decorator_frame.right + - window_frame.left); + } + + return frame; + } + void UpwardsSubset (EmacsWindow *w) { @@ -989,33 +1061,29 @@ class EmacsWindow : public BWindow Zoom (BPoint o, float w, float h) { struct haiku_zoom_event rq; + BRect rect; rq.window = this; - rq.x = o.x; - rq.y = o.y; - - rq.width = w + 1; - rq.height = h + 1; - if (fullscreen_p) MakeFullscreen (0); - if (o.x != x_before_zoom || - o.y != y_before_zoom) + if (!zoomed_p) { - x_before_zoom = Frame ().left; - y_before_zoom = Frame ().top; pre_zoom_rect = Frame (); - zoomed_p = 1; - haiku_write (ZOOM_EVENT, &rq); + zoomed_p = true; + rect = CalculateZoomRect (); } else { - zoomed_p = 0; - x_before_zoom = y_before_zoom = INT_MIN; + zoomed_p = false; + rect = pre_zoom_rect; } - BWindow::Zoom (o, w, h); + rq.zoomed = zoomed_p; + haiku_write (ZOOM_EVENT, &rq); + + BWindow::Zoom (rect.LeftTop (), BE_RECT_WIDTH (rect) - 1, + BE_RECT_HEIGHT (rect) - 1); } void @@ -1023,11 +1091,8 @@ class EmacsWindow : public BWindow { if (!zoomed_p) return; - zoomed_p = 0; - EmacsMoveTo (pre_zoom_rect.left, pre_zoom_rect.top); - ResizeTo (BE_RECT_WIDTH (pre_zoom_rect) - 1, - BE_RECT_HEIGHT (pre_zoom_rect) - 1); + BWindow::Zoom (); } void @@ -1083,6 +1148,8 @@ class EmacsWindow : public BWindow if (!screen.IsValid ()) gui_abort ("Trying to make a window fullscreen without a screen"); + UnZoom (); + if (make_fullscreen_p == fullscreen_p) return; diff --git a/src/haiku_support.h b/src/haiku_support.h index 9c21a80e20..c978926e73 100644 --- a/src/haiku_support.h +++ b/src/haiku_support.h @@ -220,10 +220,8 @@ struct haiku_menu_bar_help_event struct haiku_zoom_event { void *window; - int x; - int y; - int width; - int height; + + bool zoomed; }; #define FSPEC_FAMILY 1 diff --git a/src/haikufns.c b/src/haikufns.c index 7bb613af6e..14d4c870c1 100644 --- a/src/haikufns.c +++ b/src/haikufns.c @@ -631,11 +631,6 @@ haiku_create_frame (Lisp_Object parms) f->output_method = output_haiku; f->output_data.haiku = xzalloc (sizeof *f->output_data.haiku); - f->output_data.haiku->pending_zoom_x = INT_MIN; - f->output_data.haiku->pending_zoom_y = INT_MIN; - f->output_data.haiku->pending_zoom_width = INT_MIN; - f->output_data.haiku->pending_zoom_height = INT_MIN; - fset_icon_name (f, gui_display_get_arg (dpyinfo, parms, Qicon_name, "iconName", "Title", RES_TYPE_STRING)); @@ -961,11 +956,6 @@ haiku_create_tip_frame (Lisp_Object parms) f->output_method = output_haiku; f->output_data.haiku = xzalloc (sizeof *f->output_data.haiku); - f->output_data.haiku->pending_zoom_x = INT_MIN; - f->output_data.haiku->pending_zoom_y = INT_MIN; - f->output_data.haiku->pending_zoom_width = INT_MIN; - f->output_data.haiku->pending_zoom_height = INT_MIN; - f->tooltip = true; fset_icon_name (f, Qnil); FRAME_DISPLAY_INFO (f) = dpyinfo; diff --git a/src/haikuterm.c b/src/haikuterm.c index efaafbfac2..b0bbee9e3b 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -2851,19 +2851,6 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) cancel_mouse_face (f); haiku_clear_under_internal_border (f); } - - if (FRAME_OUTPUT_DATA (f)->pending_zoom_width != width || - FRAME_OUTPUT_DATA (f)->pending_zoom_height != height) - { - FRAME_OUTPUT_DATA (f)->zoomed_p = 0; - haiku_make_fullscreen_consistent (f); - } - else - { - FRAME_OUTPUT_DATA (f)->zoomed_p = 1; - FRAME_OUTPUT_DATA (f)->pending_zoom_width = INT_MIN; - FRAME_OUTPUT_DATA (f)->pending_zoom_height = INT_MIN; - } break; } case FRAME_EXPOSED: @@ -3249,16 +3236,6 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (!f) continue; - if (FRAME_OUTPUT_DATA (f)->pending_zoom_x != b->x || - FRAME_OUTPUT_DATA (f)->pending_zoom_y != b->y) - FRAME_OUTPUT_DATA (f)->zoomed_p = 0; - else - { - FRAME_OUTPUT_DATA (f)->zoomed_p = 1; - FRAME_OUTPUT_DATA (f)->pending_zoom_x = INT_MIN; - FRAME_OUTPUT_DATA (f)->pending_zoom_y = INT_MIN; - } - if (FRAME_PARENT_FRAME (f)) haiku_coords_from_parent (f, &b->x, &b->y); @@ -3570,12 +3547,7 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (!f) continue; - FRAME_OUTPUT_DATA (f)->pending_zoom_height = b->height; - FRAME_OUTPUT_DATA (f)->pending_zoom_width = b->width; - FRAME_OUTPUT_DATA (f)->pending_zoom_x = b->x; - FRAME_OUTPUT_DATA (f)->pending_zoom_y = b->y; - - FRAME_OUTPUT_DATA (f)->zoomed_p = 1; + FRAME_OUTPUT_DATA (f)->zoomed_p = b->zoomed; haiku_make_fullscreen_consistent (f); break; } @@ -3821,13 +3793,10 @@ haiku_fullscreen (struct frame *f) return; if (f->want_fullscreen == FULLSCREEN_MAXIMIZED) - { - EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 0); - BWindow_zoom (FRAME_HAIKU_WINDOW (f)); - } + BWindow_zoom (FRAME_HAIKU_WINDOW (f)); else if (f->want_fullscreen == FULLSCREEN_BOTH) EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 1); - else if (f->want_fullscreen == FULLSCREEN_NONE) + else { EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 0); EmacsWindow_unzoom (FRAME_HAIKU_WINDOW (f)); diff --git a/src/haikuterm.h b/src/haikuterm.h index 65fd51e237..bce1c627eb 100644 --- a/src/haikuterm.h +++ b/src/haikuterm.h @@ -150,11 +150,6 @@ struct haiku_output int menu_up_to_date_p; int zoomed_p; - int pending_zoom_x; - int pending_zoom_y; - int pending_zoom_width; - int pending_zoom_height; - int menu_bar_open_p; struct font *font; commit 0094dde11d97a0e69b053851a87f2934ef0e00aa Author: Michael Albinus Date: Tue Mar 22 10:29:16 2022 +0100 Fix grep-like functions when running on a remote host * doc/lispref/processes.texi (Shell Arguments): * etc/NEWS: Describe change in 'shell-quote-argument'. Fix typos. * lisp/subr.el (shell-quote-argument): New optional argument POSIX. * lisp/progmodes/grep.el (grep-compute-defaults) (grep-default-command, grep-expand-keywords, lgrep) (rgrep-default-command): Use POSIX argument in `shell-quote-argument'. (Bug#54487) diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index ed07c1cbf7..ea51abda4b 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -197,7 +197,7 @@ gives special treatment to certain characters, and if these characters occur in the file name, they will confuse the shell. To handle these characters, use the function @code{shell-quote-argument}: -@defun shell-quote-argument argument +@defun shell-quote-argument argument &optional posix This function returns a string that represents, in shell syntax, an argument whose actual contents are @var{argument}. It should work reliably to concatenate the return value into a shell command @@ -227,6 +227,15 @@ a shell command: " " (shell-quote-argument newfile)) @end example + +If the optional @var{posix} argument is non-@code{nil}, @var{argument} +is quoted according to POSIX shell quoting rules, regardless of the +system’s shell. This is useful when your shell could run on a remote +host, which requires a POSIX shell in general. + +@example +(shell-quote-argument "foo > bar" (file-remote-p default-directory)) +@end example @end defun @cindex quoting and unquoting command-line arguments diff --git a/etc/NEWS b/etc/NEWS index ebf1346dae..e64fe2d23b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -578,9 +578,9 @@ the "*Completions*" buffer. Available styles are no sorting, alphabetical (the default), or a custom sort function. +++ -*** New values for the 'completion-auto-help' option. +*** New values for the 'completion-auto-help' user option. There are two new values to control the way "*Completions*" behave after -a if completion is not unique. 'always' updates or shows +a 'TAB' if completion is not unique. 'always' updates or shows the "*Completions*" buffer after any attempt to complete. 'visual' is like 'always', but only update the completions if they are already visible. The default value 't' always hides the completion buffer after @@ -591,16 +591,16 @@ some completion is made. This option limits the height of the "*Completions*" buffer. +++ -*** New option 'completions-header-format' +*** New user option 'completions-header-format' This is a string to control the message to show before completions. -It may contain a "%s" to show the total number of completions. If nil no +It may contain a "%s" to show the total number of completions. If nil no completions are shown. +++ -*** New option 'completions-highlight-face'. -When this variable is a face name, it highlights the current candidate -in the "*Completions*" buffer with that face. When the value is nil, -no highlighting is performed at all. +*** New user option 'completions-highlight-face'. +When this user option is a face name, it highlights the current +candidate in the "*Completions*" buffer with that face. When the +value is nil, no highlighting is performed at all. ** Isearch and Replace @@ -1207,7 +1207,7 @@ like: --- ** The 'inhibit-changing-match-data' variable is now obsolete. Instead, functions like 'string-match' and 'looking-at' now take an -optional 'inhibit-modify' argument. +optional INHIBIT-MODIFY argument. --- ** 'gnus-define-keys' is now obsolete. @@ -1330,7 +1330,7 @@ This allows setting a minimum display width for a region of text. ** New 'cursor-face' text property. This uses 'cursor-face' instead of the default face when cursor is on or near the character and 'cursor-face-highlight-mode' is enabled. The -variable 'cursor-face-highlight-nonselected-window' is similar to +user option 'cursor-face-highlight-nonselected-window' is similar to 'highlight-nonselected-windows', but for this property. +++ @@ -1470,8 +1470,8 @@ This command lets you examine all data in the current selection and the clipboard, and insert it into the buffer. --- -** New hook 'minibuffer-lazy-highlight-setup'. -This hook is intended to be added to 'minibuffer-setup-hook'. +** New function 'minibuffer-lazy-highlight-setup'. +This function is intended to be added to 'minibuffer-setup-hook'. It sets up the minibuffer for lazy highlighting of matches in the original window. @@ -1542,8 +1542,7 @@ from a specified amount of pixels above or below a position. --- ** 'eshell-eval-using-options' now follows POSIX/GNU argument syntax conventions. Built-in commands in Eshell now accept command-line options with -values passed as a single token, such as '-oVALUE' or -'--option=VALUE'. +values passed as a single token, such as '-oVALUE' or '--option=VALUE'. ** XDG support @@ -1748,11 +1747,16 @@ This is recorded in the `function-history` symbol property. ** 'indian-tml-base-table' no longer translates digits. Use 'indian-tml-base-digits-table' if you want digits translation. --- +--- ** 'indian-tml-itrans-v5-hash' no longer translates digits. Use 'indian-tml-itrans-digits-v5-hash' if you want digits translation. ++++ +** 'shell-quote-argument' has a new optional parameter POSIX. +This is useful when quoting shell arguments for a remote shell +invocation. Such shells are POSIX conform by default. + * Changes in Emacs 29.1 on Non-Free Operating Systems diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index ccc58e6773..2128088856 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -632,12 +632,12 @@ The value depends on `grep-command', `grep-template', ,grep-use-null-filename-separator) (grep-find-use-xargs ,grep-find-use-xargs) (grep-highlight-matches ,grep-highlight-matches))))) - (let* ((host-id - (intern (or (file-remote-p default-directory) "localhost"))) + (let* ((remote (file-remote-p default-directory)) + (host-id (intern (or remote "localhost"))) (host-defaults (assq host-id grep-host-defaults-alist)) (defaults (assq nil grep-host-defaults-alist)) - (quot-braces (shell-quote-argument "{}")) - (quot-scolon (shell-quote-argument ";"))) + (quot-braces (shell-quote-argument "{}" remote)) + (quot-scolon (shell-quote-argument ";" remote))) ;; There are different defaults on different hosts. They must be ;; computed for every host once. (dolist (setting '(grep-command grep-template @@ -820,7 +820,9 @@ The value depends on `grep-command', `grep-template', (defun grep-default-command () "Compute the default grep command for \\[universal-argument] \\[grep] to offer." - (let ((tag-default (shell-quote-argument (grep-tag-default))) + (let ((tag-default + (shell-quote-argument + (grep-tag-default) (file-remote-p default-directory))) ;; This a regexp to match single shell arguments. ;; Could someone please add comments explaining it? (sh-arg-re @@ -963,7 +965,8 @@ easily repeat a find command." ("" . files) ("" . (null-device)) ("" . excl) - ("" . (shell-quote-argument (or regexp "")))) + ("" . (shell-quote-argument + (or regexp "") (file-remote-p (expand-file-name (or dir ".")))))) "List of substitutions performed by `grep-expand-template'. If car of an element matches, the cdr is evalled in order to get the substitution string. @@ -1112,11 +1115,12 @@ command before it's run." (when (and (stringp regexp) (> (length regexp) 0)) (unless (and dir (file-accessible-directory-p dir)) (setq dir default-directory)) - (let ((command regexp)) + (let ((command regexp) remote) (if (null files) (if (string= command grep-command) (setq command nil)) - (setq dir (file-name-as-directory (expand-file-name dir))) + (setq dir (file-name-as-directory (expand-file-name dir)) + remote (file-remote-p dir)) (unless (or (not grep-use-directories-skip) (eq grep-use-directories-skip t)) (setq grep-use-directories-skip @@ -1134,11 +1138,12 @@ command before it's run." (mapconcat (lambda (ignore) (cond ((stringp ignore) - (shell-quote-argument ignore)) + (shell-quote-argument + ignore remote)) ((consp ignore) (and (funcall (car ignore) dir) (shell-quote-argument - (cdr ignore)))))) + (cdr ignore) remote))))) grep-find-ignored-files " --exclude="))) (and (eq grep-use-directories-skip t) @@ -1242,48 +1247,50 @@ command before it's run." (defun rgrep-default-command (regexp files dir) "Compute the command for \\[rgrep] to use by default." (require 'find-dired) ; for `find-name-arg' - (grep-expand-template - grep-find-template - regexp - (concat (shell-quote-argument "(") - " " find-name-arg " " - (mapconcat - #'shell-quote-argument - (split-string files) - (concat " -o " find-name-arg " ")) - " " - (shell-quote-argument ")")) - dir - (concat - (and grep-find-ignored-directories - (concat "-type d " - (shell-quote-argument "(") - ;; we should use shell-quote-argument here - " -path " - (mapconcat (lambda (d) (shell-quote-argument (concat "*/" d))) - (rgrep-find-ignored-directories dir) - " -o -path ") - " " - (shell-quote-argument ")") - " -prune -o ")) - (and grep-find-ignored-files - (concat (shell-quote-argument "!") " -type d " - (shell-quote-argument "(") - ;; we should use shell-quote-argument here - " -name " - (mapconcat - (lambda (ignore) - (cond ((stringp ignore) - (shell-quote-argument ignore)) - ((consp ignore) - (and (funcall (car ignore) dir) - (shell-quote-argument - (cdr ignore)))))) - grep-find-ignored-files - " -o -name ") - " " - (shell-quote-argument ")") - " -prune -o "))))) + (let ((remote (file-remote-p (or dir default-directory)))) + (grep-expand-template + grep-find-template + regexp + (concat (shell-quote-argument "(" remote) + " " find-name-arg " " + (mapconcat + (lambda (x) (shell-quote-argument x remote)) + (split-string files) + (concat " -o " find-name-arg " ")) + " " + (shell-quote-argument ")" remote)) + dir + (concat + (and grep-find-ignored-directories + (concat "-type d " + (shell-quote-argument "(" remote) + ;; we should use shell-quote-argument here + " -path " + (mapconcat + (lambda (d) (shell-quote-argument (concat "*/" d) remote)) + (rgrep-find-ignored-directories dir) + " -o -path ") + " " + (shell-quote-argument ")" remote) + " -prune -o ")) + (and grep-find-ignored-files + (concat (shell-quote-argument "!" remote) " -type d " + (shell-quote-argument "(" remote) + ;; we should use shell-quote-argument here + " -name " + (mapconcat + (lambda (ignore) + (cond ((stringp ignore) + (shell-quote-argument ignore remote)) + ((consp ignore) + (and (funcall (car ignore) dir) + (shell-quote-argument + (cdr ignore) remote))))) + grep-find-ignored-files + " -o -name ") + " " + (shell-quote-argument ")" remote) + " -prune -o ")))))) (defun grep-find-toggle-abbreviation () "Toggle showing the hidden part of rgrep/lgrep/zrgrep command line." diff --git a/lisp/subr.el b/lisp/subr.el index 8aadcfd453..603acffea7 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -3760,14 +3760,18 @@ Note: :data and :device are currently not supported on Windows." (declare-function w32-shell-dos-semantics "w32-fns" nil) -(defun shell-quote-argument (argument) +(defun shell-quote-argument (argument &optional posix) "Quote ARGUMENT for passing as argument to an inferior shell. This function is designed to work with the syntax of your system's standard shell, and might produce incorrect results with unusual shells. -See Info node `(elisp)Security Considerations'." - (cond - ((eq system-type 'ms-dos) +See Info node `(elisp)Security Considerations'. + +If the optional POSIX argument is non-nil, ARGUMENT is quoted +according to POSIX shell quoting rules, regardless of the +system's shell." +(cond + ((and (not posix) (eq system-type 'ms-dos)) ;; Quote using double quotes, but escape any existing quotes in ;; the argument with backslashes. (let ((result "") @@ -3782,7 +3786,7 @@ See Info node `(elisp)Security Considerations'." start (1+ end)))) (concat "\"" result (substring argument start) "\""))) - ((and (eq system-type 'windows-nt) (w32-shell-dos-semantics)) + ((and (not posix) (eq system-type 'windows-nt) (w32-shell-dos-semantics)) ;; First, quote argument so that CommandLineToArgvW will ;; understand it. See commit 7872d496d5dc272dacd2d2a5fd9238e39f2dbea8 Author: Andrea Corallo Date: Tue Mar 22 09:32:57 2022 +0100 * src/comp.c: Few improvements following 71b8f1fc635. * src/comp.c (ABI_VERSION): Update. (Fcomp__register_lambda, Fcomp__register_subr): Remove unnecessary check. * src/comp.c (Fcomp__register_lambda, Fcomp__register_subr): Remove unnecessary change. diff --git a/src/comp.c b/src/comp.c index 349f228558..398f35ddb0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -447,7 +447,7 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ -#define ABI_VERSION "4" +#define ABI_VERSION "5" /* Length of the hashes used for eln file naming. */ #define HASH_LENGTH 8 @@ -5463,9 +5463,7 @@ This gets called by top_level_run during the load phase. */) { Lisp_Object doc_idx = FIRST (rest); Lisp_Object intspec = SECOND (rest); - Lisp_Object command_modes = Qnil; - if (!NILP (XCDR (XCDR (rest)))) - command_modes = THIRD (rest); + Lisp_Object command_modes = THIRD (rest); struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); if (cu->loaded_once) @@ -5498,9 +5496,7 @@ This gets called by top_level_run during the load phase. */) { Lisp_Object doc_idx = FIRST (rest); Lisp_Object intspec = SECOND (rest); - Lisp_Object command_modes = Qnil; - if (!NILP (XCDR (XCDR (rest)))) - command_modes = THIRD (rest); + Lisp_Object command_modes = THIRD (rest); Lisp_Object tem = make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, type, doc_idx, commit b10dcd0c8899dd66a07c8935ad5e16d8ebb2e32e Author: Po Lu Date: Tue Mar 22 16:26:11 2022 +0800 * src/xterm.c (x_dnd_get_window_proto): Don't return huge protocols. diff --git a/src/xterm.c b/src/xterm.c index be1dc9e3c9..a7d8445502 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1020,7 +1020,7 @@ x_dnd_get_window_proto (struct x_display_info *dpyinfo, Window wdesc) value = (int) *(Atom *) tmp_data; XFree (tmp_data); - return (int) value; + return min (X_DND_SUPPORTED_VERSION, (int) value); } static void commit 15ac51e0fd385130a0764481290d04a71aad5e88 Merge: 966ec5dae6 eba9c473a8 Author: Juri Linkov Date: Tue Mar 22 10:22:46 2022 +0200 Merge branch 'feature/completions-customs' commit 966ec5dae6a86cca6a76a4a28e4cdd86a6bf8b23 Author: Po Lu Date: Tue Mar 22 02:46:35 2022 +0000 Fix starting Emacs with -mm or -fs on Haiku * src/haikuterm.c (haiku_set_window_size): Disallow setting the window size if the frame is fullscreen, like most X window managers. diff --git a/src/haikuterm.c b/src/haikuterm.c index 221bdfd2ee..efaafbfac2 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -1835,6 +1835,22 @@ static void haiku_set_window_size (struct frame *f, bool change_gravity, int width, int height) { + Lisp_Object frame; + + /* On X Windows, window managers typically disallow resizing a + window when it is fullscreen. Do the same here. */ + + XSETFRAME (frame, f); + if (!NILP (Fframe_parameter (frame, Qfullscreen)) + /* Only do this if the fullscreen status has actually been + applied. */ + && f->want_fullscreen == FULLSCREEN_NONE + /* And if the configury during frame completion has been + completed. Otherwise, there will be no valid "old size" to + go back to. */ + && FRAME_OUTPUT_DATA (f)->configury_done) + return; + haiku_update_size_hints (f); if (FRAME_HAIKU_WINDOW (f)) commit df5fb5fafab73c96e06f139a883274c5f0660401 Author: Po Lu Date: Tue Mar 22 08:39:55 2022 +0800 Fix leak of saved menu event and output data * src/xterm.c (x_destroy_window, x_free_frame_resources): Free output data and saved menu event even if display is closed. diff --git a/src/xterm.c b/src/xterm.c index 3f16a116eb..be1dc9e3c9 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -17565,9 +17565,11 @@ x_free_frame_resources (struct frame *f) if (x_dnd_in_progress && f == x_dnd_frame) { + block_input (); if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1) x_dnd_send_leave (f, x_dnd_last_seen_window); + unblock_input (); x_dnd_in_progress = false; x_dnd_waiting_for_finish = false; @@ -17737,10 +17739,6 @@ x_free_frame_resources (struct frame *f) g_object_unref (FRAME_OUTPUT_DATA (f)->scrollbar_foreground_css_provider); #endif - xfree (f->output_data.x->saved_menu_event); - xfree (f->output_data.x); - f->output_data.x = NULL; - if (f == dpyinfo->x_focus_frame) dpyinfo->x_focus_frame = 0; if (f == dpyinfo->x_focus_event_frame) @@ -17766,6 +17764,10 @@ x_destroy_window (struct frame *f) if (dpyinfo->display != 0) x_free_frame_resources (f); + xfree (f->output_data.x->saved_menu_event); + xfree (f->output_data.x); + f->output_data.x = NULL; + dpyinfo->reference_count--; } commit 63a33c3057321a4d2fddbbfe34e11e87ef99b6ad Author: Po Lu Date: Tue Mar 22 08:22:41 2022 +0800 Fix unloading the hl-line library * lisp/hl-line.el (hl-line-unload-function): Restore function. diff --git a/lisp/hl-line.el b/lisp/hl-line.el index 47d5b0f247..70ba0fcfc2 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el @@ -127,6 +127,16 @@ Currently used in calendar/todo-mode." (let (inhibit-quit) (hl-line-mode 1)))) +(defun hl-line-unload-function () + "Unload the Hl-Line library." + (global-hl-line-mode -1) + (save-current-buffer + (dolist (buffer (buffer-list)) + (set-buffer buffer) + (when hl-line-mode (hl-line-mode -1)))) + ;; continue standard unloading + nil) + ;;;###autoload (define-globalized-minor-mode global-hl-line-mode hl-line-mode hl-line-turn-on commit f36d929ee768f03dcc63f59ff0572c2681c8f749 Author: Po Lu Date: Tue Mar 22 08:19:32 2022 +0800 Fix incompatible changes in hl-line * lisp/hl-line.el (hl-line-face): Rename back to hl-line. (hl-line-face): Restore defcustom. diff --git a/lisp/hl-line.el b/lisp/hl-line.el index daa24c4fbf..47d5b0f247 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el @@ -47,11 +47,22 @@ :version "21.1" :group 'convenience) -(defface hl-line-face '((t :inherit highlight :extend t)) +(defface hl-line '((t :inherit highlight :extend t)) "Default face for highlighting the current line in hl-line-mode." :version "22.1" :group 'hl-line) +(defcustom hl-line-face 'hl-line + "Face with which to highlight the current line in Hl-Line mode." + :type 'face + :group 'hl-line + :set (lambda (symbol value) + (set symbol value) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when hl-line--overlay + (overlay-put hl-line--overlay 'face hl-line-face)))))) + (defcustom hl-line-sticky-flag t "Non-nil to preserve highlighting overlay when focus leaves window." :type 'boolean @@ -105,7 +116,7 @@ Currently used in calendar/todo-mode." (let ((ol (make-overlay (point) (point)))) (prog1 ol (overlay-put ol 'priority hl-line-overlay-priority) - (overlay-put ol 'face 'hl-line-face))))) + (overlay-put ol 'face hl-line-face))))) (move-overlay hl-line--overlay (line-beginning-position) (line-beginning-position 2)) commit eba9c473a8cbb55d3966230117bac811e2c3ecde Author: Juri Linkov Date: Mon Mar 21 21:27:41 2022 +0200 Small fixes for new completions features * lisp/minibuffer.el (completions-header-format): Rename from completion-header-format. (completions-highlight, completions-highlight-face): Move up before first use. diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index b66454f930..24517262fa 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -624,15 +624,15 @@ completion alternatives in the completion list. @vindex completion-auto-help If @code{completion-auto-help} is set to @code{nil}, the completion commands never display the completion list buffer; you must type -@kbd{?} to display the list. If the value is @code{lazy}, Emacs only +@kbd{?} to display the list. If the value is @code{lazy}, Emacs only shows the completion list buffer on the second attempt to complete. In other words, if there is nothing to complete, the first @key{TAB} echoes @samp{Next char not unique}; the second @key{TAB} shows the completion list buffer. With the previous values and the default @code{t} the completions are hidden when some unique completion is -executed. If @code{completion-auto-help} is set to @code{always} the -completion commands are always shown after a completion attempt or -updated if they are already visible. If the value is @code{visible} +executed. If @code{completion-auto-help} is set to @code{always}, the +completion commands are always shown after a completion attempt, or +updated if they are already visible. If the value is @code{visible}, then completions are not hidden, but updated if they are already visible while the current behavior stays the same as default if they are not. @@ -659,29 +659,29 @@ changed by changing the @code{completions-format} user option. If and if @code{one-column}, just use a single column. @vindex completions-max-height - When @code{completions-max-height} is non-@code{nil} it limits the + When @code{completions-max-height} is non-@code{nil}, it limits the size of the completions window. It is specified in lines and include mode, header line and a bottom divider, if any. For a more complex -control of the Completion window display properties you can use +control of the Completion window display properties, you can use @code{display-buffer-alist} (@pxref{Buffer Display Action Alists,,Action Alists for Buffer Display, elisp, The Emacs Lisp Reference Manual}). -@vindex completion-header-format -The variable @code{completion-header-format} is a formatted string to +@vindex completions-header-format +The variable @code{completions-header-format} is a formatted string to control the informative line shown before the completions list of -candidates. It may contain a ``%s'' to show the total number of -completions. When it is @code{nil} the message is totally suppressed. +candidates. It may contain a @code{%s} to show the total number of +completions. When it is @code{nil}, the message is totally suppressed. Text properties may be added to change the appearance, some useful ones are @code{face} or @code{cursor-intangible} (@pxref{Special Properties,,Properties with Special Meanings, elisp, The Emacs Lisp Reference Manual}). @vindex completions-highlight-face -When @code{completions-highlight-face} is a face name; then the +When @code{completions-highlight-face} is a face name, then the current completion candidate will be highlighted with that face. The default value is @code{completions-highlight}. When the value is -@code{nil} no highlight is performed. This feature sets the text +@code{nil}, no highlighting is performed. This feature sets the text property @code{cursor-face}. @node Minibuffer History diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 30036675e1..edb75b453c 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -3553,15 +3553,14 @@ unhighlighted text. @item cursor-face @kindex cursor-face @r{(text property)} -This property is similar to @code{mouse-face} but the face is used if +This property is similar to @code{mouse-face}, but the face is used if the cursor (instead of mouse) is on or near the character. Near has -the same meaning than in @code{mouse-face} and the highlight only +the same meaning that in @code{mouse-face} and the highlighting only takes effect if the mode @code{cursor-face-highlight-mode} is enabled; -otherwise no highlight is performed. When the variable -@code{cursor-face-highlight-nonselected-window} is non-@code{nil} the -text is highlighted even if the window is not selected similar to -@code{highlight-nonselected-windows} for the region. The default -value is the same of @code{cursor-in-non-selected-windows}. +otherwise no highlighting is performed. When the variable +@code{cursor-face-highlight-nonselected-window} is non-@code{nil}, the +text is highlighted even if the window is not selected that is similar +to @code{highlight-nonselected-windows} for the region. @item fontified @kindex fontified @r{(text property)} diff --git a/etc/NEWS b/etc/NEWS index bb92e46310..026a9d1f7f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -556,9 +556,9 @@ alphabetical (the default), or a custom sort function. +++ *** New values for the 'completion-auto-help' option. -There are two new values to control the way *Completions* behave after +There are two new values to control the way "*Completions*" behave after a if completion is not unique. 'always' updates or shows -the *Completions* buffer after any attempt to complete. 'visual' is +the "*Completions*" buffer after any attempt to complete. 'visual' is like 'always', but only update the completions if they are already visible. The default value 't' always hides the completion buffer after some completion is made. @@ -568,17 +568,16 @@ some completion is made. This option limits the height of the "*Completions*" buffer. +++ -*** New option 'completion-header-format' +*** New option 'completions-header-format' This is a string to control the message to show before completions. -It may contain a %s to show the total number of completions. If nil no +It may contain a "%s" to show the total number of completions. If nil no completions are shown. +++ *** New option 'completions-highlight-face'. -When this variable is a face name it highlights the current candidate -in the *Completions* buffer with that face. When the value is nil no -highlight is performed at all. - +When this variable is a face name, it highlights the current candidate +in the "*Completions*" buffer with that face. When the value is nil, +no highlighting is performed at all. ** Isearch and Replace @@ -1262,11 +1261,11 @@ property. This allows setting a minimum display width for a region of text. +++ -** New 'cursor-face 'text' property. -This uses cursor-face instead of the default face when cursor is on or +** New 'cursor-face' text property. +This uses 'cursor-face' instead of the default face when cursor is on or near the character and 'cursor-face-highlight-mode' is enabled. The -variable 'highlight-nonselected-windows' is similar to -'highlight-nonselected-windows' but for this property. +variable 'cursor-face-highlight-nonselected-window' is similar to +'highlight-nonselected-windows', but for this property. +++ ** New event type 'touch-end'. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 46e7bf2fb0..00d4560865 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -899,8 +899,8 @@ is requested but cannot be done. If the value is `lazy', the *Completions* buffer is only displayed after the second failed attempt to complete. If the value is 'always', the completion commands are always shown -after a completion attempt or updated if they are already visible. -If the value is 'visible' then completions are not hidden, but updated +after a completion attempt, or updated if they are already visible. +If the value is 'visible', then completions are not hidden, but updated if they are already visible while the current behavior stays the same as default if they are not." :type '(choice (const :tag "Disabled" nil) @@ -1853,6 +1853,17 @@ Return nil if there is no valid completion, else t." This face is only used if the strings used for completions doesn't already specify a face.") +(defface completions-highlight + '((t :inherit highlight)) + "Default face for highlighting the current completion candidate." + :version "29.1") + +(defcustom completions-highlight-face 'completions-highlight + "A face name to highlight the current completion candidate. +If the value is nil, no highlighting is performed." + :type '(choice (const nil) face) + :version "29.1") + (defcustom completions-format 'horizontal "Define the appearance and sorting of completions. If the value is `vertical', display completions sorted vertically @@ -1872,15 +1883,15 @@ completions." :type 'boolean :version "28.1") -(defcustom completion-header-format +(defcustom completions-header-format (propertize "%s possible completions:\n" 'face 'shadow :help "Please select a completion") "Format of completions header. It may contain one %s to show the total count of completions. -When nil no header is shown." - :type '(choice (const :tag "No prefix" nil) - (string :tag "Prefix format string")) +When nil, no header is shown." + :type '(choice (const :tag "No header" nil) + (string :tag "Header format string")) :version "29.1") (defun completion--insert-strings (strings &optional group-fun) @@ -2145,25 +2156,13 @@ candidates." (with-current-buffer standard-output (goto-char (point-max)) - (when completion-header-format - (insert (format completion-header-format (length completions)))) + (when completions-header-format + (insert (format completions-header-format (length completions)))) (completion--insert-strings completions group-fun))) (run-hooks 'completion-setup-hook) nil) - -(defface completions-highlight - '((t :inherit highlight)) - "Default face for highlighting the current line in `completions-highlight-mode'." - :version "29.1") - -(defcustom completions-highlight-face 'completions-highlight - "A face name to highlight current completion candidate. -If the value is nil no highlight is performed." - :type '(choice (const nil) face) - :version "29.1") - (defvar completion-extra-properties nil "Property list of extra properties of the current completion job. These include: @@ -2232,12 +2231,12 @@ variables.") (completion--message message)))) (defcustom completions-max-height nil - "Maximum height for *Completions* buffer." + "Maximum height for *Completions* buffer window." :type '(choice (const nil) natnum) :version "29.1") (defun completions--fit-window-to-buffer (&optional win &rest _) - "Resize completions." + "Resize *Completions* buffer window." (if temp-buffer-resize-mode (let ((temp-buffer-max-height (or completions-max-height temp-buffer-max-height))) diff --git a/lisp/simple.el b/lisp/simple.el index 8eece3e81f..21ea08c0f2 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -6483,7 +6483,7 @@ separate contiguous regions for each line." (cdr (region-bounds))) (defun redisplay--unhighlight-overlay-function (rol) - "If ROL is an overlay, call ``delete-overlay''." + "If ROL is an overlay, call `delete-overlay'." (when (overlayp rol) (delete-overlay rol))) (defvar redisplay-unhighlight-region-function @@ -9399,7 +9399,7 @@ Called from `temp-buffer-show-hook'." (setq tab-width completion-tab-width)) ;; Maybe enable cursor completions-highlight. (when completions-highlight-face - ;; keep highlight even if not selected + ;; Keep highlighting even if not selected. (setq-local cursor-face-highlight-nonselected-window t) (cursor-face-highlight-mode 1)) ;; Maybe insert help string. commit a5e8da4fa28a233f3c1dee25a31072df7db6cf61 Author: Lars Ingebrigtsen Date: Mon Mar 21 19:28:14 2022 +0100 Add new user option `diff-entire-buffers' * lisp/vc/diff.el (diff-entire-buffers): New user option (bug#54060). (diff-file-local-copy): Use it. (diff-buffers): Mention it in the doc string. diff --git a/lisp/vc/diff.el b/lisp/vc/diff.el index 4abcf6c15a..926993eebb 100644 --- a/lisp/vc/diff.el +++ b/lisp/vc/diff.el @@ -52,6 +52,12 @@ set (`vc-git-diff-switches' for git, for instance), and "The command to use to run diff." :type 'string) +(defcustom diff-entire-buffers t + "If non-nil, diff the entire buffers, not just the visible part. +If nil, only use the narrowed-to parts of the buffers." + :type 'boolean + :version "29.1") + ;; prompt if prefix arg present (defun diff-switches () (if current-prefix-arg @@ -119,7 +125,9 @@ temporary file with the buffer's contents." (if (bufferp file-or-buf) (with-current-buffer file-or-buf (let ((tempfile (make-temp-file "buffer-content-"))) - (write-region nil nil tempfile nil 'nomessage) + (if diff-entire-buffers + (write-region nil nil tempfile nil 'nomessage) + (write-region (point-min) (point-max) tempfile nil 'nomessage)) tempfile)) (file-local-copy file-or-buf))) @@ -274,7 +282,9 @@ interactively for diff switches. Otherwise, the switches specified in the variable `diff-switches' are passed to the diff command. -OLD and NEW may each be a buffer or a buffer name." +OLD and NEW may each be a buffer or a buffer name. + +Also see the `diff-entire-buffers' variable." (interactive (let ((newb (read-buffer "Diff new buffer" (current-buffer) t)) (oldb (read-buffer "Diff original buffer" commit fd5fe11211a469c42fb7142f5a26f577e8ff0010 Author: Lars Ingebrigtsen Date: Mon Mar 21 19:15:55 2022 +0100 Don't break autoload generation of `left-margin' isn't zero * lisp/emacs-lisp/autoload.el (make-directory-autoloads): Fix autoload generation breakage is left-margin isn't zero (bug#54491). diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index d0bf342b84..1e4b2c14a0 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1108,6 +1108,9 @@ directory or directories specified." ;; Files with no autoload cookies or whose autoloads go to other ;; files because of file-local autoload-generated-file settings. (no-autoloads nil) + ;; Ensure that we don't do odd things when putting the doc + ;; strings into the autoloads file. + (left-margin 0) (autoload-modified-buffers nil) (output-time (and (file-exists-p output-file) commit d74cd0cf1f96e256c479599939efacd11600c0c8 Author: Lars Ingebrigtsen Date: Mon Mar 21 18:05:18 2022 +0100 Make `n' in image-mode work more reliably with external formats * lisp/image-mode.el (image-mode): Init the external machinery so that commands like `n' work for those files. * lisp/image/image-converter.el (image-converter-initialize): Factored out into own function. (image-convert-p): Use it. (image-convert): Ditto. diff --git a/lisp/image-mode.el b/lisp/image-mode.el index b2af3f06a2..38a5e7cdfd 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -625,6 +625,8 @@ image as text, when opening such images in `image-mode'." (put 'image-mode 'mode-class 'special) +(declare-function image-converter-initialize "image-converter.el") + ;;;###autoload (defun image-mode () "Major mode for image files. @@ -650,7 +652,12 @@ Key bindings: "Empty file" "(New file)") "Empty buffer")) - (image-mode--display))) + (image-mode--display) + ;; Ensure that we recognize externally parsed image formats in + ;; commands like `n'. + (when image-use-external-converter + (require 'image-converter) + (image-converter-initialize)))) (defun image-mode--display () (if (not (image-get-display-property)) diff --git a/lisp/image/image-converter.el b/lisp/image/image-converter.el index b8c9a62002..a339e95ab4 100644 --- a/lisp/image/image-converter.el +++ b/lisp/image/image-converter.el @@ -68,15 +68,19 @@ not, conversion will fail." (imagemagick :command "convert" :probe ("-list" "format"))) "List of supported image converters to try.") +(defun image-converter-initialize () + "Determine the external image converter to be used. +This also determines which external formats we can parse." + (unless image-converter + (image-converter--find-converter))) + (defun image-convert-p (source &optional data-p) "Return `image-convert' if SOURCE is an image that can be converted. SOURCE can either be a file name or a string containing image data. In the latter case, DATA-P should be non-nil. If DATA-P is a string, it should be a MIME format string like \"image/gif\"." - ;; Find an installed image converter. - (unless image-converter - (image-converter--find-converter)) + (image-converter-initialize) ;; When image-converter was customized (when (and image-converter (not image-converter-regexp)) (when-let ((formats (image-converter--probe image-converter))) @@ -111,9 +115,7 @@ IMAGE can also be an image object as returned by `create-image'. This function converts the image the preferred format, and the converted image data is returned as a string." - ;; Find an installed image converter. - (unless image-converter - (image-converter--find-converter)) + (image-converter-initialize) (unless image-converter (error "No external image converters available")) (when (and image-format commit 61d34c6a500d487c8952d4ad7751e1deb80f5bfc Author: Lars Ingebrigtsen Date: Mon Mar 21 17:51:21 2022 +0100 Allow specifying the intermediate format * lisp/image/image-converter.el (image-convert-to-format): New user format (bug#54494). (image-convert, image-converter--convert-magick) (image-converter--convert): Use it. diff --git a/lisp/image.el b/lisp/image.el index fd0b5b6783..bad8ba7cd7 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -461,6 +461,7 @@ must be available." (and auto (or (eq auto t) (image-type-available-p type))))) +(defvar image-convert-to-format) ;;;###autoload (defun create-image (file-or-data &optional type data-p &rest props) @@ -498,7 +499,7 @@ Image file names that are not absolute are searched for in the (when (eq type 'image-convert) (require 'image-converter) (setq file-or-data (image-convert file-or-data data-format) - type 'png + type (intern image-convert-to-format) data-p t))) (when (image-type-available-p type) (let ((image diff --git a/lisp/image/image-converter.el b/lisp/image/image-converter.el index 460ff16adb..b8c9a62002 100644 --- a/lisp/image/image-converter.el +++ b/lisp/image/image-converter.el @@ -46,6 +46,16 @@ formats that are to be supported: Only the suffixes that map to :type 'symbol :version "27.1") +(defcustom image-convert-to-format "png" + "The image format to convert to. +This should be a string like \"png\" or \"ppm\" or some +other (preferrably lossless) format that Emacs understands +natively. The converter chosen has to support the format, and if +not, conversion will fail." + :group 'image + :version "29.1" + :type 'string) + (defvar image-converter-regexp nil "A regexp that matches the file name suffixes that can be converted.") @@ -85,7 +95,10 @@ is a string, it should be a MIME format string like 'image-convert)) (defun image-convert (image &optional image-format) - "Convert IMAGE file to the PNG format. + "Convert IMAGE file to an image format Emacs understands. +This will usually be \"png\", but this is controlled by the +`image-convert-to-format' user option. + IMAGE can either be a file name or image data. To pass in image data, IMAGE should a string containing the image @@ -96,8 +109,8 @@ like \"image/webp\". For instance: IMAGE can also be an image object as returned by `create-image'. -This function converts the image to PNG, and the converted image -data is returned as a string." +This function converts the image the preferred format, and the +converted image data is returned as a string." ;; Find an installed image converter. (unless image-converter (image-converter--find-converter)) @@ -120,7 +133,9 @@ data is returned as a string." (if (listp image) ;; Return an image object that's the same as we were passed, ;; but ignore the :type value. - (apply #'create-image (buffer-string) 'png t + (apply #'create-image (buffer-string) + (intern image-convert-to-format) + t (cl-loop for (key val) on (cdr image) by #'cddr unless (eq key :type) append (list key val))) @@ -239,12 +254,15 @@ Only suffixes that map to `image-mode' are returned." (list (format "%s:-" (image-converter--mime-type image-format)) - "png:-")))) + (concat image-convert-to-format + ":-"))))) ;; SOURCE is a file name. (apply #'call-process (car command) nil t nil (append (cdr command) - (list (expand-file-name source) "png:-"))))) + (list (expand-file-name source) + (concat image-convert-to-format + ":-")))))) ;; If the command failed, hopefully the buffer contains the ;; error message. (buffer-string)))) @@ -262,14 +280,15 @@ Only suffixes that map to `image-mode' are returned." (append (cdr command) (list "-i" "-" - "-c:v" "png" + "-c:v" image-convert-to-format "-f" "image2pipe" "-")))) (apply #'call-process (car command) nil '(t nil) nil (append (cdr command) (list "-i" (expand-file-name source) - "-c:v" "png" "-f" "image2pipe" + "-c:v" image-convert-to-format + "-f" "image2pipe" "-"))))) "ffmpeg error when converting"))) commit ede8ad507d06a336ce8202927f214aecbaf15d6b Author: Lars Ingebrigtsen Date: Mon Mar 21 17:19:03 2022 +0100 Allow using image-convert to view .bmp images * lisp/image.el (image-type-from-file-name): Allow Emacs to fall back on image-convert to display .bmp images (bug#54492). diff --git a/lisp/image.el b/lisp/image.el index ec4ee06eb1..fd0b5b6783 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -378,16 +378,16 @@ be determined." ;;;###autoload (defun image-type-from-file-name (file) "Determine the type of image file FILE from its name. -Value is a symbol specifying the image type, or nil if type cannot -be determined." - (let (type first (case-fold-search t)) +Value is a symbol specifying the image type, or nil if type +cannot be determined (or if Emacs doesn't have built-in support +for the image type)." + (let ((case-fold-search t) + type) (catch 'found - (dolist (elem image-type-file-name-regexps first) - (when (string-match-p (car elem) file) - (if (image-type-available-p (setq type (cdr elem))) - (throw 'found type) - ;; If nothing seems to be supported, return first type that matched. - (or first (setq first type)))))))) + (dolist (elem image-type-file-name-regexps) + (when (and (string-match-p (car elem) file) + (image-type-available-p (setq type (cdr elem)))) + (throw 'found type)))))) (declare-function image-convert-p "image-converter.el" (source &optional image-format)) commit 20c4eca3437a58265a9c80f25ee1f0a92e4614d0 Author: Lars Ingebrigtsen Date: Mon Mar 21 16:14:40 2022 +0100 Regenerated ldefs-boot.el diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 9f5169605b..5dd4291461 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -1579,78 +1579,6 @@ key2: value2 (register-definition-prefixes "auth-source-pass" '("auth-source-pass-")) -;;;*** - -;;;### (autoloads nil "autoarg" "autoarg.el" (0 0 0 0)) -;;; Generated autoloads from autoarg.el - -(defvar autoarg-mode nil "\ -Non-nil if Autoarg mode is enabled. -See the `autoarg-mode' command -for a description of this minor mode.") - -(custom-autoload 'autoarg-mode "autoarg" nil) - -(autoload 'autoarg-mode "autoarg" "\ -Toggle Autoarg mode, a global minor mode. - -\\ -In Autoarg mode, digits are bound to `digit-argument', i.e. they -supply prefix arguments as C-DIGIT and M-DIGIT normally do. -Furthermore, C-DIGIT inserts DIGIT. -\\[autoarg-terminate] terminates the prefix sequence and inserts -the digits of the autoarg sequence into the buffer. -Without a numeric prefix arg, the normal binding of \\[autoarg-terminate] -is invoked, i.e. what it would be with Autoarg mode off. - -For example: -`6 9 \\[autoarg-terminate]' inserts `69' into the buffer, as does `C-6 C-9'. -`6 9 a' inserts 69 `a's into the buffer. -`6 9 \\[autoarg-terminate] \\[autoarg-terminate]' inserts `69' into the buffer and -then invokes the normal binding of \\[autoarg-terminate]. -`\\[universal-argument] \\[autoarg-terminate]' invokes the normal binding of \\[autoarg-terminate] four times. - -\\{autoarg-mode-map} - -\(fn &optional ARG)" t nil) - -(defvar autoarg-kp-mode nil "\ -Non-nil if Autoarg-Kp mode is enabled. -See the `autoarg-kp-mode' command -for a description of this minor mode. -Setting this variable directly does not take effect; -either customize it (see the info node `Easy Customization') -or call the function `autoarg-kp-mode'.") - -(custom-autoload 'autoarg-kp-mode "autoarg" nil) - -(autoload 'autoarg-kp-mode "autoarg" "\ -Toggle Autoarg-KP mode, a global minor mode. - -This is a minor mode. If called interactively, toggle the `Autoarg-Kp -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='autoarg-kp-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - -\\ -This is similar to `autoarg-mode' but rebinds the keypad keys -`kp-1' etc. to supply digit arguments. - -\\{autoarg-kp-mode-map} - -\(fn &optional ARG)" t nil) - -(register-definition-prefixes "autoarg" '("autoarg-")) - ;;;*** ;;;### (autoloads nil "autoconf" "progmodes/autoconf.el" (0 0 0 0)) @@ -6517,6 +6445,19 @@ If given a prefix (or a COMMENT argument), also prompt for a comment. \(fn VARIABLE VALUE &optional COMMENT)" t nil) +(autoload 'setopt "cus-edit" "\ +Set VARIABLE/VALUE pairs, and return the final VALUE. +This is like `setq', but is meant for user options instead of +plain variables. This means that `setopt' will execute any +`custom-set' form associated with VARIABLE. + +\(fn [VARIABLE VALUE]...)" nil t) + +(autoload 'setopt--set "cus-edit" "\ + + +\(fn VARIABLE VALUE)" nil nil) + (autoload 'customize-save-variable "cus-edit" "\ Set the default for VARIABLE to VALUE, and save it for future sessions. Return VALUE. @@ -6690,7 +6631,7 @@ Customize all loaded groups matching REGEXP. (autoload 'custom-prompt-customize-unsaved-options "cus-edit" "\ Prompt user to customize any unsaved customization options. -Return non-nil if user chooses to customize, for use in +Return nil if user chooses to customize, for use in `kill-emacs-query-functions'." nil nil) (autoload 'custom-buffer-create "cus-edit" "\ @@ -8045,7 +7986,7 @@ some of the `ls' switches are not supported; see the doc string of (custom-autoload 'dired-listing-switches "dired" t) -(defvar dired-directory nil "\ +(defvar-local dired-directory nil "\ The directory name or wildcard spec that this Dired directory lists. Local to each Dired buffer. May be a list, in which case the car is the directory name and the cdr is the list of files to mention. @@ -10397,6 +10338,11 @@ For example, to instrument all ELP functions, do the following: \\[elp-instrument-package] RET elp- RET +Note that only functions that are currently loaded will be +instrumented. If you run this function, and then later load +further functions that start with PREFIX, they will not be +instrumented automatically. + \(fn PREFIX)" t nil) (autoload 'elp-results "elp" "\ @@ -11854,6 +11800,15 @@ If ERROR is non-nil, report an error if there is none. \(fn NAME &optional ERROR)" t nil) +(autoload 'eudc-expand-try-all "eudc" "\ +Wrap `eudc-expand-inline' with a prefix argument. +If TRY-ALL-SERVERS -- the prefix argument when called +interactively -- is non-nil, collect results from all servers. +If TRY-ALL-SERVERS is nil, do not try subsequent servers after +one server returns any match. + +\(fn &optional TRY-ALL-SERVERS)" t nil) + (autoload 'eudc-expand-inline "eudc" "\ Query the directory server, and expand the query string before point. The query string consists of the buffer substring from the point back to @@ -11862,12 +11817,14 @@ The variable `eudc-inline-query-format' controls how to associate the individual inline query words with directory attribute names. After querying the server for the given string, the expansion specified by `eudc-inline-expansion-format' is inserted in the buffer at point. -If REPLACE is non-nil, then this expansion replaces the name in the buffer. -`eudc-expansion-overwrites-query' being non-nil inverts the meaning of REPLACE. +If SAVE-QUERY-AS-KILL is non-nil, then save the pre-expansion +text to the kill ring. `eudc-expansion-save-query-as-kill' being +non-nil inverts the meaning of SAVE-QUERY-AS-KILL. Multiple servers can be tried with the same query until one finds a match, -see `eudc-inline-expansion-servers'. +see `eudc-inline-expansion-servers'. If TRY-ALL-SERVERS is +non-nil, collect results from all servers. -\(fn &optional REPLACE)" t nil) +\(fn &optional SAVE-QUERY-AS-KILL TRY-ALL-SERVERS)" t nil) (autoload 'eudc-query-with-words "eudc" "\ Query the directory server, and return the matching responses. @@ -11877,9 +11834,10 @@ After querying the server for the given string, the expansion specified by `eudc-inline-expansion-format' is applied to the matches before returning them.inserted in the buffer at point. Multiple servers can be tried with the same query until one finds a match, -see `eudc-inline-expansion-servers'. +see `eudc-inline-expansion-servers'. When TRY-ALL-SERVERS is non-nil, +keep collecting results from subsequent servers after the first match. -\(fn QUERY-WORDS)" nil nil) +\(fn QUERY-WORDS &optional TRY-ALL-SERVERS)" nil nil) (autoload 'eudc-query-form "eudc" "\ Display a form to query the directory server. @@ -13058,6 +13016,9 @@ Interactively, prompt for LIBRARY using the one at or near point. This function searches `find-library-source-path' if non-nil, and `load-path' otherwise. +See the `find-library-include-other-files' user option for +customizing the candidate completions. + \(fn LIBRARY)" t nil) (autoload 'read-library-name "find-func" "\ @@ -13218,7 +13179,7 @@ Find directly the variable at point in the other window." t nil) (autoload 'find-function-setup-keys "find-func" "\ Define some key bindings for the `find-function' family of functions." nil nil) -(register-definition-prefixes "find-func" '("find-")) +(register-definition-prefixes "find-func" '("find-" "read-library-name--find-files")) ;;;*** @@ -13309,7 +13270,7 @@ lines. ;;;### (autoloads nil "flymake" "progmodes/flymake.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/flymake.el -(push (purecopy '(flymake 1 2 1)) package--builtin-versions) +(push (purecopy '(flymake 1 2 2)) package--builtin-versions) (autoload 'flymake-log "flymake" "\ Log, at level LEVEL, the message MSG formatted with ARGS. @@ -13471,6 +13432,9 @@ Flyspell mode is a buffer-local minor mode. When enabled, it spawns a single Ispell process and checks each word. The default flyspell behavior is to highlight incorrect words. +This mode is geared toward text modes. In buffers that contain +code, `flyspell-prog-mode' is usually a better choice. + Bindings: \\[ispell-word]: correct words (using Ispell). \\[flyspell-auto-correct-word]: automatically correct word. @@ -16237,10 +16201,15 @@ If TYPE is not a symbol, search for a function definition. The return value is the absolute name of a readable file where OBJECT is defined. If several such files exist, preference is given to a file found via `load-path'. The return value can also be `C-source', which -means that OBJECT is a function or variable defined in C. If no -suitable file is found, return nil. +means that OBJECT is a function or variable defined in C, but +it's currently unknown where. If no suitable file is found, +return nil. -\(fn OBJECT TYPE)" nil nil) +If ALSO-C-SOURCE is non-nil, instead of returning `C-source', +this function will attempt to locate the definition of OBJECT in +the C sources, too. + +\(fn OBJECT TYPE &optional ALSO-C-SOURCE)" nil nil) (autoload 'describe-function-1 "help-fns" "\ @@ -17148,7 +17117,7 @@ argument VERBOSE non-nil makes the function verbose. ;;; Generated autoloads from hl-line.el (autoload 'hl-line-mode "hl-line" "\ -Toggle highlighting of the current line (Hl-Line mode). +Toggle highlighting of the current line. This is a minor mode. If called interactively, toggle the `Hl-Line mode' mode. If the prefix argument is positive, enable the mode, and @@ -17164,18 +17133,10 @@ evaluate `hl-line-mode'. The mode's hook is called both when the mode is enabled and when it is disabled. -Hl-Line mode is a buffer-local minor mode. If -`hl-line-sticky-flag' is non-nil, Hl-Line mode highlights the -line about the buffer's point in all windows. Caveat: the -buffer's point might be different from the point of a -non-selected window. Hl-Line mode uses the function -`hl-line-highlight' on `post-command-hook' in this case. - -When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the -line about point in the selected window only. - \(fn &optional ARG)" t nil) +(put 'global-hl-line-mode 'globalized-minor-mode t) + (defvar global-hl-line-mode nil "\ Non-nil if Global Hl-Line mode is enabled. See the `global-hl-line-mode' command @@ -17187,32 +17148,22 @@ or call the function `global-hl-line-mode'.") (custom-autoload 'global-hl-line-mode "hl-line" nil) (autoload 'global-hl-line-mode "hl-line" "\ -Toggle line highlighting in all buffers (Global Hl-Line mode). - -This is a minor mode. If called interactively, toggle the `Global -Hl-Line mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='global-hl-line-mode)'. +Toggle Hl-Line mode in all buffers. +With prefix ARG, enable Global Hl-Line mode if ARG is positive; +otherwise, disable it. -The mode's hook is called both when the mode is enabled and when it is -disabled. +If called from Lisp, toggle the mode if ARG is `toggle'. +Enable the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. -If `global-hl-line-sticky-flag' is non-nil, Global Hl-Line mode -highlights the line about the current buffer's point in all live -windows. +Hl-Line mode is enabled in all buffers where `hl-line-turn-on' would +do it. -Global-Hl-Line mode uses the function `global-hl-line-highlight' -on `post-command-hook'. +See `hl-line-mode' for more information on Hl-Line mode. \(fn &optional ARG)" t nil) -(register-definition-prefixes "hl-line" '("global-hl-line-" "hl-line-")) +(register-definition-prefixes "hl-line" '("hl-line-")) ;;;*** @@ -18249,6 +18200,14 @@ See `inferior-emacs-lisp-mode' for details. (register-definition-prefixes "ietf-drums" '("ietf-drums-")) +;;;*** + +;;;### (autoloads nil "ietf-drums-date" "mail/ietf-drums-date.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from mail/ietf-drums-date.el + +(register-definition-prefixes "ietf-drums-date" '("date-parse-error" "ietf-drums-")) + ;;;*** ;;;### (autoloads nil "iimage" "iimage.el" (0 0 0 0)) @@ -18984,7 +18943,7 @@ quoted using shell quote syntax. ;;;### (autoloads nil "info" "info.el" (0 0 0 0)) ;;; Generated autoloads from info.el -(defcustom Info-default-directory-list (let* ((config-dir (file-name-as-directory (or (and (featurep 'ns) (let ((dir (expand-file-name "../info" data-directory))) (if (file-directory-p dir) dir))) configure-info-directory))) (prefixes (prune-directory-list '("/usr/local/" "/usr/" "/opt/"))) (suffixes '("share/" "")) (standard-info-dirs (apply #'nconc (mapcar (lambda (pfx) (let ((dirs (mapcar (lambda (sfx) (concat pfx sfx "info/")) suffixes))) (prune-directory-list dirs))) prefixes))) (dirs (if (member config-dir standard-info-dirs) (nconc standard-info-dirs (list config-dir)) (cons config-dir standard-info-dirs)))) (if (not (eq system-type 'windows-nt)) dirs (let* ((instdir (file-name-directory invocation-directory)) (dir1 (expand-file-name "../info/" instdir)) (dir2 (expand-file-name "../../../info/" instdir))) (cond ((file-exists-p dir1) (append dirs (list dir1))) ((file-exists-p dir2) (append dirs (list dir2))) (t dirs))))) "\ +(defvar Info-default-directory-list nil "\ Default list of directories to search for Info documentation files. They are searched in the order they are given in the list. Therefore, the directory of Info files that come with Emacs @@ -18995,13 +18954,10 @@ first in this list. Once Info is started, the list of directories to search comes from the variable `Info-directory-list'. -This variable `Info-default-directory-list' is used as the default -for initializing `Info-directory-list' when Info is started, unless -the environment variable INFOPATH is set. -Although this is a customizable variable, that is mainly for technical -reasons. Normally, you should either set INFOPATH or customize -`Info-additional-directory-list', rather than changing this variable." :initialize #'custom-initialize-delay :type '(repeat directory)) +This variable is used as the default for initializing +`Info-directory-list' when Info is started, unless the +environment variable INFOPATH is set.") (custom-autoload 'Info-default-directory-list "info" t) @@ -25153,6 +25109,15 @@ downloads in the background. \(fn &optional ASYNC)" t nil) +(autoload 'package-installed-p "package" "\ +Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed. +If PACKAGE is a symbol, it is the package name and MIN-VERSION +should be a version list. + +If PACKAGE is a `package-desc' object, MIN-VERSION is ignored. + +\(fn PACKAGE &optional MIN-VERSION)" nil nil) + (autoload 'package-install "package" "\ Install the package PKG. PKG can be a `package-desc' or a symbol naming one of the @@ -27425,8 +27390,8 @@ If it is nil, the current key is shown. DOCSTRING is the documentation string of this package. The command `describe-input-method' shows this string while replacing the form -\\=\\ in the string by the value of VAR. That value should be a -string. For instance, the form \\=\\ is +\\=\\=\\=\\ in the string by the value of VAR. That value should be a +string. For instance, the form \\=\\=\\=\\ is replaced by a description about how to select a translation from a list of candidates. @@ -29314,7 +29279,7 @@ to use for finding the schema. ;;;### (autoloads nil "rng-xsd" "nxml/rng-xsd.el" (0 0 0 0)) ;;; Generated autoloads from nxml/rng-xsd.el -(put 'http://www\.w3\.org/2001/XMLSchema-datatypes 'rng-dt-compile #'rng-xsd-compile) +(put 'http://www.w3.org/2001/XMLSchema-datatypes 'rng-dt-compile #'rng-xsd-compile) (autoload 'rng-xsd-compile "rng-xsd" "\ Provide W3C XML Schema as a RELAX NG datatypes library. @@ -30009,7 +29974,7 @@ will scroll the buffer by the respective amount of lines instead and point will be kept vertically fixed relative to window boundaries during scrolling. -Note that the default key binding to Scroll_Lock will not work on +Note that the default key binding to `scroll' will not work on MS-Windows systems if `w32-scroll-lock-modifier' is non-nil. \(fn &optional ARG)" t nil) @@ -31675,7 +31640,7 @@ configure the behaviour. ;;;### (autoloads nil "soap-client" "net/soap-client.el" (0 0 0 0)) ;;; Generated autoloads from net/soap-client.el -(push (purecopy '(soap-client 3 2 0)) package--builtin-versions) +(push (purecopy '(soap-client 3 2 1)) package--builtin-versions) (register-definition-prefixes "soap-client" '("soap-")) @@ -33027,8 +32992,8 @@ The mode's hook is called both when the mode is enabled and when it is disabled. Superword mode is a buffer-local minor mode. Enabling it changes -the definition of words such that symbols characters are treated -as parts of words: e.g., in `superword-mode', +the definition of words such that characters which have symbol +syntax are treated as parts of words: e.g., in `superword-mode', \"this_is_a_symbol\" counts as one word. \\{superword-mode-map} @@ -36310,7 +36275,7 @@ Handle file: and ftp: URLs. \(fn URL CALLBACK CBARGS)" nil nil) -(register-definition-prefixes "url-file" '("url-file-")) +(register-definition-prefixes "url-file" '("url-")) ;;;*** @@ -38767,17 +38732,10 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t nil) ;;;*** -;;;### (autoloads nil "vt-control" "vt-control.el" (0 0 0 0)) -;;; Generated autoloads from vt-control.el - -(register-definition-prefixes "vt-control" '("vt-")) - -;;;*** - -;;;### (autoloads nil "vt100-led" "vt100-led.el" (0 0 0 0)) -;;; Generated autoloads from vt100-led.el +;;;### (autoloads nil "vtable" "emacs-lisp/vtable.el" (0 0 0 0)) +;;; Generated autoloads from emacs-lisp/vtable.el -(register-definition-prefixes "vt100-led" '("led-")) +(register-definition-prefixes "vtable" '("vtable")) ;;;*** @@ -39863,7 +39821,7 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT. ;;;### (autoloads nil "xref" "progmodes/xref.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/xref.el -(push (purecopy '(xref 1 3 2)) package--builtin-versions) +(push (purecopy '(xref 1 4 1)) package--builtin-versions) (autoload 'xref-find-backend "xref" nil nil nil) @@ -39882,6 +39840,13 @@ Whether the xref back-history is empty." nil nil) (autoload 'xref-forward-history-empty-p "xref" "\ Whether the xref forward-history is empty." nil nil) +(autoload 'xref-show-xrefs "xref" "\ +Display some Xref values produced by FETCHER using DISPLAY-ACTION. +The meanings of both arguments are the same as documented in +`xref-show-xrefs-function'. + +\(fn FETCHER DISPLAY-ACTION)" nil nil) + (autoload 'xref-find-definitions "xref" "\ Find the definition of the identifier at point. With prefix argument or when there's no identifier at point, @@ -40115,24 +40080,23 @@ Zone out, completely." t nil) ;;;### (autoloads nil nil ("abbrev.el" "bindings.el" "buff-menu.el" ;;;;;; "button.el" "calc/calc-aent.el" "calc/calc-embed.el" "calc/calc-misc.el" -;;;;;; "calc/calc-yank.el" "case-table.el" "cedet/ede/base.el" "cedet/ede/config.el" -;;;;;; "cedet/ede/cpp-root.el" "cedet/ede/custom.el" "cedet/ede/dired.el" -;;;;;; "cedet/ede/emacs.el" "cedet/ede/files.el" "cedet/ede/generic.el" -;;;;;; "cedet/ede/linux.el" "cedet/ede/locate.el" "cedet/ede/make.el" -;;;;;; "cedet/ede/shell.el" "cedet/ede/speedbar.el" "cedet/ede/system.el" -;;;;;; "cedet/ede/util.el" "cedet/semantic/analyze.el" "cedet/semantic/analyze/complete.el" -;;;;;; "cedet/semantic/analyze/refs.el" "cedet/semantic/bovine.el" -;;;;;; "cedet/semantic/bovine/c-by.el" "cedet/semantic/bovine/c.el" -;;;;;; "cedet/semantic/bovine/el.el" "cedet/semantic/bovine/gcc.el" -;;;;;; "cedet/semantic/bovine/make-by.el" "cedet/semantic/bovine/make.el" -;;;;;; "cedet/semantic/bovine/scm-by.el" "cedet/semantic/bovine/scm.el" -;;;;;; "cedet/semantic/complete.el" "cedet/semantic/ctxt.el" "cedet/semantic/db-file.el" -;;;;;; "cedet/semantic/db-find.el" "cedet/semantic/db-global.el" -;;;;;; "cedet/semantic/db-mode.el" "cedet/semantic/db-typecache.el" -;;;;;; "cedet/semantic/db.el" "cedet/semantic/debug.el" "cedet/semantic/decorate/include.el" -;;;;;; "cedet/semantic/decorate/mode.el" "cedet/semantic/dep.el" -;;;;;; "cedet/semantic/doc.el" "cedet/semantic/edit.el" "cedet/semantic/find.el" -;;;;;; "cedet/semantic/format.el" "cedet/semantic/grammar-wy.el" +;;;;;; "calc/calc-yank.el" "case-table.el" "cedet/ede/cpp-root.el" +;;;;;; "cedet/ede/custom.el" "cedet/ede/dired.el" "cedet/ede/emacs.el" +;;;;;; "cedet/ede/files.el" "cedet/ede/generic.el" "cedet/ede/linux.el" +;;;;;; "cedet/ede/locate.el" "cedet/ede/make.el" "cedet/ede/speedbar.el" +;;;;;; "cedet/ede/system.el" "cedet/ede/util.el" "cedet/semantic/analyze.el" +;;;;;; "cedet/semantic/analyze/complete.el" "cedet/semantic/analyze/refs.el" +;;;;;; "cedet/semantic/bovine.el" "cedet/semantic/bovine/c-by.el" +;;;;;; "cedet/semantic/bovine/c.el" "cedet/semantic/bovine/el.el" +;;;;;; "cedet/semantic/bovine/gcc.el" "cedet/semantic/bovine/make-by.el" +;;;;;; "cedet/semantic/bovine/make.el" "cedet/semantic/bovine/scm-by.el" +;;;;;; "cedet/semantic/bovine/scm.el" "cedet/semantic/complete.el" +;;;;;; "cedet/semantic/ctxt.el" "cedet/semantic/db-file.el" "cedet/semantic/db-find.el" +;;;;;; "cedet/semantic/db-global.el" "cedet/semantic/db-mode.el" +;;;;;; "cedet/semantic/db-typecache.el" "cedet/semantic/db.el" "cedet/semantic/debug.el" +;;;;;; "cedet/semantic/decorate/include.el" "cedet/semantic/decorate/mode.el" +;;;;;; "cedet/semantic/dep.el" "cedet/semantic/doc.el" "cedet/semantic/edit.el" +;;;;;; "cedet/semantic/find.el" "cedet/semantic/format.el" "cedet/semantic/grammar-wy.el" ;;;;;; "cedet/semantic/grm-wy-boot.el" "cedet/semantic/html.el" ;;;;;; "cedet/semantic/ia-sb.el" "cedet/semantic/ia.el" "cedet/semantic/idle.el" ;;;;;; "cedet/semantic/imenu.el" "cedet/semantic/lex-spp.el" "cedet/semantic/lex.el" @@ -40151,81 +40115,93 @@ Zone out, completely." t nil) ;;;;;; "cedet/srecode/insert.el" "cedet/srecode/java.el" "cedet/srecode/map.el" ;;;;;; "cedet/srecode/mode.el" "cedet/srecode/srt-wy.el" "cedet/srecode/srt.el" ;;;;;; "cedet/srecode/template.el" "cedet/srecode/texi.el" "composite.el" -;;;;;; "cus-face.el" "cus-start.el" "custom.el" "dired-aux.el" "dired-x.el" -;;;;;; "electric.el" "emacs-lisp/backquote.el" "emacs-lisp/byte-run.el" +;;;;;; "cus-face.el" "cus-load.el" "cus-start.el" "custom.el" "dired-aux.el" +;;;;;; "dired-x.el" "electric.el" "emacs-lisp/backquote.el" "emacs-lisp/byte-run.el" ;;;;;; "emacs-lisp/cl-extra.el" "emacs-lisp/cl-macs.el" "emacs-lisp/cl-preloaded.el" -;;;;;; "emacs-lisp/cl-seq.el" "emacs-lisp/easymenu.el" "emacs-lisp/eieio-custom.el" -;;;;;; "emacs-lisp/eieio-opt.el" "emacs-lisp/float-sup.el" "emacs-lisp/lisp-mode.el" -;;;;;; "emacs-lisp/lisp.el" "emacs-lisp/macroexp.el" "emacs-lisp/map-ynp.el" -;;;;;; "emacs-lisp/nadvice.el" "emacs-lisp/shorthands.el" "emacs-lisp/syntax.el" -;;;;;; "emacs-lisp/timer.el" "env.el" "epa-hook.el" "erc/erc-autoaway.el" -;;;;;; "erc/erc-button.el" "erc/erc-capab.el" "erc/erc-compat.el" -;;;;;; "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" "erc/erc-ezbounce.el" -;;;;;; "erc/erc-fill.el" "erc/erc-identd.el" "erc/erc-imenu.el" -;;;;;; "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el" "erc/erc-match.el" -;;;;;; "erc/erc-menu.el" "erc/erc-netsplit.el" "erc/erc-notify.el" -;;;;;; "erc/erc-page.el" "erc/erc-pcomplete.el" "erc/erc-replace.el" -;;;;;; "erc/erc-ring.el" "erc/erc-services.el" "erc/erc-sound.el" -;;;;;; "erc/erc-speedbar.el" "erc/erc-spelling.el" "erc/erc-stamp.el" -;;;;;; "erc/erc-status-sidebar.el" "erc/erc-track.el" "erc/erc-truncate.el" -;;;;;; "erc/erc-xdcc.el" "eshell/em-alias.el" "eshell/em-banner.el" -;;;;;; "eshell/em-basic.el" "eshell/em-cmpl.el" "eshell/em-dirs.el" -;;;;;; "eshell/em-glob.el" "eshell/em-hist.el" "eshell/em-ls.el" -;;;;;; "eshell/em-pred.el" "eshell/em-prompt.el" "eshell/em-rebind.el" -;;;;;; "eshell/em-script.el" "eshell/em-smart.el" "eshell/em-term.el" -;;;;;; "eshell/em-tramp.el" "eshell/em-unix.el" "eshell/em-xtra.el" -;;;;;; "faces.el" "files.el" "font-core.el" "font-lock.el" "format.el" +;;;;;; "emacs-lisp/cl-seq.el" "emacs-lisp/debug-early.el" "emacs-lisp/easymenu.el" +;;;;;; "emacs-lisp/eieio-custom.el" "emacs-lisp/eieio-opt.el" "emacs-lisp/float-sup.el" +;;;;;; "emacs-lisp/lisp-mode.el" "emacs-lisp/lisp.el" "emacs-lisp/macroexp.el" +;;;;;; "emacs-lisp/map-ynp.el" "emacs-lisp/nadvice.el" "emacs-lisp/shorthands.el" +;;;;;; "emacs-lisp/syntax.el" "emacs-lisp/timer.el" "env.el" "epa-hook.el" +;;;;;; "erc/erc-autoaway.el" "erc/erc-button.el" "erc/erc-capab.el" +;;;;;; "erc/erc-compat.el" "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" +;;;;;; "erc/erc-ezbounce.el" "erc/erc-fill.el" "erc/erc-identd.el" +;;;;;; "erc/erc-imenu.el" "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el" +;;;;;; "erc/erc-match.el" "erc/erc-menu.el" "erc/erc-netsplit.el" +;;;;;; "erc/erc-notify.el" "erc/erc-page.el" "erc/erc-pcomplete.el" +;;;;;; "erc/erc-replace.el" "erc/erc-ring.el" "erc/erc-services.el" +;;;;;; "erc/erc-sound.el" "erc/erc-speedbar.el" "erc/erc-spelling.el" +;;;;;; "erc/erc-stamp.el" "erc/erc-status-sidebar.el" "erc/erc-track.el" +;;;;;; "erc/erc-truncate.el" "erc/erc-xdcc.el" "eshell/em-alias.el" +;;;;;; "eshell/em-banner.el" "eshell/em-basic.el" "eshell/em-cmpl.el" +;;;;;; "eshell/em-dirs.el" "eshell/em-glob.el" "eshell/em-hist.el" +;;;;;; "eshell/em-ls.el" "eshell/em-pred.el" "eshell/em-prompt.el" +;;;;;; "eshell/em-rebind.el" "eshell/em-script.el" "eshell/em-smart.el" +;;;;;; "eshell/em-term.el" "eshell/em-tramp.el" "eshell/em-unix.el" +;;;;;; "eshell/em-xtra.el" "eshell/esh-groups.el" "faces.el" "files.el" +;;;;;; "finder-inf.el" "font-core.el" "font-lock.el" "format.el" ;;;;;; "frame.el" "help.el" "hfy-cmap.el" "ibuf-ext.el" "indent.el" -;;;;;; "international/characters.el" "international/charscript.el" -;;;;;; "international/cp51932.el" "international/emoji-zwj.el" "international/eucjp-ms.el" +;;;;;; "international/characters.el" "international/charprop.el" +;;;;;; "international/charscript.el" "international/cp51932.el" +;;;;;; "international/emoji-labels.el" "international/emoji-zwj.el" +;;;;;; "international/eucjp-ms.el" "international/idna-mapping.el" ;;;;;; "international/iso-transl.el" "international/mule-cmds.el" -;;;;;; "international/mule-conf.el" "international/mule.el" "isearch.el" -;;;;;; "jit-lock.el" "jka-cmpr-hook.el" "keymap.el" "language/burmese.el" -;;;;;; "language/cham.el" "language/chinese.el" "language/cyrillic.el" -;;;;;; "language/czech.el" "language/english.el" "language/ethiopic.el" -;;;;;; "language/european.el" "language/georgian.el" "language/greek.el" -;;;;;; "language/hebrew.el" "language/indian.el" "language/japanese.el" -;;;;;; "language/khmer.el" "language/korean.el" "language/lao.el" -;;;;;; "language/misc-lang.el" "language/romanian.el" "language/sinhala.el" -;;;;;; "language/slovak.el" "language/tai-viet.el" "language/thai.el" -;;;;;; "language/tibetan.el" "language/utf-8-lang.el" "language/vietnamese.el" -;;;;;; "ldefs-boot.el" "leim/ja-dic/ja-dic.el" "leim/leim-list.el" -;;;;;; "leim/quail/4Corner.el" "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el" -;;;;;; "leim/quail/CTLau-b5.el" "leim/quail/CTLau.el" "leim/quail/ECDICT.el" -;;;;;; "leim/quail/ETZY.el" "leim/quail/PY-b5.el" "leim/quail/PY.el" -;;;;;; "leim/quail/Punct-b5.el" "leim/quail/Punct.el" "leim/quail/QJ-b5.el" -;;;;;; "leim/quail/QJ.el" "leim/quail/SW.el" "leim/quail/TONEPY.el" -;;;;;; "leim/quail/ZIRANMA.el" "leim/quail/ZOZY.el" "leim/quail/arabic.el" -;;;;;; "leim/quail/cham.el" "leim/quail/compose.el" "leim/quail/croatian.el" -;;;;;; "leim/quail/cyril-jis.el" "leim/quail/cyrillic.el" "leim/quail/czech.el" -;;;;;; "leim/quail/emoji.el" "leim/quail/georgian.el" "leim/quail/greek.el" -;;;;;; "leim/quail/hanja-jis.el" "leim/quail/hanja.el" "leim/quail/hanja3.el" -;;;;;; "leim/quail/hebrew.el" "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el" -;;;;;; "leim/quail/latin-ltx.el" "leim/quail/latin-post.el" "leim/quail/latin-pre.el" -;;;;;; "leim/quail/persian.el" "leim/quail/programmer-dvorak.el" -;;;;;; "leim/quail/py-punct.el" "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el" -;;;;;; "leim/quail/quick-cns.el" "leim/quail/rfc1345.el" "leim/quail/sami.el" -;;;;;; "leim/quail/sgml-input.el" "leim/quail/slovak.el" "leim/quail/symbol-ksc.el" -;;;;;; "leim/quail/tamil-dvorak.el" "leim/quail/tsang-b5.el" "leim/quail/tsang-cns.el" -;;;;;; "leim/quail/vntelex.el" "leim/quail/vnvni.el" "leim/quail/welsh.el" -;;;;;; "loadup.el" "mail/blessmail.el" "mail/undigest.el" "menu-bar.el" -;;;;;; "mh-e/mh-gnus.el" "minibuffer.el" "mouse.el" "newcomment.el" -;;;;;; "obarray.el" "org/ob-core.el" "org/ob-lob.el" "org/ob-matlab.el" -;;;;;; "org/ob-tangle.el" "org/ob.el" "org/ol-bbdb.el" "org/ol-irc.el" -;;;;;; "org/ol.el" "org/org-archive.el" "org/org-attach.el" "org/org-clock.el" -;;;;;; "org/org-colview.el" "org/org-compat.el" "org/org-datetree.el" -;;;;;; "org/org-duration.el" "org/org-element.el" "org/org-feed.el" -;;;;;; "org/org-footnote.el" "org/org-goto.el" "org/org-id.el" "org/org-indent.el" -;;;;;; "org/org-install.el" "org/org-keys.el" "org/org-lint.el" -;;;;;; "org/org-list.el" "org/org-macs.el" "org/org-mobile.el" "org/org-num.el" -;;;;;; "org/org-plot.el" "org/org-refile.el" "org/org-table.el" -;;;;;; "org/org-timer.el" "org/ox-ascii.el" "org/ox-beamer.el" "org/ox-html.el" -;;;;;; "org/ox-icalendar.el" "org/ox-latex.el" "org/ox-md.el" "org/ox-odt.el" -;;;;;; "org/ox-org.el" "org/ox-publish.el" "org/ox-texinfo.el" "org/ox.el" -;;;;;; "paren.el" "progmodes/elisp-mode.el" "progmodes/prog-mode.el" -;;;;;; "ps-mule.el" "register.el" "replace.el" "rfn-eshadow.el" -;;;;;; "select.el" "simple.el" "startup.el" "subdirs.el" "subr.el" -;;;;;; "tab-bar.el" "textmodes/fill.el" "textmodes/makeinfo.el" +;;;;;; "international/mule-conf.el" "international/mule.el" "international/uni-bidi.el" +;;;;;; "international/uni-brackets.el" "international/uni-category.el" +;;;;;; "international/uni-combining.el" "international/uni-comment.el" +;;;;;; "international/uni-confusable.el" "international/uni-decimal.el" +;;;;;; "international/uni-decomposition.el" "international/uni-digit.el" +;;;;;; "international/uni-lowercase.el" "international/uni-mirrored.el" +;;;;;; "international/uni-name.el" "international/uni-numeric.el" +;;;;;; "international/uni-old-name.el" "international/uni-scripts.el" +;;;;;; "international/uni-special-lowercase.el" "international/uni-special-titlecase.el" +;;;;;; "international/uni-special-uppercase.el" "international/uni-titlecase.el" +;;;;;; "international/uni-uppercase.el" "isearch.el" "jit-lock.el" +;;;;;; "jka-cmpr-hook.el" "keymap.el" "language/burmese.el" "language/cham.el" +;;;;;; "language/chinese.el" "language/cyrillic.el" "language/czech.el" +;;;;;; "language/english.el" "language/ethiopic.el" "language/european.el" +;;;;;; "language/georgian.el" "language/greek.el" "language/hebrew.el" +;;;;;; "language/indian.el" "language/japanese.el" "language/khmer.el" +;;;;;; "language/korean.el" "language/lao.el" "language/misc-lang.el" +;;;;;; "language/romanian.el" "language/sinhala.el" "language/slovak.el" +;;;;;; "language/tai-viet.el" "language/thai.el" "language/tibetan.el" +;;;;;; "language/utf-8-lang.el" "language/vietnamese.el" "ldefs-boot.el" +;;;;;; "leim/ja-dic/ja-dic.el" "leim/leim-list.el" "leim/quail/4Corner.el" +;;;;;; "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el" "leim/quail/CTLau-b5.el" +;;;;;; "leim/quail/CTLau.el" "leim/quail/ECDICT.el" "leim/quail/ETZY.el" +;;;;;; "leim/quail/PY-b5.el" "leim/quail/PY.el" "leim/quail/Punct-b5.el" +;;;;;; "leim/quail/Punct.el" "leim/quail/QJ-b5.el" "leim/quail/QJ.el" +;;;;;; "leim/quail/SW.el" "leim/quail/TONEPY.el" "leim/quail/ZIRANMA.el" +;;;;;; "leim/quail/ZOZY.el" "leim/quail/arabic.el" "leim/quail/cham.el" +;;;;;; "leim/quail/compose.el" "leim/quail/croatian.el" "leim/quail/cyril-jis.el" +;;;;;; "leim/quail/cyrillic.el" "leim/quail/czech.el" "leim/quail/emoji.el" +;;;;;; "leim/quail/georgian.el" "leim/quail/greek.el" "leim/quail/hanja-jis.el" +;;;;;; "leim/quail/hanja.el" "leim/quail/hanja3.el" "leim/quail/hebrew.el" +;;;;;; "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el" "leim/quail/latin-ltx.el" +;;;;;; "leim/quail/latin-post.el" "leim/quail/latin-pre.el" "leim/quail/persian.el" +;;;;;; "leim/quail/programmer-dvorak.el" "leim/quail/py-punct.el" +;;;;;; "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el" "leim/quail/quick-cns.el" +;;;;;; "leim/quail/rfc1345.el" "leim/quail/sami.el" "leim/quail/sgml-input.el" +;;;;;; "leim/quail/slovak.el" "leim/quail/symbol-ksc.el" "leim/quail/tamil-dvorak.el" +;;;;;; "leim/quail/tsang-b5.el" "leim/quail/tsang-cns.el" "leim/quail/vntelex.el" +;;;;;; "leim/quail/vnvni.el" "leim/quail/welsh.el" "loadup.el" "mail/blessmail.el" +;;;;;; "mail/undigest.el" "menu-bar.el" "mh-e/mh-gnus.el" "minibuffer.el" +;;;;;; "mouse.el" "newcomment.el" "obarray.el" "org/ob-core.el" +;;;;;; "org/ob-lob.el" "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el" +;;;;;; "org/ol-bbdb.el" "org/ol-irc.el" "org/ol.el" "org/org-archive.el" +;;;;;; "org/org-attach.el" "org/org-clock.el" "org/org-colview.el" +;;;;;; "org/org-compat.el" "org/org-datetree.el" "org/org-duration.el" +;;;;;; "org/org-element.el" "org/org-feed.el" "org/org-footnote.el" +;;;;;; "org/org-goto.el" "org/org-id.el" "org/org-indent.el" "org/org-install.el" +;;;;;; "org/org-keys.el" "org/org-lint.el" "org/org-list.el" "org/org-macs.el" +;;;;;; "org/org-mobile.el" "org/org-num.el" "org/org-plot.el" "org/org-refile.el" +;;;;;; "org/org-table.el" "org/org-timer.el" "org/ox-ascii.el" "org/ox-beamer.el" +;;;;;; "org/ox-html.el" "org/ox-icalendar.el" "org/ox-latex.el" +;;;;;; "org/ox-md.el" "org/ox-odt.el" "org/ox-org.el" "org/ox-publish.el" +;;;;;; "org/ox-texinfo.el" "org/ox.el" "paren.el" "progmodes/elisp-mode.el" +;;;;;; "progmodes/prog-mode.el" "ps-mule.el" "register.el" "replace.el" +;;;;;; "rfn-eshadow.el" "select.el" "simple.el" "startup.el" "subdirs.el" +;;;;;; "subr.el" "tab-bar.el" "textmodes/fill.el" "textmodes/makeinfo.el" ;;;;;; "textmodes/page.el" "textmodes/paragraphs.el" "textmodes/reftex-auc.el" ;;;;;; "textmodes/reftex-cite.el" "textmodes/reftex-dcr.el" "textmodes/reftex-global.el" ;;;;;; "textmodes/reftex-index.el" "textmodes/reftex-parse.el" "textmodes/reftex-ref.el" commit 0a094fb65ca1392231ef8176f89f936e39f3296e Author: dickmao Date: Sun Mar 20 11:34:56 2022 -0400 Rewrite hl-line-mode The fashion of dual global and minor modes, each managing a replica of state, has long been outmoded by globalized minor modes (nee easy-mmode-define-global-mode) around the turn of the century. * lisp/calendar/todo-mode.el (todo-toggle-item-highlighting, todo-hl-line-range, todo-modes-set-2): Adapt to new hl-line-highlight-hook. * lisp/hl-line.el (hl-line-overlay): Rename hl-line--overlay. (global-hl-line-overlay, global-hl-line-overlays, global-hl-line-sticky-flag, hl-line-overlay-buffer, hl-line-range-function): Obsolesce. (hl-line--overlay): Erstwhile hl-line-overlay. (hl-line, hl-line-face): Consolidate. (hl-line-sticky-flag): Say less (Gen Z Hospital). (hl-line-overlay-priority): Make this a custom. (hl-line-highlight-hook): Prefer hook over specialized hl-line-range-function. (hl-line-mode): Say less (Gen Z Hospital). (hl-line-make-overlay): Remove (hl-line-highlight, hl-line-unhighlight): Rewrite. (hl-line-maybe-unhighlight): Remove. (hl-line-turn-on): Necessary for globalized minor mode. (global-hl-line-mode, global-hl-line-highlight, global-hl-line-highlight-all, global-hl-line-unhighlight, global-hl-line-maybe-unhighlight, global-hl-line-unhighlight-all): Prefer globalized minor mode. (hl-line-move, hl-line-unload-function): Remove. * test/lisp/calendar/todo-mode-tests.el (todo-test-item-highlighting, todo-test-done-items-separator06-bol, todo-test-done-items-separator06-eol, todo-test-done-items-separator07): Adapt to consolidated face. diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el index 57fcd1b17e..eed597a033 100644 --- a/lisp/calendar/todo-mode.el +++ b/lisp/calendar/todo-mode.el @@ -1040,9 +1040,7 @@ empty line above the done items separator." (eval-and-compile (require 'hl-line)) (when (memq major-mode '(todo-mode todo-archive-mode todo-filtered-items-mode)) - (if hl-line-mode - (hl-line-mode -1) - (hl-line-mode 1)))) + (hl-line-mode 'toggle))) (defvar todo--item-headers-hidden nil "Non-nil if item date-time headers in current buffer are hidden.") @@ -6676,9 +6674,8 @@ Added to `window-configuration-change-hook' in Todo mode." (defun todo-hl-line-range () "Make `todo-toggle-item-highlighting' highlight entire item." (save-excursion - (when (todo-item-end) - (cons (todo-item-start) - (todo-item-end))))) + (when (and (todo-item-end) hl-line--overlay) + (move-overlay hl-line--overlay (todo-item-start) (todo-item-end))))) (defun todo-modes-set-2 () "Make some settings that apply to multiple Todo modes." @@ -6686,7 +6683,7 @@ Added to `window-configuration-change-hook' in Todo mode." (setq buffer-read-only t) (setq-local todo--item-headers-hidden nil) (setq-local desktop-save-buffer 'todo-desktop-save-buffer) - (setq-local hl-line-range-function #'todo-hl-line-range)) + (add-hook 'hl-line-highlight-hook #'todo-hl-line-range nil t)) (defun todo-modes-set-3 () "Make some settings that apply to multiple Todo modes." diff --git a/lisp/hl-line.el b/lisp/hl-line.el index 8e60ddf6b0..daa24c4fbf 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el @@ -24,274 +24,103 @@ ;;; Commentary: -;; Provides a local minor mode (toggled by M-x hl-line-mode) and -;; a global minor mode (toggled by M-x global-hl-line-mode) to -;; highlight, on a suitable terminal, the line on which point is. The -;; global mode highlights the current line in the selected window only -;; (except when the minibuffer window is selected). This was -;; implemented to satisfy a request for a feature of Lesser Editors. -;; The local mode is sticky: it highlights the line about the buffer's -;; point even if the buffer's window is not selected. Caveat: the -;; buffer's point might be different from the point of a non-selected -;; window. Set the variable `hl-line-sticky-flag' to nil to make the -;; local mode behave like the global mode. - -;; You probably don't really want to use the global mode; if the -;; cursor is difficult to spot, try changing its color, relying on -;; `blink-cursor-mode' or both. The hookery used might affect -;; response noticeably on a slow machine. The local mode may be -;; useful in non-editing buffers such as Gnus or PCL-CVS though. - -;; An overlay is used. In the non-sticky cases, this overlay is -;; active only on the selected window. A hook is added to -;; `post-command-hook' to activate the overlay and move it to the line -;; about point. - -;; You could make variable `global-hl-line-mode' buffer-local and set -;; it to nil to avoid highlighting specific buffers, when the global -;; mode is used. - -;; By default the whole line is highlighted. The range of highlighting -;; can be changed by defining an appropriate function as the -;; buffer-local value of `hl-line-range-function'. - ;;; Code: -(defvar-local hl-line-overlay nil - "Overlay used by Hl-Line mode to highlight the current line.") +(make-obsolete-variable 'hl-line-overlay nil "29.1") +(make-obsolete-variable 'global-hl-line-overlay nil "29.1") +(make-obsolete-variable 'global-hl-line-overlays nil "29.1") +(make-obsolete-variable 'global-hl-line-sticky-flag nil "29.1") +(make-obsolete-variable 'hl-line-overlay-buffer nil "29.1") +(make-obsolete-variable 'hl-line-range-function nil "29.1") -(defvar-local global-hl-line-overlay nil - "Overlay used by Global-Hl-Line mode to highlight the current line.") +(defvar-local hl-line--overlay nil + "Keep state else scan entire buffer in `post-command-hook'.") -(defvar global-hl-line-overlays nil - "Overlays used by Global-Hl-Line mode in various buffers. -Global-Hl-Line keeps displaying one overlay in each buffer -when `global-hl-line-sticky-flag' is non-nil.") +;; 1. define-minor-mode creates buffer-local hl-line--overlay +;; 2. overlay wiped by kill-all-local-variables +;; 3. post-command-hook dupes overlay +;; Solution: prevent step 2. +(put 'hl-line--overlay 'permanent-local t) (defgroup hl-line nil "Highlight the current line." :version "21.1" :group 'convenience) -(defface hl-line - '((t :inherit highlight :extend t)) - "Default face for highlighting the current line in Hl-Line mode." +(defface hl-line-face '((t :inherit highlight :extend t)) + "Default face for highlighting the current line in hl-line-mode." :version "22.1" :group 'hl-line) -(defcustom hl-line-face 'hl-line - "Face with which to highlight the current line in Hl-Line mode." - :type 'face - :group 'hl-line - :set (lambda (symbol value) - (set symbol value) - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (when (overlayp hl-line-overlay) - (overlay-put hl-line-overlay 'face hl-line-face)))) - (when (overlayp global-hl-line-overlay) - (overlay-put global-hl-line-overlay 'face hl-line-face)))) - (defcustom hl-line-sticky-flag t - "Non-nil means the HL-Line mode highlight appears in all windows. -Otherwise Hl-Line mode will highlight only in the selected -window. Setting this variable takes effect the next time you use -the command `hl-line-mode' to turn Hl-Line mode on. - -This variable has no effect in Global Highlight Line mode. -For that, use `global-hl-line-sticky-flag'." + "Non-nil to preserve highlighting overlay when focus leaves window." :type 'boolean :version "22.1" + :group 'hl-line + :set (lambda (symbol value) + (set-default symbol value) + (unless value + (let ((selected (window-buffer (selected-window)))) + (dolist (buffer (buffer-list)) + (unless (eq buffer selected) + (with-current-buffer buffer + (hl-line-unhighlight)))))))) + +(defcustom hl-line-overlay-priority -50 + "Priority used on the overlay used by hl-line." + :type 'integer + :version "22.1" :group 'hl-line) -(defcustom global-hl-line-sticky-flag nil - "Non-nil means the Global HL-Line mode highlight appears in all windows. -Otherwise Global Hl-Line mode will highlight only in the selected -window. Setting this variable takes effect the next time you use -the command `global-hl-line-mode' to turn Global Hl-Line mode on." - :type 'boolean - :version "24.1" +(defcustom hl-line-highlight-hook nil + "After hook for `hl-line-highlight'. +Currently used in calendar/todo-mode." + :type 'hook :group 'hl-line) -(defvar hl-line-range-function nil - "If non-nil, function to call to return highlight range. -The function of no args should return a cons cell; its car value -is the beginning position of highlight and its cdr value is the -end position of highlight in the buffer. -It should return nil if there's no region to be highlighted. - -This variable is expected to be made buffer-local by modes.") - -(defvar hl-line-overlay-buffer nil - "Most recently visited buffer in which Hl-Line mode is enabled.") - -(defvar hl-line-overlay-priority -50 - "Priority used on the overlay used by hl-line.") - ;;;###autoload (define-minor-mode hl-line-mode - "Toggle highlighting of the current line (Hl-Line mode). - -Hl-Line mode is a buffer-local minor mode. If -`hl-line-sticky-flag' is non-nil, Hl-Line mode highlights the -line about the buffer's point in all windows. Caveat: the -buffer's point might be different from the point of a -non-selected window. Hl-Line mode uses the function -`hl-line-highlight' on `post-command-hook' in this case. - -When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the -line about point in the selected window only." + "Toggle highlighting of the current line." :group 'hl-line (if hl-line-mode (progn - ;; In case `kill-all-local-variables' is called. - (add-hook 'change-major-mode-hook #'hl-line-unhighlight nil t) (hl-line-highlight) - (setq hl-line-overlay-buffer (current-buffer)) + (add-hook 'change-major-mode-hook #'hl-line-unhighlight nil t) (add-hook 'post-command-hook #'hl-line-highlight nil t)) (remove-hook 'post-command-hook #'hl-line-highlight t) - (hl-line-unhighlight) - (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t))) - -(defun hl-line-make-overlay () - (let ((ol (make-overlay (point) (point)))) - (overlay-put ol 'priority hl-line-overlay-priority) ;(bug#16192) - (overlay-put ol 'face hl-line-face) - ol)) - -(defun hl-line-highlight () - "Activate the Hl-Line overlay on the current line." - (if hl-line-mode ; Might be changed outside the mode function. - (progn - (unless (overlayp hl-line-overlay) - (setq hl-line-overlay (hl-line-make-overlay))) ; To be moved. - (overlay-put hl-line-overlay - 'window (unless hl-line-sticky-flag (selected-window))) - (hl-line-move hl-line-overlay) - (hl-line-maybe-unhighlight)) - (hl-line-unhighlight))) + (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t) + (let (hl-line-sticky-flag) + (hl-line-unhighlight)))) (defun hl-line-unhighlight () - "Deactivate the Hl-Line overlay on the current line." - (when (overlayp hl-line-overlay) - (delete-overlay hl-line-overlay) - (setq hl-line-overlay nil))) + (unless hl-line-sticky-flag + (when hl-line--overlay + (delete-overlay hl-line--overlay) + (setq hl-line--overlay nil)))) -(defun hl-line-maybe-unhighlight () - "Maybe deactivate the Hl-Line overlay on the current line. -Specifically, when `hl-line-sticky-flag' is nil deactivate all -such overlays in all buffers except the current one." - (let ((hlob hl-line-overlay-buffer) - (curbuf (current-buffer))) - (when (and (buffer-live-p hlob) - (not hl-line-sticky-flag) - (not (eq curbuf hlob)) - (not (minibufferp))) - (with-current-buffer hlob - (hl-line-unhighlight))) - (when (and (overlayp hl-line-overlay) - (eq (overlay-buffer hl-line-overlay) curbuf)) - (setq hl-line-overlay-buffer curbuf)))) +(defun hl-line-highlight () + (unless (minibufferp) + (unless hl-line--overlay + (setq hl-line--overlay + (let ((ol (make-overlay (point) (point)))) + (prog1 ol + (overlay-put ol 'priority hl-line-overlay-priority) + (overlay-put ol 'face 'hl-line-face))))) + (move-overlay hl-line--overlay + (line-beginning-position) + (line-beginning-position 2)) + (run-hooks 'hl-line-highlight-hook))) + +(defun hl-line-turn-on () + (unless (minibufferp) + (let (inhibit-quit) + (hl-line-mode 1)))) ;;;###autoload -(define-minor-mode global-hl-line-mode - "Toggle line highlighting in all buffers (Global Hl-Line mode). - -If `global-hl-line-sticky-flag' is non-nil, Global Hl-Line mode -highlights the line about the current buffer's point in all live -windows. - -Global-Hl-Line mode uses the function `global-hl-line-highlight' -on `post-command-hook'." - :global t +(define-globalized-minor-mode global-hl-line-mode + hl-line-mode hl-line-turn-on :group 'hl-line - (if global-hl-line-mode - (progn - ;; In case `kill-all-local-variables' is called. - (add-hook 'change-major-mode-hook #'global-hl-line-unhighlight) - (global-hl-line-highlight-all) - (add-hook 'post-command-hook #'global-hl-line-highlight)) - (global-hl-line-unhighlight-all) - (remove-hook 'post-command-hook #'global-hl-line-highlight) - (remove-hook 'change-major-mode-hook #'global-hl-line-unhighlight))) - -(defun global-hl-line-highlight () - "Highlight the current line in the current window." - (when global-hl-line-mode ; Might be changed outside the mode function. - (unless (window-minibuffer-p) - (unless (overlayp global-hl-line-overlay) - (setq global-hl-line-overlay (hl-line-make-overlay))) ; To be moved. - (unless (member global-hl-line-overlay global-hl-line-overlays) - (push global-hl-line-overlay global-hl-line-overlays)) - (overlay-put global-hl-line-overlay 'window - (unless global-hl-line-sticky-flag - (selected-window))) - (hl-line-move global-hl-line-overlay) - (global-hl-line-maybe-unhighlight)))) - -(defun global-hl-line-highlight-all () - "Highlight the current line in all live windows." - (walk-windows (lambda (w) - (with-current-buffer (window-buffer w) - (global-hl-line-highlight))) - nil t)) - -(defun global-hl-line-unhighlight () - "Deactivate the Global-Hl-Line overlay on the current line." - (when (overlayp global-hl-line-overlay) - (delete-overlay global-hl-line-overlay) - (setq global-hl-line-overlay nil))) - -(defun global-hl-line-maybe-unhighlight () - "Maybe deactivate the Global-Hl-Line overlay on the current line. -Specifically, when `global-hl-line-sticky-flag' is nil deactivate -all such overlays in all buffers except the current one." - (mapc (lambda (ov) - (let ((ovb (overlay-buffer ov))) - (when (and (not global-hl-line-sticky-flag) - (bufferp ovb) - (not (eq ovb (current-buffer))) - (not (minibufferp))) - (with-current-buffer ovb - (global-hl-line-unhighlight))))) - global-hl-line-overlays)) - -(defun global-hl-line-unhighlight-all () - "Deactivate all Global-Hl-Line overlays." - (mapc (lambda (ov) - (let ((ovb (overlay-buffer ov))) - (when (bufferp ovb) - (with-current-buffer ovb - (global-hl-line-unhighlight))))) - global-hl-line-overlays) - (setq global-hl-line-overlays nil)) - -(defun hl-line-move (overlay) - "Move the Hl-Line overlay. -If `hl-line-range-function' is non-nil, move the OVERLAY to the position -where the function returns. If `hl-line-range-function' is nil, fill -the line including the point by OVERLAY." - (let (tmp b e) - (if hl-line-range-function - (setq tmp (funcall hl-line-range-function) - b (car tmp) - e (cdr tmp)) - (setq tmp t - b (line-beginning-position) - e (line-beginning-position 2))) - (if tmp - (move-overlay overlay b e) - (move-overlay overlay 1 1)))) - -(defun hl-line-unload-function () - "Unload the Hl-Line library." - (global-hl-line-mode -1) - (save-current-buffer - (dolist (buffer (buffer-list)) - (set-buffer buffer) - (when hl-line-mode (hl-line-mode -1)))) - ;; continue standard unloading - nil) + :version "29.1") (provide 'hl-line) diff --git a/test/lisp/calendar/todo-mode-tests.el b/test/lisp/calendar/todo-mode-tests.el index 0102b62c10..8715a32b88 100644 --- a/test/lisp/calendar/todo-mode-tests.el +++ b/test/lisp/calendar/todo-mode-tests.el @@ -130,8 +130,8 @@ In particular, all lines of a multiline item should be highlighted." (todo-toggle-item-highlighting) (let ((end (1- (todo-item-end))) (beg (todo-item-start))) - (should (eq (get-char-property beg 'face) 'hl-line)) - (should (eq (get-char-property end 'face) 'hl-line)) + (should (eq (get-char-property beg 'face) 'hl-line-face)) + (should (eq (get-char-property end 'face) 'hl-line-face)) (should (> (count-lines beg end) 1)) (should (eq (next-single-char-property-change beg 'face) (1+ end)))) (todo-toggle-item-highlighting))) ; Turn off highlighting (for test rerun). @@ -736,7 +736,7 @@ Subsequently moving to an item should show it highlighted." (todo-test--done-items-separator) (call-interactively #'todo-toggle-item-highlighting) (ert-simulate-command '(todo-previous-item)) - (should (eq 'hl-line (get-char-property (point) 'face))))) + (should (eq 'hl-line-face (get-char-property (point) 'face))))) (ert-deftest todo-test-done-items-separator06-eol () ; bug#32343 "Test enabling item highlighting at EOL of done items separator. @@ -746,7 +746,7 @@ Subsequently moving to an item should show it highlighted." (todo-toggle-item-highlighting) (forward-line -1) (ert-simulate-command '(todo-previous-item)) - (should (eq 'hl-line (get-char-property (point) 'face))))) + (should (eq 'hl-line-face (get-char-property (point) 'face))))) (ert-deftest todo-test-done-items-separator07 () ; bug#32343 "Test item highlighting when crossing done items separator. @@ -758,7 +758,7 @@ The highlighting should remain enabled." (todo-next-item) ; Now on empty line above separator. (forward-line) ; Now on separator. (ert-simulate-command '(forward-line)) ; Now on first done item. - (should (eq 'hl-line (get-char-property (point) 'face))))) + (should (eq 'hl-line-face (get-char-property (point) 'face))))) (ert-deftest todo-test-current-file-in-edit-mode () ; bug#32437 "Test the value of todo-current-todo-file in todo-edit-mode." diff --git a/test/lisp/hl-line-tests.el b/test/lisp/hl-line-tests.el new file mode 100644 index 0000000000..422d4ddae7 --- /dev/null +++ b/test/lisp/hl-line-tests.el @@ -0,0 +1,51 @@ +;;; hl-line-tests.el --- Test suite for hl-line. -*- lexical-binding: t -*- + +;; Copyright (C) 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 . + +;;; Code: +(require 'ert) +(require 'hl-line) + +(ert-deftest hl-line-sticky () + (should hl-line-sticky-flag) + (with-temp-buffer + (let ((from-buffer (current-buffer))) + (hl-line-mode 1) + (save-excursion + (insert "foo")) + (hl-line-highlight) + (should (cl-some (apply-partially #'eq hl-line--overlay) + (overlays-at (point)))) + (switch-to-buffer (get-buffer-create "*scratch*")) + (hl-line-mode 1) + (save-excursion + (insert "bar")) + (hl-line-highlight) + (should (cl-some (apply-partially #'eq hl-line--overlay) + (overlays-at (point)))) + (should (buffer-local-value 'hl-line--overlay from-buffer)) + (should-not (eq (buffer-local-value 'hl-line--overlay from-buffer) + hl-line--overlay)) + (customize-set-variable 'hl-line-sticky-flag nil) + (should hl-line--overlay) + (should (buffer-live-p from-buffer)) + (should-not (buffer-local-value 'hl-line--overlay from-buffer))))) + +(provide 'hl-line-tests) + +;;; hl-line-tests.el ends here commit bd5d136777ef30f36807c7e690413846ed38fce1 Author: Lars Ingebrigtsen Date: Mon Mar 21 16:01:33 2022 +0100 Add a new face shr-code * lisp/net/shr.el (shr-code): New face (bug#54480). (shr-tag-code): Use it. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 386f1d6095..43d34a9d4d 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -228,6 +228,10 @@ temporarily blinks with this face." "Face for
elements." :version "28.1") +(defface shr-code '((t :inherit fixed-pitch)) + "Face used for rendering blocks." + :version "29.1") + (defcustom shr-inhibit-images nil "If non-nil, inhibit loading images." :version "28.1" @@ -1410,7 +1414,7 @@ ones, in case fg and bg are nil." (shr-fontize-dom dom 'underline)) (defun shr-tag-code (dom) - (let ((shr-current-font 'fixed-pitch)) + (let ((shr-current-font 'shr-code)) (shr-generic dom))) (defun shr-tag-tt (dom) commit c69a6177422d52cb75f295ddf3ca29cd50337995 Author: Lars Ingebrigtsen Date: Mon Mar 21 15:53:25 2022 +0100 Add notes about command modes and nativecomp interaction * doc/lispref/commands.texi (Command Modes): Note interaction with native-compile (bug#54437). * src/data.c: Add comment about not being supported. Do not merge to master. diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index 0d13408e3f..d948af6b4f 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -682,6 +682,11 @@ different ways (e.g., @code{eww-open-in-new-buffer} and mode-specific, as they can be issued by the user from pretty much any context. +Note that specifying command modes is not supported in native-compiled +functions in Emacs 28.1 (but this is fixed in later Emacs versions). +This means that @code{read-extended-command-predicate} isn't supported +in native-compile builds, either. + @node Generic Commands @subsection Select among Command Alternatives @cindex generic commands diff --git a/src/data.c b/src/data.c index 9bf9d605cf..57205d8808 100644 --- a/src/data.c +++ b/src/data.c @@ -1022,6 +1022,9 @@ Value, if non-nil, is a list (interactive SPEC). */) return Qnil; } +/* Note that this doesn't work for native-compiled functions in Emacs + 28.1, but it's fixed in later Emacs versions. */ + DEFUN ("command-modes", Fcommand_modes, Scommand_modes, 1, 1, 0, doc: /* Return the modes COMMAND is defined for. If COMMAND is not a command, the return value is nil. commit 59a8a0ef0d57dd28b47fb39d2cb5651d297e1c89 Author: Andrea Corallo Date: Mon Mar 21 15:04:49 2022 +0100 ; * src/comp.c: Update a comment. diff --git a/src/comp.c b/src/comp.c index 50f92fe2cf..349f228558 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4969,7 +4969,6 @@ unknown (before GCC version 10). */) /******************************************************************************/ /* Helper functions called from the run-time. */ -/* These can't be statics till shared mechanism is used to solve relocations. */ /* Note: this are all potentially definable directly to gcc and are here just */ /* for laziness. Change this if a performance impact is measured. */ /******************************************************************************/ commit efb76604c49c9277f8091da31aa75beb85e8c9fa Author: Po Lu Date: Mon Mar 21 09:00:38 2022 +0000 Minor fixes to Haiku DND support * src/haiku_support.cc (MessageReceived): If source is remote, don't test window ID. (MouseMoved): Don't send mouse motion if dragging. (be_drag_message): Return true if quit-flag. * src/haiku_support.h: Update prototypes. * src/haikuselect.c (haiku_should_quit_drag): New function. (Fhaiku_drag_message): If rc is true, quit. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 26b7ebed24..5d0385f6d9 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -645,6 +645,7 @@ class EmacsWindow : public BWindow struct haiku_drag_and_drop_event rq; if (msg->FindInt32 ("emacs:window_id", &windowid) == B_OK + && !msg->IsSourceRemote () && windowid == this->window_id) return; @@ -1449,7 +1450,7 @@ class EmacsView : public BView } void - MouseMoved (BPoint point, uint32 transit, const BMessage *msg) + MouseMoved (BPoint point, uint32 transit, const BMessage *drag_msg) { struct haiku_mouse_motion_event rq; @@ -1459,6 +1460,9 @@ class EmacsView : public BView rq.window = this->Window (); rq.time = system_time (); + if (drag_msg && transit != B_EXITED_VIEW) + return; + if (ToolTip ()) ToolTip ()->SetMouseRelativeLocation (BPoint (-(point.x - tt_absl_pos.x), -(point.y - tt_absl_pos.y))); @@ -3960,11 +3964,12 @@ be_drag_message_thread_entry (void *thread_data) return 0; } -void +bool be_drag_message (void *view, void *message, void (*block_input_function) (void), void (*unblock_input_function) (void), - void (*process_pending_signals_function) (void)) + void (*process_pending_signals_function) (void), + bool (*should_quit_function) (void)) { EmacsView *vw = (EmacsView *) view; EmacsWindow *window = (EmacsWindow *) vw->Window (); @@ -3995,7 +4000,7 @@ be_drag_message (void *view, void *message, unblock_input_function (); if (infos[1].object < B_OK) - return; + return false; block_input_function (); resume_thread (infos[1].object); @@ -4017,8 +4022,11 @@ be_drag_message (void *view, void *message, if (infos[0].events & B_EVENT_READ) process_pending_signals_function (); + if (should_quit_function ()) + return true; + if (infos[1].events & B_EVENT_INVALID) - return; + return false; infos[0].events = B_EVENT_READ; infos[1].events = B_EVENT_INVALID; diff --git a/src/haiku_support.h b/src/haiku_support.h index af7216286a..9c21a80e20 100644 --- a/src/haiku_support.h +++ b/src/haiku_support.h @@ -945,11 +945,12 @@ extern "C" extern void BMessage_delete (void *message); - extern void + extern bool be_drag_message (void *view, void *message, void (*block_input_function) (void), void (*unblock_input_function) (void), - void (*process_pending_signals_function) (void)); + void (*process_pending_signals_function) (void), + bool (*should_quit_function) (void)); #ifdef __cplusplus extern void * diff --git a/src/haikuselect.c b/src/haikuselect.c index 8192a1ad5b..21407eedf0 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -506,6 +506,12 @@ haiku_lisp_to_message (Lisp_Object obj, void *message) CHECK_LIST_END (tem, obj); } +static bool +haiku_should_quit_drag (void) +{ + return !NILP (Vquit_flag); +} + DEFUN ("haiku-drag-message", Fhaiku_drag_message, Shaiku_drag_message, 2, 2, 0, doc: /* Begin dragging MESSAGE from FRAME. @@ -530,6 +536,7 @@ drag will originate. */) specpdl_ref idx; void *be_message; struct frame *f; + bool rc; idx = SPECPDL_INDEX (); f = decode_window_system_frame (frame); @@ -541,11 +548,15 @@ drag will originate. */) record_unwind_protect_ptr (BMessage_delete, be_message); haiku_lisp_to_message (message, be_message); - be_drag_message (FRAME_HAIKU_VIEW (f), be_message, - block_input, unblock_input, - process_pending_signals); + rc = be_drag_message (FRAME_HAIKU_VIEW (f), be_message, + block_input, unblock_input, + process_pending_signals, + haiku_should_quit_drag); FRAME_DISPLAY_INFO (f)->grabbed = 0; + if (rc) + quit (); + return unbind_to (idx, Qnil); } commit 1641b5c04c383b5f53298d70776e3c18577b6f30 Author: Jimmy Aguilar Mena Date: Mon Mar 21 07:55:03 2022 +0100 Set cursor-face-highlight-nonselected-window in completions. * lisp/simple.el (completion-setup-function) : Sets cursor-face-highlight-nonselected-window to t in Completions. diff --git a/lisp/simple.el b/lisp/simple.el index 369e11e47c..8eece3e81f 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -9399,6 +9399,8 @@ Called from `temp-buffer-show-hook'." (setq tab-width completion-tab-width)) ;; Maybe enable cursor completions-highlight. (when completions-highlight-face + ;; keep highlight even if not selected + (setq-local cursor-face-highlight-nonselected-window t) (cursor-face-highlight-mode 1)) ;; Maybe insert help string. (when completion-show-help commit 7cee79655656f02c36fb2858eccce477b7d90b6b Merge: a379f50acb f15922a57c Author: Stefan Kangas Date: Mon Mar 21 06:30:40 2022 +0100 Merge from origin/emacs-28 f15922a57c Update to Org 9.5.2-25-gaf6f12 9fcdd5b63f Improve doc strings of read-char-from-minibuffer-insert-* ... commit a379f50acb023e37c1731a41c49e1d3d8a34e858 Author: Po Lu Date: Mon Mar 21 11:48:36 2022 +0800 Improve handling of input methods during drag-and-drop * src/xterm.c (x_dnd_cleanup_drag_and_drop) (x_dnd_begin_drag_and_drop): Stop removing IC and filter events before dispatching them. (x_filter_event): Actually filter events during DND. (XTread_socket): Verify GenericEvents are actually input extension events before ignoring them. diff --git a/src/xterm.c b/src/xterm.c index ec5a65b3bb..3f16a116eb 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -787,6 +787,10 @@ static void x_update_opaque_region (struct frame *, XEvent *); static void x_scroll_bar_end_update (struct x_display_info *, struct scroll_bar *); #endif +#ifdef HAVE_X_I18N +static int x_filter_event (struct x_display_info *, XEvent *); +#endif + static bool x_dnd_in_progress; static bool x_dnd_waiting_for_finish; static Window x_dnd_pending_finish_target; @@ -813,7 +817,6 @@ static Atom *x_dnd_targets = NULL; static int x_dnd_n_targets; static struct frame *x_dnd_frame; static XWindowAttributes x_dnd_old_window_attrs; -static XIC x_dnd_old_ic; static bool x_dnd_unwind_flag; #define X_DND_SUPPORTED_VERSION 5 @@ -1180,9 +1183,6 @@ x_dnd_cleanup_drag_and_drop (void *frame) #ifdef USE_GTK current_hold_quit = NULL; #endif -#ifdef HAVE_X_I18N - FRAME_XIC (f) = x_dnd_old_ic; -#endif block_input (); /* Restore the old event mask. */ @@ -1201,9 +1201,6 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, #ifndef USE_GTK XEvent next_event; int finish; -#endif -#ifdef HAVE_X_I18N - XIC ic = FRAME_XIC (f); #endif XWindowAttributes root_window_attrs; @@ -1261,11 +1258,6 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, | SubstructureNotifyMask | PropertyChangeMask); -#ifdef HAVE_X_I18N - /* Make sure no events get filtered when XInput 2 is enabled. - Otherwise, the ibus XIM server gets very confused. */ - FRAME_XIC (f) = NULL; -#endif while (x_dnd_in_progress || x_dnd_waiting_for_finish) { hold_quit.kind = NO_EVENT; @@ -1277,8 +1269,27 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, #ifndef USE_GTK XNextEvent (FRAME_X_DISPLAY (f), &next_event); +#ifdef HAVE_X_I18N +#ifdef HAVE_XINPUT2 + if (next_event.type != GenericEvent + || !FRAME_DISPLAY_INFO (f)->supports_xi2 + || (next_event.xgeneric.extension + != FRAME_DISPLAY_INFO (f)->xi2_opcode)) + { +#endif + if (!x_filter_event (FRAME_DISPLAY_INFO (f), &next_event)) + handle_one_xevent (FRAME_DISPLAY_INFO (f), + &next_event, &finish, &hold_quit); +#ifdef HAVE_XINPUT2 + } + else + handle_one_xevent (FRAME_DISPLAY_INFO (f), + &next_event, &finish, &hold_quit); +#endif +#else handle_one_xevent (FRAME_DISPLAY_INFO (f), &next_event, &finish, &hold_quit); +#endif #else gtk_main_iteration (); #endif @@ -1287,7 +1298,6 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, { if (hold_quit.kind == SELECTION_REQUEST_EVENT) { - x_dnd_old_ic = ic; x_dnd_old_window_attrs = root_window_attrs; x_dnd_unwind_flag = true; @@ -1314,9 +1324,6 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, FRAME_DISPLAY_INFO (f)->grabbed = 0; #ifdef USE_GTK current_hold_quit = NULL; -#endif -#ifdef HAVE_X_I18N - FRAME_XIC (f) = ic; #endif /* Restore the old event mask. */ XSelectInput (FRAME_X_DISPLAY (f), @@ -1326,9 +1333,6 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, quit (); } } -#ifdef HAVE_X_I18N - FRAME_XIC (f) = ic; -#endif x_set_dnd_targets (NULL, 0); x_dnd_waiting_for_finish = false; @@ -10436,9 +10440,6 @@ x_filter_event (struct x_display_info *dpyinfo, XEvent *event) f1 = x_any_window_to_frame (dpyinfo, event->xclient.window); - if (x_dnd_in_progress || x_dnd_waiting_for_finish) - return 0; - #ifdef USE_GTK if (!x_gtk_use_native_input && !dpyinfo->prefer_native_input) @@ -14818,7 +14819,9 @@ XTread_socket (struct terminal *terminal, struct input_event *hold_quit) #ifdef HAVE_X_I18N /* Filter events for the current X input method. */ #ifdef HAVE_XINPUT2 - if (event.type != GenericEvent) + if (event.type != GenericEvent + || !dpyinfo->supports_xi2 + || event.xgeneric.extension != dpyinfo->xi2_opcode) { /* Input extension key events are filtered inside handle_one_xevent. */ commit 2af8b18b2a53c11d33813ff407384f5eb53d92b2 Author: Po Lu Date: Mon Mar 21 09:32:54 2022 +0800 Make quitting work while DND is waitng for finish * src/xterm.c (x_dnd_cleanup_drag_and_drop): (x_dnd_begin_drag_and_drop, handle_one_xevent) (x_free_frame_resources): Clear waiting for finish flag. (x_filter_event): Don't filter if waiting for DND finish as well. diff --git a/src/xterm.c b/src/xterm.c index 7928f4fafb..ec5a65b3bb 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1174,6 +1174,8 @@ x_dnd_cleanup_drag_and_drop (void *frame) x_set_dnd_targets (NULL, 0); } + x_dnd_waiting_for_finish = false; + FRAME_DISPLAY_INFO (f)->grabbed = 0; #ifdef USE_GTK current_hold_quit = NULL; @@ -1213,7 +1215,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, if (!FRAME_VISIBLE_P (f)) error ("Frame is invisible"); - if (x_dnd_in_progress) + if (x_dnd_in_progress || x_dnd_waiting_for_finish) error ("A drag-and-drop session is already in progress"); ltimestamp = x_timestamp_for_selection (FRAME_DISPLAY_INFO (f), @@ -1306,6 +1308,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, x_dnd_in_progress = false; x_dnd_frame = NULL; x_set_dnd_targets (NULL, 0); + x_dnd_waiting_for_finish = false; } FRAME_DISPLAY_INFO (f)->grabbed = 0; @@ -1327,6 +1330,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, FRAME_XIC (f) = ic; #endif x_set_dnd_targets (NULL, 0); + x_dnd_waiting_for_finish = false; #ifdef USE_GTK current_hold_quit = NULL; @@ -10432,7 +10436,7 @@ x_filter_event (struct x_display_info *dpyinfo, XEvent *event) f1 = x_any_window_to_frame (dpyinfo, event->xclient.window); - if (x_dnd_in_progress) + if (x_dnd_in_progress || x_dnd_waiting_for_finish) return 0; #ifdef USE_GTK @@ -17563,6 +17567,7 @@ x_free_frame_resources (struct frame *f) x_dnd_send_leave (f, x_dnd_last_seen_window); x_dnd_in_progress = false; + x_dnd_waiting_for_finish = false; x_dnd_frame = NULL; } commit f15922a57cd6177c9c945d3390a6b9918883415d Author: Kyle Meyer Date: Sun Mar 20 21:31:32 2022 -0400 Update to Org 9.5.2-25-gaf6f12 diff --git a/lisp/org/org-mouse.el b/lisp/org/org-mouse.el index 8d5be42545..20c20acc32 100644 --- a/lisp/org/org-mouse.el +++ b/lisp/org/org-mouse.el @@ -295,7 +295,7 @@ nor a function, elements of KEYWORDS are used directly." ((functionp itemformat) (funcall itemformat keyword)) ((stringp itemformat) (format itemformat keyword)) (t keyword)) - (list 'funcall function keyword) + `(funcall #',function ,keyword) :style (cond ((null selected) t) ((functionp selected) 'toggle) diff --git a/lisp/org/org-version.el b/lisp/org/org-version.el index a38b79304e..e82dbbf398 100644 --- a/lisp/org/org-version.el +++ b/lisp/org/org-version.el @@ -11,7 +11,7 @@ Inserted by installing Org mode or when a release is made." (defun org-git-version () "The Git version of Org mode. Inserted by installing Org or when a release is made." - (let ((org-git-version "release_9.5.2-24-g668205")) + (let ((org-git-version "release_9.5.2-25-gaf6f12")) org-git-version)) (provide 'org-version) commit f0e8f4a4ca34c6510d87266951948f527b289631 Author: Dmitry Gutov Date: Mon Mar 21 03:18:36 2022 +0200 Support indentation of Ruby pattern matching expressions * lisp/progmodes/ruby-mode.el (ruby-smie-grammar, ruby-smie-rules) (ruby-block-mid-keywords): Treat 'in' token similarly to 'when'. * test/lisp/progmodes/ruby-mode-resources/ruby.rb: Add indentation example. diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el index eb54ffe05a..fdc8164dc0 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -70,7 +70,7 @@ "Regexp to match modifiers.") (defconst ruby-block-mid-keywords - '("then" "else" "elsif" "when" "rescue" "ensure") + '("then" "else" "elsif" "when" "in" "rescue" "ensure") "Keywords where the indentation gets shallower in middle of block statements.") (defconst ruby-block-mid-re @@ -369,7 +369,9 @@ This only affects the output of the command `ruby-toggle-block'." (for-body (for-head ";" insts)) (for-head (id "in" exp)) (cases (exp "then" insts) - (cases "when" cases) (insts "else" insts)) + (cases "when" cases) + (cases "in" cases) + (insts "else" insts)) (expseq (exp) );;(expseq "," expseq) (hashvals (exp1 "=>" exp1) (hashvals "," hashvals)) (insts-rescue-insts (insts) @@ -380,7 +382,7 @@ This only affects the output of the command `ruby-toggle-block'." (if-body (ielsei) (if-body "elsif" if-body))) '((nonassoc "in") (assoc ";") (right " @ ") (assoc ",") (right "=")) - '((assoc "when")) + '((assoc "when" "in")) '((assoc "elsif")) '((assoc "rescue" "ensure")) '((assoc ","))) @@ -595,7 +597,7 @@ This only affects the output of the command `ruby-toggle-block'." (cond ((smie-rule-parent-p "def" "begin" "do" "class" "module" "for" "while" "until" "unless" - "if" "then" "elsif" "else" "when" + "if" "then" "elsif" "else" "when" "in" "rescue" "ensure" "{") (smie-rule-parent ruby-indent-level)) ;; For (invalid) code between switch and case. @@ -659,7 +661,7 @@ This only affects the output of the command `ruby-toggle-block'." ruby-indent-level)))) (`(:before . ,(or "else" "then" "elsif" "rescue" "ensure")) (smie-rule-parent)) - ('(:before . "when") + (`(:before . ,(or "when" "in")) ;; Align to the previous `when', but look up the virtual ;; indentation of `case'. (if (smie-rule-sibling-p) 0 (smie-rule-parent))) diff --git a/test/lisp/progmodes/ruby-mode-resources/ruby.rb b/test/lisp/progmodes/ruby-mode-resources/ruby.rb index 8c698e4fac..f31cea86a5 100644 --- a/test/lisp/progmodes/ruby-mode-resources/ruby.rb +++ b/test/lisp/progmodes/ruby-mode-resources/ruby.rb @@ -483,3 +483,11 @@ def qux 2 = 3 :foo= if true {:abc=>4} # not indented, and '=' is not highlighted + +# Pattern matching +case translation +in ['th', orig_text, 'en', trans_text] + puts "English translation: #{orig_text} => #{trans_text}" +in {'th' => orig_text, 'ja' => trans_text} + puts "Japanese translation: #{orig_text} => #{trans_text}" +end commit 01336a2582269040a05bca4376285b1b1c8e3449 Author: Andrew G Cohen Date: Sun Mar 20 13:49:37 2022 +0800 Fix imap fetching multiple mailboxes (bug#54158) * lisp/gnus/mail-source.el (mail-source-fetch-imap): Variables mailbox-source-string and remove should be reset for each mailbox. diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index 04de70bf0f..320bc9c3b0 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -1065,9 +1065,7 @@ This only works when `display-time' is enabled." (let ((from (format "%s:%s:%s" server user port)) (found 0) (buf (generate-new-buffer " *imap source*")) - (mail-source-string (format "imap:%s:%s" server mailbox)) - (imap-shell-program (or (list program) imap-shell-program)) - remove) + (imap-shell-program (or (list program) imap-shell-program))) (if (and (imap-open server port stream authentication buf) (imap-authenticate user (or (cdr (assoc from mail-source-password-cache)) @@ -1076,8 +1074,10 @@ This only works when `display-time' is enabled." (let ((mailbox-list (if (listp mailbox) mailbox (list mailbox)))) (dolist (mailbox mailbox-list) (when (imap-mailbox-select mailbox nil buf) - (let ((coding-system-for-write mail-source-imap-file-coding-system) - str) + (let ((coding-system-for-write + mail-source-imap-file-coding-system) + (mail-source-string (format "imap:%s:%s" server mailbox)) + str remove) (message "Fetching from %s..." mailbox) (with-temp-file mail-source-crash-box ;; Avoid converting 8-bit chars from inserted strings to commit 6b923a5ebc6b2183fd2d7be54e1804bb088d59ed Author: Juri Linkov Date: Sun Mar 20 22:27:17 2022 +0200 * etc/NEWS: Mention new hook 'minibuffer-lazy-highlight-setup'. diff --git a/etc/NEWS b/etc/NEWS index 87fc323990..1ae231afdb 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1437,6 +1437,12 @@ platforms. This command lets you examine all data in the current selection and the clipboard, and insert it into the buffer. +--- +** New hook 'minibuffer-lazy-highlight-setup'. +This hook is intended to be added to 'minibuffer-setup-hook'. +It sets up the minibuffer for lazy highlighting of matches +in the original window. + +++ ** New text property 'inhibit-isearch'. If set, 'isearch' will skip these areas, which can be useful (for commit ceb57e10d605f4ec4d61182f58f7a6ef633a592a Author: Augusto Stoffel Date: Sun Mar 20 20:49:32 2022 +0100 Add lazy highlight to 'isearch-edit-string' * lisp/isearch.el (isearch-edit-string): Activate lazy highlight and lazy count, provided 'isearch-lazy-highlight' respectively 'isearch-lazy-count' are non-nil. diff --git a/lisp/isearch.el b/lisp/isearch.el index 1ee5f2e9a8..1a83586ef8 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -1812,6 +1812,8 @@ The following additional command keys are active while editing. (minibuffer-history-symbol) ;; Search string might have meta information on text properties. (minibuffer-allow-text-properties t)) + (when isearch-lazy-highlight + (add-hook 'minibuffer-setup-hook #'minibuffer-lazy-highlight-setup)) (setq isearch-new-string (read-from-minibuffer (isearch-message-prefix nil isearch-nonincremental) commit 0f7c3f553f95939e08103adcfef2f1176d120dff Author: Augusto Stoffel Date: Sun Mar 20 20:46:31 2022 +0100 Allow lazy highlight and match count while reading from minibuffer * lisp/isearch.el (minibuffer-lazy-highlight-setup): New function, can be added to 'minibuffer-setup-hook' to enable lazy highlight and count while reading from minibuffer. (minibuffer-lazy-count-format, minibuffer-lazy-highlight-transform, minibuffer-lazy-highlight--overlay, minibuffer-lazy-highlight--count, minibuffer-lazy-highlight--after-change, minibuffer-lazy-highlight--exit): Auxiliary variables and functions implementing the lazy highlight functionality while reading from minibuffer. diff --git a/lisp/isearch.el b/lisp/isearch.el index b1951a8659..1ee5f2e9a8 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -4346,6 +4346,69 @@ Attempt to do the search exactly the way the pending Isearch would." (run-at-time lazy-highlight-interval nil 'isearch-lazy-highlight-buffer-update))))))))) + +;; Reading from minibuffer with lazy highlight and match count + +(defcustom minibuffer-lazy-count-format "%s " + "Format of the total number of matches for the prompt prefix." + :type '(choice (const :tag "Don't display a count" nil) + (string :tag "Display match count" "%s ")) + :group 'lazy-count + :version "29.1") + +(defvar minibuffer-lazy-highlight-transform #'identity + "Function to transform minibuffer text into a `isearch-string' for highlighting.") + +(defvar minibuffer-lazy-highlight--overlay nil + "Overlay for minibuffer prompt updates.") + +(defun minibuffer-lazy-highlight--count () + "Display total match count in the minibuffer prompt." + (when minibuffer-lazy-highlight--overlay + (overlay-put minibuffer-lazy-highlight--overlay + 'before-string + (and isearch-lazy-count-total + (not isearch-error) + (format minibuffer-lazy-count-format + isearch-lazy-count-total))))) + +(defun minibuffer-lazy-highlight--after-change (_beg _end _len) + "Update lazy highlight state in minibuffer selected window." + (when isearch-lazy-highlight + (let ((inhibit-redisplay t) ;; Avoid cursor flickering + (string (minibuffer-contents))) + (with-minibuffer-selected-window + (setq isearch-string (funcall minibuffer-lazy-highlight-transform string)) + (isearch-lazy-highlight-new-loop))))) + +(defun minibuffer-lazy-highlight--exit () + "Unwind changes from `minibuffer-lazy-highlight-setup'." + (remove-hook 'after-change-functions + #'minibuffer-lazy-highlight--after-change) + (remove-hook 'lazy-count-update-hook #'minibuffer-lazy-highlight--count) + (remove-hook 'minibuffer-exit-hook #'minibuffer-lazy-highlight--exit) + (setq minibuffer-lazy-highlight--overlay nil) + (when lazy-highlight-cleanup + (lazy-highlight-cleanup))) + +(defun minibuffer-lazy-highlight-setup () + "Set up minibuffer for lazy highlight of matches in the original window. + +This function is intended to be added to `minibuffer-setup-hook'. +Note that several other isearch variables influence the lazy +highlighting, including `isearch-regexp', +`isearch-lazy-highlight' and `isearch-lazy-count'." + (remove-hook 'minibuffer-setup-hook #'minibuffer-lazy-highlight-setup) + (add-hook 'after-change-functions + #'minibuffer-lazy-highlight--after-change) + (add-hook 'lazy-count-update-hook #'minibuffer-lazy-highlight--count) + (add-hook 'minibuffer-exit-hook #'minibuffer-lazy-highlight--exit) + (setq minibuffer-lazy-highlight--overlay + (and minibuffer-lazy-count-format + (make-overlay (point-min) (point-min) (current-buffer) t))) + (minibuffer-lazy-highlight--after-change nil nil nil)) + + (defun isearch-resume (string regexp word forward message case-fold) "Resume an incremental search. STRING is the string or regexp searched for. commit 3d204afe3c80cf4b8ab39dfbdb180884630e815b Author: Augusto Stoffel Date: Sun Mar 20 20:43:10 2022 +0100 New hook, lazy-count-update-hook * lisp/isearch.el (lazy-count-update-hook): New hook allowing to display the lazy count in special ways. (isearch-lazy-highlight-new-loop, isearch-lazy-highlight-buffer-update): Run `lazy-count-update-hook' at appropriate times. * lisp/comint.el (comint-history-isearch-setup, comint-history-isearch-end): Make sure no lazy count is displayed. * lisp/simple.el (minibuffer-history-isearch-setup): Make sure no lazy count is displayed. diff --git a/lisp/comint.el b/lisp/comint.el index 4c82e74e4b..56082f622a 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -1515,6 +1515,7 @@ Intended to be added to `isearch-mode-hook' in `comint-mode'." #'comint-history-isearch-wrap) (setq-local isearch-push-state-function #'comint-history-isearch-push-state) + (setq-local isearch-lazy-count nil) (add-hook 'isearch-mode-end-hook 'comint-history-isearch-end nil t))) (defun comint-history-isearch-end () @@ -1526,6 +1527,7 @@ Intended to be added to `isearch-mode-hook' in `comint-mode'." (setq isearch-message-function nil) (setq isearch-wrap-function nil) (setq isearch-push-state-function nil) + (kill-local-variable 'isearch-lazy-count) (remove-hook 'isearch-mode-end-hook 'comint-history-isearch-end t) (unless isearch-suspended (custom-reevaluate-setting 'comint-history-isearch))) diff --git a/lisp/isearch.el b/lisp/isearch.el index 8970216398..b1951a8659 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -3990,6 +3990,8 @@ since they have special meaning in a regexp." (defvar isearch-lazy-count-current nil) (defvar isearch-lazy-count-total nil) (defvar isearch-lazy-count-hash (make-hash-table)) +(defvar lazy-count-update-hook nil + "Hook run after new lazy count results are computed.") (defun lazy-highlight-cleanup (&optional force procrastinate) "Stop lazy highlighting and remove extra highlighting from current buffer. @@ -4048,7 +4050,7 @@ by other Emacs features." isearch-lazy-highlight-window-end)))))) ;; something important did indeed change (lazy-highlight-cleanup t (not (equal isearch-string ""))) ;stop old timer - (when (and isearch-lazy-count isearch-mode (null isearch-message-function)) + (when isearch-lazy-count (when (or (equal isearch-string "") ;; Check if this place was reached by a condition above ;; other than changed window boundaries (that shouldn't @@ -4067,7 +4069,10 @@ by other Emacs features." (setq isearch-lazy-count-current nil isearch-lazy-count-total nil) ;; Delay updating the message if possible, to avoid flicker - (when (string-equal isearch-string "") (isearch-message)))) + (when (string-equal isearch-string "") + (when (and isearch-mode (null isearch-message-function)) + (isearch-message)) + (run-hooks 'lazy-count-update-hook)))) (setq isearch-lazy-highlight-window-start-changed nil) (setq isearch-lazy-highlight-window-end-changed nil) (setq isearch-lazy-highlight-error isearch-error) @@ -4120,13 +4125,15 @@ by other Emacs features." 'isearch-lazy-highlight-start)))) ;; Update the current match number only in isearch-mode and ;; unless isearch-mode is used specially with isearch-message-function - (when (and isearch-lazy-count isearch-mode (null isearch-message-function)) + (when isearch-lazy-count ;; Update isearch-lazy-count-current only when it was already set ;; at the end of isearch-lazy-highlight-buffer-update (when isearch-lazy-count-current (setq isearch-lazy-count-current (gethash (point) isearch-lazy-count-hash 0)) - (isearch-message)))) + (when (and isearch-mode (null isearch-message-function)) + (isearch-message)) + (run-hooks 'lazy-count-update-hook)))) (defun isearch-lazy-highlight-search (string bound) "Search ahead for the next or previous match, for lazy highlighting. @@ -4327,12 +4334,14 @@ Attempt to do the search exactly the way the pending Isearch would." (setq looping nil nomore t)))) (if nomore - (when (and isearch-lazy-count isearch-mode (null isearch-message-function)) + (when isearch-lazy-count (unless isearch-lazy-count-total (setq isearch-lazy-count-total 0)) (setq isearch-lazy-count-current (gethash opoint isearch-lazy-count-hash 0)) - (isearch-message)) + (when (and isearch-mode (null isearch-message-function)) + (isearch-message)) + (run-hooks 'lazy-count-update-hook)) (setq isearch-lazy-highlight-timer (run-at-time lazy-highlight-interval nil 'isearch-lazy-highlight-buffer-update))))))))) diff --git a/lisp/simple.el b/lisp/simple.el index 83f27e0dbb..43a0d1efc1 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2840,6 +2840,7 @@ Intended to be added to `minibuffer-setup-hook'." #'minibuffer-history-isearch-wrap) (setq-local isearch-push-state-function #'minibuffer-history-isearch-push-state) + (setq-local isearch-lazy-count nil) (add-hook 'isearch-mode-end-hook 'minibuffer-history-isearch-end nil t)) (defun minibuffer-history-isearch-end () commit a31be116aeee43b7a2e14d53db226933d4e8a012 Author: Juri Linkov Date: Sun Mar 20 20:59:04 2022 +0200 * lisp/tab-bar.el (tab-bar-new-tab-to): Don't funcall const values. Filter out the values 'clone' and 'window' of 'tab-bar-new-tab-choice' from function call. diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 245a55a671..cf1cca4af3 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -1384,7 +1384,8 @@ After the tab is created, the hooks in (split-window) (delete-window)))) (let ((buffer - (if (functionp tab-bar-new-tab-choice) + (if (and (functionp tab-bar-new-tab-choice) + (not (memq tab-bar-new-tab-choice '(clone window)))) (funcall tab-bar-new-tab-choice) (if (stringp tab-bar-new-tab-choice) (or (get-buffer tab-bar-new-tab-choice) commit aec44a5be3fddb253b85d15a139b5712fddbc3d4 Author: Michael Albinus Date: Sun Mar 20 19:15:53 2022 +0100 Extend connection-local variables example in Elisp manual * doc/lispref/variables.texi (Connection Local Variables): Explain, how to append variable settings to an existing profile. diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index cd39e6b647..f85ed847c4 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -2295,6 +2295,21 @@ list in @var{variables} is an alist of the form '((null-device . "/dev/null"))) @end group @end example + +@findex connection-local-get-profile-variables +If you want to append variable settings to an existing profile, you +could use the function @code{connection-local-get-profile-variables} +in order to retrieve the existing settings, like + +@example +@group +(connection-local-set-profile-variables + 'remote-bash + (append + (connection-local-get-profile-variables 'remote-bash) + '((shell-command-dont-erase-buffer . t)))) +@end group +@end example @end defun @deffn {User Option} connection-local-profile-alist commit 5feddb4b1a983a398b4788b1005e7355c38cff3f Author: Paul Eggert Date: Sun Mar 20 10:46:06 2022 -0700 Remove duplicate INLINE_HEADER_BEGIN * src/thread.h: Remove duplicate INLINE_HEADER_BEGIN. Problem reportd by Mattias Engdegård. diff --git a/src/thread.h b/src/thread.h index b34ca3d57c..82c445ba7e 100644 --- a/src/thread.h +++ b/src/thread.h @@ -196,8 +196,6 @@ struct thread_state struct bc_thread_state bc; } GCALIGNED_STRUCT; -INLINE_HEADER_BEGIN - INLINE bool THREADP (Lisp_Object a) { commit 9fcdd5b63fcb5f9c6fba9884911f305806980fd5 Author: Eli Zaretskii Date: Sun Mar 20 18:21:44 2022 +0200 Improve doc strings of read-char-from-minibuffer-insert-* commands * lisp/subr.el (read-char-from-minibuffer-insert-char) (read-char-from-minibuffer-insert-other): Clarify the doc strings. (Bug#54479) diff --git a/lisp/subr.el b/lisp/subr.el index 8e5a65efcd..921853de60 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -3050,7 +3050,7 @@ If there is a natural number at point, use it as default." (make-hash-table :test 'equal)) (defun read-char-from-minibuffer-insert-char () - "Insert the character you type in the minibuffer and exit. + "Insert the character you type into the minibuffer and exit minibuffer. Discard all previous input before inserting and exiting the minibuffer." (interactive) (when (minibufferp) @@ -3059,9 +3059,11 @@ Discard all previous input before inserting and exiting the minibuffer." (exit-minibuffer))) (defun read-char-from-minibuffer-insert-other () - "Handle inserting of a character other than allowed. -Display an error on trying to insert a disallowed character. -Also discard all previous input in the minibuffer." + "Reject a disallowed character typed into the minibuffer. +This command is intended to be bound to keys that users are not +allowed to type into the minibuffer. When the user types any +such key, this command discard all minibuffer input and displays +an error message." (interactive) (when (minibufferp) (delete-minibuffer-contents) commit 0afef91fa1ee667d8797318011cd8eabc998f4e1 Author: Po Lu Date: Sun Mar 20 21:19:31 2022 +0800 Fix confusion of wanted action with actual action on X * src/xterm.c (x_dnd_begin_drag_and_drop) (x_dnd_update_state, handle_one_xevent): Differentiate between wanted action and chosen action correctly. diff --git a/src/xterm.c b/src/xterm.c index d094224952..7928f4fafb 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1349,11 +1349,11 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, FRAME_DISPLAY_INFO (f)->grabbed = 0; - if (x_dnd_wanted_action != None) + if (x_dnd_action != None) { block_input (); atom_name = XGetAtomName (FRAME_X_DISPLAY (f), - x_dnd_wanted_action); + x_dnd_action); action = intern (atom_name); XFree (atom_name); unblock_input (); @@ -10699,6 +10699,7 @@ x_dnd_update_state (struct x_display_info *dpyinfo) x_dnd_return_frame = 3; } + x_dnd_action = None; x_dnd_last_seen_window = target; x_dnd_last_protocol_version = target_proto; @@ -10710,8 +10711,9 @@ x_dnd_update_state (struct x_display_info *dpyinfo) if (x_dnd_last_protocol_version != -1 && target != None) x_dnd_send_position (x_dnd_frame, target, x_dnd_last_protocol_version, - root_x, root_y, x_dnd_selection_timestamp, - dpyinfo->Xatom_XdndActionCopy); + root_x, root_y, + x_dnd_selection_timestamp, + x_dnd_wanted_action); } /* The pointer moved out of the screen. */ else if (x_dnd_last_protocol_version) @@ -10825,12 +10827,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (event->xclient.data.l[1] & 1) { if (x_dnd_last_protocol_version >= 2) - x_dnd_wanted_action = event->xclient.data.l[4]; + x_dnd_action = event->xclient.data.l[4]; else - x_dnd_wanted_action = dpyinfo->Xatom_XdndActionCopy; + x_dnd_action = dpyinfo->Xatom_XdndActionCopy; } else - x_dnd_wanted_action = None; + x_dnd_action = None; } } @@ -10841,11 +10843,11 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_dnd_waiting_for_finish = false; if (x_dnd_waiting_for_finish_proto >= 5) - x_dnd_wanted_action = event->xclient.data.l[2]; + x_dnd_action = event->xclient.data.l[2]; if (x_dnd_waiting_for_finish_proto >= 5 && !(event->xclient.data.l[1] & 1)) - x_dnd_wanted_action = None; + x_dnd_action = None; } if (event->xclient.message_type == dpyinfo->Xatom_wm_protocols @@ -12005,12 +12007,22 @@ handle_one_xevent (struct x_display_info *dpyinfo, clear_mouse_face (hlinfo); } + f = mouse_or_wdesc_frame (dpyinfo, event->xmotion.window); + if (x_dnd_in_progress && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) { Window target; int target_proto; + /* Sometimes the drag-and-drop operation starts with the + pointer of a frame invisible due to input. Since + motion events are ignored during that, make the pointer + visible manually. */ + + if (f) + XTtoggle_invisible_pointer (f, false); + target = x_dnd_get_target_window (dpyinfo, event->xmotion.x_root, event->xmotion.y_root, @@ -12036,7 +12048,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_dnd_return_frame = 3; } - x_dnd_wanted_action = None; + x_dnd_action = None; x_dnd_last_seen_window = target; x_dnd_last_protocol_version = target_proto; @@ -12051,13 +12063,11 @@ handle_one_xevent (struct x_display_info *dpyinfo, event->xmotion.x_root, event->xmotion.y_root, x_dnd_selection_timestamp, - dpyinfo->Xatom_XdndActionCopy); + x_dnd_wanted_action); goto OTHER; } - f = mouse_or_wdesc_frame (dpyinfo, event->xmotion.window); - #ifdef USE_GTK if (f && xg_event_is_for_scrollbar (f, event, false)) f = 0; @@ -13254,12 +13264,22 @@ handle_one_xevent (struct x_display_info *dpyinfo, clear_mouse_face (hlinfo); } + f = mouse_or_wdesc_frame (dpyinfo, xev->event); + if (x_dnd_in_progress && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) { Window target; int target_proto; + /* Sometimes the drag-and-drop operation starts with the + pointer of a frame invisible due to input. Since + motion events are ignored during that, make the pointer + visible manually. */ + + if (f) + XTtoggle_invisible_pointer (f, false); + target = x_dnd_get_target_window (dpyinfo, xev->root_x, xev->root_y, @@ -13285,6 +13305,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_dnd_return_frame = 3; } + x_dnd_action = None; x_dnd_last_seen_window = target; x_dnd_last_protocol_version = target_proto; @@ -13298,13 +13319,11 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_dnd_last_protocol_version, xev->root_x, xev->root_y, x_dnd_selection_timestamp, - dpyinfo->Xatom_XdndActionCopy); + x_dnd_wanted_action); goto XI_OTHER; } - f = mouse_or_wdesc_frame (dpyinfo, xev->event); - #ifdef USE_GTK if (f && xg_event_is_for_scrollbar (f, event, false)) f = 0; commit 978681e78295d1f3457afb944d7ad4049039397f Author: Manuel Giraud Date: Sun Mar 20 11:08:31 2022 +0100 Fix wrong password stored in Tramp * lisp/net/tramp.el (tramp-process-actions): Unset `tramp-password-save-function'. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 38bdfab192..0192a63a10 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -5008,8 +5008,9 @@ performed successfully. Any other value means an error." (tramp-message vec 6 "\n%s" (buffer-string))) (if (eq exit 'ok) (ignore-errors - (and (functionp tramp-password-save-function) - (funcall tramp-password-save-function))) + (when (functionp tramp-password-save-function) + (funcall tramp-password-save-function) + (setq tramp-password-save-function nil))) ;; Not successful. (tramp-clear-passwd vec) (delete-process proc) commit e1178eb6405f8aa9196ecaede464707277a90afa Author: Po Lu Date: Sun Mar 20 16:21:45 2022 +0800 Make DND between frames work properly * src/xterm.c (handle_one_xevent): Don't wait for a finish event when dropping on top of another Emacs frame. diff --git a/src/xterm.c b/src/xterm.c index 98888414d5..d094224952 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -12429,7 +12429,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1) { - x_dnd_waiting_for_finish = true; + /* Crazy hack to make dragging from one frame to + another work. */ + x_dnd_waiting_for_finish = !x_any_window_to_frame (dpyinfo, + x_dnd_last_seen_window); x_dnd_pending_finish_target = x_dnd_last_seen_window; x_dnd_waiting_for_finish_proto = x_dnd_last_protocol_version; @@ -13414,7 +13417,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1) { - x_dnd_waiting_for_finish = true; + x_dnd_waiting_for_finish = !x_any_window_to_frame (dpyinfo, + x_dnd_last_seen_window); x_dnd_pending_finish_target = x_dnd_last_seen_window; x_dnd_waiting_for_finish_proto = x_dnd_last_protocol_version; commit 9bcf58d27c7c9ebe3bdd4d0564808767420bd44c (refs/remotes/origin/feature/completions-customs) Author: Jimmy Aguilar Mena Date: Thu Mar 17 23:28:07 2022 +0100 cursor-face-highlight-nonselected-window default to nil * lisp/simple.el (redisplay--update-cursor-face-highlight) : Use if-let* and not check facep. (cursor-face-highlight-nonselected-window) : default to nil diff --git a/lisp/simple.el b/lisp/simple.el index 42f3a80c3f..369e11e47c 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -6540,7 +6540,7 @@ The overlay is returned by the function.") (unless (equal new rol) (set-window-parameter window 'internal-region-overlay new)))))) -(defcustom cursor-face-highlight-nonselected-window cursor-in-non-selected-windows +(defcustom cursor-face-highlight-nonselected-window nil "Non-nil means highlight text with `cursor-face' even in nonselected windows. This variable is similar to `highlight-nonselected-windows'." :local t @@ -6550,14 +6550,12 @@ This variable is similar to `highlight-nonselected-windows'." (defun redisplay--update-cursor-face-highlight (window) "Highlights the overlay used to highlight text with cursor-face." (let ((rol (window-parameter window 'internal-cursor-face-overlay))) - (if-let (((or cursor-face-highlight-nonselected-window - (eq window (selected-window)) - (and (window-minibuffer-p) - (eq window (minibuffer-selected-window))))) - (pt (window-point window)) - (value (get-text-property pt 'cursor-face)) - ;; Extra code needed here for when passing plists. - (cursor-face (if (facep value) value))) + (if-let* (((or cursor-face-highlight-nonselected-window + (eq window (selected-window)) + (and (window-minibuffer-p) + (eq window (minibuffer-selected-window))))) + (pt (window-point window)) + (cursor-face (get-text-property pt 'cursor-face))) (let* ((start (previous-single-property-change (1+ pt) 'cursor-face nil (point-min))) (end (next-single-property-change commit d7d0f5b5a2d9705e6e3cf667677edc3e3f8ac9fc Author: Jimmy Aguilar Mena Date: Thu Mar 17 19:16:36 2022 +0100 Add new variable cursor-face-highlight-nonselected-window * lisp/simple.el (cursor-face-highlight-nonselected-window) : New custom default to cursor-in-non-selected-windows. (redisplay--update-cursor-face-highlight) : Extend highlight condition to consider the new variable. diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index b7377d3156..30036675e1 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -3553,11 +3553,15 @@ unhighlighted text. @item cursor-face @kindex cursor-face @r{(text property)} -This property is similar to @code{mouse-face} but the face is used the -cursor (instead of mouse) is on or near the character. Near has the -same meaning than in @code{mouse-face} and the highlight only takes -effect if the mode @code{cursor-face-highlight-mode} is enabled; -otherwise no highlight is performed. +This property is similar to @code{mouse-face} but the face is used if +the cursor (instead of mouse) is on or near the character. Near has +the same meaning than in @code{mouse-face} and the highlight only +takes effect if the mode @code{cursor-face-highlight-mode} is enabled; +otherwise no highlight is performed. When the variable +@code{cursor-face-highlight-nonselected-window} is non-@code{nil} the +text is highlighted even if the window is not selected similar to +@code{highlight-nonselected-windows} for the region. The default +value is the same of @code{cursor-in-non-selected-windows}. @item fontified @kindex fontified @r{(text property)} diff --git a/etc/NEWS b/etc/NEWS index 9e9ed6cb87..bb92e46310 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1264,7 +1264,9 @@ This allows setting a minimum display width for a region of text. +++ ** New 'cursor-face 'text' property. This uses cursor-face instead of the default face when cursor is on or -near the character and 'cursor-face-highlight-mode' is enabled. +near the character and 'cursor-face-highlight-mode' is enabled. The +variable 'highlight-nonselected-windows' is similar to +'highlight-nonselected-windows' but for this property. +++ ** New event type 'touch-end'. diff --git a/lisp/simple.el b/lisp/simple.el index a91895907d..42f3a80c3f 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -6540,10 +6540,18 @@ The overlay is returned by the function.") (unless (equal new rol) (set-window-parameter window 'internal-region-overlay new)))))) +(defcustom cursor-face-highlight-nonselected-window cursor-in-non-selected-windows + "Non-nil means highlight text with `cursor-face' even in nonselected windows. +This variable is similar to `highlight-nonselected-windows'." + :local t + :type 'boolean + :version "29.1") + (defun redisplay--update-cursor-face-highlight (window) "Highlights the overlay used to highlight text with cursor-face." (let ((rol (window-parameter window 'internal-cursor-face-overlay))) - (if-let (((or (eq window (selected-window)) + (if-let (((or cursor-face-highlight-nonselected-window + (eq window (selected-window)) (and (window-minibuffer-p) (eq window (minibuffer-selected-window))))) (pt (window-point window)) commit f96669e0a4a905cc857db389bf4c6b2d8382f3a5 Author: Stefan Monnier Date: Mon Mar 14 08:27:31 2022 -0400 * lisp/simple.el (cursor-face-highlight-mode): Fix copy&paste diff --git a/lisp/simple.el b/lisp/simple.el index 5768fb3c95..a91895907d 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -6572,8 +6572,8 @@ is set to the buffer displayed in that window.") (if cursor-face-highlight-mode (add-hook 'pre-redisplay-functions #'redisplay--update-cursor-face-highlight nil t) - (add-hook 'pre-redisplay-functions - #'redisplay--update-cursor-face-highlight t))) + (remove-hook 'pre-redisplay-functions + #'redisplay--update-cursor-face-highlight t))) (defun redisplay--pre-redisplay-functions (windows) (with-demoted-errors "redisplay--pre-redisplay-functions: %S" commit 11bfff37ad6cced524a43d1a0f77d2b691cabddf Author: Jimmy Aguilar Mena Date: Mon Mar 14 09:46:32 2022 +0100 Add local to remove-hook in cursor-face-highlight-mode Add LOCAL flag in remove-hook and reword the dock string. Thanks to Stefan Monnier for this diff --git a/lisp/simple.el b/lisp/simple.el index cada2e5571..5768fb3c95 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -6567,13 +6567,13 @@ which is the window that will be redisplayed. When run, the `current-buffer' is set to the buffer displayed in that window.") (define-minor-mode cursor-face-highlight-mode - "When enabled the cursor-face property is respected." + "When enabled, respect the cursor-face property." :global nil (if cursor-face-highlight-mode (add-hook 'pre-redisplay-functions #'redisplay--update-cursor-face-highlight nil t) (add-hook 'pre-redisplay-functions - #'redisplay--update-cursor-face-highlight))) + #'redisplay--update-cursor-face-highlight t))) (defun redisplay--pre-redisplay-functions (windows) (with-demoted-errors "redisplay--pre-redisplay-functions: %S" commit c1ea52f4ad2e673e364ca8565938ba3584126556 Author: Jimmy Aguilar Mena Date: Mon Mar 14 02:55:27 2022 +0100 Improve cursor-face-highlight-mode a bit more. Add the hook locally to the buffer only when needed to avoid even calling the function redisplay--update-cursor-face-highlight when the mode is enabled. * lisp/simple.el (redisplay--update-cursor-face-highlight) : Remove unneeded condition. (cursor-face-highlight-mode) : Conditionally add or remove redisplay--update-cursor-face-highlight to pre-redisplay-functions with buffer local flag. diff --git a/lisp/simple.el b/lisp/simple.el index 02f05ccb04..cada2e5571 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -6540,37 +6540,41 @@ The overlay is returned by the function.") (unless (equal new rol) (set-window-parameter window 'internal-region-overlay new)))))) -(define-minor-mode cursor-face-highlight-mode - "When enabled the cursor-face property is respected.") - (defun redisplay--update-cursor-face-highlight (window) "Highlights the overlay used to highlight text with cursor-face." - (when cursor-face-highlight-mode - (let ((rol (window-parameter window 'internal-cursor-face-overlay))) - (if-let (((or (eq window (selected-window)) - (and (window-minibuffer-p) - (eq window (minibuffer-selected-window))))) - (pt (window-point window)) - (value (get-text-property pt 'cursor-face)) - ;; Extra code needed here for when passing plists. - (cursor-face (if (facep value) value))) - (let* ((start (previous-single-property-change - (1+ pt) 'cursor-face nil (point-min))) - (end (next-single-property-change - pt 'cursor-face nil (point-max))) - (new (redisplay--highlight-overlay-function - start end window rol cursor-face))) - (unless (equal new rol) - (set-window-parameter window 'internal-cursor-face-overlay new))) - (redisplay--unhighlight-overlay-function rol))))) - -(defvar pre-redisplay-functions (list #'redisplay--update-cursor-face-highlight - #'redisplay--update-region-highlight) + (let ((rol (window-parameter window 'internal-cursor-face-overlay))) + (if-let (((or (eq window (selected-window)) + (and (window-minibuffer-p) + (eq window (minibuffer-selected-window))))) + (pt (window-point window)) + (value (get-text-property pt 'cursor-face)) + ;; Extra code needed here for when passing plists. + (cursor-face (if (facep value) value))) + (let* ((start (previous-single-property-change + (1+ pt) 'cursor-face nil (point-min))) + (end (next-single-property-change + pt 'cursor-face nil (point-max))) + (new (redisplay--highlight-overlay-function + start end window rol cursor-face))) + (unless (equal new rol) + (set-window-parameter window 'internal-cursor-face-overlay new))) + (redisplay--unhighlight-overlay-function rol)))) + +(defvar pre-redisplay-functions (list #'redisplay--update-region-highlight) "Hook run just before redisplay. It is called in each window that is to be redisplayed. It takes one argument, which is the window that will be redisplayed. When run, the `current-buffer' is set to the buffer displayed in that window.") +(define-minor-mode cursor-face-highlight-mode + "When enabled the cursor-face property is respected." + :global nil + (if cursor-face-highlight-mode + (add-hook 'pre-redisplay-functions + #'redisplay--update-cursor-face-highlight nil t) + (add-hook 'pre-redisplay-functions + #'redisplay--update-cursor-face-highlight))) + (defun redisplay--pre-redisplay-functions (windows) (with-demoted-errors "redisplay--pre-redisplay-functions: %S" (if (null windows) commit e06c4039c2d77f5cacb8c2a76e310e4a2e041fbc Author: Jimmy Aguilar Mena Date: Mon Mar 14 02:38:46 2022 +0100 Improve the cursor-face feature. Use a minor mode to reduce potential performance issues. * lisp/simple.el (cursor-face-highlight-mode) : New minor mode (completion-setup-function) : Use the new minor mode cursor-face-highlight-mode in completions. (redisplay--unhighlight-overlay-function) : Add -- to the name (redisplay--highlight-overlay-function) : Make the face parameter optional and add -- in the name. diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index a27d6f88c2..b7377d3156 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -3553,8 +3553,11 @@ unhighlighted text. @item cursor-face @kindex cursor-face @r{(text property)} -This property is similar to @code{mouse-face} but is used when the -cursor is on or near the character. +This property is similar to @code{mouse-face} but the face is used the +cursor (instead of mouse) is on or near the character. Near has the +same meaning than in @code{mouse-face} and the highlight only takes +effect if the mode @code{cursor-face-highlight-mode} is enabled; +otherwise no highlight is performed. @item fontified @kindex fontified @r{(text property)} diff --git a/etc/NEWS b/etc/NEWS index 69c3e16b56..9e9ed6cb87 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1264,7 +1264,7 @@ This allows setting a minimum display width for a region of text. +++ ** New 'cursor-face 'text' property. This uses cursor-face instead of the default face when cursor is on or -near the character. +near the character and 'cursor-face-highlight-mode' is enabled. +++ ** New event type 'touch-end'. diff --git a/lisp/simple.el b/lisp/simple.el index e20719f7a0..02f05ccb04 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -6482,15 +6482,17 @@ An example is a rectangular region handled as a list of separate contiguous regions for each line." (cdr (region-bounds))) -(defun redisplay-unhighlight-overlay-function (rol) +(defun redisplay--unhighlight-overlay-function (rol) "If ROL is an overlay, call ``delete-overlay''." (when (overlayp rol) (delete-overlay rol))) -(defvar redisplay-unhighlight-region-function #'redisplay-unhighlight-overlay-function +(defvar redisplay-unhighlight-region-function + #'redisplay--unhighlight-overlay-function "Function to remove the region-highlight overlay.") -(defun redisplay-highlight-overlay-function (start end window rol face) +(defun redisplay--highlight-overlay-function (start end window rol &optional face) "Update the overlay ROL in WINDOW with FACE in range START-END." + (unless face (setq face 'region)) (if (not (overlayp rol)) (let ((nrol (make-overlay start end))) (funcall redisplay-unhighlight-region-function rol) @@ -6510,7 +6512,8 @@ separate contiguous regions for each line." (move-overlay rol start end (current-buffer))) rol)) -(defvar redisplay-highlight-region-function #'redisplay-highlight-overlay-function +(defvar redisplay-highlight-region-function + #'redisplay--highlight-overlay-function "Function to move the region-highlight overlay. This function is called with four parameters, START, END, WINDOW and OVERLAY. If OVERLAY is nil, a new overlay is created. In @@ -6533,28 +6536,33 @@ The overlay is returned by the function.") (end (max pt mark)) (new (funcall redisplay-highlight-region-function - start end window rol 'region))) + start end window rol))) (unless (equal new rol) (set-window-parameter window 'internal-region-overlay new)))))) +(define-minor-mode cursor-face-highlight-mode + "When enabled the cursor-face property is respected.") + (defun redisplay--update-cursor-face-highlight (window) - "This highlights the overlay used to highlight text with cursor-face." - (let ((rol (window-parameter window 'internal-cursor-face-overlay)) - (pt) (value) (cursor-face)) - (if (and (or (eq window (selected-window)) - (and (window-minibuffer-p) - (eq window (minibuffer-selected-window)))) - (setq pt (window-point window)) - (setq value (get-text-property pt 'cursor-face)) - ;; extra code needed here for when passing plists - (setq cursor-face (if (facep value) value))) - (let* ((start (previous-single-property-change (1+ pt) 'cursor-face nil (point-min))) - (end (next-single-property-change pt 'cursor-face nil (point-max))) - (new (redisplay-highlight-overlay-function start end window rol cursor-face))) - (unless (equal new rol) - (set-window-parameter window 'internal-cursor-face-overlay new))) - (if rol - (redisplay-unhighlight-overlay-function rol))))) + "Highlights the overlay used to highlight text with cursor-face." + (when cursor-face-highlight-mode + (let ((rol (window-parameter window 'internal-cursor-face-overlay))) + (if-let (((or (eq window (selected-window)) + (and (window-minibuffer-p) + (eq window (minibuffer-selected-window))))) + (pt (window-point window)) + (value (get-text-property pt 'cursor-face)) + ;; Extra code needed here for when passing plists. + (cursor-face (if (facep value) value))) + (let* ((start (previous-single-property-change + (1+ pt) 'cursor-face nil (point-min))) + (end (next-single-property-change + pt 'cursor-face nil (point-max))) + (new (redisplay--highlight-overlay-function + start end window rol cursor-face))) + (unless (equal new rol) + (set-window-parameter window 'internal-cursor-face-overlay new))) + (redisplay--unhighlight-overlay-function rol))))) (defvar pre-redisplay-functions (list #'redisplay--update-cursor-face-highlight #'redisplay--update-region-highlight) @@ -9379,6 +9387,9 @@ Called from `temp-buffer-show-hook'." (if base-dir (setq default-directory base-dir)) (when completion-tab-width (setq tab-width completion-tab-width)) + ;; Maybe enable cursor completions-highlight. + (when completions-highlight-face + (cursor-face-highlight-mode 1)) ;; Maybe insert help string. (when completion-show-help (goto-char (point-min)) commit 7380b6f0adf94b785e693d494816b419b55bf7cb Author: Jimmy Aguilar Mena Date: Sun Mar 13 23:51:13 2022 +0100 Make the completion-header-format info more precise. diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index eca0464fdf..b66454f930 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -669,12 +669,13 @@ Reference Manual}). @vindex completion-header-format The variable @code{completion-header-format} is a formatted string to -control the message shown before completions. It may contain a ``%s'' -to show the total number of completions. If nil no completion header -is shown. Text properties may be added to change the appearance, some -useful ones are @code{face} or @code{cursor-intangible} -(@pxref{Special Properties,,Properties with Special Meanings, elisp, -The Emacs Lisp Reference Manual}). +control the informative line shown before the completions list of +candidates. It may contain a ``%s'' to show the total number of +completions. When it is @code{nil} the message is totally suppressed. +Text properties may be added to change the appearance, some useful +ones are @code{face} or @code{cursor-intangible} (@pxref{Special +Properties,,Properties with Special Meanings, elisp, The Emacs Lisp +Reference Manual}). @vindex completions-highlight-face When @code{completions-highlight-face} is a face name; then the commit 325548d726c881d4a8d42db11ebce72cb130f66a Author: Jimmy Aguilar Mena Date: Sun Mar 13 22:22:02 2022 +0100 Simplify unneeded condition. * lisp/minibuffer.el (display-completion-list) : The function completion--insert-string already has a condition for when completions is nil. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index d6d40d5b25..46e7bf2fb0 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2145,10 +2145,9 @@ candidates." (with-current-buffer standard-output (goto-char (point-max)) - (when completions - (when completion-header-format - (insert (format completion-header-format (length completions)))) - (completion--insert-strings completions group-fun)))) + (when completion-header-format + (insert (format completion-header-format (length completions)))) + (completion--insert-strings completions group-fun))) (run-hooks 'completion-setup-hook) nil) commit 2ce4c038ec27e5fc40a5adf54f7a8498f0692b88 Author: Jimmy Aguilar Mena Date: Sun Mar 13 21:35:48 2022 +0100 Rename hook * lisp/simple.el (redisplay--update-cursor-property-highlight) : Renamed to redisplay--update-cursor-property-highlight diff --git a/lisp/simple.el b/lisp/simple.el index cc356addb9..e20719f7a0 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -6537,7 +6537,7 @@ The overlay is returned by the function.") (unless (equal new rol) (set-window-parameter window 'internal-region-overlay new)))))) -(defun redisplay--update-cursor-property-highlight (window) +(defun redisplay--update-cursor-face-highlight (window) "This highlights the overlay used to highlight text with cursor-face." (let ((rol (window-parameter window 'internal-cursor-face-overlay)) (pt) (value) (cursor-face)) @@ -6556,7 +6556,7 @@ The overlay is returned by the function.") (if rol (redisplay-unhighlight-overlay-function rol))))) -(defvar pre-redisplay-functions (list #'redisplay--update-cursor-property-highlight +(defvar pre-redisplay-functions (list #'redisplay--update-cursor-face-highlight #'redisplay--update-region-highlight) "Hook run just before redisplay. It is called in each window that is to be redisplayed. It takes one argument, commit 3f17e3acb3f0cff731c555f2abb97c763f005fc4 Author: Jimmy Aguilar Mena Date: Sun Mar 13 20:42:08 2022 +0100 Extend completion-auto-help 'always and 'visible. Make them behave the same also with exact but not single completion. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 878a1104eb..d6d40d5b25 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1353,18 +1353,17 @@ when the buffer's text is already an exact match." (minibuffer-force-complete beg end)) (completed (cond - (exact - ;; If completion did not put point at end of field, - ;; it's a sign that completion is not finished. - (minibuffer-hide-completions) - (completion--done completion - (if (< comp-pos (length completion)) - 'exact 'unknown))) ((pcase completion-auto-help ('visible (get-buffer-window "*Completions*" 0)) ('always t)) (minibuffer-completion-help beg end)) - (t (minibuffer-hide-completions)))) + (t (minibuffer-hide-completions) + (when exact + ;; If completion did not put point at end of field, + ;; it's a sign that completion is not finished. + (completion--done completion + (if (< comp-pos (length completion)) + 'exact 'unknown)))))) ;; Show the completion table, if requested. ((not exact) (if (pcase completion-auto-help commit e303fa3e605bd9d0f43a5acaa39e9a24ac44e1db Author: Jimmy Aguilar Mena Date: Sun Mar 13 20:34:19 2022 +0100 Use the new cursor-face feature to highlight completions. * lisp/minibuffer.el (completions-highlight-face) : New custom. (completions-highlight-mode) : Removed diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index 718ac3ec7a..eca0464fdf 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -676,10 +676,12 @@ useful ones are @code{face} or @code{cursor-intangible} (@pxref{Special Properties,,Properties with Special Meanings, elisp, The Emacs Lisp Reference Manual}). -@vindex completions-highlight-mode -When the mode @code{completions-highlight-mode} is active the candidate -under the cursor is highlighted when the completion window is -selected. The mode uses the face @code{completions-highlight}. +@vindex completions-highlight-face +When @code{completions-highlight-face} is a face name; then the +current completion candidate will be highlighted with that face. The +default value is @code{completions-highlight}. When the value is +@code{nil} no highlight is performed. This feature sets the text +property @code{cursor-face}. @node Minibuffer History @section Minibuffer History diff --git a/etc/NEWS b/etc/NEWS index 76da1787a2..69c3e16b56 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -574,9 +574,10 @@ It may contain a %s to show the total number of completions. If nil no completions are shown. +++ -*** New mode 'completions-highlight-mode'. -This mode highlights the current candidate in the *Completions* buffer -with the 'completions-highlight' face. +*** New option 'completions-highlight-face'. +When this variable is a face name it highlights the current candidate +in the *Completions* buffer with that face. When the value is nil no +highlight is performed at all. ** Isearch and Replace diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 0cab09bd98..878a1104eb 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2035,7 +2035,7 @@ Runs of equal candidate strings are eliminated. GROUP-FUN is a (funcall group-fun str 'transform) str)) (point)) - `(mouse-face highlight completion--string ,str)) + `(mouse-face highlight cursor-face ,completions-highlight-face completion--string ,str)) ;; If `str' is a list that has 2 elements, ;; then the second element is a suffix annotation. ;; If `str' has 3 elements, then the second element @@ -2156,49 +2156,15 @@ candidates." (defface completions-highlight - '((t :inherit highlight :extend t)) + '((t :inherit highlight)) "Default face for highlighting the current line in `completions-highlight-mode'." :version "29.1") -(defvar completions--overlay nil - "Overlay to use when `completions-highlight-mode' is enabled.") - -(defun completions-highlight--delete () - "Highlight current candidate in *Completions* with `completions-highlight'." - (when (overlayp completions--overlay) - (delete-overlay completions--overlay))) - -(defun completions-highlight--highlight () - "Highlight current candidate if point in a candidate." - (let* ((point (point)) - (hpoint (or (and (get-text-property point 'mouse-face) point) - (and (> point 1) (get-text-property (1- point) 'mouse-face) (1- point))))) - (when hpoint - (move-overlay completions--overlay - (previous-single-property-change (1+ hpoint) 'mouse-face nil (point-min)) - (next-single-property-change hpoint 'mouse-face nil (point-max)))))) - -(defun completions-highlight--setup-hook () - "Function to call when enabling the `completion-highlight-mode' mode. -It is called when showing the *Completions* buffer." - (with-current-buffer "*Completions*" - (completions-highlight--highlight) - (add-hook 'pre-command-hook #'completions-highlight--delete nil t) - (add-hook 'post-command-hook #'completions-highlight--highlight nil t))) - -;;;###autoload -(define-minor-mode completions-highlight-mode - "Completion highlight mode to enable candidates highlight in the minibuffer." - :global t - :group 'minibuffer - (cond - (completions-highlight-mode - (setq completions--overlay (make-overlay 0 0)) - (overlay-put completions--overlay 'face 'completions-highlight) - (add-hook 'completion-setup-hook #'completions-highlight--setup-hook t)) - (t - (remove-hook 'completion-setup-hook #'completions-highlight--setup-hook))) - (completions-highlight--delete)) +(defcustom completions-highlight-face 'completions-highlight + "A face name to highlight current completion candidate. +If the value is nil no highlight is performed." + :type '(choice (const nil) face) + :version "29.1") (defvar completion-extra-properties nil "Property list of extra properties of the current completion job. commit 10cb469ee81c0ff2ad3740e7099227d0a6907545 Author: Jimmy Aguilar Mena Date: Sun Mar 13 19:44:11 2022 +0100 Rename completion-header-string to completion-header-format And use a propertized default value. diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index b7a30b72bf..718ac3ec7a 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -667,14 +667,14 @@ control of the Completion window display properties you can use Alists,,Action Alists for Buffer Display, elisp, The Emacs Lisp Reference Manual}). -@vindex completion-header-string -The variable @code{completion-header-string} is a string to control -the message shown before completions. It may contain a ``%s'' to show -the total number of completions. If nil no completions are shown. -Text properties may be added to change the appearance, some useful -ones are @code{face} or @code{cursor-intangible} (@pxref{Special -Properties,,Properties with Special Meanings, elisp, The Emacs Lisp -Reference Manual}). +@vindex completion-header-format +The variable @code{completion-header-format} is a formatted string to +control the message shown before completions. It may contain a ``%s'' +to show the total number of completions. If nil no completion header +is shown. Text properties may be added to change the appearance, some +useful ones are @code{face} or @code{cursor-intangible} +(@pxref{Special Properties,,Properties with Special Meanings, elisp, +The Emacs Lisp Reference Manual}). @vindex completions-highlight-mode When the mode @code{completions-highlight-mode} is active the candidate diff --git a/etc/NEWS b/etc/NEWS index 22ba84f084..76da1787a2 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -568,7 +568,7 @@ some completion is made. This option limits the height of the "*Completions*" buffer. +++ -*** New option 'completion-header-string' +*** New option 'completion-header-format' This is a string to control the message to show before completions. It may contain a %s to show the total number of completions. If nil no completions are shown. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index c0281c6343..0cab09bd98 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1873,8 +1873,11 @@ completions." :type 'boolean :version "28.1") -(defcustom completion-header-string "Possible completions are (%s):\n" - "Propertized header text for completions list. +(defcustom completion-header-format + (propertize "%s possible completions:\n" + 'face 'shadow + :help "Please select a completion") + "Format of completions header. It may contain one %s to show the total count of completions. When nil no header is shown." :type '(choice (const :tag "No prefix" nil) @@ -2143,10 +2146,9 @@ candidates." (with-current-buffer standard-output (goto-char (point-max)) - (if (not completions) - (insert "There are no possible completions of what you have typed.") - (when completion-header-string - (insert (format completion-header-string (length completions)))) + (when completions + (when completion-header-format + (insert (format completion-header-format (length completions)))) (completion--insert-strings completions group-fun)))) (run-hooks 'completion-setup-hook) commit fd7bde612ab7a027651ffa29cb390aeb67679d8b Author: Jimmy Aguilar Mena Date: Sun Mar 13 19:26:23 2022 +0100 Add new special text attribute cursor-face Reuse the functions for highlight region. * lisp/simple.el (redisplay-unhighlight-overlay-function) : (redisplay-highlight-overlay-function) : New functions from previous lambda (redisplay-unhighlight-region-function) : (redisplay-highlight-region-function) : Redefined with the new functions. (redisplay--update-cursor-property-highlight) : New function for pre-redisplay-functions. diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 7897adeb05..a27d6f88c2 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -3551,6 +3551,11 @@ that alter the text size (e.g., @code{:height}, @code{:weight}, and @code{:slant}). Those attributes are always the same as for the unhighlighted text. +@item cursor-face +@kindex cursor-face @r{(text property)} +This property is similar to @code{mouse-face} but is used when the +cursor is on or near the character. + @item fontified @kindex fontified @r{(text property)} This property says whether the text is ready for display. If diff --git a/etc/NEWS b/etc/NEWS index c374a5b999..22ba84f084 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1260,6 +1260,11 @@ property. ** New 'min-width' 'display' property. This allows setting a minimum display width for a region of text. ++++ +** New 'cursor-face 'text' property. +This uses cursor-face instead of the default face when cursor is on or +near the character. + +++ ** New event type 'touch-end'. This event is sent whenever the user's finger moves off the mouse diff --git a/lisp/simple.el b/lisp/simple.el index accc119e2b..cc356addb9 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -6482,27 +6482,35 @@ An example is a rectangular region handled as a list of separate contiguous regions for each line." (cdr (region-bounds))) -(defvar redisplay-unhighlight-region-function - (lambda (rol) (when (overlayp rol) (delete-overlay rol)))) - -(defvar redisplay-highlight-region-function - (lambda (start end window rol) - (if (not (overlayp rol)) - (let ((nrol (make-overlay start end))) - (funcall redisplay-unhighlight-region-function rol) - (overlay-put nrol 'window window) - (overlay-put nrol 'face 'region) - ;; Normal priority so that a large region doesn't hide all the - ;; overlays within it, but high secondary priority so that if it - ;; ends/starts in the middle of a small overlay, that small overlay - ;; won't hide the region's boundaries. - (overlay-put nrol 'priority '(nil . 100)) - nrol) - (unless (and (eq (overlay-buffer rol) (current-buffer)) - (eq (overlay-start rol) start) - (eq (overlay-end rol) end)) - (move-overlay rol start end (current-buffer))) - rol)) +(defun redisplay-unhighlight-overlay-function (rol) + "If ROL is an overlay, call ``delete-overlay''." + (when (overlayp rol) (delete-overlay rol))) + +(defvar redisplay-unhighlight-region-function #'redisplay-unhighlight-overlay-function + "Function to remove the region-highlight overlay.") + +(defun redisplay-highlight-overlay-function (start end window rol face) + "Update the overlay ROL in WINDOW with FACE in range START-END." + (if (not (overlayp rol)) + (let ((nrol (make-overlay start end))) + (funcall redisplay-unhighlight-region-function rol) + (overlay-put nrol 'window window) + (overlay-put nrol 'face face) + ;; Normal priority so that a large region doesn't hide all the + ;; overlays within it, but high secondary priority so that if it + ;; ends/starts in the middle of a small overlay, that small overlay + ;; won't hide the region's boundaries. + (overlay-put nrol 'priority '(nil . 100)) + nrol) + (unless (eq (overlay-get rol 'face) face) + (overlay-put rol 'face face)) + (unless (and (eq (overlay-buffer rol) (current-buffer)) + (eq (overlay-start rol) start) + (eq (overlay-end rol) end)) + (move-overlay rol start end (current-buffer))) + rol)) + +(defvar redisplay-highlight-region-function #'redisplay-highlight-overlay-function "Function to move the region-highlight overlay. This function is called with four parameters, START, END, WINDOW and OVERLAY. If OVERLAY is nil, a new overlay is created. In @@ -6525,12 +6533,31 @@ The overlay is returned by the function.") (end (max pt mark)) (new (funcall redisplay-highlight-region-function - start end window rol))) + start end window rol 'region))) (unless (equal new rol) - (set-window-parameter window 'internal-region-overlay - new)))))) - -(defvar pre-redisplay-functions (list #'redisplay--update-region-highlight) + (set-window-parameter window 'internal-region-overlay new)))))) + +(defun redisplay--update-cursor-property-highlight (window) + "This highlights the overlay used to highlight text with cursor-face." + (let ((rol (window-parameter window 'internal-cursor-face-overlay)) + (pt) (value) (cursor-face)) + (if (and (or (eq window (selected-window)) + (and (window-minibuffer-p) + (eq window (minibuffer-selected-window)))) + (setq pt (window-point window)) + (setq value (get-text-property pt 'cursor-face)) + ;; extra code needed here for when passing plists + (setq cursor-face (if (facep value) value))) + (let* ((start (previous-single-property-change (1+ pt) 'cursor-face nil (point-min))) + (end (next-single-property-change pt 'cursor-face nil (point-max))) + (new (redisplay-highlight-overlay-function start end window rol cursor-face))) + (unless (equal new rol) + (set-window-parameter window 'internal-cursor-face-overlay new))) + (if rol + (redisplay-unhighlight-overlay-function rol))))) + +(defvar pre-redisplay-functions (list #'redisplay--update-cursor-property-highlight + #'redisplay--update-region-highlight) "Hook run just before redisplay. It is called in each window that is to be redisplayed. It takes one argument, which is the window that will be redisplayed. When run, the `current-buffer' commit 49d1fe522215d64639f62b4737c3e45f75f94eab Author: Jimmy Aguilar Mena Date: Sun Mar 13 16:04:58 2022 +0100 Make minibuffer-hide-completions interactive. Mainly to find a binding for it. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index c8af72667c..c0281c6343 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2432,6 +2432,7 @@ variables.") "Get rid of an out-of-date *Completions* buffer." ;; FIXME: We could/should use minibuffer-scroll-window here, but it ;; can also point to the minibuffer-parent-window, so it's a bit tricky. + (interactive) (let ((win (get-buffer-window "*Completions*" 0))) (if win (with-selected-window win (bury-buffer))))) commit 7a6c6f16689158fd8faadabc239378653d39ae7e Author: Jimmy Aguilar Mena Date: Sun Mar 13 15:59:13 2022 +0100 Add completion-header-string. * doc/emacs/mini.texi (completion-header-string): Remove completion-header-text-property-list and completion-lazy-count. (completion-header-string): Substitutes the removed variable. diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index 769acbcdd5..b7a30b72bf 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -667,17 +667,14 @@ control of the Completion window display properties you can use Alists,,Action Alists for Buffer Display, elisp, The Emacs Lisp Reference Manual}). -@vindex completion-lazy-count -@vindex completion-header-text-property-list - When the boolean variable @code{completion-lazy-count} is -non-@code{nil} the completions header line shows the total number of -completion candidates. With the text property list -@code{completion-header-text-property-list} (@pxref{Property -Lists,,Property Lists, elisp, The Emacs Lisp Reference Manual}) the -user can specify some text properties to the completions header line. -Some useful values may be @code{face}, @code{cursor-intangible} or -@code{invisible} (@pxref{Special Properties,,Properties with Special -Meanings, elisp, The Emacs Lisp Reference Manual}). +@vindex completion-header-string +The variable @code{completion-header-string} is a string to control +the message shown before completions. It may contain a ``%s'' to show +the total number of completions. If nil no completions are shown. +Text properties may be added to change the appearance, some useful +ones are @code{face} or @code{cursor-intangible} (@pxref{Special +Properties,,Properties with Special Meanings, elisp, The Emacs Lisp +Reference Manual}). @vindex completions-highlight-mode When the mode @code{completions-highlight-mode} is active the candidate diff --git a/etc/NEWS b/etc/NEWS index 041d3c9d19..c374a5b999 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -568,13 +568,10 @@ some completion is made. This option limits the height of the "*Completions*" buffer. +++ -*** New option 'completion-header-text-property-list' -List of text properties to add to the header line of completions. - -+++ -*** New option 'completion-lazy-count' -When non-nil the completions header line shows the total number of -completion candidates. +*** New option 'completion-header-string' +This is a string to control the message to show before completions. +It may contain a %s to show the total number of completions. If nil no +completions are shown. +++ *** New mode 'completions-highlight-mode'. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 1768673bcb..c8af72667c 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1873,18 +1873,12 @@ completions." :type 'boolean :version "28.1") -(defcustom completion-header-text-property-list nil - "List of text properties to add to the header line of completions. -For example you can change the header color to red setting this -to: `(face (:foreground ``red'')). Some useful properties may be -`cursor-intangible' or `invisible'. See Info node `(elisp) Special -Properties'." - :type 'plist - :version "29.1") - -(defcustom completion-lazy-count nil - "When non-nil, display the total number of candidates in the completions header." - :type 'boolean +(defcustom completion-header-string "Possible completions are (%s):\n" + "Propertized header text for completions list. +It may contain one %s to show the total count of completions. +When nil no header is shown." + :type '(choice (const :tag "No prefix" nil) + (string :tag "Prefix format string")) :version "29.1") (defun completion--insert-strings (strings &optional group-fun) @@ -2149,18 +2143,11 @@ candidates." (with-current-buffer standard-output (goto-char (point-max)) - (if completions - (let ((start (point)) - (text (concat - "Possible completions are" - (if completion-lazy-count - (format " (%s)" (length completions))) - ":\n"))) - (insert text) - (when completion-header-text-property-list - (add-text-properties start (point) completion-header-text-property-list)) - (completion--insert-strings completions group-fun)) - (insert "There are no possible completions of what you have typed.")))) + (if (not completions) + (insert "There are no possible completions of what you have typed.") + (when completion-header-string + (insert (format completion-header-string (length completions)))) + (completion--insert-strings completions group-fun)))) (run-hooks 'completion-setup-hook) nil) commit e28309ce053be8736176109755cb492fea338b20 Author: Jimmy Aguilar Mena Date: Sat Mar 12 00:54:39 2022 +0100 Add two new options for completions. * doc/emacs/mini.texi (completion-lazy-count): (completion-header-text-property-list) : New customs Updated NEWS and manual. diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index 7224c48613..769acbcdd5 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -667,6 +667,18 @@ control of the Completion window display properties you can use Alists,,Action Alists for Buffer Display, elisp, The Emacs Lisp Reference Manual}). +@vindex completion-lazy-count +@vindex completion-header-text-property-list + When the boolean variable @code{completion-lazy-count} is +non-@code{nil} the completions header line shows the total number of +completion candidates. With the text property list +@code{completion-header-text-property-list} (@pxref{Property +Lists,,Property Lists, elisp, The Emacs Lisp Reference Manual}) the +user can specify some text properties to the completions header line. +Some useful values may be @code{face}, @code{cursor-intangible} or +@code{invisible} (@pxref{Special Properties,,Properties with Special +Meanings, elisp, The Emacs Lisp Reference Manual}). + @vindex completions-highlight-mode When the mode @code{completions-highlight-mode} is active the candidate under the cursor is highlighted when the completion window is diff --git a/etc/NEWS b/etc/NEWS index 9ea6512dca..041d3c9d19 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -567,11 +567,21 @@ some completion is made. *** New user option 'completions-max-height'. This option limits the height of the "*Completions*" buffer. ++++ +*** New option 'completion-header-text-property-list' +List of text properties to add to the header line of completions. + ++++ +*** New option 'completion-lazy-count' +When non-nil the completions header line shows the total number of +completion candidates. + +++ *** New mode 'completions-highlight-mode'. This mode highlights the current candidate in the *Completions* buffer with the 'completions-highlight' face. + ** Isearch and Replace +++ diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 9ac18f8df9..1768673bcb 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1873,6 +1873,20 @@ completions." :type 'boolean :version "28.1") +(defcustom completion-header-text-property-list nil + "List of text properties to add to the header line of completions. +For example you can change the header color to red setting this +to: `(face (:foreground ``red'')). Some useful properties may be +`cursor-intangible' or `invisible'. See Info node `(elisp) Special +Properties'." + :type 'plist + :version "29.1") + +(defcustom completion-lazy-count nil + "When non-nil, display the total number of candidates in the completions header." + :type 'boolean + :version "29.1") + (defun completion--insert-strings (strings &optional group-fun) "Insert a list of STRINGS into the current buffer. The candidate strings are inserted into the buffer depending on the @@ -2135,10 +2149,18 @@ candidates." (with-current-buffer standard-output (goto-char (point-max)) - (if (null completions) - (insert "There are no possible completions of what you have typed.") - (insert "Possible completions are:\n") - (completion--insert-strings completions group-fun)))) + (if completions + (let ((start (point)) + (text (concat + "Possible completions are" + (if completion-lazy-count + (format " (%s)" (length completions))) + ":\n"))) + (insert text) + (when completion-header-text-property-list + (add-text-properties start (point) completion-header-text-property-list)) + (completion--insert-strings completions group-fun)) + (insert "There are no possible completions of what you have typed.")))) (run-hooks 'completion-setup-hook) nil) commit 7b62bef2d3ed7d998b8d50b7ce7f7ec8c5fe7db1 Author: Juri Linkov Date: Thu Mar 10 20:48:48 2022 +0200 Fix new option completions-max-height and new values for completion-auto-help * doc/emacs/mini.texi (Completion Options): Fix pxref for "Buffer Display Action Alists". * lisp/minibuffer.el (completion-auto-help): Explain new values in docstring. (completions-max-height): Use choice to allow nil. diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index afacb9c7cd..7224c48613 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -632,7 +632,7 @@ completion list buffer. With the previous values and the default @code{t} the completions are hidden when some unique completion is executed. If @code{completion-auto-help} is set to @code{always} the completion commands are always shown after a completion attempt or -updated if they are already visible. If the value is @code{visible} +updated if they are already visible. If the value is @code{visible} then completions are not hidden, but updated if they are already visible while the current behavior stays the same as default if they are not. @@ -660,13 +660,15 @@ and if @code{one-column}, just use a single column. @vindex completions-max-height When @code{completions-max-height} is non-@code{nil} it limits the -size of the completions window. It is specified in lines and include +size of the completions window. It is specified in lines and include mode, header line and a bottom divider, if any. For a more complex control of the Completion window display properties you can use -@code{display-buffer-alist} (@pxref{Buffer Display Action Alists}). +@code{display-buffer-alist} (@pxref{Buffer Display Action +Alists,,Action Alists for Buffer Display, elisp, The Emacs Lisp +Reference Manual}). @vindex completions-highlight-mode -When the mode @{completions-highlight-mode} is active the candidate +When the mode @code{completions-highlight-mode} is active the candidate under the cursor is highlighted when the completion window is selected. The mode uses the face @code{completions-highlight}. diff --git a/etc/NEWS b/etc/NEWS index 05f219ca03..9ea6512dca 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -554,20 +554,23 @@ This option controls the sorting of the completion candidates in the "*Completions*" buffer. Available styles are no sorting, alphabetical (the default), or a custom sort function. -*** New values for the 'completion-auto-select' option. ++++ +*** New values for the 'completion-auto-help' option. There are two new values to control the way *Completions* behave after -a if completion is not unique. 'always updates or shows -the *Completions* buffer after any attempt to complete. 'visual is -like 'always, but only update the completions if they are already -visible. The default value t always hide the completion buffer after +a if completion is not unique. 'always' updates or shows +the *Completions* buffer after any attempt to complete. 'visual' is +like 'always', but only update the completions if they are already +visible. The default value 't' always hides the completion buffer after some completion is made. ++++ *** New user option 'completions-max-height'. This option limits the height of the "*Completions*" buffer. -*** New mode completions-highlight. ++++ +*** New mode 'completions-highlight-mode'. This mode highlights the current candidate in the *Completions* buffer -with the completions-highlight face. +with the 'completions-highlight' face. ** Isearch and Replace diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 148ba7a873..9ac18f8df9 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -897,7 +897,12 @@ If the current buffer is not a minibuffer, erase its entire contents." If the value is t the *Completions* buffer is displayed whenever completion is requested but cannot be done. If the value is `lazy', the *Completions* buffer is only displayed after -the second failed attempt to complete." +the second failed attempt to complete. +If the value is 'always', the completion commands are always shown +after a completion attempt or updated if they are already visible. +If the value is 'visible' then completions are not hidden, but updated +if they are already visible while the current behavior stays the same +as default if they are not." :type '(choice (const :tag "Disabled" nil) (const :tag "Enabled legacy" t) (const :tag "After a second attempt" lazy) @@ -2141,14 +2146,14 @@ candidates." (defface completions-highlight '((t :inherit highlight :extend t)) - "Default face for highlighting the current line in Hl-Line mode." + "Default face for highlighting the current line in `completions-highlight-mode'." :version "29.1") (defvar completions--overlay nil "Overlay to use when `completions-highlight-mode' is enabled.") (defun completions-highlight--delete () - "Highlight current candidate in *Completions* when ``completions-highlight''." + "Highlight current candidate in *Completions* with `completions-highlight'." (when (overlayp completions--overlay) (delete-overlay completions--overlay))) @@ -2253,7 +2258,7 @@ variables.") (defcustom completions-max-height nil "Maximum height for *Completions* buffer." - :type 'natnum + :type '(choice (const nil) natnum) :version "29.1") (defun completions--fit-window-to-buffer (&optional win &rest _) commit e683e60fad69914eb0c33c9ad83b819b160fd5a2 Author: Jimmy Aguilar Mena Date: Thu Mar 10 14:36:02 2022 +0100 Add new mode completions-highlight-mode. diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index eb2bfce136..afacb9c7cd 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -665,6 +665,11 @@ mode, header line and a bottom divider, if any. For a more complex control of the Completion window display properties you can use @code{display-buffer-alist} (@pxref{Buffer Display Action Alists}). +@vindex completions-highlight-mode +When the mode @{completions-highlight-mode} is active the candidate +under the cursor is highlighted when the completion window is +selected. The mode uses the face @code{completions-highlight}. + @node Minibuffer History @section Minibuffer History @cindex minibuffer history diff --git a/etc/NEWS b/etc/NEWS index 5a0d6c8fdb..05f219ca03 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -565,6 +565,9 @@ some completion is made. *** New user option 'completions-max-height'. This option limits the height of the "*Completions*" buffer. +*** New mode completions-highlight. +This mode highlights the current candidate in the *Completions* buffer +with the completions-highlight face. ** Isearch and Replace diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index cd0c274765..148ba7a873 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2138,6 +2138,52 @@ candidates." (run-hooks 'completion-setup-hook) nil) + +(defface completions-highlight + '((t :inherit highlight :extend t)) + "Default face for highlighting the current line in Hl-Line mode." + :version "29.1") + +(defvar completions--overlay nil + "Overlay to use when `completions-highlight-mode' is enabled.") + +(defun completions-highlight--delete () + "Highlight current candidate in *Completions* when ``completions-highlight''." + (when (overlayp completions--overlay) + (delete-overlay completions--overlay))) + +(defun completions-highlight--highlight () + "Highlight current candidate if point in a candidate." + (let* ((point (point)) + (hpoint (or (and (get-text-property point 'mouse-face) point) + (and (> point 1) (get-text-property (1- point) 'mouse-face) (1- point))))) + (when hpoint + (move-overlay completions--overlay + (previous-single-property-change (1+ hpoint) 'mouse-face nil (point-min)) + (next-single-property-change hpoint 'mouse-face nil (point-max)))))) + +(defun completions-highlight--setup-hook () + "Function to call when enabling the `completion-highlight-mode' mode. +It is called when showing the *Completions* buffer." + (with-current-buffer "*Completions*" + (completions-highlight--highlight) + (add-hook 'pre-command-hook #'completions-highlight--delete nil t) + (add-hook 'post-command-hook #'completions-highlight--highlight nil t))) + +;;;###autoload +(define-minor-mode completions-highlight-mode + "Completion highlight mode to enable candidates highlight in the minibuffer." + :global t + :group 'minibuffer + (cond + (completions-highlight-mode + (setq completions--overlay (make-overlay 0 0)) + (overlay-put completions--overlay 'face 'completions-highlight) + (add-hook 'completion-setup-hook #'completions-highlight--setup-hook t)) + (t + (remove-hook 'completion-setup-hook #'completions-highlight--setup-hook))) + (completions-highlight--delete)) + (defvar completion-extra-properties nil "Property list of extra properties of the current completion job. These include: commit 09b548fd5e7860f363a3d5bf6f975f577b9cd43e Author: Jimmy Aguilar Mena Date: Tue Mar 8 12:46:56 2022 +0100 completions-max-height new custom variable. diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index 5d351dd10b..eb2bfce136 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -658,6 +658,13 @@ changed by changing the @code{completions-format} user option. If @code{vertical}, sort the completions vertically in columns instead, and if @code{one-column}, just use a single column. +@vindex completions-max-height + When @code{completions-max-height} is non-@code{nil} it limits the +size of the completions window. It is specified in lines and include +mode, header line and a bottom divider, if any. For a more complex +control of the Completion window display properties you can use +@code{display-buffer-alist} (@pxref{Buffer Display Action Alists}). + @node Minibuffer History @section Minibuffer History @cindex minibuffer history diff --git a/etc/NEWS b/etc/NEWS index 3d32513386..5a0d6c8fdb 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -555,7 +555,6 @@ the "*Completions*" buffer. Available styles are no sorting, alphabetical (the default), or a custom sort function. *** New values for the 'completion-auto-select' option. - There are two new values to control the way *Completions* behave after a if completion is not unique. 'always updates or shows the *Completions* buffer after any attempt to complete. 'visual is @@ -563,6 +562,10 @@ like 'always, but only update the completions if they are already visible. The default value t always hide the completion buffer after some completion is made. +*** New user option 'completions-max-height'. +This option limits the height of the "*Completions*" buffer. + + ** Isearch and Replace +++ diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index c6a803cbc4..cd0c274765 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2205,6 +2205,19 @@ variables.") (equal pre-msg (and exit-fun (current-message)))) (completion--message message)))) +(defcustom completions-max-height nil + "Maximum height for *Completions* buffer." + :type 'natnum + :version "29.1") + +(defun completions--fit-window-to-buffer (&optional win &rest _) + "Resize completions." + (if temp-buffer-resize-mode + (let ((temp-buffer-max-height (or completions-max-height + temp-buffer-max-height))) + (resize-temp-buffer-window win)) + (fit-window-to-buffer win completions-max-height))) + (defun minibuffer-completion-help (&optional start end) "Display a list of possible completions of the current minibuffer contents." (interactive) @@ -2268,9 +2281,7 @@ variables.") ,(if (eq (selected-window) (minibuffer-window)) 'display-buffer-at-bottom 'display-buffer-below-selected)) - ,(if temp-buffer-resize-mode - '(window-height . resize-temp-buffer-window) - '(window-height . fit-window-to-buffer)) + (window-height . completions--fit-window-to-buffer) ,(when temp-buffer-resize-mode '(preserve-size . (nil . t))) (body-function commit 6b3c665d2a8070791dff6520652c00c7b44d64bd Author: Jimmy Aguilar Mena Date: Thu Mar 10 11:24:17 2022 +0100 completion-auto-help new values. Added also entries to news and manual diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index 13d9269c68..5d351dd10b 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -628,7 +628,14 @@ commands never display the completion list buffer; you must type shows the completion list buffer on the second attempt to complete. In other words, if there is nothing to complete, the first @key{TAB} echoes @samp{Next char not unique}; the second @key{TAB} shows the -completion list buffer. +completion list buffer. With the previous values and the default +@code{t} the completions are hidden when some unique completion is +executed. If @code{completion-auto-help} is set to @code{always} the +completion commands are always shown after a completion attempt or +updated if they are already visible. If the value is @code{visible} +then completions are not hidden, but updated if they are already +visible while the current behavior stays the same as default if they +are not. @vindex completion-cycle-threshold If @code{completion-cycle-threshold} is non-@code{nil}, completion diff --git a/etc/NEWS b/etc/NEWS index 80cf0a2f72..3d32513386 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -554,6 +554,15 @@ This option controls the sorting of the completion candidates in the "*Completions*" buffer. Available styles are no sorting, alphabetical (the default), or a custom sort function. +*** New values for the 'completion-auto-select' option. + +There are two new values to control the way *Completions* behave after +a if completion is not unique. 'always updates or shows +the *Completions* buffer after any attempt to complete. 'visual is +like 'always, but only update the completions if they are already +visible. The default value t always hide the completion buffer after +some completion is made. + ** Isearch and Replace +++ diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 36b8d80841..c6a803cbc4 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -898,7 +898,11 @@ If the value is t the *Completions* buffer is displayed whenever completion is requested but cannot be done. If the value is `lazy', the *Completions* buffer is only displayed after the second failed attempt to complete." - :type '(choice (const nil) (const t) (const lazy))) + :type '(choice (const :tag "Disabled" nil) + (const :tag "Enabled legacy" t) + (const :tag "After a second attempt" lazy) + (const :tag "Visible update" visible) + (const :tag "Always update" always))) (defvar completion-styles-alist '((emacs21 @@ -1343,16 +1347,19 @@ when the buffer's text is already an exact match." (completion--cache-all-sorted-completions beg end comps) (minibuffer-force-complete beg end)) (completed - ;; We could also decide to refresh the completions, - ;; if they're displayed (and assuming there are - ;; completions left). - (minibuffer-hide-completions) - (if exact - ;; If completion did not put point at end of field, - ;; it's a sign that completion is not finished. - (completion--done completion - (if (< comp-pos (length completion)) - 'exact 'unknown)))) + (cond + (exact + ;; If completion did not put point at end of field, + ;; it's a sign that completion is not finished. + (minibuffer-hide-completions) + (completion--done completion + (if (< comp-pos (length completion)) + 'exact 'unknown))) + ((pcase completion-auto-help + ('visible (get-buffer-window "*Completions*" 0)) + ('always t)) + (minibuffer-completion-help beg end)) + (t (minibuffer-hide-completions)))) ;; Show the completion table, if requested. ((not exact) (if (pcase completion-auto-help