commit d7fc7bdd81acd37fda8c094754e3f118e11a3b2a (HEAD, refs/remotes/origin/master) Author: Po Lu Date: Sun Feb 20 10:05:46 2022 +0800 Fix typo in last change * src/xterm.c (handle_one_xevent): Use `xi_done_keysym' label when ignoring modifier keys from XI2 input. diff --git a/src/xterm.c b/src/xterm.c index 4c1c431217..01de3e27b9 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -11576,7 +11576,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, XkbDescRec *rec = FRAME_DISPLAY_INFO (f)->xkb_desc; if (rec->map->modmap && rec->map->modmap[xev->detail]) - goto done_keysym; + goto xi_done_keysym; } else #endif @@ -11586,7 +11586,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, for (i = 0; i < 8 * dpyinfo->modmap->max_keypermod; i++) { if (xkey.keycode == dpyinfo->modmap->modifiermap[xev->detail]) - goto done_keysym; + goto xi_done_keysym; } } } commit 15910e5da34a084fe01e0fd96ecf394cb1030e25 Author: Po Lu Date: Sun Feb 20 10:03:28 2022 +0800 Ignore modifier keys early when handling X key press events * src/xterm.c (handle_one_xevent): Ignore modifier keys earlier without going through the usual key lookup. (x_delete_terminal): Free recorded modifier map. (x_find_modifier_meanings): Record modifier map. * src/xterm.h (struct x_display_info): New field `modmap'. diff --git a/src/xterm.c b/src/xterm.c index 64bee11022..4c1c431217 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -6162,7 +6162,10 @@ x_find_modifier_meanings (struct x_display_info *dpyinfo) dpyinfo->hyper_mod_mask &= ~dpyinfo->super_mod_mask; XFree (syms); - XFreeModifiermap (mods); + + if (dpyinfo->modmap) + XFreeModifiermap (dpyinfo->modmap); + dpyinfo->modmap = mods; } /* Convert between the modifier bits X uses and the modifier bits @@ -9893,6 +9896,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, /* `xkey' will be modified, but it's not important to modify `event' itself. */ XKeyEvent xkey = event->xkey; + int i; #ifdef USE_GTK /* Don't pass keys to GTK. A Tab will shift focus to the @@ -9924,6 +9928,27 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (modifiers & dpyinfo->meta_mod_mask) memset (&compose_status, 0, sizeof (compose_status)); +#ifdef HAVE_XKB + if (FRAME_DISPLAY_INFO (f)->xkb_desc) + { + XkbDescRec *rec = FRAME_DISPLAY_INFO (f)->xkb_desc; + + if (rec->map->modmap && rec->map->modmap[xkey.keycode]) + goto done_keysym; + } + else +#endif + { + if (dpyinfo->modmap) + { + for (i = 0; i < 8 * dpyinfo->modmap->max_keypermod; i++) + { + if (xkey.keycode == dpyinfo->modmap->modifiermap[i]) + goto done_keysym; + } + } + } + #ifdef HAVE_X_I18N if (FRAME_XIC (f)) { @@ -11545,6 +11570,27 @@ handle_one_xevent (struct x_display_info *dpyinfo, } #endif +#ifdef HAVE_XKB + if (FRAME_DISPLAY_INFO (f)->xkb_desc) + { + XkbDescRec *rec = FRAME_DISPLAY_INFO (f)->xkb_desc; + + if (rec->map->modmap && rec->map->modmap[xev->detail]) + goto done_keysym; + } + else +#endif + { + if (dpyinfo->modmap) + { + for (i = 0; i < 8 * dpyinfo->modmap->max_keypermod; i++) + { + if (xkey.keycode == dpyinfo->modmap->modifiermap[xev->detail]) + goto done_keysym; + } + } + } + #ifdef HAVE_XKB if (dpyinfo->xkb_desc) { @@ -16743,6 +16789,9 @@ x_delete_terminal (struct terminal *terminal) XCloseDisplay (dpyinfo->display); #endif #endif /* ! USE_GTK */ + + if (dpyinfo->modmap) + XFreeModifiermap (dpyinfo->modmap); /* Do not close the connection here because it's already closed by X(t)CloseDisplay (Bug#18403). */ dpyinfo->display = NULL; diff --git a/src/xterm.h b/src/xterm.h index f58fa0fe54..14457b32cc 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -526,6 +526,9 @@ struct x_display_info Atom Xatom_Meta, Xatom_Super, Xatom_Hyper, Xatom_ShiftLock, Xatom_Alt; #endif + /* Core modifier map when XKB is not present. */ + XModifierKeymap *modmap; + #ifdef HAVE_XRANDR int xrandr_major_version; int xrandr_minor_version; commit 7a699e79f6e2616dbbc3acc2024f97c90caa485c Author: Po Lu Date: Sun Feb 20 09:14:00 2022 +0800 Free XI2 devices in x_delete_display instead * src/xterm.c (x_delete_display): Free XI2 device data here instead, since it doesn't involve contacting the X server any more. (x_delete_terminal): Stop freeing XI2 device data. diff --git a/src/xterm.c b/src/xterm.c index e2ad0b48f5..64bee11022 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -16584,6 +16584,11 @@ x_delete_display (struct x_display_info *dpyinfo) xfree (dpyinfo->x_dnd_atoms); xfree (dpyinfo->color_cells); xfree (dpyinfo); + +#ifdef HAVE_XINPUT2 + if (dpyinfo->supports_xi2) + x_free_xi_devices (dpyinfo); +#endif } #ifdef USE_X_TOOLKIT @@ -16729,10 +16734,6 @@ x_delete_terminal (struct terminal *terminal) if (dpyinfo->xkb_desc) XkbFreeKeyboard (dpyinfo->xkb_desc, XkbAllComponentsMask, True); #endif -#ifdef HAVE_XINPUT2 - if (dpyinfo->supports_xi2) - x_free_xi_devices (dpyinfo); -#endif #ifdef USE_GTK xg_display_close (dpyinfo->display); #else commit 5767e06b8e7662bc76c199b3bcb3d5d09c6d9ca2 Author: Philip Kaludercic Date: Sat Feb 19 22:04:44 2022 +0100 Revert "; * rcirc.el (rcirc-print): Prefer sleep-for over sit-for" diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 9bbba6dfbe..9d1600ed72 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -2043,7 +2043,7 @@ connection." rcirc-log-process-buffers)) (rcirc-log process sender response target text)) - (sleep-for 0) ; displayed text before hook + (sit-for 0) ; displayed text before hook (run-hook-with-args 'rcirc-print-functions process sender response target text))))) commit ecaedf2117cb015ad4028e4d6fc7058608c98096 Author: Stefan Monnier Date: Sat Feb 19 14:55:39 2022 -0500 (specpdl_unrewind): Fix corner case * src/lisp.h (enum specbind_tag): New elem SPECPDL_NOP. * src/eval.c (specpdl_unrewind): Zap entries that can't be applied any more, and simplify. (default_toplevel_binding, lexbound_p, Fbacktrace__locals): Simplify. (do_one_unbind, mark_specpdl): Handle SPECPDL_NOP. diff --git a/src/eval.c b/src/eval.c index d3342289fb..294d79e67a 100644 --- a/src/eval.c +++ b/src/eval.c @@ -664,23 +664,7 @@ default_toplevel_binding (Lisp_Object symbol) binding = pdl; break; - case SPECPDL_UNWIND: - case SPECPDL_UNWIND_ARRAY: - case SPECPDL_UNWIND_PTR: - case SPECPDL_UNWIND_INT: - case SPECPDL_UNWIND_INTMAX: - case SPECPDL_UNWIND_EXCURSION: - case SPECPDL_UNWIND_VOID: - case SPECPDL_BACKTRACE: -#ifdef HAVE_MODULES - case SPECPDL_MODULE_RUNTIME: - case SPECPDL_MODULE_ENVIRONMENT: -#endif - case SPECPDL_LET_LOCAL: - break; - - default: - emacs_abort (); + default: break; } } return binding; @@ -707,23 +691,7 @@ lexbound_p (Lisp_Object symbol) } break; - case SPECPDL_UNWIND: - case SPECPDL_UNWIND_ARRAY: - case SPECPDL_UNWIND_PTR: - case SPECPDL_UNWIND_INT: - case SPECPDL_UNWIND_INTMAX: - case SPECPDL_UNWIND_EXCURSION: - case SPECPDL_UNWIND_VOID: - case SPECPDL_BACKTRACE: -#ifdef HAVE_MODULES - case SPECPDL_MODULE_RUNTIME: - case SPECPDL_MODULE_ENVIRONMENT: -#endif - case SPECPDL_LET_LOCAL: - break; - - default: - emacs_abort (); + default: break; } } return false; @@ -3721,6 +3689,7 @@ do_one_unbind (union specbinding *this_binding, bool unwinding, this_binding->unwind_excursion.window); break; case SPECPDL_BACKTRACE: + case SPECPDL_NOP: break; #ifdef HAVE_MODULES case SPECPDL_MODULE_RUNTIME: @@ -4044,17 +4013,6 @@ specpdl_unrewind (union specbinding *pdl, int distance, bool vars_only) save_excursion_restore (marker, window); } break; - case SPECPDL_UNWIND_ARRAY: - case SPECPDL_UNWIND_PTR: - case SPECPDL_UNWIND_INT: - case SPECPDL_UNWIND_INTMAX: - case SPECPDL_UNWIND_VOID: - case SPECPDL_BACKTRACE: -#ifdef HAVE_MODULES - case SPECPDL_MODULE_RUNTIME: - case SPECPDL_MODULE_ENVIRONMENT: -#endif - break; case SPECPDL_LET: { /* If variable has a trivial value (no forwarding), we can just set it. No need to check for constant symbols here, @@ -4097,14 +4055,16 @@ specpdl_unrewind (union specbinding *pdl, int distance, bool vars_only) SET_INTERNAL_THREAD_SWITCH); } else - /* FIXME: If the var is not local any more, we failed - to swap the old and new values. As long as the var remains - non-local, this is fine, but if it ever reverts to being - local we may end up using this entry "in the wrong - direction". */ - {} + /* If the var is not local any more, it can't be undone nor + redone, so just zap it. + This is important in case the buffer re-gains a local value + before we unrewind again, in which case we'd risk applying + this entry in the wrong direction. */ + tmp->kind = SPECPDL_NOP; } break; + + default: break; } } } @@ -4195,22 +4155,7 @@ NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. } break; - case SPECPDL_UNWIND: - case SPECPDL_UNWIND_ARRAY: - case SPECPDL_UNWIND_PTR: - case SPECPDL_UNWIND_INT: - case SPECPDL_UNWIND_INTMAX: - case SPECPDL_UNWIND_EXCURSION: - case SPECPDL_UNWIND_VOID: - case SPECPDL_BACKTRACE: -#ifdef HAVE_MODULES - case SPECPDL_MODULE_RUNTIME: - case SPECPDL_MODULE_ENVIRONMENT: -#endif - break; - - default: - emacs_abort (); + default: break; } } } @@ -4274,8 +4219,12 @@ mark_specpdl (union specbinding *first, union specbinding *ptr) case SPECPDL_UNWIND_INT: case SPECPDL_UNWIND_INTMAX: case SPECPDL_UNWIND_VOID: + case SPECPDL_NOP: break; + /* While other loops that scan the specpdl use "default: break;" + for simplicity, here we explicitly list all cases and abort + if we find an unexpected value, as a sanity check. */ default: emacs_abort (); } diff --git a/src/lisp.h b/src/lisp.h index 19788ef07c..deeca9bc86 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3284,6 +3284,7 @@ enum specbind_tag { SPECPDL_UNWIND_EXCURSION, /* Likewise, on an excursion. */ SPECPDL_UNWIND_VOID, /* Likewise, with no arg. */ SPECPDL_BACKTRACE, /* An element of the backtrace. */ + SPECPDL_NOP, /* A filler. */ #ifdef HAVE_MODULES SPECPDL_MODULE_RUNTIME, /* A live module runtime. */ SPECPDL_MODULE_ENVIRONMENT, /* A live module environment. */ commit 43237f3d27897e2a0c6de745770802d0ba40e3a5 Author: Philip Kaludercic Date: Sat Feb 19 20:29:29 2022 +0100 ; * rcirc.el (rcirc-print): Prefer sleep-for over sit-for Compare (benchmark-run 100000 (sit-for 0)) ;; => (2.600030102 12 1.523461324000003) with (benchmark-run 100000 (sleep-for 0)) ;; (0.015882939 0 0.0) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 9d1600ed72..9bbba6dfbe 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -2043,7 +2043,7 @@ connection." rcirc-log-process-buffers)) (rcirc-log process sender response target text)) - (sit-for 0) ; displayed text before hook + (sleep-for 0) ; displayed text before hook (run-hook-with-args 'rcirc-print-functions process sender response target text))))) commit f262a6af3694b41828ffb8e62a800f8a3ed4e4aa Author: Stefan Monnier Date: Sat Feb 19 14:20:02 2022 -0500 (macroexp-warn-and-return): Fix bug#53618 * lisp/emacs-lisp/macroexp.el (macroexp-warn-and-return): Reorder arguments to preserve compatibility with that of Emacs-28. (macroexp--unfold-lambda, macroexp--expand-all): * lisp/emacs-lisp/pcase.el (pcase-compile-patterns, pcase--u1): * lisp/emacs-lisp/gv.el (gv-ref): * lisp/emacs-lisp/eieio.el (defclass): * lisp/emacs-lisp/eieio-core.el (eieio-oref, eieio-oref-default) (eieio-oset-default): * lisp/emacs-lisp/easy-mmode.el (define-minor-mode): * lisp/emacs-lisp/cl-macs.el (cl-symbol-macrolet, cl-defstruct): * lisp/emacs-lisp/cl-generic.el (cl-defmethod): * lisp/emacs-lisp/byte-run.el (defmacro, defun): * lisp/emacs-lisp/bindat.el (bindat--type): Adjust accordingly. diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 04c5b9f080..c6d64975ec 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -804,7 +804,6 @@ is the name of a variable that will hold the value we need to pack.") (if (or (eq label '_) (not (assq label labels))) code (macroexp-warn-and-return - code (format "Duplicate label: %S" label) code)))) (`(,_ ,val) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 5c59d0ae94..c542c55016 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -311,11 +311,10 @@ The return value is undefined. (let ((f (cdr (assq (car x) macro-declarations-alist)))) (if f (apply (car f) name arglist (cdr x)) (macroexp-warn-and-return - (car x) (format-message "Unknown macro property %S in %S" (car x) name) - nil)))) + nil nil nil (car x))))) decls))) ;; Refresh font-lock if this is a new macro, or it is an ;; existing macro whose 'no-font-lock-keyword declaration @@ -385,10 +384,9 @@ The return value is undefined. nil) (t (macroexp-warn-and-return - (car x) (format-message "Unknown defun property `%S' in %S" (car x) name) - nil))))) + nil nil nil (car x)))))) decls)) (def (list 'defalias (list 'quote name) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 5e0e0834ff..b44dda6f9d 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -499,7 +499,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined lambda-doc ; documentation string def-body))) ; part to be debugged (let ((qualifiers nil) - (org-name name)) + (orig-name name)) (while (cl-generic--method-qualifier-p args) (push args qualifiers) (setq args (pop body))) @@ -514,9 +514,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (byte-compile-warning-enabled-p 'obsolete name)) (let* ((obsolete (get name 'byte-obsolete-info))) (macroexp-warn-and-return - org-name (macroexp--obsolete-warning name obsolete "generic function") - nil))) + nil nil 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' diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 470168177c..5085217250 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2431,10 +2431,9 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (if malformed-bindings (let ((rev-malformed-bindings (nreverse malformed-bindings))) (macroexp-warn-and-return - rev-malformed-bindings (format-message "Malformed `cl-symbol-macrolet' binding(s): %S" rev-malformed-bindings) - expansion)) + expansion nil nil rev-malformed-bindings)) expansion))) (unless advised (advice-remove 'macroexpand #'cl--sm-macroexpand))))) @@ -3118,20 +3117,18 @@ To see the documentation for a defined struct type, use (when (cl-oddp (length desc)) (push (macroexp-warn-and-return - (car (last desc)) (format "Missing value for option `%S' of slot `%s' in struct %s!" (car (last desc)) slot name) - 'nil) + nil nil nil (car (last desc))) forms) (when (and (keywordp (car defaults)) (not (keywordp (car desc)))) (let ((kw (car defaults))) (push (macroexp-warn-and-return - kw (format " I'll take `%s' to be an option rather than a default value." kw) - 'nil) + nil nil nil kw) forms) (push kw desc) (setcar defaults nil)))) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 7bcb2f2936..688c76e0c5 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -230,7 +230,6 @@ INIT-VALUE LIGHTER KEYMAP. (warnwrap (if (or (null body) (keywordp (car body))) #'identity (lambda (exp) (macroexp-warn-and-return - exp "Use keywords rather than deprecated positional arguments to `define-minor-mode'" exp)))) keyw keymap-sym tmp) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 45ded15899..19aa20fa08 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -748,9 +748,8 @@ Argument FN is the function calling this verifier." ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return - name (format-message "Unknown slot `%S'" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) (_ exp)))) (gv-setter eieio-oset)) (cl-check-type slot symbol) @@ -785,15 +784,13 @@ Fills in CLASS's SLOT with its default value." ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return - name (format-message "Unknown slot `%S'" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-class-slot-names)))) (macroexp-warn-and-return - name (format-message "Slot `%S' is not class-allocated" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) (_ exp))))) (cl-check-type class (or eieio-object class)) (cl-check-type slot symbol) @@ -849,15 +846,13 @@ Fills in the default value in CLASS' in SLOT with VALUE." ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return - name (format-message "Unknown slot `%S'" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-class-slot-names)))) (macroexp-warn-and-return - name (format-message "Slot `%S' is not class-allocated" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) (_ exp))))) (setq class (eieio--class-object class)) (cl-check-type class eieio--class) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 6f97c25ca9..1315ca0c62 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -246,7 +246,7 @@ This method is obsolete." `(progn ,@(mapcar (lambda (w) (macroexp-warn-and-return - (car w) (cdr w) `(progn ',(cdr w)) nil 'compile-only)) + (cdr w) `(progn ',(cdr w)) nil 'compile-only (car w))) warnings) ;; This test must be created right away so we can have self- ;; referencing classes. ei, a class whose slot can contain only @@ -296,13 +296,13 @@ This method is obsolete." (if (not (stringp (car slots))) whole (macroexp-warn-and-return - (car slots) (format "Obsolete name arg %S to constructor %S" (car slots) (car whole)) ;; Keep the name arg, for backward compatibility, ;; but hide it so we don't trigger indefinitely. `(,(car whole) (identity ,(car slots)) - ,@(cdr slots))))))) + ,@(cdr slots)) + nil nil (car slots)))))) (apply #'make-instance ',name slots)))))) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 91538d1f06..7cfa1f2dad 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -581,9 +581,7 @@ This is like the `&' operator of the C language. Note: this only works reliably with lexical binding mode, except for very simple PLACEs such as (symbol-function \\='foo) which will also work in dynamic binding mode." - (let ((org-place place) ; It's too difficult to determine by inspection whether - ; the functions modify place. - (code + (let ((code (gv-letplace (getter setter) place `(cons (lambda () ,getter) (lambda (gv--val) ,(funcall setter 'gv--val)))))) @@ -595,9 +593,8 @@ binding mode." (eq (car-safe code) 'cons)) code (macroexp-warn-and-return - org-place "Use of gv-ref probably requires lexical-binding" - code)))) + code nil nil place)))) (defsubst gv-deref (ref) "Dereference REF, returning the referenced value. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 256092599b..e91b302af1 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -160,14 +160,14 @@ Other uses risk returning non-nil value that point to the wrong file." (define-obsolete-function-alias 'macroexp--warn-and-return #'macroexp-warn-and-return "28.1") -(defun macroexp-warn-and-return (arg msg form &optional category compile-only) +(defun macroexp-warn-and-return (msg form &optional category compile-only arg) "Return code equivalent to FORM labeled with warning MSG. -ARG is a symbol (or a form) giving the source code position of FORM -for the message. It should normally be a symbol with position. CATEGORY is the category of the warning, like the categories that can appear in `byte-compile-warnings'. COMPILE-ONLY non-nil means no warning should be emitted if the code -is executed without being compiled first." +is executed without being compiled first. +ARG is a symbol (or a form) giving the source code position for the message. +It should normally be a symbol with position and it defaults to FORM." (cond ((null msg) form) ((macroexp-compiling-p) @@ -177,7 +177,7 @@ is executed without being compiled first." ;; macroexpand-all gets right back to macroexpanding `form'. form (puthash form form macroexp--warned) - (macroexp--warn-wrap arg msg form category))) + (macroexp--warn-wrap (or arg form) msg form category))) (t (unless compile-only (message "%sWarning: %s" @@ -233,12 +233,11 @@ is executed without being compiled first." (let* ((fun (car form)) (obsolete (get fun 'byte-obsolete-info))) (macroexp-warn-and-return - fun (macroexp--obsolete-warning fun obsolete (if (symbolp (symbol-function fun)) "alias" "macro")) - new-form (list 'obsolete fun))) + new-form (list 'obsolete fun) nil fun)) new-form))) (defun macroexp--unfold-lambda (form &optional name) @@ -289,12 +288,11 @@ is executed without being compiled first." (setq arglist (cdr arglist))) (if values (macroexp-warn-and-return - arglist (format (if (eq values 'too-few) "attempt to open-code `%s' with too few arguments" "attempt to open-code `%s' with too many arguments") name) - form) + form nil nil arglist) ;; The following leads to infinite recursion when loading a ;; file containing `(defsubst f () (f))', and then trying to @@ -365,9 +363,8 @@ Assumes the caller has bound `macroexpand-all-environment'." (if (null body) (macroexp-unprogn (macroexp-warn-and-return - fun (format "Empty %s body" fun) - nil nil 'compile-only)) + nil nil 'compile-only fun)) (macroexp--all-forms body)) (cdr form)) form))) @@ -405,11 +402,10 @@ Assumes the caller has bound `macroexpand-all-environment'." (eq 'lambda (car-safe (cadr arg)))) (setcar (nthcdr funarg form) (macroexp-warn-and-return - (cadr arg) (format "%S quoted with ' rather than with #'" (let ((f (cadr arg))) (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) - arg))))) + arg nil nil (cadr arg)))))) ;; Macro expand compiler macros. This cannot be delayed to ;; byte-optimize-form because the output of the compiler-macro can ;; use macros. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index c3dbfe2947..0330a2a0ab 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -433,10 +433,9 @@ how many time this CODEGEN is called." (memq (car case) pcase--dontwarn-upats)) (setq main (macroexp-warn-and-return - (car case) (format "pcase pattern %S shadowed by previous pcase pattern" (car case)) - main)))) + main nil nil (car case))))) main))) (defun pcase--expand (exp cases) @@ -941,9 +940,8 @@ Otherwise, it defers to REST which is a list of branches of the form (let ((code (pcase--u1 matches code vars rest))) (if (eq upat '_) code (macroexp-warn-and-return - upat "Pattern t is deprecated. Use `_' instead" - code)))) + code nil nil upat)))) ((eq upat 'pcase--dontcare) :pcase--dontcare) ((memq (car-safe upat) '(guard pred)) (if (eq (car upat) 'pred) (pcase--mark-used sym)) commit c3e064013ee81b0dac5475cc3450209d637cf3b4 Author: Stefan Monnier Date: Sat Feb 19 14:12:14 2022 -0500 (loadhist_initialize): Minor refactoring Consolidate a bit of code. * src/lread.c (loadhist_initialize): New function. (Fload, readevalloop): Use it. diff --git a/src/lread.c b/src/lread.c index 58b40ef37e..d225403b20 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1169,6 +1169,13 @@ compute_found_effective (Lisp_Object found) return concat2 (src_name, build_string ("c")); } +static void +loadhist_initialize (Lisp_Object filename) +{ + eassert (STRINGP (filename)); + specbind (Qcurrent_load_list, Fcons (filename, Qnil)); +} + DEFUN ("load", Fload, Sload, 1, 5, 0, doc: /* Execute a file of Lisp code named FILE. First try FILE with `.elc' appended, then try with `.el', then try @@ -1552,8 +1559,7 @@ Return t if the file exists and loads successfully. */) if (is_module) { #ifdef HAVE_MODULES - specbind (Qcurrent_load_list, Qnil); - LOADHIST_ATTACH (found); + loadhist_initialize (found); Fmodule_load (found); build_load_history (found, true); #else @@ -1564,8 +1570,7 @@ Return t if the file exists and loads successfully. */) else if (is_native_elisp) { #ifdef HAVE_NATIVE_COMP - specbind (Qcurrent_load_list, Qnil); - LOADHIST_ATTACH (hist_file_name); + loadhist_initialize (hist_file_name); Fnative_elisp_load (found, Qnil); build_load_history (hist_file_name, true); #else @@ -2197,7 +2202,6 @@ readevalloop (Lisp_Object readcharfun, emacs_abort (); specbind (Qstandard_input, readcharfun); - specbind (Qcurrent_load_list, Qnil); record_unwind_protect_int (readevalloop_1, load_convert_to_unibyte); load_convert_to_unibyte = !NILP (unibyte); @@ -2215,7 +2219,7 @@ readevalloop (Lisp_Object readcharfun, && !NILP (sourcename) && !NILP (Ffile_name_absolute_p (sourcename))) sourcename = Fexpand_file_name (sourcename, Qnil); - LOADHIST_ATTACH (sourcename); + loadhist_initialize (sourcename); continue_reading_p = 1; while (continue_reading_p) commit 910cdcf8c3939b84f0eaeb178119dd32f867411d Author: Stefan Monnier Date: Sat Feb 19 13:45:04 2022 -0500 * lisp/vc/diff-mode.el (diff--font-lock-prettify): Fix mishaps This reverts the last change so it also applies to non-git diffs again. Instead, we're now more careful not to mis-recognize file headers as addition/removal lines. In addition to that, mark the file header such that it's re-font-locked all at once, and to still recognize it after `diff-reverse-direction`. diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index d0c05d3204..fb622bb6f9 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -2599,22 +2599,23 @@ fixed, visit it in a buffer." nil nil 'center) (defun diff--font-lock-prettify (limit) - (when (and diff-font-lock-prettify - (eq diff-buffer-type 'git)) + (when diff-font-lock-prettify (save-excursion ;; FIXME: Include the first space for context-style hunks! (while (re-search-forward "^[-+! ]" limit t) - (let ((spec (alist-get (char-before) - '((?+ . (left-fringe diff-fringe-add diff-indicator-added)) - (?- . (left-fringe diff-fringe-del diff-indicator-removed)) - (?! . (left-fringe diff-fringe-rep diff-indicator-changed)) - (?\s . (left-fringe diff-fringe-nul fringe)))))) - (put-text-property (match-beginning 0) (match-end 0) 'display spec)))) + (unless (eq (get-text-property (match-beginning 0) 'face) 'diff-header) + (let ((spec + (alist-get + (char-before) + '((?+ . (left-fringe diff-fringe-add diff-indicator-added)) + (?- . (left-fringe diff-fringe-del diff-indicator-removed)) + (?! . (left-fringe diff-fringe-rep diff-indicator-changed)) + (?\s . (left-fringe diff-fringe-nul fringe)))))) + (put-text-property (match-beginning 0) (match-end 0) + 'display spec))))) ;; Mimicks the output of Magit's diff. ;; FIXME: This has only been tested with Git's diff output. (while (re-search-forward "^diff " limit t) - ;; FIXME: Switching between context<->unified leads to messed up - ;; file headers by cutting the `display' property in chunks! (when (save-excursion (forward-line 0) (looking-at @@ -2622,19 +2623,21 @@ fixed, visit it in a buffer." (concat "diff.*\n" "\\(?:\\(?:new file\\|deleted\\).*\n\\)?" "\\(?:index.*\n\\)?" - "--- \\(?:" null-device "\\|a/\\(.*\\)\\)\n" - "\\+\\+\\+ \\(?:" null-device "\\|b/\\(.*\\)\\)\n")))) - (put-text-property (match-beginning 0) (1- (match-end 0)) - 'display - (propertize - (cond - ((null (match-string 1)) - (concat "new file " (match-string 2))) - ((null (match-string 2)) - (concat "deleted " (match-string 1))) - (t - (concat "modified " (match-string 1)))) - 'face '(diff-file-header diff-header)))))) + "--- \\(?:" null-device "\\|[ab]/\\(.*\\)\\)\n" + "\\+\\+\\+ \\(?:" null-device "\\|[ab]/\\(.*\\)\\)\n")))) + (add-text-properties + (match-beginning 0) (1- (match-end 0)) + (list 'display + (propertize + (cond + ((null (match-string 1)) + (concat "new file " (match-string 2))) + ((null (match-string 2)) + (concat "deleted " (match-string 1))) + (t + (concat "modified " (match-string 1)))) + 'face '(diff-file-header diff-header)) + 'font-lock-multiline t))))) nil) ;;; Syntax highlighting from font-lock commit 7e4ef09aa0d9587677d44284af72ceb3f44061b7 Author: Michael Albinus Date: Sat Feb 19 18:38:12 2022 +0100 Adapt Tramp password prompts for sudo-like methods * doc/misc/tramp.texi (Password handling): Explain entries for doas, sudo and sudoedit. * etc/NEWS (Tramp): Document changed password prompts. * lisp/net/tramp-sh.el (tramp-methods) : Add `tramp-password-previous-hop'. (tramp-maybe-open-connection): Modify `previous-hop' if needed. * lisp/net/tramp-sudoedit.el (tramp-methods) : Add `tramp-password-previous-hop'. (tramp-sudoedit-null-hop): New defconst. (tramp-sudoedit-send-command): Use it. * lisp/net/tramp.el (tramp-methods): Adapt docstring. (tramp-null-hop): New defconst. (tramp-get-remote-null-device): Use it. diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index ec9f07dc9e..25ff2796bd 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -1986,6 +1986,20 @@ file name syntax, must be appended to the machine and login items: machine melancholia#4711 port davs login daniel%BIZARRE password geheim @end example +For the methods @option{doas}, @option{sudo} and @option{sudoedit} the +password of the user requesting the connection is needed, and not the +password of the target user. If these connections happen on the local +host, an entry with the local user and local host is used: + +@example +machine @var{HOST} port sudo login @var{USER} password secret +@end example + +@var{USER} and @var{HOST} are the strings returned by +@code{(user-login-name)} and @code{(system-name)}. If one of these +methods is connected via a multi hop (@pxref{Multi-hops}), the +credentials of the previous hop are used. + @vindex auth-source-save-behavior If no proper entry exists, the password is read interactively. After successful login (verification of the password), diff --git a/etc/NEWS b/etc/NEWS index 5c5684e1d1..dd9e822871 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -73,7 +73,7 @@ and Broadway. We do not recommend that you use this configuration, unless you are running a window system that's supported by GDK other than X. Running this configuration on X is known to have problems, such as undesirable frame positioning and various issues with keyboard -input of sequences such as "C-;" and "C-S-u". +input of sequences such as 'C-;' and 'C-S-u'. --- ** The docstrings of preloaded files are not in "etc/DOC" any more. @@ -523,7 +523,7 @@ This uses the Tai Tham script, whose support has been enhanced. --- ** 'savehist.el' can now truncate variables that are too long. An element of 'savehist-additional-variables' can now be of the form -(VARIABLE . MAX-ELTS), which means to truncate the VARIABLE's value to +'(VARIABLE . MAX-ELTS)', which means to truncate the VARIABLE's value to at most MAX-ELTS elements (if the value is a list) before saving the value. @@ -962,6 +962,13 @@ When set to non-nil, Tramp does not copy files between two remote hosts via a local copy in its temporary directory, but let the 'scp' command do this job. ++++ +*** Proper password prompts for methods "doas", "sudo" and "sudoedit". +The password prompts for these methods reflect now the credentials of +the user requesting such a connection, and not of the user who is the +target. This has always been needed, just the password prompt and the +related 'auth-sources' entry were wrong. + ** Browse URL --- diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 40ddf106c9..3c28463515 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -301,7 +301,8 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-connection-timeout 10) - (tramp-session-timeout 300))) + (tramp-session-timeout 300) + (tramp-password-previous-hop t))) (add-to-list 'tramp-methods `("doas" (tramp-login-program "doas") @@ -309,7 +310,8 @@ The string is used in `tramp-methods'.") (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-args ("-c")) (tramp-connection-timeout 10) - (tramp-session-timeout 300))) + (tramp-session-timeout 300) + (tramp-password-previous-hop t))) (add-to-list 'tramp-methods `("ksu" (tramp-login-program "ksu") @@ -5005,8 +5007,7 @@ connection if a previous connection has died for some reason." (tramp-error vec 'file-error "`tramp-encoding-shell' not set")) (let* ((current-host tramp-system-name) (target-alist (tramp-compute-multi-hops vec)) - ;; Needed for `tramp-get-remote-null-device'. - (previous-hop nil) + (previous-hop tramp-null-hop) ;; We will apply `tramp-ssh-controlmaster-options' ;; only for the first hop. (options (tramp-ssh-controlmaster-options vec)) @@ -5091,9 +5092,14 @@ connection if a previous connection has died for some reason." ;; Set password prompt vector. (tramp-set-connection-property p "password-vector" - (make-tramp-file-name - :method l-method :user l-user :domain l-domain - :host l-host :port l-port)) + (if (tramp-get-method-parameter + hop 'tramp-password-previous-hop) + (let ((pv (copy-tramp-file-name previous-hop))) + (setf (tramp-file-name-method pv) l-method) + pv) + (make-tramp-file-name + :method l-method :user l-user :domain l-domain + :host l-host :port l-port))) ;; Set session timeout. (when (tramp-get-method-parameter diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 797804dfd4..a35f9391a1 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -45,7 +45,8 @@ (add-to-list 'tramp-methods `(,tramp-sudoedit-method (tramp-sudo-login (("sudo") ("-u" "%u") ("-S") ("-H") - ("-p" "Password:") ("--"))))) + ("-p" "Password:") ("--"))) + (tramp-password-previous-hop t))) (add-to-list 'tramp-default-user-alist '("\\`sudoedit\\'" nil "root")) @@ -168,6 +169,12 @@ arguments to pass to the OPERATION." (tramp-register-foreign-file-name-handler #'tramp-sudoedit-file-name-p #'tramp-sudoedit-file-name-handler)) +;; Needed for `tramp-read-passwd'. +(defconst tramp-sudoedit-null-hop + (make-tramp-file-name + :method tramp-sudoedit-method :user (user-login-name) :host tramp-system-name) +"Connection hop which identifies the virtual hop before the first one.") + ;; File name primitives. @@ -825,6 +832,7 @@ in case of error, t otherwise." (process-put p 'vector vec) (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) + (tramp-set-connection-property p "password-vector" tramp-sudoedit-null-hop) (tramp-process-actions p vec nil tramp-sudoedit-sudo-actions) (tramp-message vec 6 "%s\n%s" (process-exit-status p) (buffer-string)) (prog1 diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 0ffaeb0ce9..7b558aec11 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -315,14 +315,20 @@ pair of the form (KEY VALUE). The following KEYs are defined: * `tramp-connection-timeout' This is the maximum time to be spent for establishing a connection. In general, the global default value shall be used, but for - some methods, like \"su\" or \"sudo\", a shorter timeout - might be desirable. + some methods, like \"doas\", \"su\" or \"sudo\", a shorter + timeout might be desirable. * `tramp-session-timeout' How long a Tramp connection keeps open before being disconnected. - This is useful for methods like \"su\" or \"sudo\", which + This is useful for methods like \"doas\" or \"sudo\", which shouldn't run an open connection in the background forever. + * `tramp-password-previous-hop' + The password for this connection is the same like the + password for the previous hop. If there is no previous hop, + the password of the local user is applied. This is needed + for methods like \"doas\", \"sudo\" or \"sudoedit\". + * `tramp-case-insensitive' Whether the remote file system handles file names case insensitive. Only a non-nil value counts, the default value nil means to @@ -1427,6 +1433,11 @@ calling HANDLER.") (put #'tramp-file-name-localname 'tramp-suppress-trace t) (put #'tramp-file-name-hop 'tramp-suppress-trace t) +;; Needed for `tramp-read-passwd' and `tramp-get-remote-null-device'. +(defconst tramp-null-hop + (make-tramp-file-name :user (user-login-name) :host tramp-system-name) +"Connection hop which identifies the virtual hop before the first one.") + (defun tramp-file-name-user-domain (vec) "Return user and domain components of VEC." (when (or (tramp-file-name-user vec) (tramp-file-name-domain vec)) @@ -5938,8 +5949,8 @@ name of a process or buffer, or nil to default to the current buffer." (defun tramp-get-remote-null-device (vec) "Return null device on the remote host identified by VEC. -If VEC is nil, return local null device." - (if (null vec) +If VEC is nil or `tramp-null-hop', return local null device." + (if (or (null vec) (equal vec tramp-null-hop)) null-device (with-tramp-connection-property vec "null-device" (let ((default-directory (tramp-make-tramp-file-name vec))) commit a72e0e50f0afbb8b37b9ebd8e1fa83ce3eb9f643 Author: Lars Ingebrigtsen Date: Sat Feb 19 16:58:52 2022 +0100 Some vtable.texi copy edits * doc/misc/vtable.texi (Making A Table): Mention the accessors. diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index 8e6db5659d..472dee70ec 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -89,7 +89,7 @@ Here's just about the simplest vtable that can be created: @end lisp By default, vtable uses the @code{variable-pitch} font, and -right-aligns columns that only have numerical data (and left-aligns +right-aligns columns that have only numerical data (and left-aligns the rest). You'd normally want to name the columns: @@ -102,7 +102,8 @@ You'd normally want to name the columns: @end lisp Clicking on the column names will sort the table based on the data in -each object (and in this example, each object is just a simple list). +each column (which, in this example, corresponds to an element in a +list). By default, the data is displayed ``as is'', that is, the way @samp{(format "%s" ...)} would display it, but you can override that. @@ -123,7 +124,7 @@ will still sort after @samp{45}, because sorting is done on the actual data, and not the displayed data. Alternatively, instead of having a general formatter for the table, -you can instead put the formatter in the column definition: +you can put the formatter in the column definition: @lisp (make-vtable @@ -151,10 +152,10 @@ version of @kbd{M-x list-buffers}: ("File" (or (buffer-file-name object) ""))))) @end lisp -@var{objects} in this case is a list of buffers. To get the data to be -displayed, vtable calls the @dfn{getter} function, which is called for -each column of every object, and should return something suitable for -display. +@var{objects} in this case is a list of buffers. To get the data to +be displayed, vtable calls the @dfn{getter} function, which is called +for each column of every object, and which should return the data that +will eventually be displayed. Also note the @dfn{actions}: These are simple commands that will be called with the object under point. So hitting @kbd{@key{RET}} on a line @@ -178,7 +179,7 @@ Finally, here's an example that uses just about all the features: :max-width max-width)))) (:name "Size" :width 10 :formatter file-size-human-readable) - (:name "Time" :width 10 :primary ascend :direction 'descend) + (:name "Time" :width 10 :primary ascend) "Name") :objects-function (lambda () (directory-files "/tmp/" t "\\.jpg\\'")) commit 9f571a2e6c1cf0f039438093a28ee2a962658fd5 Author: Lars Ingebrigtsen Date: Sat Feb 19 16:25:13 2022 +0100 Mention vtable accessor functions * doc/misc/vtable.texi (Making A Table): Mention the accessors. diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index 83ce24fd1a..8e6db5659d 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -422,6 +422,11 @@ is @code{nil}, nothing is inserted, but the vtable object is returned, and you can insert it later with the @code{vtable-insert} function. @end table +@code{make-table} returns a @code{vtable} object. You can access the +slots in that object by using accessor functions that have names based +on the keywords described above. For instance, to access the face, +use @code{vtable-face}. + @node Commands @chapter Commands @cindex vtable commands commit 16abc240358cc6432637939a0de281dc449583fc Author: Lars Ingebrigtsen Date: Sat Feb 19 16:13:39 2022 +0100 Improve the vtable documentation on argument types * doc/misc/vtable.texi (Making A Table): Say what the argument types are. diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index 46d038b075..83ce24fd1a 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -242,8 +242,15 @@ the argument. @findex make-vtable The interface function for making (and optionally inserting a table -into a buffer) is @code{make-vtable}. It takes the following keyword -parameters: +into a buffer) is @code{make-vtable}. It returns a table object. + +The keyword parameters are described below. + +There are many callback interface functions possible in +@code{make-vtable}, and many of them take a @var{object} argument (an +object from the @code{:objects} list), a column index argument (an +integer starting at zero), and a table argument (the object returned +by @code{make-vtable}). @table @code @item :objects @@ -330,7 +337,6 @@ the table, and will be called once for each element in the table (unless overridden by a column getter function). @defun getter object index table -@c FIXME: Describe the arguments. For a simple object (like a sequence), this function will typically just return the element corresponding to the column index (zero-based), but the function can do any computation it wants. If it's more convenient to @@ -344,7 +350,6 @@ will be called on all values in the table (unless overridden by a column formatter). @defun formatter value index table -@c FIXME: The arguments are named, but not explained. E.g., what is TABLE? This function is called with three parameters: the value (as returned by the getter); the column index, and the table. It can return any value. @@ -421,7 +426,7 @@ and you can insert it later with the @code{vtable-insert} function. @chapter Commands @cindex vtable commands -@c FIXME: Some introductory text is in order? Commands where? +When point is placed on a vtable, the following keys are bound: @table @kbd @findex vtable-sort-by-current-column commit 9eefe59d579410698ce41623806a7d1968a7169b Author: Lars Ingebrigtsen Date: Sat Feb 19 14:48:39 2022 +0100 Fix a vtable example * doc/misc/vtable.texi (Introduction): Fix example. diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index 1b0525e78a..46d038b075 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -181,8 +181,7 @@ Finally, here's an example that uses just about all the features: (:name "Time" :width 10 :primary ascend :direction 'descend) "Name") :objects-function (lambda () - (directory-files "~/pics/redslur/" - t "DSC0000[0-5].JPG")) + (directory-files "/tmp/" t "\\.jpg\\'")) :actions '("RET" find-file) :getter (lambda (object column table) (pcase (vtable-column table column) commit 999115845a187cedaa8bb696bae1c3c5769b555c Author: Eli Zaretskii Date: Sat Feb 19 15:34:01 2022 +0200 Improve vtable documentation * doc/misc/vtable.texi (top-level): Add @syncodeindex directives. (Introduction): Fix wording and markup. Add indexing. (Making A Table, Commands, Interface Functions): Fix typos and markup. Add indexing. * etc/NEWS: Improve wording of the vtable's NEWS entry. * doc/misc/Makefile.in (INFO_COMMON): Add 'vtable'. diff --git a/doc/misc/Makefile.in b/doc/misc/Makefile.in index 5bd8f6a151..d9c5173c07 100644 --- a/doc/misc/Makefile.in +++ b/doc/misc/Makefile.in @@ -74,7 +74,7 @@ INFO_COMMON = auth autotype bovine calc ccmode cl \ mairix-el message mh-e modus-themes newsticker nxml-mode octave-mode \ org pcl-cvs pgg rcirc remember reftex sasl \ sc semantic ses sieve smtpmail speedbar srecode todo-mode transient \ - tramp url vhdl-mode vip viper widget wisent woman + tramp url vhdl-mode vip viper vtable widget wisent woman ## Info files to install on current platform. INFO_INSTALL = $(INFO_COMMON) $(DOCMISC_W32) diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index 71c021da28..1b0525e78a 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -3,6 +3,10 @@ @setfilename ../../info/vtable.info @settitle Variable Pitch Tables @include docstyle.texi +@c Merge all indexes into a single Index node. +@syncodeindex fn cp +@syncodeindex vr cp +@syncodeindex ky cp @c %**end of header @copying @@ -63,16 +67,16 @@ Indices @end menu @node Introduction -@chapter Introduction +@chapter Introduction and Tutorial Most modes that display tabular data in Emacs use @code{tabulated-list-mode}, but it has some limitations: It assumes that the text it's displaying is monospaced, which makes it difficult -to mix fonts and images in a single list. The @dfn{vtable} (variable -pitch tables) package tackles this instead. +to mix fonts and images in a single list. The @dfn{vtable} (``variable +pitch tables'') package tackles this instead. @code{tabulated-list-mode} is a major mode, and assumes that it -controls the entire buffer. vtable doesn't assume that---you can have +controls the entire buffer. A vtable doesn't assume that---you can have a vtable in the middle of other data, or have several vtables in the same buffer. @@ -153,7 +157,7 @@ each column of every object, and should return something suitable for display. Also note the @dfn{actions}: These are simple commands that will be -called with the object under point. So hitting @kbd{RET} on a line +called with the object under point. So hitting @kbd{@key{RET}} on a line will result in @code{display-buffer} being called with a buffer object as the parameter. (You can also supply a keymap to be used, but then you have to write commands that call @code{vtable-current-object} to @@ -196,25 +200,29 @@ Finally, here's an example that uses just about all the features: This vtable implements a simple image browser that displays image thumbnails (that change sizes dynamically depending on the width of the column), human-readable file sizes, date and file name. The -separator width is 5 typical characters wide. Hitting @kbd{RET} on a +separator width is 5 typical characters wide. Hitting @kbd{@key{RET}} on a line will open the image in a new window, and hitting @kbd{q} will kill a buffer. @node Concepts @chapter Concepts +@cindex vtable A vtable lists data about a number of @dfn{objects}. Each object can be a list or a vector, but it can also be anything else. +@cindex getter of a vtable To get the @dfn{value} for a particular column, the @dfn{getter} function is called on the object. If no getter function is defined, the default is to try to index the object as a sequence. In any case, we end up with a value that is then used for sorting. +@cindex formatter of a vtable This value is then @dfn{formatted} via a @dfn{formatter} function, which is called with the @dfn{value} as the argument. The formatter commonly makes the value more reader friendly. +@cindex displayer of a vtable Finally, the formatted value is passed to the @dfn{displayer} function, which is responsible for putting the table face on the formatted value, and also ensuring that it's not wider than the column @@ -233,9 +241,9 @@ the argument. @node Making A Table @chapter Making A Table -@findex make-table +@findex make-vtable The interface function for making (and optionally inserting a table -into a buffer) is @code{make-table}. It takes the following keyword +into a buffer) is @code{make-vtable}. It takes the following keyword parameters: @table @code @@ -243,11 +251,11 @@ parameters: This is a list of objects to be displayed. It should either be a list of strings (which will then be displayed as a single-column table), or a list where each element is a sequence containing a mixture of -strings, number and other objects that can be displayed ``simply''. +strings, numbers, and other objects that can be displayed ``simply''. In the latter case, if @code{:columns} is non-@code{nil} and there's more elements in the sequence than there is in @code{:columns}, only -the @code{:columns}th first elements are displayed. +the @code{:columns} first elements are displayed. @item :objects-function It's often convenient to generate the objects dynamically (for @@ -268,17 +276,17 @@ The name of the column. @item width The width of the column. This is either a number (the width of that many @samp{x} characters in the table's face), or a string on the form -@samp{Xex}, where @var{x} is a number of @samp{x} characters, or a -string on the form @samp{Xpx} (denoting a number of pixels), or a +@samp{Xe@var{x}}, where @var{x} is a number of @samp{x} characters, or a +string on the form @samp{Xp@var{x}} (denoting a number of pixels), or a string on the form @samp{X%} (a percentage of the window's width). @item min-width This uses the same format as @code{width}, but specifies the minimum -width (and overrides @code{width} is @code{width} is smaller than this. +width (and overrides @code{width} if @code{width} is smaller than this. @item max-width This uses the same format as @code{width}, but specifies the maximum -width (and overrides @code{width} is @code{width} is larger than this. +width (and overrides @code{width} if @code{width} is larger than this. @code{min-width}/@code{max-width} can be useful if @code{width} is given as a percentage of the window width, and you want to ensure that the column doesn't grow pointlessly large or unreadably narrow. @@ -286,20 +294,20 @@ the column doesn't grow pointlessly large or unreadably narrow. @item primary Whether this is the primary column---this will be used for initial sorting. This should be either @code{ascend} or @code{descend} to say -which order the table should be sorted in. +in which order the table should be sorted. @item getter If present, this function will be called to return the column value. @defun column-getter object table -It's called with two parameters: The object and the table. +It's called with two parameters: the object and the table. @end defun @item formatter If present, this function will be called to format the value. @defun column-formatter value -It's called with one parameter: The column value. +It's called with one parameter: the column value. @end defun @item displayer @@ -323,8 +331,9 @@ the table, and will be called once for each element in the table (unless overridden by a column getter function). @defun getter object index table +@c FIXME: Describe the arguments. For a simple object (like a sequence), this function will typically -just return the element corresponding to the column index, but the +just return the element corresponding to the column index (zero-based), but the function can do any computation it wants. If it's more convenient to write the function based on column names rather than the column index, the @code{vtable-column} function can be used to map from index to name. @@ -336,7 +345,8 @@ will be called on all values in the table (unless overridden by a column formatter). @defun formatter value index table -This function is called with three parameters: The value (as returned +@c FIXME: The arguments are named, but not explained. E.g., what is TABLE? +This function is called with three parameters: the value (as returned by the getter); the column index, and the table. It can return any value. @@ -349,7 +359,7 @@ Before displaying an element, it's passed to the displaying function (if any). @defun displayer fvalue index max-width table -This is called with four arguments: The formatted value of the element +This is called with four arguments: the formatted value of the element (as returned by the formatter function); the column index; the display width (in pixels); and the table. @@ -361,16 +371,16 @@ displayed in the table. @end defun @item :use-header-line -If non-@code{nil} (which is the default), use the Emacs header line -machinery to display the column names. This is the most common use +If non-@code{nil} (which is the default), display the column names on +the header line. This is the most common use case, but if there's other text in the buffer before the table, or there are several tables in the same buffer, then this should be @code{nil}. @item :face The face to be used. This defaults to @code{variable-pitch}. This -face doesn't override the faces in the data, or supplied by the getter -or formatter functions. +face doesn't override the faces in the data, or the faces supplied by +the getter and formatter functions. @item :actions This uses the same syntax as @code{define-keymap}, but doesn't refer @@ -382,10 +392,10 @@ with that as the argument. This is a keymap used on the table. The commands here are called as usual, and if they're supposed to work on the object displayed on the current line, they can use the @code{vtable-current-object} function -to determine what that object is. +(@pxref{Interface Functions}) to determine what that object is. @item :separator-width -The blank space between columns. +The width of the blank space between columns. @item :sort-by This should be a list of tuples, and specifies how the table is to be @@ -410,29 +420,39 @@ and you can insert it later with the @code{vtable-insert} function. @node Commands @chapter Commands +@cindex vtable commands + +@c FIXME: Some introductory text is in order? Commands where? @table @kbd +@findex vtable-sort-by-current-column @item S Sort the table by the current column (@code{vtable-sort-by-current-column}). Note that the table is sorted -according to the data returned by the getter function, not by how it's +according to the data returned by the getter function (@pxref{Making A +Table}), not by how it's displayed in the buffer. Columns that have only numerical data is sorted as numbers, the rest are sorted as strings. +@findex vtable-narrow-current-column @item @{ Make the current column narrower (@code{vtable-narrow-current-column}). +@findex vtable-widen-current-column @item @} Make the current column wider (@code{vtable-widen-current-column}). +@findex vtable-previous-column @item M- Move to the previous column (@code{vtable-previous-column}). +@findex vtable-next-column @item M- Move to the next column (@code{vtable-next-column}). +@findex vtable-revert-command @item g Regenerate the table (@code{vtable-revert-command}). This command mostly makes sense if the table has a @code{:objects-function} that @@ -442,9 +462,12 @@ can fetch new data. @node Interface Functions @chapter Interface Functions -People writing modes based on vtable has to interact with the table in -various ways---for instance, to write commands that updates an object -and then displays the result. +If you need to write a mode based on vtable, you will have to interact +with the table in +various ways---for instance, you'll need to write commands that +updates an object +and then displays the result. This chapter describes functions for +such interaction. @defun vtable-current-table This function returns the table under point. @@ -452,7 +475,7 @@ This function returns the table under point. @defun vtable-current-object This function returns the object on the current line. (Note that this -is the original object, and not the characters displayed in the +is the original object, not the characters displayed in the buffer.) @end defun @@ -468,7 +491,7 @@ return @code{nil}. @defun vtable-goto-object object Move point to the start of the line where @var{object} is displayed in -the current table and return point. If @var{object} can't be found, +the current table and return the position. If @var{object} can't be found, don't move point and return @code{nil}. @end defun diff --git a/etc/NEWS b/etc/NEWS index e1dc64c8aa..5c5684e1d1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -992,10 +992,11 @@ support for pipelines which will move a lot of data. See section ** Miscellaneous +++ -*** A new package for formatting tabular data, vtable.el, has been added. -This new package allows formatting data using non-monospaced fonts. -Variable pitch fonts, and text using fonts with different sizes can be -displayed, as well as images. See the '(vtable)Top' manual. +*** New package vtable.el for formatting tabular data. +This package allows formatting data using variable-pitch fonts. +The resulting tables can display text in variable pitch fonts, text +using fonts of different sizes, and images. See the '(vtable)Top' +manual for more details. --- *** 'list-bookmarks' now includes a type column. commit d98b6fbba208e2f9e4d84b22507d6827a0925ca3 Author: Lars Ingebrigtsen Date: Sat Feb 19 14:21:10 2022 +0100 Add column sorting order indicators to vtable * lisp/emacs-lisp/vtable.el (vtable--indicator): New function. (vtable--insert-header-line): Use it to display sorting order indicators. diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index 5c010a1f79..71c021da28 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -517,5 +517,3 @@ Return the column name of the @var{index}th column in @var{table}. @printindex cp @bye - -@c todo up/down markers diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 9107c4439c..0884986030 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -474,21 +474,41 @@ This also updates the displayed table." (when (eq direction 'descend) (setcar cache (nreverse (car cache))))))) +(defun vtable--indicator (table index) + (let ((order (car (last (vtable-sort-by table))))) + (if (eq index (car order)) + ;; We're sorting by this column last, so return an indicator. + (catch 'found + (dolist (candidate (nth (if (eq (cdr order) 'ascend) + 1 + 0) + '((?â–¼ ?v) + (?â–² ?^)))) + (when (char-displayable-p candidate) + (throw 'found (string candidate))))) + ""))) + (defun vtable--insert-header-line (table widths spacer) ;; Insert the header directly into the buffer. - (let ((start (point))) + (let* ((start (point))) (seq-do-indexed (lambda (column index) - (let ((name (propertize - (vtable-column-name column) - 'face (list 'header-line (vtable-face table)))) - (start (point)) - displayed) + (let* ((name (propertize + (vtable-column-name column) + 'face (list 'header-line (vtable-face table)))) + (start (point)) + (indicator (vtable--indicator table index)) + (indicator-width (string-pixel-width indicator)) + displayed) (insert (setq displayed - (if (> (string-pixel-width name) (elt widths index)) - (vtable--limit-string name (elt widths index)) - name)) + (concat + (if (> (string-pixel-width name) + (- (elt widths index) indicator-width)) + (vtable--limit-string + name (- (elt widths index) indicator-width)) + name) + indicator)) (propertize " " 'display (list 'space :width (list (+ (- (elt widths index) commit babfb064c48e621ab7ad43b380ed1fdb0a6904a8 Author: Lars Ingebrigtsen Date: Sat Feb 19 14:20:30 2022 +0100 Make string-pixel-width slightly speedier * lisp/emacs-lisp/subr-x.el (string-pixel-width): Speed up string-pixel-width in the zero-length string case. diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 1f69850958..647397e7f7 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -444,9 +444,11 @@ is inserted before adjusting the number of empty lines." ;;;###autoload (defun string-pixel-width (string) "Return the width of STRING in pixels." - (with-temp-buffer - (insert string) - (car (buffer-text-pixel-size nil nil t)))) + (if (zerop (length string)) + 0 + (with-temp-buffer + (insert string) + (car (buffer-text-pixel-size nil nil t))))) ;;;###autoload (defun string-glyph-split (string) commit 14562b45bd81334064b19ed91f02e11cd46aaf56 Author: Po Lu Date: Sat Feb 19 20:59:12 2022 +0800 Avoid consing extra string when processing GTK native input * src/gtkutil.c (xg_im_context_commit): Use `decode_string_utf8' to decode input text. * src/keyboard.c (kbd_buffer_get_event_1): If coding system is Qt, simply return the string without decoding it. * src/termhooks.h (enum event_kind): Document meaning of Qt as coding system in a multibyte keystroke event's string argument. diff --git a/src/gtkutil.c b/src/gtkutil.c index 27aa28b890..158c29272f 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -6097,11 +6097,21 @@ xg_im_context_commit (GtkIMContext *imc, gchar *str, struct input_event ie; EVENT_INIT (ie); + /* This used to use g_utf8_to_ucs4_fast, which led to bad results + when STR wasn't actually a UTF-8 string, which some input method + modules commit. */ + ie.kind = MULTIBYTE_CHAR_KEYSTROKE_EVENT; - ie.arg = build_unibyte_string (str); + ie.arg = decode_string_utf_8 (Qnil, str, strlen (str), + Qnil, false, Qnil, Qnil); + + /* STR is invalid and not really encoded in UTF-8. */ + if (NILP (ie.arg)) + ie.arg = build_unibyte_string (str); - Fput_text_property (make_fixnum (0), make_fixnum (strlen (str)), - Qcoding, Qutf_8_unix, ie.arg); + Fput_text_property (make_fixnum (0), + make_fixnum (SCHARS (ie.arg)), + Qcoding, Qt, ie.arg); XSETFRAME (ie.frame_or_window, f); ie.modifiers = 0; diff --git a/src/keyboard.c b/src/keyboard.c index 0747ab4820..2aff0f1011 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -3841,6 +3841,9 @@ kbd_buffer_get_event_1 (Lisp_Object arg) Lisp_Object coding_system = Fget_text_property (make_fixnum (0), Qcoding, arg); + if (EQ (coding_system, Qt)) + return arg; + return code_convert_string (arg, (!NILP (coding_system) ? coding_system : Vlocale_coding_system), diff --git a/src/termhooks.h b/src/termhooks.h index 0a9ab61afa..b7696fed4f 100644 --- a/src/termhooks.h +++ b/src/termhooks.h @@ -100,7 +100,9 @@ enum event_kind If it is nil, then the locale coding system will - be used. */ + be used. If it is t, then + no decoding will take + place. */ NON_ASCII_KEYSTROKE_EVENT, /* .code is a number identifying the function key. A code N represents a key whose name is commit f273a504be670d714fe46a067e5edba548443701 Author: Mauro Aranda Date: Sat Feb 19 13:34:11 2022 +0100 Fix types of some align.el defcustoms * lisp/align.el (align-region-heuristic) (align-large-region): Both options can be nil, but the defcustom type didn't allow nil values. (align-rules-list-type): The "Run If" and "Valid" attributes should be functions, but the default value was t. Change it to #'always (bug#54048). diff --git a/lisp/align.el b/lisp/align.el index 2279c659b4..b054b1bac4 100644 --- a/lisp/align.el +++ b/lisp/align.el @@ -160,7 +160,8 @@ string), this heuristic is used to determine how far before and after point we should search in looking for a region separator. Larger values can mean slower performance in large files, although smaller values may cause unexpected behavior at times." - :type 'integer + :type '(choice (const :tag "Don't use heuristic when aligning a region" nil) + integer) :group 'align) (defcustom align-highlight-change-face 'highlight @@ -176,7 +177,7 @@ values may cause unexpected behavior at times." (defcustom align-large-region 10000 "If an integer, defines what constitutes a \"large\" region. If nil, then no messages will ever be printed to the minibuffer." - :type 'integer + :type '(choice (const :tag "Align a large region silently" nil) integer) :group 'align) (defcustom align-c++-modes '(c++-mode c-mode java-mode) @@ -356,11 +357,11 @@ The possible settings for `align-region-separate' are: (cons :tag "Valid" (const :tag "(Return non-nil if rule is valid)" valid) - (function :value t)) + (function :value always)) (cons :tag "Run If" (const :tag "(Return non-nil if rule should run)" run-if) - (function :value t)) + (function :value always)) (cons :tag "Column" (const :tag "(Column to fix alignment at)" column) (choice :value comment-column commit 8ccf9b52767c7634af1941c15198538313aaf2c0 Author: Mauro Aranda Date: Sat Feb 19 13:33:05 2022 +0100 Fix :match function for the key widget * lisp/wid-edit.el (key): Calling key-valid-p directly doesn't work, because the :match function is called with the widget and the value as arguments (bug#54049). diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index f00a524c0c..29b6e13bc6 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -3532,13 +3532,17 @@ It reads a directory name from an editable text field." (define-widget 'key 'editable-field "A key sequence." :prompt-value 'widget-field-prompt-value - :match 'key-valid-p + :match #'widget-key-valid-p :format "%{%t%}: %v" :validate 'widget-key-validate :keymap widget-key-sequence-map :help-echo "C-q: insert KEY, EVENT, or CODE; RET: enter value" :tag "Key") +(defun widget-key-valid-p (_widget value) + "Non-nil if VALUE is a valid value for the key widget WIDGET." + (key-valid-p value)) + (defun widget-key-validate (widget) (unless (and (stringp (widget-value widget)) (key-valid-p (widget-value widget))) commit 9fff6388b4df163990e581515892f7a09c4f728e Author: Po Lu Date: Sat Feb 19 12:30:26 2022 +0000 Fix some more hangs when parenting child frames around on Haiku * src/haiku_support.cc (ParentTo): (FrameMoved): Don't sync when a recursive lock might be able to be held. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index eb78afc6cb..f867e775f8 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -582,7 +582,6 @@ class EmacsWindow : public BWindow fullscreen_p = 0; MakeFullscreen (1); } - this->Sync (); window->LinkChild (this); child_frame_lock.Unlock (); @@ -914,7 +913,6 @@ class EmacsWindow : public BWindow DoMove (f); child_frame_lock.Unlock (); - Sync (); BWindow::FrameMoved (newPosition); } commit dfaf150631a235f7239774b73676955244513c54 Author: Lars Ingebrigtsen Date: Sat Feb 19 13:16:19 2022 +0100 Add a new library to format variable-pitch tables * doc/misc/vtable.texi (Index): New manual. * lisp/emacs-lisp/vtable.el: New library. diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi new file mode 100644 index 0000000000..5c010a1f79 --- /dev/null +++ b/doc/misc/vtable.texi @@ -0,0 +1,521 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename ../../info/vtable.info +@settitle Variable Pitch Tables +@include docstyle.texi +@c %**end of header + +@copying +This file documents the GNU vtable.el package. + +Copyright @copyright{} 2022 Free Software Foundation, Inc. + +@quotation +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.3 or +any later version published by the Free Software Foundation; with no +Invariant Sections, with the Front-Cover Texts being ``A GNU Manual,'' +and with the Back-Cover Texts as in (a) below. A copy of the license +is included in the section entitled ``GNU Free Documentation License.'' + +(a) The FSF's Back-Cover Text is: ``You have the freedom to copy and +modify this GNU manual.'' +@end quotation +@end copying + +@dircategory Emacs misc features +@direntry +* vtable: (vtable). Variable Pitch Tables. +@end direntry + +@finalout + +@titlepage +@title Variable Pitch Tables +@subtitle Columnar Display of Data. + +@page +@vskip 0pt plus 1filll +@insertcopying +@end titlepage + +@contents + +@ifnottex +@node Top +@top vtable + +@insertcopying +@end ifnottex + +@menu +* Introduction:: Introduction and examples. +* Concepts:: vtable concepts. +* Making A Table:: The main interface function. +* Commands:: vtable commands. +* Interface Functions:: Interface functions. + +Appendices +* GNU Free Documentation License:: The license for this documentation. + +Indices +* Index:: +@end menu + +@node Introduction +@chapter Introduction + +Most modes that display tabular data in Emacs use +@code{tabulated-list-mode}, but it has some limitations: It assumes +that the text it's displaying is monospaced, which makes it difficult +to mix fonts and images in a single list. The @dfn{vtable} (variable +pitch tables) package tackles this instead. + +@code{tabulated-list-mode} is a major mode, and assumes that it +controls the entire buffer. vtable doesn't assume that---you can have +a vtable in the middle of other data, or have several vtables in the +same buffer. + +Here's just about the simplest vtable that can be created: + +@lisp +(make-vtable + :objects '(("Foo" 1034) + ("Gazonk" 45))) +@end lisp + +By default, vtable uses the @code{variable-pitch} font, and +right-aligns columns that only have numerical data (and left-aligns +the rest). + +You'd normally want to name the columns: + +@lisp +(make-vtable + :columns '("Name" "ID") + :objects '(("Foo" 1034) + ("Gazonk" 45))) +@end lisp + +Clicking on the column names will sort the table based on the data in +each object (and in this example, each object is just a simple list). + +By default, the data is displayed ``as is'', that is, the way +@samp{(format "%s" ...)} would display it, but you can override that. + +@lisp +(make-vtable + :columns '("Name" "ID") + :objects '(("Foo" 1034) + ("Gazonk" 45)) + :formatter (lambda (value column &rest _) + (if (= column 1) + (file-size-human-readable value) + value))) +@end lisp + +In this case, that @samp{1034} will be displayed as @samp{1k}---but +will still sort after @samp{45}, because sorting is done on the actual +data, and not the displayed data. + +Alternatively, instead of having a general formatter for the table, +you can instead put the formatter in the column definition: + +@lisp +(make-vtable + :columns '("Name" + (:name "ID" :formatter file-size-human-readable)) + :objects '(("Foo" 1034) + ("Gazonk" 45))) +@end lisp + +The data doesn't have to be simple lists---you can give any type of +object to vtable, but then you also have to write a function that +returns the data for each column. For instance, here's a very simple +version of @kbd{M-x list-buffers}: + +@lisp +(make-vtable + :columns '("Name" "Size" "File") + :objects (buffer-list) + :actions '("k" kill-buffer + "RET" display-buffer) + :getter (lambda (object column vtable) + (pcase (vtable-column vtable column) + ("Name" (buffer-name object)) + ("Size" (buffer-size object)) + ("File" (or (buffer-file-name object) ""))))) +@end lisp + +@var{objects} in this case is a list of buffers. To get the data to be +displayed, vtable calls the @dfn{getter} function, which is called for +each column of every object, and should return something suitable for +display. + +Also note the @dfn{actions}: These are simple commands that will be +called with the object under point. So hitting @kbd{RET} on a line +will result in @code{display-buffer} being called with a buffer object +as the parameter. (You can also supply a keymap to be used, but then +you have to write commands that call @code{vtable-current-object} to +get at the object.) + +Note that the actions aren't called with the data displayed in the +buffer---they're called with the original objects. + +Finally, here's an example that uses just about all the features: + +@lisp +(make-vtable + :columns `(( :name "Thumb" :width "500px" + :displayer + ,(lambda (value max-width table) + (propertize "*" 'display + (create-image value nil nil + :max-width max-width)))) + (:name "Size" :width 10 + :formatter file-size-human-readable) + (:name "Time" :width 10 :primary ascend :direction 'descend) + "Name") + :objects-function (lambda () + (directory-files "~/pics/redslur/" + t "DSC0000[0-5].JPG")) + :actions '("RET" find-file) + :getter (lambda (object column table) + (pcase (vtable-column table column) + ("Name" (file-name-nondirectory object)) + ("Thumb" object) + ("Size" (file-attribute-size (file-attributes object))) + ("Time" (format-time-string + "%F" (file-attribute-modification-time + (file-attributes object)))))) + :separator-width 5 + :keymap (define-keymap + "q" #'kill-buffer)) +@end lisp + +This vtable implements a simple image browser that displays image +thumbnails (that change sizes dynamically depending on the width of +the column), human-readable file sizes, date and file name. The +separator width is 5 typical characters wide. Hitting @kbd{RET} on a +line will open the image in a new window, and hitting @kbd{q} will +kill a buffer. + +@node Concepts +@chapter Concepts + +A vtable lists data about a number of @dfn{objects}. Each object can +be a list or a vector, but it can also be anything else. + +To get the @dfn{value} for a particular column, the @dfn{getter} +function is called on the object. If no getter function is defined, +the default is to try to index the object as a sequence. In any case, +we end up with a value that is then used for sorting. + +This value is then @dfn{formatted} via a @dfn{formatter} function, +which is called with the @dfn{value} as the argument. The formatter +commonly makes the value more reader friendly. + +Finally, the formatted value is passed to the @dfn{displayer} +function, which is responsible for putting the table face on the +formatted value, and also ensuring that it's not wider than the column +width. The displayer will commonly truncate too-long strings and +scale image sizes. + +All these three transforms, the getter, the formatter and the display +functions, can be defined on a per-column basis, and also on a +per-table basis. (The per-column transform takes precedence over the +per-table transform.) + +User commands that are defined on a table does not work on the +displayed data. Instead they are called with the original object as +the argument. + +@node Making A Table +@chapter Making A Table + +@findex make-table +The interface function for making (and optionally inserting a table +into a buffer) is @code{make-table}. It takes the following keyword +parameters: + +@table @code +@item :objects +This is a list of objects to be displayed. It should either be a list +of strings (which will then be displayed as a single-column table), or +a list where each element is a sequence containing a mixture of +strings, number and other objects that can be displayed ``simply''. + +In the latter case, if @code{:columns} is non-@code{nil} and there's +more elements in the sequence than there is in @code{:columns}, only +the @code{:columns}th first elements are displayed. + +@item :objects-function +It's often convenient to generate the objects dynamically (for +instance, to make reversion work automatically). In that case, this +should be a function (which will be called with no arguments), and +should return a value as accepted as an @code{:objects} list. + +@item :columns +This is a list where each element is either a string (the column +name), a plist of keyword/values (to make a @code{vtable-column} +object), or a full @code{vtable-column} object. A +@code{vtable-column} object has the following slots: + +@table @code +@item name +The name of the column. + +@item width +The width of the column. This is either a number (the width of that +many @samp{x} characters in the table's face), or a string on the form +@samp{Xex}, where @var{x} is a number of @samp{x} characters, or a +string on the form @samp{Xpx} (denoting a number of pixels), or a +string on the form @samp{X%} (a percentage of the window's width). + +@item min-width +This uses the same format as @code{width}, but specifies the minimum +width (and overrides @code{width} is @code{width} is smaller than this. + +@item max-width +This uses the same format as @code{width}, but specifies the maximum +width (and overrides @code{width} is @code{width} is larger than this. +@code{min-width}/@code{max-width} can be useful if @code{width} is +given as a percentage of the window width, and you want to ensure that +the column doesn't grow pointlessly large or unreadably narrow. + +@item primary +Whether this is the primary column---this will be used for initial +sorting. This should be either @code{ascend} or @code{descend} to say +which order the table should be sorted in. + +@item getter +If present, this function will be called to return the column value. + +@defun column-getter object table +It's called with two parameters: The object and the table. +@end defun + +@item formatter +If present, this function will be called to format the value. + +@defun column-formatter value +It's called with one parameter: The column value. +@end defun + +@item displayer +If present, this function will be called to prepare the formatted +value for display. This function should return a string with the +table face applied, and also limit the width of the string to the +display width. + +@defun column-displayer fvalue max-width table +@var{fvalue} is the formatted value; @var{max-width} is the maximum +width (in pixels), and @var{table} is the table. +@end defun + +@item align +Should be either @code{right} or @code{left}. +@end table + +@item :getter +If given, this is a function that should return the values to use in +the table, and will be called once for each element in the table +(unless overridden by a column getter function). + +@defun getter object index table +For a simple object (like a sequence), this function will typically +just return the element corresponding to the column index, but the +function can do any computation it wants. If it's more convenient to +write the function based on column names rather than the column index, +the @code{vtable-column} function can be used to map from index to name. +@end defun + +@item :formatter +If present, this is a function that should format the value, and it +will be called on all values in the table (unless overridden by a +column formatter). + +@defun formatter value index table +This function is called with three parameters: The value (as returned +by the getter); the column index, and the table. It can return any +value. + +This can be used to (for instance) format numbers in a human-readable +form. +@end defun + +@item :displayer +Before displaying an element, it's passed to the displaying function +(if any). + +@defun displayer fvalue index max-width table +This is called with four arguments: The formatted value of the element +(as returned by the formatter function); the column index; the display +width (in pixels); and the table. + +This function should return a string with the table face applied, and +truncated to the display width. + +This can be used to (for instance) change the size of images that are +displayed in the table. +@end defun + +@item :use-header-line +If non-@code{nil} (which is the default), use the Emacs header line +machinery to display the column names. This is the most common use +case, but if there's other text in the buffer before the table, or +there are several tables in the same buffer, then this should be +@code{nil}. + +@item :face +The face to be used. This defaults to @code{variable-pitch}. This +face doesn't override the faces in the data, or supplied by the getter +or formatter functions. + +@item :actions +This uses the same syntax as @code{define-keymap}, but doesn't refer +to commands directly. Instead each key is bound to a command that +picks out the current object, and then calls the function specified +with that as the argument. + +@item :keymap +This is a keymap used on the table. The commands here are called as +usual, and if they're supposed to work on the object displayed on the +current line, they can use the @code{vtable-current-object} function +to determine what that object is. + +@item :separator-width +The blank space between columns. + +@item :sort-by +This should be a list of tuples, and specifies how the table is to be +sorted. Each tuple should consist of an integer (the column index) +and either @code{ascend} or @code{descend}. + +The table is first sorted by the first element in this list, and then +the next, until the end is reached. + +@item :ellipsis +By default, when shortening displayed values, an ellipsis will be +shown. If this is @code{nil}, no ellipsis is shown. (The text to use +as the ellipsis is determined by the @code{truncate-string-ellipsis} +function.) + +@findex vtable-insert +@item :insert +By default, @code{make-vtable} will insert the table at point. If this +is @code{nil}, nothing is inserted, but the vtable object is returned, +and you can insert it later with the @code{vtable-insert} function. +@end table + +@node Commands +@chapter Commands + +@table @kbd +@item S +Sort the table by the current column +(@code{vtable-sort-by-current-column}). Note that the table is sorted +according to the data returned by the getter function, not by how it's +displayed in the buffer. Columns that have only numerical data is +sorted as numbers, the rest are sorted as strings. + +@item @{ +Make the current column narrower +(@code{vtable-narrow-current-column}). + +@item @} +Make the current column wider +(@code{vtable-widen-current-column}). + +@item M- +Move to the previous column (@code{vtable-previous-column}). + +@item M- +Move to the next column (@code{vtable-next-column}). + +@item g +Regenerate the table (@code{vtable-revert-command}). This command +mostly makes sense if the table has a @code{:objects-function} that +can fetch new data. +@end table + +@node Interface Functions +@chapter Interface Functions + +People writing modes based on vtable has to interact with the table in +various ways---for instance, to write commands that updates an object +and then displays the result. + +@defun vtable-current-table +This function returns the table under point. +@end defun + +@defun vtable-current-object +This function returns the object on the current line. (Note that this +is the original object, and not the characters displayed in the +buffer.) +@end defun + +@defun vtable-current-column +This function returns the column index of the column under point. +@end defun + +@defun vtable-goto-table table +Move point to the start of @var{table} and return the position. If +@var{table} can't be found in the current buffer, don't move point and +return @code{nil}. +@end defun + +@defun vtable-goto-object object +Move point to the start of the line where @var{object} is displayed in +the current table and return point. If @var{object} can't be found, +don't move point and return @code{nil}. +@end defun + +@defun vtable-goto-column index +Move point to the start of the @var{index}th column. (The first +column is numbered zero.) +@end defun + +@defun vtable-beginning-of-table +Move to the beginning of the current table. +@end defun + +@defun vtable-end-of-table +Move to the end of the current table. +@end defun + +@defun vtable-remove-object table object +Remove @var{object} from @var{table}. This also updates the displayed +table. +@end defun + +@defun vtable-insert-object table object &optional after-object +Insert @var{object} into @var{table}. If @var{after-object}, insert +the object after this object; otherwise append to @var{table}. This +also updates the displayed table. +@end defun + +@defun vtable-update-object table object old-object +Change @var{old-object} into @var{object} in @var{table}. This also +updates the displayed table. + +This has the same effect as calling @code{vtable-remove-object} and +then @code{vtable-insert-object}, but is more efficient. +@end defun + +@defun vtable-column table index +Return the column name of the @var{index}th column in @var{table}. +@end defun + +@node GNU Free Documentation License +@chapter GNU Free Documentation License +@include doclicense.texi + +@node Index +@unnumbered Index +@printindex cp + +@bye + +@c todo up/down markers diff --git a/etc/NEWS b/etc/NEWS index 706c88d67b..e1dc64c8aa 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -991,6 +991,12 @@ support for pipelines which will move a lot of data. See section ** Miscellaneous ++++ +*** A new package for formatting tabular data, vtable.el, has been added. +This new package allows formatting data using non-monospaced fonts. +Variable pitch fonts, and text using fonts with different sizes can be +displayed, as well as images. See the '(vtable)Top' manual. + --- *** 'list-bookmarks' now includes a type column. Types are registered via a 'bookmark-handler-type' symbol property on diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el new file mode 100644 index 0000000000..9107c4439c --- /dev/null +++ b/lisp/emacs-lisp/vtable.el @@ -0,0 +1,731 @@ +;;; vtable.el --- Displaying data in tables -*- 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: + +;; + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'text-property-search) +(require 'mule-util) + +(cl-defstruct vtable-column + "A vtable column." + name + width + min-width + max-width + primary + align + getter + formatter + displayer + -numerical) + +(defclass vtable () + ((columns :initarg :columns :accessor vtable-columns) + (objects :initarg :objects :accessor vtable-objects) + (objects-function :initarg :objects-function + :accessor vtable-objects-function) + (getter :initarg :getter :accessor vtable-getter) + (formatter :initarg :formatter :accessor vtable-formatter) + (displayer :initarg :displayer :accessor vtable-displayer) + (use-header-line :initarg :use-header-line + :accessor vtable-use-header-line) + (face :initarg :face :accessor vtable-face) + (actions :initarg :actions :accessor vtable-actions) + (keymap :initarg :keymap :accessor vtable-keymap) + (separator-width :initarg :separator-width :accessor vtable-separator-width) + (sort-by :initarg :sort-by :accessor vtable-sort-by) + (ellipsis :initarg :ellipsis :accessor vtable-ellipsis) + (-cache :initform (make-hash-table :test #'equal))) + "A object to hold the data for a table.") + +(defvar-keymap vtable-map + :suppress t + "S" #'vtable-sort-by-current-column + "{" #'vtable-narrow-current-column + "}" #'vtable-widen-current-column + "g" #'vtable-revert-command + "M-" #'vtable-previous-column + "M-" #'vtable-next-column) + +(defvar-keymap vtable-header-line-map + :parent vtable-map + "" 'mouse-face + "" #'vtable-header-line-sort) + +(cl-defun make-vtable (&key columns objects objects-function + getter + formatter + displayer + (use-header-line t) + (face 'variable-pitch) + actions keymap + (separator-width 1) + sort-by + (ellipsis t) + (insert t)) + "Create and insert a vtable at point. +The vtable object is returned. If INSERT is nil, the table won't +be inserted." + (when objects-function + (setq objects (funcall objects-function))) + ;; Auto-generate the columns. + (unless columns + (unless objects + (error "Can't auto-generate columns; no objects")) + (setf columns (make-list (length (car objects)) ""))) + (setq columns (mapcar (lambda (column) + (cond + ;; We just have the name (as a string). + ((stringp column) + (make-vtable-column :name column)) + ;; A plist of keywords/values. + ((listp column) + (apply #'make-vtable-column column)) + ;; A full `vtable-column' object. + (t + column))) + columns)) + ;; We'll be altering the list, so create a copy. + (setq objects (copy-sequence objects)) + (let ((table + (make-instance 'vtable + :columns columns + :objects objects + :objects-function objects-function + :getter getter + :formatter formatter + :displayer displayer + :use-header-line use-header-line + :face face + :actions actions + :keymap keymap + :separator-width separator-width + :sort-by sort-by + :ellipsis ellipsis))) + ;; Compute missing column data. + (setf (vtable-columns table) (vtable--compute-columns table)) + (unless sort-by + (seq-do-indexed (lambda (column index) + (when (vtable-column-primary column) + (push (cons index (vtable-column-primary column)) + (vtable-sort-by table)))) + (vtable-columns table))) + (when insert + (vtable-insert table)) + table)) + +;;; Interface utility functions. + +(defun vtable-current-table () + "Return the table under point." + (get-text-property (point) 'vtable)) + +(defun vtable-current-object () + "Return the object under point." + (get-text-property (point) 'vtable-object)) + +(defun vtable-current-column () + "Return the index of the column under point." + (get-text-property (point) 'vtable-column)) + +(defun vtable-beginning-of-table () + "Go to the start of the current table." + (if (text-property-search-backward 'vtable (vtable-current-table)) + (point) + (goto-char (point-min)))) + +(defun vtable-end-of-table () + "Go to the end of the current table." + (if (text-property-search-forward 'vtable (vtable-current-table)) + (point) + (goto-char (point-max)))) + +(defun vtable-goto-object (object) + "Go to OBJECT in the current table. +Return the position of the object if found, and nil if not." + (let ((start (point))) + (vtable-beginning-of-table) + (save-restriction + (narrow-to-region (point) (vtable-end-of-table)) + (if (text-property-search-forward 'vtable-object object #'eq) + (progn + (forward-line -1) + (point)) + (goto-char start) + nil)))) + +(defun vtable-goto-table (table) + "Go to TABLE in the current buffer. +If TABLE is found, return the position of the start of the table. +If it can't be found, return nil and don't move point." + (let ((start (point))) + (goto-char (point-min)) + (if-let ((match (text-property-search-forward 'vtable table t))) + (goto-char (prop-match-beginning match)) + (goto-char start) + nil))) + +(defun vtable-goto-column (column) + "Go to COLUMN on the current line." + (beginning-of-line) + (if-let ((match (text-property-search-forward 'vtable-column column t))) + (goto-char (prop-match-beginning match)) + (end-of-line))) + +(defun vtable-update-object (table object old-object) + "Replace OLD-OBJECT in TABLE with OBJECT." + (let* ((objects (vtable-objects table)) + (inhibit-read-only t)) + ;; First replace the object in the object storage. + (if (eq old-object (car objects)) + ;; It's at the head, so replace it there. + (setf (vtable-objects table) + (cons object (cdr objects))) + ;; Otherwise splice into the list. + (while (and (cdr objects) + (not (eq (cadr objects) old-object))) + (setq objects (cdr objects))) + (unless objects + (error "Can't find the old object")) + (setcar (cdr objects) object)) + ;; Then update the cache... + (let ((line (assq old-object (car (vtable--cache table))))) + (unless line + (error "Can't find cached object")) + (setcar line object) + (setcdr line (vtable--compute-cached-line table object)) + ;; ... and redisplay the line in question. + (save-excursion + (vtable-goto-object old-object) + (let ((keymap (get-text-property (point) 'keymap)) + (start (point))) + (delete-line) + (vtable--insert-line table line (nth 1 (vtable--cache table)) + (vtable--spacer table)) + (add-text-properties start (point) (list 'keymap keymap + 'vtable table)))) + ;; We may have inserted a non-numerical value into a previously + ;; all-numerical table, so recompute. + (vtable--recompute-numerical table (cdr line))))) + +(defun vtable-remove-object (table object) + "Remove OBJECT from TABLE. +This will also remove the displayed line." + ;; First remove from the objects. + (setf (vtable-objects table) (delq object (vtable-objects table))) + ;; Then adjust the cache and display. + (let ((cache (vtable--cache table)) + (inhibit-read-only t)) + (setcar cache (delq (assq object (car cache)) (car cache))) + (save-excursion + (vtable-goto-table table) + (when (vtable-goto-object object) + (delete-line))))) + +(defun vtable-insert-object (table object &optional after-object) + "Insert OBJECT into TABLE after AFTER-OBJECT. +If AFTER-OBJECT is nil (or doesn't exist in the table), insert +OBJECT at the end. +This also updates the displayed table." + ;; First insert into the objects. + (let (pos) + (if (and after-object + (setq pos (memq after-object (vtable-objects table)))) + ;; Splice into list. + (setcdr pos (cons object (cdr pos))) + ;; Append. + (nconc (vtable-objects table) (list object)))) + ;; Then adjust the cache and display. + (save-excursion + (vtable-goto-table table) + (let* ((cache (vtable--cache table)) + (inhibit-read-only t) + (keymap (get-text-property (point) 'keymap)) + (elem (and after-object + (assq after-object (car cache)))) + (line (cons object (vtable--compute-cached-line table object)))) + (if (not elem) + ;; Append. + (progn + (setcar cache (nconc (car cache) (list line))) + (vtable-end-of-table)) + ;; Splice into list. + (let ((pos (memq elem (car cache)))) + (setcdr pos (cons line (cdr pos))) + (unless (vtable-goto-object after-object) + (vtable-end-of-table)))) + (let ((start (point))) + (vtable--insert-line table line (nth 1 cache) (vtable--spacer table)) + (add-text-properties start (point) (list 'keymap keymap + 'vtable table))) + ;; We may have inserted a non-numerical value into a previously + ;; all-numerical table, so recompute. + (vtable--recompute-numerical table (cdr line))))) + +(defun vtable-column (table index) + "Return the name of the INDEXth column in TABLE." + (vtable-column-name (elt (vtable-columns table) index))) + +;;; Generating the table. + +(defun vtable--get-value (object index column table) + "Compute a cell value." + (cond + ((vtable-column-getter column) + (funcall (vtable-column-getter column) + object table)) + ((vtable-getter table) + (funcall (vtable-getter table) + object index table)) + ;; No getter functions; standard getters. + ((stringp object) + object) + (t + (elt object index)))) + +(defun vtable--compute-columns (table) + (let ((numerical (make-vector (length (vtable-columns table)) t)) + (columns (vtable-columns table))) + ;; First determine whether there are any all-numerical columns. + (dolist (object (vtable-objects table)) + (seq-do-indexed + (lambda (_elem index) + (unless (numberp (vtable--get-value object index (elt columns index) + table)) + (setf (elt numerical index) nil))) + (vtable-columns table))) + ;; Then fill in defaults. + (seq-map-indexed + (lambda (column index) + ;; This is used when displaying. + (unless (vtable-column-align column) + (setf (vtable-column-align column) + (if (elt numerical index) + 'right + 'left))) + ;; This is used for sorting. + (setf (vtable-column--numerical column) + (elt numerical index)) + column) + (vtable-columns table)))) + +(defun vtable--spacer (table) + (vtable--compute-width table (vtable-separator-width table))) + +(defun vtable-insert (table) + (let* ((spacer (vtable--spacer table)) + (start (point)) + (ellipsis (if (vtable-ellipsis table) + (propertize (truncate-string-ellipsis) + 'face (vtable-face table)) + "")) + (ellipsis-width (string-pixel-width ellipsis)) + data widths) + ;; We maintain a cache per screen/window width, so that we render + ;; correctly if Emacs is open on two different screens (or the + ;; user resizes the frame). + (if-let ((cache (vtable--cache table))) + (setq data (nth 0 cache) + widths (nth 1 cache)) + (setq data (vtable--compute-cache table) + widths (vtable--compute-widths table data)) + (setf (gethash (vtable--cache-key) (slot-value table '-cache)) + (list data widths))) + (if (vtable-use-header-line table) + (vtable--set-header-line table widths spacer) + ;; Insert the header line directly into the buffer, and put a + ;; keymap to be able to sort the columns there (by clicking on + ;; them). + (vtable--insert-header-line table widths spacer) + (add-text-properties start (point) + (list 'keymap vtable-header-line-map + 'rear-nonsticky t + 'vtable table)) + (setq start (point))) + (vtable--sort table) + ;; Insert the data. + (dolist (line (car (vtable--cache table))) + (vtable--insert-line table line widths spacer + ellipsis ellipsis-width)) + (add-text-properties start (point) + (list 'keymap (vtable--make-keymap table) + 'rear-nonsticky t + 'vtable table)) + (goto-char start))) + +(defun vtable--insert-line (table line widths spacer + &optional ellipsis ellipsis-width) + (let ((start (point)) + (columns (vtable-columns table))) + (seq-do-indexed + (lambda (elem index) + (let ((value (nth 0 elem)) + (column (elt columns index)) + (pre-computed (nth 2 elem))) + ;; See if we have any formatters here. + (cond + ((vtable-column-formatter column) + (setq value (funcall (vtable-column-formatter column) value) + pre-computed nil)) + ((vtable-formatter table) + (setq value (funcall (vtable-formatter table) + value index table) + pre-computed nil))) + (let ((displayed + ;; Allow any displayers to have their say. + (cond + ((vtable-column-displayer column) + (funcall (vtable-column-displayer column) + value (elt widths index) table)) + ((vtable-displayer table) + (funcall (vtable-displayer table) + value index (elt widths index) table)) + (pre-computed + ;; If we don't have a displayer, use the pre-made + ;; (cached) string value. + (if (> (nth 1 elem) (elt widths index)) + (concat + (vtable--limit-string + pre-computed (- (elt widths index) ellipsis-width)) + ellipsis) + pre-computed)) + ;; Recompute widths. + (t + (if (> (string-pixel-width value) (elt widths index)) + (concat + (vtable--limit-string + value (- (elt widths index) ellipsis-width)) + ellipsis) + value)))) + (start (point))) + (if (eq (vtable-column-align column) 'left) + (insert displayed + (propertize + " " 'display + (list 'space + :width (list + (+ (- (elt widths index) + (string-pixel-width displayed)) + spacer))))) + ;; Align to the right. + (insert (propertize " " 'display + (list 'space + :width (list (- (elt widths index) + (string-pixel-width + displayed))))) + displayed + (propertize " " 'display + (list 'space + :width (list spacer))))) + (put-text-property start (point) 'vtable-column index)))) + (cdr line)) + (insert "\n") + (put-text-property start (point) 'vtable-object (car line)))) + +(defun vtable--cache-key () + (cons (frame-terminal) (window-width))) + +(defun vtable--cache (table) + (gethash (vtable--cache-key) (slot-value table '-cache))) + +(defun vtable--clear-cache (table) + (setf (gethash (vtable--cache-key) (slot-value table '-cache)) nil)) + +(defun vtable--sort (table) + (pcase-dolist (`(,index . ,direction) (vtable-sort-by table)) + (let ((cache (vtable--cache table)) + (numerical (vtable-column--numerical + (elt (vtable-columns table) index)))) + (setcar cache + (sort (car cache) + (lambda (e1 e2) + (let ((c1 (elt e1 (1+ index))) + (c2 (elt e2 (1+ index)))) + (if numerical + (< (car c1) (car c2)) + (string< (if (stringp (car c1)) + (car c1) + (format "%s" (car c1))) + (if (stringp (car c2)) + (car c2) + (format "%s" (car c2))))))))) + (when (eq direction 'descend) + (setcar cache (nreverse (car cache))))))) + +(defun vtable--insert-header-line (table widths spacer) + ;; Insert the header directly into the buffer. + (let ((start (point))) + (seq-do-indexed + (lambda (column index) + (let ((name (propertize + (vtable-column-name column) + 'face (list 'header-line (vtable-face table)))) + (start (point)) + displayed) + (insert + (setq displayed + (if (> (string-pixel-width name) (elt widths index)) + (vtable--limit-string name (elt widths index)) + name)) + (propertize " " 'display + (list 'space :width + (list (+ (- (elt widths index) + (string-pixel-width displayed)) + spacer))))) + (put-text-property start (point) 'vtable-column index))) + (vtable-columns table)) + (insert "\n") + (add-face-text-property start (point) 'header-line))) + +(defun vtable--recompute-numerical (table line) + "Recompute numericalness of columns if necessary." + (let ((columns (vtable-columns table)) + (recompute nil)) + (seq-do-indexed + (lambda (elem index) + (when (and (vtable-column--numerical (elt columns index)) + (not (numberp elem))) + (setq recompute t))) + line) + (when recompute + (vtable--compute-columns table)))) + +(defun vtable--set-header-line (table widths spacer) + (setq header-line-format + (string-replace + "%" "%%" + (with-temp-buffer + (insert " ") + (vtable--insert-header-line table widths spacer) + ;; Align the header with the (possibly) fringed buffer text. + (put-text-property + (point-min) (1+ (point-min)) + 'display '(space :align-to 0)) + (buffer-substring (point-min) (1- (point-max)))))) + (vtable-header-mode 1)) + +(defun vtable--limit-string (string pixels) + (while (and (length> string 0) + (> (string-pixel-width string) pixels)) + (setq string (substring string 0 (1- (length string))))) + string) + +(defun vtable--char-width (table) + (string-pixel-width (propertize "x" 'face (vtable-face table)))) + +(defun vtable--compute-width (table spec) + (cond + ((numberp spec) + (* spec (vtable--char-width table))) + ((string-match "\\([0-9.]+\\)ex" spec) + (* (string-to-number (match-string 1 spec)) (vtable--char-width table))) + ((string-match "\\([0-9.]+\\)px" spec) + (string-to-number (match-string 1 spec))) + ((string-match "\\([0-9.]+\\)%" spec) + (* (string-to-number (match-string 1 spec)) (window-width nil t))) + (t + (error "Invalid spec: %s" spec)))) + +(defun vtable--compute-widths (table cache) + "Compute the display widths for TABLE." + (seq-into + (seq-map-indexed + (lambda (column index) + (let ((width + (or + ;; Explicit widths. + (and (vtable-column-width column) + (vtable--compute-width table (vtable-column-width column))) + ;; Compute based on the displayed widths of + ;; the data. + (seq-max (seq-map (lambda (elem) + (nth 1 (elt (cdr elem) index))) + cache))))) + ;; Let min-width/max-width specs have their say. + (when-let ((min-width (and (vtable-column-min-width column) + (vtable--compute-width + table (vtable-column-min-width column))))) + (setq width (max width min-width))) + (when-let ((max-width (and (vtable-column-max-width column) + (vtable--compute-width + table (vtable-column-max-width column))))) + (setq width (min width max-width))) + width)) + (vtable-columns table)) + 'vector)) + +(defun vtable--compute-cache (table) + (seq-map + (lambda (object) + (cons object (vtable--compute-cached-line table object))) + (vtable-objects table))) + +(defun vtable--compute-cached-line (table object) + (seq-map-indexed + (lambda (column index) + (let* ((value (vtable--get-value object index column table)) + (string (if (stringp value) + (copy-sequence value) + (format "%s" value)))) + (add-face-text-property 0 (length string) + (vtable-face table) + t string) + ;; We stash the computed width and string here -- if there are + ;; no formatters/displayers, we'll be using the string, and + ;; then won't have to recreate it. + (list value (string-pixel-width string) string))) + (vtable-columns table))) + +(defun vtable--make-keymap (table) + (let ((map (if (or (vtable-actions table) + (vtable-keymap table)) + (copy-keymap vtable-map) + vtable-map))) + (when-let ((actions (vtable-actions table))) + (while actions + (funcall (lambda (key binding) + (keymap-set map key + (lambda (object) + (interactive (list (vtable-current-object))) + (funcall binding object)))) + (car actions) (cadr actions)) + (setq actions (cddr actions)))) + (if (vtable-keymap table) + (progn + (set-keymap-parent (vtable-keymap table) map) + (vtable-keymap table)) + map))) + +(defun vtable-revert () + "Regenerate the table under point." + (let ((table (vtable-current-table)) + (object (vtable-current-object)) + (column (vtable-current-column)) + (inhibit-read-only t)) + (unless table + (user-error "No table under point")) + (delete-region (vtable-beginning-of-table) (vtable-end-of-table)) + (vtable-insert table) + (when object + (vtable-goto-object object)) + (when column + (vtable-goto-column column)))) + +(defun vtable--widths (table) + (nth 1 (vtable--cache table))) + +;;; Commands. + +(defvar-keymap vtable-header-mode-map + " " 'vtable-header-line-sort + " " 'vtable-header-line-sort) + +(define-minor-mode vtable-header-mode + "Minor mode for buffers with vtables with headers." + :keymap vtable-header-mode-map) + +(defun vtable-narrow-current-column () + "Narrow the current column." + (interactive) + (let* ((table (vtable-current-table)) + (column (vtable-current-column)) + (widths (vtable--widths table))) + (setf (aref widths column) + (max (* (vtable--char-width table) 2) + (- (aref widths column) (vtable--char-width table)))) + (vtable-revert))) + +(defun vtable-widen-current-column () + "Widen the current column." + (interactive) + (let* ((table (vtable-current-table)) + (column (vtable-current-column)) + (widths (nth 1 (vtable--cache table)))) + (cl-incf (aref widths column) (vtable--char-width table)) + (vtable-revert))) + +(defun vtable-previous-column () + "Go to the previous column." + (interactive) + (vtable-goto-column + (max 0 (1- (or (vtable-current-column) + (length (vtable--widths (vtable-current-table)))))))) + +(defun vtable-next-column () + "Go to the next column." + (interactive) + (when (vtable-current-column) + (vtable-goto-column + (min (1- (length (vtable--widths (vtable-current-table)))) + (1+ (vtable-current-column)))))) + +(defun vtable-revert-command () + "Re-query data and regenerate the table under point." + (interactive) + (let ((table (vtable-current-table))) + (when (vtable-objects-function table) + (setf (vtable-objects table) (funcall (vtable-objects-function table)))) + (vtable--clear-cache table)) + (vtable-revert)) + +(defun vtable-sort-by-current-column () + "Sort the table under point by the column under point." + (interactive) + (unless (vtable-current-column) + (user-error "No current column")) + (let* ((table (vtable-current-table)) + (last (car (last (vtable-sort-by table)))) + (index (vtable-current-column))) + ;; First prune any previous appearance of this column. + (setf (vtable-sort-by table) + (delq (assq index (vtable-sort-by table)) + (vtable-sort-by table))) + ;; Then insert this as the last sort key. + (setf (vtable-sort-by table) + (append (vtable-sort-by table) + (list (cons index + (if (eq (car last) index) + (if (eq (cdr last) 'ascend) + 'descend + 'ascend) + 'ascend)))))) + (vtable-revert)) + +(defun vtable-header-line-sort (e) + "Sort a vtable from the header line." + (interactive "e") + (let* ((pos (event-start e)) + (obj (posn-object pos))) + (with-current-buffer (window-buffer (posn-window pos)) + (goto-char (point-min)) + (vtable-goto-column + (get-text-property (if obj (cdr obj) (posn-point pos)) + 'vtable-column + (car obj))) + (vtable-sort-by-current-column)))) + +(provide 'vtable) + +;;; vtable.el ends here diff --git a/test/lisp/emacs-lisp/vtable-tests.el b/test/lisp/emacs-lisp/vtable-tests.el new file mode 100644 index 0000000000..627d9f9c5d --- /dev/null +++ b/test/lisp/emacs-lisp/vtable-tests.el @@ -0,0 +1,42 @@ +;;; vtable-tests.el --- Tests for vtable.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 . + +;;; Commentary: + +;; + +;;; Code: + +(require 'vtable) +(require 'ert) +(require 'ert-x) + +(ert-deftest test-vstable-compute-columns () + (should + (equal (mapcar + (lambda (column) + (vtable-column-align column)) + (vtable--compute-columns + (make-vtable :columns '("a" "b" "c") + :objects '(("foo" 1 2) + ("bar" 3 :zot)) + :insert nil))) + '(left right left)))) + +;;; vtable-tests.el ends here commit 88f591f389ba4ac13dd5aebfffa7863805758bcb Author: Po Lu Date: Sat Feb 19 20:05:18 2022 +0800 Improve portability of alpha channel visual detection * src/xfns.c (select_visual): Look for PictVisuals with an alpha channel instead of blindly assuming that 32 bit visuals have an alpha channel. (Fx_show_tip): Fix crash on some displays where child is None. * src/xterm.c (x_term_init): Initialize Xrender before calling select_visual. diff --git a/src/xfns.c b/src/xfns.c index 0a8d18d918..b0e7af9d8f 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -6574,28 +6574,45 @@ select_visual (struct x_display_info *dpyinfo) vinfo_template.screen = XScreenNumberOfScreen (screen); -#if !defined USE_X_TOOLKIT && !(defined USE_GTK && !defined HAVE_GTK3) - /* First attempt to use 32-bit visual if available */ - - vinfo_template.depth = 32; - vinfo_template.class = TrueColor; +#if !defined USE_X_TOOLKIT && !(defined USE_GTK && !defined HAVE_GTK3) \ + && defined HAVE_XRENDER + int i; + XRenderPictFormat *format; - vinfo = XGetVisualInfo (dpy, (VisualScreenMask - | VisualDepthMask - | VisualClassMask), - &vinfo_template, &n_visuals); + /* First attempt to find a visual with an alpha mask if + available. That information is only available when the + render extension is present, and we cannot do much with such + a visual if it isn't. */ - if (n_visuals > 0 && vinfo) + if (dpyinfo->xrender_supported_p) { - dpyinfo->n_planes = vinfo->depth; - dpyinfo->visual = vinfo->visual; - XFree (vinfo); - return; - } + vinfo = XGetVisualInfo (dpy, VisualScreenMask, + &vinfo_template, &n_visuals); + + for (i = 0; i < n_visuals; ++i) + { + format = XRenderFindVisualFormat (dpy, vinfo[i].visual); + + if (format && format->type == PictTypeDirect + && format->direct.alphaMask) + { + dpyinfo->n_planes = vinfo[i].depth; + dpyinfo->visual = vinfo[i].visual; + dpyinfo->pict_format = format; + + XFree (vinfo); + return; + } + } + + if (vinfo) + XFree (vinfo); + } #endif /* !USE_X_TOOLKIT */ - /* 32-bit visual not available, fallback to default visual */ + /* Visual with alpha channel (or the Render extension) not + available, fallback to default visual. */ dpyinfo->visual = DefaultVisualOfScreen (screen); vinfo_template.visualid = XVisualIDFromVisual (dpyinfo->visual); vinfo = XGetVisualInfo (dpy, VisualIDMask | VisualScreenMask, @@ -8091,7 +8108,8 @@ Text larger than the specified size is clipped. */) FRAME_DISPLAY_INFO (f)->root_window, FRAME_DISPLAY_INFO (f)->root_window, root_x, root_y, &dest_x_return, - &dest_y_return, &child)) + &dest_y_return, &child) + && child != None) { /* But only if the child is not override-redirect, which can happen if the pointer is above a menu. */ diff --git a/src/xterm.c b/src/xterm.c index 2dc420a8de..e2ad0b48f5 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -15989,6 +15989,18 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) #else dpyinfo->display->db = xrdb; #endif + +#ifdef HAVE_XRENDER + int event_base, error_base; + dpyinfo->xrender_supported_p + = XRenderQueryExtension (dpyinfo->display, &event_base, &error_base); + + if (dpyinfo->xrender_supported_p) + dpyinfo->xrender_supported_p + = XRenderQueryVersion (dpyinfo->display, &dpyinfo->xrender_major, + &dpyinfo->xrender_minor); +#endif + /* Put the rdb where we can find it in a way that works on all versions. */ dpyinfo->rdb = xrdb; @@ -16004,19 +16016,12 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) reset_mouse_highlight (&dpyinfo->mouse_highlight); #ifdef HAVE_XRENDER - int event_base, error_base; - dpyinfo->xrender_supported_p - = XRenderQueryExtension (dpyinfo->display, &event_base, &error_base); - - if (dpyinfo->xrender_supported_p) - { - if (!XRenderQueryVersion (dpyinfo->display, &dpyinfo->xrender_major, - &dpyinfo->xrender_minor)) - dpyinfo->xrender_supported_p = false; - else - dpyinfo->pict_format = XRenderFindVisualFormat (dpyinfo->display, - dpyinfo->visual); - } + if (dpyinfo->xrender_supported_p + /* This could already have been initialized by + `select_visual'. */ + && !dpyinfo->pict_format) + dpyinfo->pict_format = XRenderFindVisualFormat (dpyinfo->display, + dpyinfo->visual); #endif #ifdef HAVE_XSYNC commit f687e62ac5dff18a81354e2a29f523c16e3446c3 Author: Alan Mackenzie Date: Sat Feb 19 10:38:19 2022 +0000 Fix symbols with position appearing in the output of `compile-defun' This happened with the tags of a condition-case. Also fix the detection of circular lists while stripping the positions from symbols with position. * lisp/emacs-lisp/byte-run.el (byte-run--circular-list-p): Remove. (byte-run--strip-s-p-1): Write a value of t into a hash table for each cons or vector/record encountered. (This is to prevent loops with circular structures.) This is now done for all arguments, not just those detected as circular lists. * lisp/emacs-lisp/bytecomp.el (byte-compile-file-form-defvar) (byte-compile-form, byte-compile-dynamic-variable-op) (byte-compile-constant, byte-compile-push-constant): Remove redundant calls to `bare-symbol'. (byte-compile-lambda): call `byte-run-strip-symbol-positions' on the arglist. (byte-compile-out): call `byte-run-strip-symbol-positions' on the operand. This is the main call to this function in bytecomp.el. * src/fns.c (hashfn_eq): Strip the position from an argument which is a symbol with position. (hash_lookup): No longer strip a position from a symbol with position. (sxhash_obj): Add handling for symbols with position, substituting their bare symbols when symbols with position are enabled. diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 110f7e4abf..5c59d0ae94 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -37,24 +37,6 @@ the corresponding new element of the same type. The purpose of this is to detect circular structures.") -(defalias 'byte-run--circular-list-p - #'(lambda (l) - "Return non-nil when the list L is a circular list. -Note that this algorithm doesn't check any circularity in the -CARs of list elements." - (let ((hare l) - (tortoise l)) - (condition-case err - (progn - (while (progn - (setq hare (cdr (cdr hare)) - tortoise (cdr tortoise)) - (not (or (eq tortoise hare) - (null hare))))) - (eq tortoise hare)) - (wrong-type-argument nil) - (error (signal (car err) (cdr err))))))) - (defalias 'byte-run--strip-s-p-1 #'(lambda (arg) "Strip all positions from symbols in ARG, modifying ARG. @@ -64,41 +46,36 @@ Return the modified ARG." (bare-symbol arg)) ((consp arg) - (let* ((round (byte-run--circular-list-p arg)) - (hash (and round (gethash arg byte-run--ssp-seen)))) - (or hash - (let ((a arg) new) - (while - (progn - (when round - (puthash a new byte-run--ssp-seen)) - (setq new (byte-run--strip-s-p-1 (car a))) - (when (not (eq new (car a))) ; For read-only things. - (setcar a new)) - (and (consp (cdr a)) - (not - (setq hash - (and round - (gethash (cdr a) byte-run--ssp-seen)))))) - (setq a (cdr a))) - (setq new (byte-run--strip-s-p-1 (cdr a))) - (when (not (eq new (cdr a))) - (setcdr a (or hash new))) - arg)))) + (let* ((hash (gethash arg byte-run--ssp-seen))) + (if hash ; Already processed this node. + arg + (let ((a arg) new) + (while + (progn + (puthash a t byte-run--ssp-seen) + (setq new (byte-run--strip-s-p-1 (car a))) + (setcar a new) + (and (consp (cdr a)) + (not + (setq hash (gethash (cdr a) byte-run--ssp-seen))))) + (setq a (cdr a))) + (setq new (byte-run--strip-s-p-1 (cdr a))) + (setcdr a new) + arg)))) ((or (vectorp arg) (recordp arg)) (let ((hash (gethash arg byte-run--ssp-seen))) - (or hash - (let* ((len (length arg)) - (i 0) - new) - (puthash arg arg byte-run--ssp-seen) - (while (< i len) - (setq new (byte-run--strip-s-p-1 (aref arg i))) - (when (not (eq new (aref arg i))) - (aset arg i new)) - (setq i (1+ i))) - arg)))) + (if hash + arg + (let* ((len (length arg)) + (i 0) + new) + (puthash arg t byte-run--ssp-seen) + (while (< i len) + (setq new (byte-run--strip-s-p-1 (aref arg i))) + (aset arg i new) + (setq i (1+ i))) + arg)))) (t arg)))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index ff372151e1..c59bb292f8 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2610,15 +2610,9 @@ list that represents a doc string reference. nil (byte-compile-docstring-length-warn form) (setq form (copy-sequence form)) - (cond ((consp (nth 2 form)) - (setcar (cdr (cdr form)) - (byte-compile-top-level (nth 2 form) nil 'file))) - ((symbolp (nth 2 form)) - (setcar (cddr form) (bare-symbol (nth 2 form)))) - (t (setcar (cddr form) (nth 2 form)))) - (setcar form (bare-symbol (car form))) - (if (symbolp (nth 1 form)) - (setcar (cdr form) (bare-symbol (nth 1 form)))) + (when (consp (nth 2 form)) + (setcar (cdr (cdr form)) + (byte-compile-top-level (nth 2 form) nil 'file))) form)) (put 'define-abbrev-table 'byte-hunk-handler @@ -3034,7 +3028,8 @@ lambda-expression." (byte-compile-docstring-length-warn fun) (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) - (arglistvars (byte-compile-arglist-vars arglist)) + (arglistvars (byte-run-strip-symbol-positions + (byte-compile-arglist-vars arglist))) (byte-compile-bound-variables (append (if (not lexical-binding) arglistvars) byte-compile-bound-variables)) @@ -3337,12 +3332,10 @@ lambda-expression." (cond ((not (consp form)) (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) - (byte-compile-constant - (if (symbolp form) (bare-symbol form) form))) + (byte-compile-constant form)) ((and byte-compile--for-effect byte-compile-delete-errors) (setq byte-compile--for-effect nil)) - (t - (byte-compile-variable-ref (bare-symbol form))))) + (t (byte-compile-variable-ref form)))) ((symbolp (car form)) (let* ((fn (car form)) (handler (get fn 'byte-compile)) @@ -3572,7 +3565,6 @@ lambda-expression." (byte-compile-warn-obsolete var)))) (defsubst byte-compile-dynamic-variable-op (base-op var) - (if (symbolp var) (setq var (bare-symbol var))) (let ((tmp (assq var byte-compile-variables))) (unless tmp (setq tmp (list var)) @@ -3646,14 +3638,11 @@ assignment (i.e. `setq')." (defun byte-compile-constant (const) (if byte-compile--for-effect (setq byte-compile--for-effect nil) - (inline (byte-compile-push-constant - (if (symbolp const) (bare-symbol const) const))))) + (inline (byte-compile-push-constant const)))) ;; Use this for a constant that is not the value of its containing form. ;; This ignores byte-compile--for-effect. (defun byte-compile-push-constant (const) - (when (symbolp const) - (setq const (bare-symbol const))) (byte-compile-out 'byte-constant (byte-compile-get-constant const))) @@ -5120,6 +5109,7 @@ OP and OPERAND are as passed to `byte-compile-out'." (- 1 operand)))) (defun byte-compile-out (op &optional operand) + (setq operand (byte-run-strip-symbol-positions operand)) (push (cons op operand) byte-compile-output) (if (eq op 'byte-return) ;; This is actually an unnecessary case, because there should be no diff --git a/src/fns.c b/src/fns.c index ea8428fd98..06a6456380 100644 --- a/src/fns.c +++ b/src/fns.c @@ -4265,6 +4265,8 @@ cmpfn_user_defined (Lisp_Object key1, Lisp_Object key2, static Lisp_Object hashfn_eq (Lisp_Object key, struct Lisp_Hash_Table *h) { + if (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (key)) + key = SYMBOL_WITH_POS_SYM (key); return make_ufixnum (XHASH (key) ^ XTYPE (key)); } @@ -4543,8 +4545,6 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object *hash) ptrdiff_t start_of_bucket, i; Lisp_Object hash_code; - if (SYMBOL_WITH_POS_P (key)) - key = SYMBOL_WITH_POS_SYM (key); hash_code = h->test.hashfn (key, h); if (hash) *hash = hash_code; @@ -4982,6 +4982,8 @@ sxhash_obj (Lisp_Object obj, int depth) hash = sxhash_combine (hash, sxhash_obj (XOVERLAY (obj)->plist, depth)); return SXHASH_REDUCE (hash); } + else if (symbols_with_pos_enabled && pvec_type == PVEC_SYMBOL_WITH_POS) + return sxhash_obj (XSYMBOL_WITH_POS (obj)->sym, depth + 1); else /* Others are 'equal' if they are 'eq', so take their address as hash. */ commit 767619595cf0fd7169ae682aaea24ab04ad44915 Author: Eli Zaretskii Date: Sat Feb 19 11:19:48 2022 +0200 Fix character compositions on the mode line * src/composite.c (composition_compute_stop_pos) (Ffind_composition_internal): When characters come from a string, determine whether to compose them from that string's multibyteness, not from that of the current buffer. (Bug#53729) diff --git a/src/composite.c b/src/composite.c index c3e9afc807..3659de8900 100644 --- a/src/composite.c +++ b/src/composite.c @@ -988,7 +988,9 @@ inhibit_auto_composition (void) less than CHARPOS, search backward to ENDPOS+1 assuming that set_iterator_to_next works in reverse order. In this case, if a composition closest to CHARPOS is found, set cmp_it->stop_pos to - the last character of the composition. + the last character of the composition. STRING, if non-nil, is + the string (as opposed to a buffer) whose characters should be + tested for being composable. If no composition is found, set cmp_it->ch to -2. If a static composition is found, set cmp_it->ch to -1. Otherwise, set @@ -996,7 +998,9 @@ inhibit_auto_composition (void) composition. */ void -composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t endpos, Lisp_Object string) +composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos, + ptrdiff_t bytepos, ptrdiff_t endpos, + Lisp_Object string) { ptrdiff_t start, end; int c; @@ -1035,7 +1039,9 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos, cmp_it->stop_pos = endpos = start; cmp_it->ch = -1; } - if (NILP (BVAR (current_buffer, enable_multibyte_characters)) + if ((NILP (string) + && NILP (BVAR (current_buffer, enable_multibyte_characters))) + || (STRINGP (string) && !STRING_MULTIBYTE (string)) || inhibit_auto_composition ()) return; if (bytepos < 0) @@ -1971,7 +1977,9 @@ See `find-composition' for more details. */) if (!find_composition (from, to, &start, &end, &prop, string)) { - if (!NILP (BVAR (current_buffer, enable_multibyte_characters)) + if (((NILP (string) + && !NILP (BVAR (current_buffer, enable_multibyte_characters))) + || (!NILP (string) && STRING_MULTIBYTE (string))) && ! inhibit_auto_composition () && find_automatic_composition (from, to, (ptrdiff_t) -1, &start, &end, &gstring, string)) commit e015dc77f5e38d52bb0b328c764c8186c8c9bf73 Author: Po Lu Date: Sat Feb 19 16:21:51 2022 +0800 Don't ignore events from XI2 slave devices anymore All the machinery needed to keep track of events from those devices is already in place, so that's no longer required. * src/xterm.c (x_get_scroll_valuator_delta): (xi_reset_scroll_valuators_for_device_id): (handle_one_xevent): Don't ignore XI devices that are not master pointers or keyboards. diff --git a/src/xterm.c b/src/xterm.c index af456389ab..2dc420a8de 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -689,7 +689,7 @@ x_get_scroll_valuator_delta (struct x_display_info *dpyinfo, int device_id, { struct xi_device_t *device = &dpyinfo->devices[i]; - if (device->device_id == device_id && device->master_p) + if (device->device_id == device_id) { for (int j = 0; j < device->scroll_valuator_count; ++j) { @@ -803,7 +803,7 @@ xi_reset_scroll_valuators_for_device_id (struct x_display_info *dpyinfo, int id, struct xi_device_t *device = xi_device_from_id (dpyinfo, id); struct xi_scroll_valuator_t *valuator; - if (!device || !device->master_p) + if (!device) return; if (!device->scroll_valuator_count) @@ -11314,7 +11314,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, device = xi_device_from_id (dpyinfo, xev->deviceid); - if (!device || !device->master_p) + if (!device) goto XI_OTHER; bv.button = xev->detail; @@ -11487,7 +11487,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, device = xi_device_from_id (dpyinfo, xev->deviceid); - if (!device || !device->master_p) + if (!device) goto XI_OTHER; #if defined (USE_X_TOOLKIT) || defined (USE_GTK) @@ -12132,7 +12132,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, XIGesturePinchEvent *pev = (XIGesturePinchEvent *) xi_event; struct xi_device_t *device = xi_device_from_id (dpyinfo, pev->deviceid); - if (!device || !device->master_p) + if (!device) goto XI_OTHER; #ifdef HAVE_XWIDGETS