commit 4e2fa4c34b8e1d49dc1788544c50f89732264a82 (HEAD, refs/remotes/origin/master) Merge: 0c9f98f761 30553d889d Author: Stefan Kangas Date: Tue Nov 30 07:38:52 2021 +0100 Merge from origin/emacs-28 30553d889d Merge branch 'emacs-28' of git.savannah.gnu.org:/srv/git/e... ecf3bf66ba Remove problematic characters from modus-themes.org (bug#5... de9d27f679 Avoid undefined behaviour when copying part of structure # Conflicts: # doc/misc/modus-themes.org commit 0c9f98f7619f31f1d8c97f22523a598658d99bef Merge: 3cba568886 de9d27f679 Author: Stefan Kangas Date: Tue Nov 30 07:35:37 2021 +0100 ; Merge from origin/emacs-28 The following commit was skipped: de9d27f679 Avoid undefined behaviour when copying part of structure commit 3cba56888656227280754595f4715258d6c29355 Author: Po Lu Date: Tue Nov 30 14:05:18 2021 +0800 Fix annoying bell rings when pixel scrolling to buffer limits * lisp/pixel-scroll.el (pixel-scroll-precision): Don't ding at buffer limits. diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 888320cf1a..1af292139e 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -480,9 +480,15 @@ wheel." (if (> (abs delta) (window-text-height window t)) (mwheel-scroll event nil) (with-selected-window window - (if (< delta 0) - (pixel-scroll-precision-scroll-down (- delta)) - (pixel-scroll-precision-scroll-up delta))))) + (condition-case nil + (if (< delta 0) + (pixel-scroll-precision-scroll-down (- delta)) + (pixel-scroll-precision-scroll-up delta)) + ;; Do not ding at buffer limits. Show a message instead. + (beginning-of-buffer + (message (error-message-string '(beginning-of-buffer)))) + (end-of-buffer + (message (error-message-string '(end-of-buffer)))))))) (mwheel-scroll event nil)))) ;;;###autoload commit f3bb2b80b4a347974de3e9da1feb18181ed20cc0 Author: Po Lu Date: Tue Nov 30 13:41:16 2021 +0800 Add `ns-scroll-event-delta-factor' * src/nsterm.m (- mouseDown): Take delta factor into account. (Vns_scroll_event_delta_factor): New variable. * lisp/cus-start.el: Add option. diff --git a/lisp/cus-start.el b/lisp/cus-start.el index 33b861b340..53cad99692 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -572,6 +572,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of (ns-use-native-fullscreen ns boolean "24.4") (ns-use-fullscreen-animation ns boolean "25.1") (ns-use-srgb-colorspace ns boolean "24.4") + (ns-scroll-event-delta-factor ns float "29.1") ;; process.c (delete-exited-processes processes-basics boolean) ;; syntax.c diff --git a/src/nsterm.m b/src/nsterm.m index 78bbae69a2..f5c2d4d9fb 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -6665,6 +6665,12 @@ - (void)mouseDown: (NSEvent *)theEvent if (lines == 0 && x_coalesce_scroll_events) return; + if (NUMBERP (Vns_scroll_event_delta_factor)) + { + x *= XFLOATINT (Vns_scroll_event_delta_factor); + y *= XFLOATINT (Vns_scroll_event_delta_factor); + } + emacs_event->kind = horizontal ? HORIZ_WHEEL_EVENT : WHEEL_EVENT; emacs_event->arg = list3 (make_fixnum (lines), make_float (x), @@ -10037,6 +10043,12 @@ Nil means use fullscreen the old (< 10.7) way. The old way works better with DEFSYM (Qx_underline_at_descent_line, "x-underline-at-descent-line"); + DEFVAR_LISP ("ns-scroll-event-delta-factor", Vns_scroll_event_delta_factor, + doc: /* A delta to apply to pixel deltas reported in scroll events. + This is only effective for pixel deltas generated from touch pads or + mice with smooth scrolling capability. */); + Vns_scroll_event_delta_factor = make_float (1.0); + /* Tell Emacs about this window system. */ Fprovide (Qns, Qnil); commit a59deef359c5ffa49ea2adb78250f4d4adf94447 Author: Po Lu Date: Tue Nov 30 09:46:25 2021 +0800 Allow non-float values in x-scroll-event-delta-factor * src/xterm.c (handle_one_xevent): Use XFLOATINT instead of XFLOAT_DATA. diff --git a/src/xterm.c b/src/xterm.c index a6d9c8c7a1..ed6a31125c 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10045,8 +10045,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, scroll_unit = pow (FRAME_PIXEL_HEIGHT (f), 2.0 / 3.0); - if (FLOATP (Vx_scroll_event_delta_factor)) - scroll_unit *= XFLOAT_DATA (Vx_scroll_event_delta_factor); + if (NUMBERP (Vx_scroll_event_delta_factor)) + scroll_unit *= XFLOATINT (Vx_scroll_event_delta_factor); if (val->horizontal) { commit 72b7fccc15cadd5ab3c6996888527ae6a2886b76 Author: Lars Ingebrigtsen Date: Tue Nov 30 02:07:22 2021 +0100 Add new package pixel-fill.el * lisp/net/shr.el (shr-char-breakable-p, shr-char-nospace-p) (shr-char-kinsoku-bol-p, shr-char-kinsoku-eol-p) (shr-find-fill-point): Moved to pixel-fill.el and renamed. (shr-pixel-region): Made obsolete. (shr-fill-line): Use pixel-fill-region. * lisp/textmodes/pixel-fill.el: New package. diff --git a/etc/NEWS b/etc/NEWS index 715a57af65..1ca5c86096 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -295,6 +295,13 @@ received. * Changes in Specialized Modes and Packages in Emacs 29.1 +** pixel-fill + +*** This is a new package that deals with filling variable-pitch text. + +*** New function 'pixel-fill-region'. +This fills the region to be no wider than a specified pixel width. + ** Info --- diff --git a/lisp/net/shr.el b/lisp/net/shr.el index d59b0ed362..5d38a7e19d 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -40,6 +40,7 @@ (require 'image) (require 'puny) (require 'url-cookie) +(require 'pixel-fill) (require 'text-property-search) (defgroup shr nil @@ -240,7 +241,6 @@ and other things: (defvar shr-internal-width nil) (defvar shr-list-mode nil) (defvar shr-content-cache nil) -(defvar shr-kinsoku-shorten nil) (defvar shr-table-depth 0) (defvar shr-stylesheet nil) (defvar shr-base nil) @@ -641,28 +641,6 @@ size, and full-buffer size." (shr-fill-lines (point-min) (point-max)) (buffer-string))))) -(define-inline shr-char-breakable-p (char) - "Return non-nil if a line can be broken before and after CHAR." - (inline-quote (aref fill-find-break-point-function-table ,char))) -(define-inline shr-char-nospace-p (char) - "Return non-nil if no space is required before and after CHAR." - (inline-quote (aref fill-nospace-between-words-table ,char))) - -;; KINSOKU is a Japanese word meaning a rule that should not be violated. -;; In Emacs, it is a term used for characters, e.g. punctuation marks, -;; parentheses, and so on, that should not be placed in the beginning -;; of a line or the end of a line. -(define-inline shr-char-kinsoku-bol-p (char) - "Return non-nil if a line ought not to begin with CHAR." - (inline-letevals (char) - (inline-quote (and (not (eq ,char ?')) - (aref (char-category-set ,char) ?>))))) -(define-inline shr-char-kinsoku-eol-p (char) - "Return non-nil if a line ought not to end with CHAR." - (inline-quote (aref (char-category-set ,char) ?<))) -(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35)) - (load "kinsoku" nil t)) - (defun shr-pixel-column () (if (not shr-use-fonts) (current-column) @@ -676,6 +654,7 @@ size, and full-buffer size." (car (window-text-pixel-size nil (line-beginning-position) (point)))))) (defun shr-pixel-region () + (declare (obsolete nil "29.1")) (- (shr-pixel-column) (save-excursion (goto-char (mark)) @@ -795,7 +774,7 @@ size, and full-buffer size." (while (not (eolp)) ;; We have to do some folding. First find the first ;; previous point suitable for folding. - (if (or (not (shr-find-fill-point (line-beginning-position))) + (if (or (not (pixel-fill-find-fill-point (line-beginning-position))) (= (point) start)) ;; We had unbreakable text (for this width), so just go to ;; the first space and carry on. @@ -836,84 +815,6 @@ size, and full-buffer size." (when (looking-at " $") (delete-region (point) (line-end-position))))))) -(defun shr-find-fill-point (start) - (let ((bp (point)) - (end (point)) - failed) - (while (not (or (setq failed (<= (point) start)) - (eq (preceding-char) ? ) - (eq (following-char) ? ) - (shr-char-breakable-p (preceding-char)) - (shr-char-breakable-p (following-char)) - (and (shr-char-kinsoku-bol-p (preceding-char)) - (shr-char-breakable-p (following-char)) - (not (shr-char-kinsoku-bol-p (following-char)))) - (shr-char-kinsoku-eol-p (following-char)) - (bolp))) - (backward-char 1)) - (if failed - ;; There's no breakable point, so we give it up. - (let (found) - (goto-char bp) - ;; Don't overflow the window edge, even if - ;; shr-kinsoku-shorten is nil. - (unless (or shr-kinsoku-shorten (null shr-width)) - (while (setq found (re-search-forward - "\\(\\c>\\)\\| \\|\\c<\\|\\c|" - (line-end-position) 'move))) - (if (and found - (not (match-beginning 1))) - (goto-char (match-beginning 0))))) - (or - (eolp) - ;; Don't put kinsoku-bol characters at the beginning of a line, - ;; or kinsoku-eol characters at the end of a line. - (cond - ;; Don't overflow the window edge, even if shr-kinsoku-shorten - ;; is nil. - ((or shr-kinsoku-shorten (null shr-width)) - (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) - (or (shr-char-kinsoku-eol-p (preceding-char)) - (shr-char-kinsoku-bol-p (following-char)))) - (backward-char 1)) - (when (setq failed (<= (point) start)) - ;; There's no breakable point that doesn't violate kinsoku, - ;; so we look for the second best position. - (while (and (progn - (forward-char 1) - (<= (point) end)) - (progn - (setq bp (point)) - (shr-char-kinsoku-eol-p (following-char))))) - (goto-char bp))) - ((shr-char-kinsoku-eol-p (preceding-char)) - ;; Find backward the point where kinsoku-eol characters begin. - (let ((count 4)) - (while - (progn - (backward-char 1) - (and (> (setq count (1- count)) 0) - (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) - (or (shr-char-kinsoku-eol-p (preceding-char)) - (shr-char-kinsoku-bol-p (following-char))))))) - (when (setq failed (<= (point) start)) - ;; There's no breakable point that doesn't violate kinsoku, - ;; so we go to the second best position. - (if (looking-at "\\(\\c<+\\)\\c<") - (goto-char (match-end 1)) - (forward-char 1)))) - ((shr-char-kinsoku-bol-p (following-char)) - ;; Find forward the point where kinsoku-bol characters end. - (let ((count 4)) - (while (progn - (forward-char 1) - (and (>= (setq count (1- count)) 0) - (shr-char-kinsoku-bol-p (following-char)) - (shr-char-breakable-p (following-char)))))))) - (when (eq (following-char) ? ) - (forward-char 1)))) - (not failed))) - (defun shr-parse-base (url) ;; Always chop off anchors. (when (string-match "#.*" url) @@ -2077,7 +1978,8 @@ BASE is the URL of the HTML being rendered." (setq dom (or (dom-child-by-tag dom 'tbody) dom)) (let* ((shr-inhibit-images t) (shr-table-depth (1+ shr-table-depth)) - (shr-kinsoku-shorten t) + ;; Fill hard in CJK languages. + (pixel-fill-respect-kinsoku nil) ;; Find all suggested widths. (columns (shr-column-specs dom)) ;; Compute how many pixels wide each TD should be. diff --git a/lisp/textmodes/pixel-fill.el b/lisp/textmodes/pixel-fill.el new file mode 100644 index 0000000000..eff09dfca6 --- /dev/null +++ b/lisp/textmodes/pixel-fill.el @@ -0,0 +1,202 @@ +;;; pixel-fill.el --- variable pitch filling functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org +;; Keywords: filling + +;; 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: + +;; The main entry point is `pixel-fill-region', but +;; `pixel-fill-find-fill-point' can also be useful by itself. + +;;; Code: + +(require 'kinsoku) + +(defgroup pixel-fill nil + "Filling based on pixel widths." + :group 'fill + :version "29.1") + +(defcustom pixel-fill-respect-kinsoku t + "If nil, fill even if we can't find a good kinsoku point. +Kinsoku is a Japanese word meaning a rule that should not be violated. +In Emacs, it is a term used for characters, e.g. punctuation marks, +parentheses, and so on, that should not be placed in the beginning +of a line or the end of a line." + :type 'boolean + :version "29.1") + +(defun pixel-fill-region (start end pixel-width) + "Fill the region between START and END. +This will attempt to reformat the text in the region to have no +lines that are visually wider than PIXEL-WIDTH. + +If START isn't at the start of a line, that pixel position will +be used as the indentation prefix on subsequent lines." + (save-excursion + (goto-char start) + (let ((indentation + (car (window-text-pixel-size nil (line-beginning-position) + (point))))) + (when (> indentation pixel-width) + (error "The indentation (%s) is wider than the fill width (%s)" + indentation pixel-width)) + (save-restriction + (narrow-to-region start end) + (goto-char start) + ;; First replace all whitespace with space. + (while (re-search-forward "[ \t\n]+" nil t) + (if (= (match-beginning 0) start) + (delete-region (match-beginning 0) (match-end 0)) + (replace-match " "))) + (goto-char start) + (pixel-fill--fill-line pixel-width indentation))))) + +(defun pixel-fill--goto-pixel (width) + (vertical-motion (cons (/ width (frame-char-width)) 0))) + +(defun pixel-fill--fill-line (width &optional indentation) + (let ((start (point))) + (pixel-fill--goto-pixel width) + (while (not (eolp)) + ;; We have to do some folding. First find the first previous + ;; point suitable for folding. + (if (or (not (pixel-fill-find-fill-point (line-beginning-position))) + (= (point) start)) + ;; We had unbreakable text (for this width), so just go to + ;; the first space and carry on. + (progn + (beginning-of-line) + (skip-chars-forward " ") + (search-forward " " (line-end-position) 'move))) + ;; Success; continue. + (when (= (preceding-char) ?\s) + (delete-char -1)) + (insert ?\n) + (when (> indentation 0) + (insert (propertize " " 'display + (list 'space :align-to (list indentation))))) + (setq start (point)) + (pixel-fill--goto-pixel width)))) + +(define-inline pixel-fill--char-breakable-p (char) + "Return non-nil if a line can be broken before and after CHAR." + (inline-quote (aref fill-find-break-point-function-table ,char))) + +(define-inline pixel-fill--char-nospace-p (char) + "Return non-nil if no space is required before and after CHAR." + (inline-quote (aref fill-nospace-between-words-table ,char))) + +(define-inline pixel-fill--char-kinsoku-bol-p (char) + "Return non-nil if a line ought not to begin with CHAR." + (inline-letevals (char) + (inline-quote (and (not (eq ,char ?')) + (aref (char-category-set ,char) ?>))))) + +(define-inline pixel-fill--char-kinsoku-eol-p (char) + "Return non-nil if a line ought not to end with CHAR." + (inline-quote (aref (char-category-set ,char) ?<))) + +(defun pixel-fill-find-fill-point (start) + "Find a place suitable for breaking the current line. +START should be the earliest buffer position that should be considered +(typically the start of the line), and this function will search +backward in the current buffer from the current position." + (let ((bp (point)) + (end (point)) + failed) + (while (not + (or (setq failed (<= (point) start)) + (eq (preceding-char) ?\s) + (eq (following-char) ?\s) + (pixel-fill--char-breakable-p (preceding-char)) + (pixel-fill--char-breakable-p (following-char)) + (and (pixel-fill--char-kinsoku-bol-p (preceding-char)) + (pixel-fill--char-breakable-p (following-char)) + (not (pixel-fill--char-kinsoku-bol-p (following-char)))) + (pixel-fill--char-kinsoku-eol-p (following-char)) + (bolp))) + (backward-char 1)) + (if failed + ;; There's no breakable point, so we give it up. + (let (found) + (goto-char bp) + ;; Don't overflow the window edge, even if + ;; `pixel-fill-respect-kinsoku' is t. + (when pixel-fill-respect-kinsoku + (while (setq found (re-search-forward + "\\(\\c>\\)\\| \\|\\c<\\|\\c|" + (line-end-position) 'move))) + (if (and found + (not (match-beginning 1))) + (goto-char (match-beginning 0))))) + (or + (eolp) + ;; Don't put kinsoku-bol characters at the beginning of a line, + ;; or kinsoku-eol characters at the end of a line. + (cond + ;; Don't overflow the window edge, even if `pixel-fill-respect-kinsoku' + ;; is t. + ((not pixel-fill-respect-kinsoku) + (while (and (not (eq (preceding-char) ?\s)) + (or (pixel-fill--char-kinsoku-eol-p (preceding-char)) + (pixel-fill--char-kinsoku-bol-p (following-char)))) + (backward-char 1)) + (when (setq failed (<= (point) start)) + ;; There's no breakable point that doesn't violate kinsoku, + ;; so we look for the second best position. + (while (and (progn + (forward-char 1) + (<= (point) end)) + (progn + (setq bp (point)) + (pixel-fill--char-kinsoku-eol-p (following-char))))) + (goto-char bp))) + ((pixel-fill--char-kinsoku-eol-p (preceding-char)) + ;; Find backward the point where kinsoku-eol characters begin. + (let ((count 4)) + (while + (progn + (backward-char 1) + (and (> (setq count (1- count)) 0) + (not (eq (preceding-char) ?\s)) + (or (pixel-fill--char-kinsoku-eol-p (preceding-char)) + (pixel-fill--char-kinsoku-bol-p (following-char))))))) + (when (setq failed (<= (point) start)) + ;; There's no breakable point that doesn't violate kinsoku, + ;; so we go to the second best position. + (if (looking-at "\\(\\c<+\\)\\c<") + (goto-char (match-end 1)) + (forward-char 1)))) + ((pixel-fill--char-kinsoku-bol-p (following-char)) + ;; Find forward the point where kinsoku-bol characters end. + (let ((count 4)) + (while (progn + (forward-char 1) + (and (>= (setq count (1- count)) 0) + (pixel-fill--char-kinsoku-bol-p (following-char)) + (pixel-fill--char-breakable-p (following-char)))))))) + (when (eq (following-char) ?\s) + (forward-char 1)))) + (not failed))) + +(provide 'pixel-fill) + +;;; pixel-fill.el ends here commit 804c69dafd686b386630b125182e66551dd592f4 Author: Lars Ingebrigtsen Date: Tue Nov 30 00:14:51 2021 +0100 Audit the Emacs manual for keymap-*-related changes * doc/emacs/programs.texi (Other C Commands): * doc/emacs/msdos-xtra.texi (MS-DOS Keyboard): * doc/emacs/custom.texi (Init Examples): * doc/emacs/abbrevs.texi (Editing Abbrevs): Change some examples to use keymap-* functions. diff --git a/doc/emacs/abbrevs.texi b/doc/emacs/abbrevs.texi index c83da8aaec..972416ff1c 100644 --- a/doc/emacs/abbrevs.texi +++ b/doc/emacs/abbrevs.texi @@ -274,7 +274,7 @@ Edit a list of abbrevs; you can add, alter or remove definitions. @example @var{various other tables@dots{}} (lisp-mode-abbrev-table) -"dk" 0 "define-key" +"ks" 0 "keymap-set" (global-abbrev-table) "dfn" 0 "definition" @end example diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi index 917f6f4921..310a8563ae 100644 --- a/doc/emacs/custom.texi +++ b/doc/emacs/custom.texi @@ -2567,10 +2567,9 @@ Do the same thing for Lisp mode only. Redefine all keys which now run @code{next-line} in Fundamental mode so that they run @code{forward-line} instead. -@findex substitute-key-definition +@findex keymap-substitute @example -(substitute-key-definition 'next-line 'forward-line - global-map) +(keymap-substitute global-map 'next-line 'forward-line) @end example @item diff --git a/doc/emacs/msdos-xtra.texi b/doc/emacs/msdos-xtra.texi index fce6ae46f8..114700f08d 100644 --- a/doc/emacs/msdos-xtra.texi +++ b/doc/emacs/msdos-xtra.texi @@ -105,7 +105,7 @@ following line into your @file{_emacs} file: @smallexample ;; @r{Make the @key{ENTER} key from the numeric keypad act as @kbd{C-j}.} -(define-key function-key-map [kp-enter] [?\C-j]) +(keymap-set function-key-map "" "C-j") @end smallexample @node MS-DOS Mouse diff --git a/doc/emacs/programs.texi b/doc/emacs/programs.texi index 0056906e1f..85ed65a495 100644 --- a/doc/emacs/programs.texi +++ b/doc/emacs/programs.texi @@ -1827,7 +1827,7 @@ sure the keymap is loaded before we try to change it. @example (defun my-bind-clb () - (define-key c-mode-base-map "\C-m" + (keymap-set c-mode-base-map "RET" 'c-context-line-break)) (add-hook 'c-initialization-hook 'my-bind-clb) @end example commit 1bd7b5dd5165d8ac70870b1c69701183befa868a Author: Lars Ingebrigtsen Date: Tue Nov 30 00:13:47 2021 +0100 Fix some of the argument handling in keymap-set and keymap-substitute * lisp/keymap.el (keymap-set): Fix handling of binding one key to another key. (keymap-substitute): Fix confusion in implementation -- the args are definitions, not keys. diff --git a/lisp/keymap.el b/lisp/keymap.el index 770a6ed20d..07e43c37b3 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -58,6 +58,11 @@ DEFINITION is anything that can be a key's definition: (See info node `(elisp)Extended Menu Items'.)" (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) (keymap--check key) + ;; If we're binding this key to another key, then parse that other + ;; key, too. + (when (stringp definition) + (keymap--check definition) + (setq definition (key-parse definition))) (define-key keymap (key-parse key) definition)) (defun keymap-global-set (key command) @@ -143,8 +148,6 @@ If you don't specify OLDMAP, you can usually get the same results in a cleaner way with command remapping, like this: (define-key KEYMAP [remap OLDDEF] NEWDEF) \n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)" - (declare (compiler-macro - (lambda (form) (keymap--compile-check olddef newdef) form))) ;; Don't document PREFIX in the doc string because we don't want to ;; advertise it. It's meant for recursive calls only. Here's its ;; meaning @@ -154,10 +157,6 @@ in a cleaner way with command remapping, like this: ;; original key, with PREFIX added at the front. (unless prefix (setq prefix "")) - (keymap--check olddef) - (keymap--check newdef) - (setq olddef (key-parse olddef)) - (setq newdef (key-parse newdef)) (let* ((scan (or oldmap keymap)) (prefix1 (vconcat prefix [nil])) (key-substitution-in-progress commit 1efc14561d6ec735cd35ac5e8124c4c244b1f1a2 Author: Lars Ingebrigtsen Date: Mon Nov 29 23:54:48 2021 +0100 Edit the lispref manual for define-key/keymap-set fallout * doc/lispref/variables.texi (Tips for Defining): * doc/lispref/text.texi (Clickable Text): * doc/lispref/modes.texi (Derived Modes): (Example Major Modes): * doc/lispref/loading.texi (Autoload): (Hooks for Loading): * doc/lispref/keymaps.texi (Creating Keymaps): (Inheritance and Keymaps): (Controlling Active Maps): (Changing Key Bindings): (Low-Level Key Binding): (Remapping Commands): (Translation Keymaps): (Key Binding Commands): * doc/lispref/help.texi (Help Functions): * doc/lispref/display.texi (Abstract Display Example): * doc/lispref/commands.texi (Interactive Codes): (Keyboard Events): (Misc Events): (Classifying Events): (Strings of Events): Prefer `keymap-set' instead of `define-key' most places, and use `defvar-keymap' in some of the examples. diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index 581183a0a3..920d380266 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -455,7 +455,7 @@ This kind of input is used by commands such as @code{describe-key} and @item K A key sequence on a form that can be used as input to functions like -@code{define-key}. This works like @samp{k}, except that it +@code{keymap-set}. This works like @samp{k}, except that it suppresses, for the last input event in the key sequence, the conversions that are normally used (when necessary) to convert an undefined key into a defined one (@pxref{Key Sequence Input}), so this @@ -1315,12 +1315,9 @@ actually treated as the meta key, not this.) It is best to avoid mentioning specific bit numbers in your program. To test the modifier bits of a character, use the function @code{event-modifiers} (@pxref{Classifying Events}). When making key -bindings, you can use the read syntax for characters with modifier bits -(@samp{\C-}, @samp{\M-}, and so on). For making key bindings with -@code{define-key}, you can use lists such as @code{(control hyper ?x)} to -specify the characters (@pxref{Changing Key Bindings}). The function -@code{event-convert-list} converts such a list into an event type -(@pxref{Classifying Events}). +bindings with @code{keymap-set}, you specify these events using +strings like @samp{C-H-x} instead (for ``control hyper x'') +(@pxref{Changing Key Bindings}). @node Function Keys @subsection Function Keys @@ -2078,7 +2075,7 @@ example: (interactive) (message "Caught signal %S" last-input-event)) -(define-key special-event-map [sigusr1] 'sigusr-handler) +(keymap-set special-event-map "" 'sigusr-handler) @end smallexample To test the signal handler, you can make Emacs send a signal to itself: @@ -2284,21 +2281,6 @@ This function returns non-@code{nil} if @var{object} is a mouse movement event. @xref{Motion Events}. @end defun -@defun event-convert-list list -This function converts a list of modifier names and a basic event type -to an event type which specifies all of them. The basic event type -must be the last element of the list. For example, - -@example -(event-convert-list '(control ?a)) - @result{} 1 -(event-convert-list '(control meta ?a)) - @result{} -134217727 -(event-convert-list '(control super f1)) - @result{} C-s-f1 -@end example -@end defun - @node Accessing Mouse @subsection Accessing Mouse Events @cindex mouse events, data in @@ -2518,25 +2500,14 @@ characters in a string is a complex matter, for reasons of historical compatibility, and it is not always possible. We recommend that new programs avoid dealing with these complexities -by not storing keyboard events in strings. Here is how to do that: - -@itemize @bullet -@item -Use vectors instead of strings for key sequences, when you plan to use -them for anything other than as arguments to @code{lookup-key} and -@code{define-key}. For example, you can use -@code{read-key-sequence-vector} instead of @code{read-key-sequence}, and -@code{this-command-keys-vector} instead of @code{this-command-keys}. - -@item -Use vectors to write key sequence constants containing meta characters, -even when passing them directly to @code{define-key}. - -@item -When you have to look at the contents of a key sequence that might be a -string, use @code{listify-key-sequence} (@pxref{Event Input Misc}) -first, to convert it to a list. -@end itemize +by not storing keyboard events in strings containing control +characters or the like, but instead store them in the common Emacs +format as understood by @code{key-valid-p}. + + If you read a key sequence with @code{read-key-sequence-vector} (or +@code{read-key-sequence}), or access a key sequence with +@code{this-command-keys-vector} (or @code{this-command-keys}), you can +transform this to the recommended format by using @code{key-description}. The complexities stem from the modifier bits that keyboard input characters can include. Aside from the Meta modifier, none of these diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 0bdbc06013..f37b35112a 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -7777,16 +7777,14 @@ The string is formatted #RRGGBB (hash followed by six hex digits)." (kill-buffer nil)) (setq colorcomp-mode-map - (let ((m (make-sparse-keymap))) - (suppress-keymap m) - (define-key m "i" 'colorcomp-R-less) - (define-key m "o" 'colorcomp-R-more) - (define-key m "k" 'colorcomp-G-less) - (define-key m "l" 'colorcomp-G-more) - (define-key m "," 'colorcomp-B-less) - (define-key m "." 'colorcomp-B-more) - (define-key m " " 'colorcomp-copy-as-kill-and-exit) - m)) + (define-keymap :suppress t + "i" 'colorcomp-R-less + "o" 'colorcomp-R-more + "k" 'colorcomp-G-less + "l" 'colorcomp-G-more + "," 'colorcomp-B-less + "." 'colorcomp-B-more + "SPC" 'colorcomp-copy-as-kill-and-exit)) @end smallexample Note that we never modify the data in each node, which is fixed when the diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi index 1a9eb30fde..71017a4d3d 100644 --- a/doc/lispref/help.texi +++ b/doc/lispref/help.texi @@ -647,7 +647,7 @@ follows: @smallexample @group -(define-key global-map (string help-char) 'help-command) +(keymap-set global-map (key-description (string help-char)) 'help-command) (fset 'help-command help-map) @end group @end smallexample diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi index d893e22b8b..edf1d6e83f 100644 --- a/doc/lispref/keymaps.texi +++ b/doc/lispref/keymaps.texi @@ -367,7 +367,7 @@ I.e., something like: @group (let ((map (make-sparse-keymap))) (set-keymap-parent map ) - (define-key map ...) + (keymap-set map ...) ...) @end group @end example @@ -420,10 +420,10 @@ The effect is that this keymap inherits all the bindings of but can add to them or override them with @var{elements}. If you change the bindings in @var{parent-keymap} using -@code{define-key} or other key-binding functions, these changed +@code{keymap-set} or other key-binding functions, these changed bindings are visible in the inheriting keymap, unless shadowed by the bindings made by @var{elements}. The converse is not true: if you use -@code{define-key} to change bindings in the inheriting keymap, these +@code{keymap-set} to change bindings in the inheriting keymap, these changes are recorded in @var{elements}, but have no effect on @var{parent-keymap}. @@ -797,7 +797,7 @@ out with. This function returns the current global keymap. This is the same as the value of @code{global-map} unless you change one or the other. The return value is a reference, not a copy; if you use -@code{define-key} or other functions on it you will alter global +@code{keymap-set} or other functions on it you will alter global bindings. @example @@ -833,7 +833,7 @@ keymap. @end defun @code{current-local-map} returns a reference to the local keymap, not -a copy of it; if you use @code{define-key} or other functions on it +a copy of it; if you use @code{keymap-set} or other functions on it you will alter local bindings. @defun current-minor-mode-maps @@ -1297,7 +1297,7 @@ This function sets the binding for @var{key} in @var{keymap}. (If in another keymap reached from @var{keymap}.) The argument @var{binding} can be any Lisp object, but only certain types are meaningful. (For a list of meaningful types, see @ref{Key Lookup}.) -The value returned by @code{define-key} is @var{binding}. +The value returned by @code{keymap-set} is @var{binding}. If @var{key} is @kbd{}, this sets the default binding in @var{keymap}. When an event has no binding of its own, the Emacs @@ -1726,6 +1726,21 @@ The argument @var{accept-defaults} controls checking for default bindings, as in @code{lookup-key} (above). @end defun +@defun event-convert-list list +This function converts a list of modifier names and a basic event type +to an event type which specifies all of them. The basic event type +must be the last element of the list. For example, + +@example +(event-convert-list '(control ?a)) + @result{} 1 +(event-convert-list '(control meta ?a)) + @result{} -134217727 +(event-convert-list '(control super f1)) + @result{} C-s-f1 +@end example +@end defun + @node Remapping Commands @section Remapping Commands @cindex remapping commands @@ -1744,7 +1759,7 @@ definition for a key binding). the following remapping: @smallexample -(define-key my-mode-map [remap kill-line] 'my-kill-line) +(keymap-set my-mode-map " " 'my-kill-line) @end smallexample @noindent @@ -1759,8 +1774,8 @@ In addition, remapping only works through a single level; in the following example, @smallexample -(define-key my-mode-map [remap kill-line] 'my-kill-line) -(define-key my-mode-map [remap my-kill-line] 'my-other-kill-line) +(keymap-set my-mode-map " " 'my-kill-line) +(keymap-set my-mode-map " " 'my-other-kill-line) @end smallexample @noindent @@ -1772,7 +1787,7 @@ remapped to @code{my-kill-line}; if an ordinary binding specifies To undo the remapping of a command, remap it to @code{nil}; e.g., @smallexample -(define-key my-mode-map [remap kill-line] nil) +(keymap-set my-mode-map " " nil) @end smallexample @defun command-remapping command &optional position keymaps @@ -1904,7 +1919,7 @@ to turn the character that follows into a Hyper character: symbol (cons symbol (cdr e))))) -(define-key local-function-key-map "\C-ch" 'hyperify) +(keymap-set local-function-key-map "C-c h" 'hyperify) @end group @end example @@ -1934,7 +1949,7 @@ problematic suffixes/prefixes are @kbd{@key{ESC}}, @kbd{M-O} (which is really @section Commands for Binding Keys This section describes some convenient interactive interfaces for -changing key bindings. They work by calling @code{define-key}. +changing key bindings. They work by calling @code{keymap-set}. People often use @code{keymap-global-set} in their init files (@pxref{Init File}) for simple customization. For example, diff --git a/doc/lispref/loading.texi b/doc/lispref/loading.texi index 4d683da1ad..ee119445e5 100644 --- a/doc/lispref/loading.texi +++ b/doc/lispref/loading.texi @@ -552,7 +552,7 @@ An autoloaded keymap loads automatically during key lookup when a prefix key's binding is the symbol @var{function}. Autoloading does not occur for other kinds of access to the keymap. In particular, it does not happen when a Lisp program gets the keymap from the value of a variable -and calls @code{define-key}; not even if the variable name is the same +and calls @code{keymap-set}; not even if the variable name is the same symbol @var{function}. @cindex function cell in autoload @@ -1156,7 +1156,7 @@ You don't need to give a directory or extension in the file name @var{library}. Normally, you just give a bare file name, like this: @example -(with-eval-after-load "js" (define-key js-mode-map "\C-c\C-c" 'js-eval)) +(with-eval-after-load "js" (keymap-set js-mode-map "C-c C-c" 'js-eval)) @end example To restrict which files can trigger the evaluation, include a diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index bc5c08c687..69c022e525 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -916,10 +916,8 @@ which in turn may have been changed in a mode hook. Here is a hypothetical example: @example -(defvar hypertext-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [down-mouse-3] 'do-hyper-link) - map)) +(defvar-keymap hypertext-mode-map + "" #'do-hyper-link) (define-derived-mode hypertext-mode text-mode "Hypertext" @@ -1344,11 +1342,9 @@ the conventions listed above: ;; @r{Create the keymap for this mode.} @group -(defvar text-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\e\t" 'ispell-complete-word) - @dots{} - map) +(defvar-keymap text-mode-map + "C-M-i" #'ispell-complete-word + @dots{}) "Keymap for `text-mode'. Many other modes, such as `mail-mode', `outline-mode' and `indented-text-mode', inherit all the commands defined in this map.") @@ -1421,13 +1417,11 @@ common. The following code sets up the common commands: @smallexample @group -(defvar lisp-mode-shared-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map prog-mode-map) - (define-key map "\e\C-q" 'indent-sexp) - (define-key map "\177" 'backward-delete-char-untabify) - map) - "Keymap for commands shared by all sorts of Lisp modes.") +(defvar-keymap lisp-mode-shared-map + :parent prog-mode-map + :doc "Keymap for commands shared by all sorts of Lisp modes." + "C-M-q" #'indent-sexp + "DEL" #'backward-delete-char-untabify) @end group @end smallexample @@ -1436,16 +1430,12 @@ And here is the code to set up the keymap for Lisp mode: @smallexample @group -(defvar lisp-mode-map - (let ((map (make-sparse-keymap)) - (menu-map (make-sparse-keymap "Lisp"))) - (set-keymap-parent map lisp-mode-shared-map) - (define-key map "\e\C-x" 'lisp-eval-defun) - (define-key map "\C-c\C-z" 'run-lisp) - @dots{} - map) - "Keymap for ordinary Lisp mode. -All commands in `lisp-mode-shared-map' are inherited by this map.") +(defvar-keymap lisp-mode-map + :doc "Keymap for ordinary Lisp mode. +All commands in `lisp-mode-shared-map' are inherited by this map." + :parent lisp-mode-shared-map + "C-M-x" #'lisp-eval-defun + "C-c C-z" #'run-lisp) @end group @end smallexample diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 863b318c20..25579e79ea 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -4195,7 +4195,7 @@ position. The action code is always @code{t}. For example, here is how Info mode handles @key{mouse-1}: @smallexample -(define-key Info-mode-map [follow-link] 'mouse-face) +(keymap-set Info-mode-map "" 'mouse-face) @end smallexample @item a function @@ -4208,9 +4208,9 @@ For example, here is how pcvs enables @kbd{mouse-1} to follow links on file names only: @smallexample -(define-key map [follow-link] - (lambda (pos) - (eq (get-char-property pos 'face) 'cvs-filename-face))) +(keymap-set map "" + (lambda (pos) + (eq (get-char-property pos 'face) 'cvs-filename-face))) @end smallexample @item anything else diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index 1ae0e5e5ee..abef0b3d0c 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -686,7 +686,7 @@ entire computation of the value into the @code{defvar}, like this: @example (defvar my-mode-map (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-a" 'my-command) + (keymap-set map "C-c C-a" 'my-command) @dots{} map) @var{docstring}) @@ -702,25 +702,6 @@ important if the user has run hooks to alter part of the contents (such as, to rebind keys). Third, evaluating the @code{defvar} form with @kbd{C-M-x} will reinitialize the map completely. - Putting so much code in the @code{defvar} form has one disadvantage: -it puts the documentation string far away from the line which names the -variable. Here's a safe way to avoid that: - -@example -(defvar my-mode-map nil - @var{docstring}) -(unless my-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-a" 'my-command) - @dots{} - (setq my-mode-map map))) -@end example - -@noindent -This has all the same advantages as putting the initialization inside -the @code{defvar}, except that you must type @kbd{C-M-x} twice, once on -each form, if you do want to reinitialize the variable. - @node Accessing Variables @section Accessing Variable Values commit 50379fb78d04deb9f422b906add126219a1a775d Author: Alan Third Date: Mon Nov 29 22:11:04 2021 +0000 Fix build on macOS * src/nsterm.h (NSPasteboardTypeMultipleTextSelection): (NSPasteboardTypePNG): These are already defined on macOS 10.6 and above and aren't used at all in GNUstep. diff --git a/src/nsterm.h b/src/nsterm.h index a32b8fe149..ce8f594902 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -1352,9 +1352,7 @@ enum NSWindowTabbingMode #define NSPasteboardTypeTabularText NSTabularTextPboardType #define NSPasteboardTypeURL NSURLPboardType #define NSPasteboardTypeHTML NSHTMLPboardType -#define NSPasteboardTypeMultipleTextSelection NSMultipleTextSelectionPboardType #define NSPasteboardTypePDF NSPDFPboardType -#define NSPasteboardTypePNG NSPNGPboardType #define NSPasteboardTypeRTF NSRTFPboardType #define NSPasteboardTypeRTFD NSRTFDPboardType #define NSPasteboardTypeTIFF NSTIFFPboardType commit 67676bb5a04fe0f09037c6938579903c9426acc6 Author: Alan Third Date: Mon Nov 29 21:56:13 2021 +0000 Fix NS port text decorations (bug#52156) * src/nsterm.m (ns_draw_text_decoration): Set the correct colors for decorations other than underline. (ns_draw_glyph_string): Remove superfluous color setting call. diff --git a/src/nsterm.m b/src/nsterm.m index 747539eae6..78bbae69a2 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -3307,16 +3307,17 @@ Note that CURSOR_WIDTH is meaningful only for (h)bar cursors. if (s->hl == DRAW_CURSOR) [FRAME_BACKGROUND_COLOR (s->f) set]; - else if (face->underline_defaulted_p) - [defaultCol set]; else - [ns_lookup_indexed_color (face->underline_color, s->f) set]; + [defaultCol set]; /* Do underline. */ if (face->underline) { if (s->face->underline == FACE_UNDER_WAVE) { + if (!face->underline_defaulted_p) + [ns_lookup_indexed_color (face->underline_color, s->f) set]; + ns_draw_underwave (s, width, x); } else if (s->face->underline == FACE_UNDER_LINE) @@ -3387,6 +3388,9 @@ Note that CURSOR_WIDTH is meaningful only for (h)bar cursors. s->underline_position = position; r = NSMakeRect (x, s->ybase + position, width, thickness); + + if (!face->underline_defaulted_p) + [ns_lookup_indexed_color (face->underline_color, s->f) set]; NSRectFill (r); } } @@ -3396,6 +3400,10 @@ Note that CURSOR_WIDTH is meaningful only for (h)bar cursors. { NSRect r; r = NSMakeRect (x, s->y, width, 1); + + if (!face->overline_color_defaulted_p) + [ns_lookup_indexed_color (face->overline_color, s->f) set]; + NSRectFill (r); } @@ -3418,6 +3426,9 @@ larger if there are taller display elements (e.g., characters dy = lrint ((glyph_height - h) / 2); r = NSMakeRect (x, glyph_y + dy, width, 1); + if (!face->strike_through_color_defaulted_p) + [ns_lookup_indexed_color (face->strike_through_color, s->f) set]; + NSRectFill (r); } } @@ -4066,7 +4077,6 @@ Function modeled after x_draw_glyph_string_box (). ? ns_lookup_indexed_color (NS_FACE_FOREGROUND (s->face), s->f) : FRAME_FOREGROUND_COLOR (s->f)); - [col set]; /* Draw underline, overline, strike-through. */ ns_draw_text_decoration (s, s->face, col, s->width, s->x); commit 0c1c6f0ba71b9820fdcb9bd91547abeebe684d87 Author: Lars Ingebrigtsen Date: Mon Nov 29 22:40:38 2021 +0100 Regenerate ldefs-boot.el diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 613d9734ae..af53e9bf75 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -2811,6 +2811,13 @@ used instead of `browse-url-new-window-flag'. (make-obsolete 'browse-url-galeon 'nil '"25.1") +(autoload 'browse-url-webpositive "browse-url" "\ +Ask the WebPositive WWW browser to load URL. +Default to the URL around or before point. +The optional argument NEW-WINDOW is not used. + +\(fn URL &optional NEW-WINDOW)" t nil) + (autoload 'browse-url-emacs "browse-url" "\ Ask Emacs to load URL into a buffer and show it in another window. Optional argument SAME-WINDOW non-nil means show the URL in the @@ -17342,9 +17349,7 @@ inlined into the compiled format versions. This means that if you change its definition, you should explicitly call `ibuffer-recompile-formats'. -\(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)" nil t) - -(function-put 'define-ibuffer-column 'lisp-indent-function 'defun) +\(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)" nil 'macro) (autoload 'define-ibuffer-sorter "ibuf-macs" "\ Define a method of sorting named NAME. @@ -17356,11 +17361,7 @@ For sorting, the forms in BODY will be evaluated with `a' bound to one buffer object, and `b' bound to another. BODY should return a non-nil value if and only if `a' is \"less than\" `b'. -\(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)" nil t) - -(function-put 'define-ibuffer-sorter 'lisp-indent-function '1) - -(function-put 'define-ibuffer-sorter 'doc-string-elt '2) +\(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)" nil 'macro) (autoload 'define-ibuffer-op "ibuf-macs" "\ Generate a function which operates on a buffer. @@ -17400,11 +17401,7 @@ BODY define the operation; they are forms to evaluate per each marked buffer. BODY is evaluated with `buf' bound to the buffer object. -\(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING BEFORE AFTER COMPLEX) &rest BODY)" nil t) - -(function-put 'define-ibuffer-op 'lisp-indent-function '2) - -(function-put 'define-ibuffer-op 'doc-string-elt '3) +\(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING BEFORE AFTER COMPLEX) &rest BODY)" nil 'macro) (autoload 'define-ibuffer-filter "ibuf-macs" "\ Define a filter named NAME. @@ -17420,11 +17417,7 @@ not a particular buffer should be displayed or not. The forms in BODY will be evaluated with BUF bound to the buffer object, and QUALIFIER bound to the current value of the filter. -\(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)" nil t) - -(function-put 'define-ibuffer-filter 'lisp-indent-function '2) - -(function-put 'define-ibuffer-filter 'doc-string-elt '2) +\(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)" nil 'macro) (register-definition-prefixes "ibuf-macs" '("ibuffer-")) @@ -19542,24 +19535,24 @@ Display a list of the options available when a misspelling is encountered. Selections are: -DIGIT: Replace the word with a digit offered in the *Choices* buffer. -SPC: Accept word this time. -`i': Accept word and insert into private dictionary. -`a': Accept word for this session. -`A': Accept word and place in `buffer-local dictionary'. -`r': Replace word with typed-in value. Rechecked. -`R': Replace word with typed-in value. Query-replaced in buffer. Rechecked. -`?': Show these commands. -`x': Exit spelling buffer. Move cursor to original point. -`X': Exit spelling buffer. Leaves cursor at the current point, and permits +\\`0'..\\`9' Replace the word with a digit offered in the *Choices* buffer. +\\`SPC' Accept word this time. +\\`i' Accept word and insert into private dictionary. +\\`a' Accept word for this session. +\\`A' Accept word and place in `buffer-local dictionary'. +\\`r' Replace word with typed-in value. Rechecked. +\\`R' Replace word with typed-in value. Query-replaced in buffer. Rechecked. +\\`?' Show these commands. +\\`x' Exit spelling buffer. Move cursor to original point. +\\`X' Exit spelling buffer. Leaves cursor at the current point, and permits the aborted check to be completed later. -`q': Quit spelling session (Kills ispell process). -`l': Look up typed-in replacement in alternate dictionary. Wildcards okay. -`u': Like `i', but the word is lower-cased first. -`m': Place typed-in value in personal dictionary, then recheck current word. -`C-l': Redraw screen. -`C-r': Recursive edit. -`C-z': Suspend Emacs or iconify frame." nil nil) +\\`q' Quit spelling session (Kills ispell process). +\\`l' Look up typed-in replacement in alternate dictionary. Wildcards okay. +\\`u' Like \\`i', but the word is lower-cased first. +\\`m' Place typed-in value in personal dictionary, then recheck current word. +\\`C-l' Redraw screen. +\\`C-r' Recursive edit. +\\`C-z' Suspend Emacs or iconify frame." nil nil) (autoload 'ispell-kill-ispell "ispell" "\ Kill current Ispell process (so that you may start a fresh one). @@ -19666,8 +19659,8 @@ Don't check spelling of message headers except the Subject field. Don't check included messages. To abort spell checking of a message region and send the message anyway, -use the `x' command. (Any subsequent regions will be checked.) -The `X' command aborts sending the message so that you can edit the buffer. +use the \\`x' command. (Any subsequent regions will be checked.) +The \\`X' command aborts sending the message so that you can edit the buffer. To spell-check whenever a message is sent, include the appropriate lines in your init file: @@ -21025,7 +21018,7 @@ current header, calls `mail-complete-function' and passes prefix ARG if any. ;;; Generated autoloads from net/mailcap.el (autoload 'mailcap-mime-type-to-extension "mailcap" "\ -Return a file name extension based on a mime type. +Return a file name extension based on a MIME-TYPE. For instance, `image/png' will result in `png'. \(fn MIME-TYPE)" nil nil) @@ -24164,7 +24157,7 @@ Coloring: ;;;### (autoloads nil "org" "org/org.el" (0 0 0 0)) ;;; Generated autoloads from org/org.el -(push (purecopy '(org 9 5)) package--builtin-versions) +(push (purecopy '(org 9 5 1)) package--builtin-versions) (autoload 'org-babel-do-load-languages "org" "\ Load the languages defined in `org-babel-load-languages'. @@ -25900,6 +25893,38 @@ disabled. \(fn &optional ARG)" t nil) +(defvar pixel-scroll-precision-mode nil "\ +Non-nil if Pixel-Scroll-Precision mode is enabled. +See the `pixel-scroll-precision-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `pixel-scroll-precision-mode'.") + +(custom-autoload 'pixel-scroll-precision-mode "pixel-scroll" nil) + +(autoload 'pixel-scroll-precision-mode "pixel-scroll" "\ +Toggle pixel scrolling. +When enabled, this minor mode allows to scroll the display +precisely, according to the turning of the mouse wheel. + +This is a minor mode. If called interactively, toggle the +`Pixel-Scroll-Precision mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable the +mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the +mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='pixel-scroll-precision-mode)'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +\(fn &optional ARG)" t nil) + (register-definition-prefixes "pixel-scroll" '("pixel-")) ;;;*** @@ -27680,11 +27705,11 @@ If ARG is non-nil, instead prompt for connection parameters. (autoload 'rcirc-connect "rcirc" "\ Connect to SERVER. The arguments PORT, NICK, USER-NAME, FULL-NAME, PASSWORD, -ENCRYPTION, SERVER-ALIAS are interpreted as in +ENCRYPTION, CERTFP, SERVER-ALIAS are interpreted as in `rcirc-server-alist'. STARTUP-CHANNELS is a list of channels that are joined after authentication. -\(fn SERVER &optional PORT NICK USER-NAME FULL-NAME STARTUP-CHANNELS PASSWORD ENCRYPTION SERVER-ALIAS)" nil nil) +\(fn SERVER &optional PORT NICK USER-NAME FULL-NAME STARTUP-CHANNELS PASSWORD ENCRYPTION CERTFP SERVER-ALIAS)" nil nil) (defvar rcirc-track-minor-mode nil "\ Non-nil if Rcirc-Track minor mode is enabled. @@ -32539,6 +32564,16 @@ This takes into account combining characters and grapheme clusters. \(fn STRING)" nil nil) +(autoload 'add-display-text-property "subr-x" "\ +Add display property PROP with VALUE to the text from START to END. +If any text in the region has a non-nil `display' property, those +properties are retained. + +If OBJECT is non-nil, it should be a string or a buffer. If nil, +this defaults to the current buffer. + +\(fn START END PROP VALUE &optional OBJECT)" nil nil) + (register-definition-prefixes "subr-x" '("and-let*" "hash-table-" "if-let*" "internal--" "named-let" "replace-region-contents" "string-" "thread-" "when-let*" "with-memoization")) ;;;*** @@ -35583,16 +35618,20 @@ You might need to set `uce-mail-reader' before using this. ;;; Generated autoloads from international/ucs-normalize.el (autoload 'string-glyph-compose "ucs-normalize" "\ -Compose the string STR by according to the Unicode NFC. -This is the canonical composed form. For instance: +Compose STRING according to the Unicode NFC. +This returns a new string obtained by canonical decomposition +of STRING (see `ucs-normalize-NFC-string') followed by canonical +composition, a.k.a. the \"Unicode Normalization Form C\" of STRING. +For instance: - (ucs-normalize-NFC-string \"Å\") => \"Å\" + (string-glyph-compose \"Å\") => \"Å\" \(fn STRING)" nil nil) (autoload 'string-glyph-decompose "ucs-normalize" "\ -Decompose the string STR according to the Unicode NFD. -This is the canonical decomposed form. For instance: +Decompose STRING according to the Unicode NFD. +This returns a new string that is the canonical decomposition of STRING, +a.k.a. the \"Unicode Normalization Form D\" of STRING. For instance: (ucs-normalize-NFD-string \"Å\") => \"Å\" @@ -36460,7 +36499,7 @@ Report an ERROR that occurred while unlocking a file. \(fn ERROR)" nil nil) -(register-definition-prefixes "userlock" '("ask-user-about-" "file-" "userlock--")) +(register-definition-prefixes "userlock" '("ask-user-about-" "file-" "userlock--check-content-unchanged")) ;;;*** @@ -39173,7 +39212,7 @@ where PREFIX is a prefix key and MODIFIERS is either a list of modifiers or a single modifier. If PREFIX is `none', no prefix is used. If MODIFIERS is `none', the keybindings are directly bound to the arrow keys. -Default value of PREFIX is `C-x' and MODIFIERS is `shift'. +Default value of PREFIX is \\`C-x' and MODIFIERS is `shift'. \(fn &optional PREFIX MODIFIERS)" t nil) commit c623746241278a8159e764f639ae42ef9244dc0d Author: Lars Ingebrigtsen Date: Mon Nov 29 22:39:57 2021 +0100 Fix up generation of help text for ldefs-boot.el * lisp/emacs-lisp/autoload.el (autoload-rubric): Don't put the help text into cedet/*/loaddefs.el (bug#51744). diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 148fb70981..23fb400249 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -393,7 +393,7 @@ FILE's name." (concat ";;; " basename " --- automatically extracted " (or type "autoloads") " -*- lexical-binding: t -*-\n" - (when (equal basename "loaddefs.el") + (when (string-match "/lisp/loaddefs\\.el\\'" file) ";; This file will be copied to ldefs-boot.el and checked in periodically.\n") ";;\n" ";;; Code:\n\n" commit 708ffac5ea1cc8f233a4ff698bc29c2a4ef08fc0 Author: Michael Albinus Date: Mon Nov 29 21:36:51 2021 +0100 * test/infra/gitlab-ci.yml (.job-template): Modify find scripts. diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 4b97f5f0a8..b0ea6813b3 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -93,8 +93,8 @@ default: # Prepare test artifacts. - test -n "$(docker ps -aq -f name=${test_name})" && docker cp ${test_name}:checkout/test ${test_name} - test -n "$(docker ps -aq -f name=${test_name})" && docker rm ${test_name} - - /usr/bin/find ${test_name} ! -name "*.log" -type f -delete - - /usr/bin/find ${test_name} -empty -type d -delete + - find ${test_name} ! -name "*.log" -type f -delete + - find ${test_name} -type d -depth -exec rmdir {} + 2>/dev/null .build-template: needs: [] commit 30553d889d733613e8e5fd22358980baa7ee148e (refs/remotes/origin/emacs-28) Merge: de9d27f679 ecf3bf66ba Author: Eli Zaretskii Date: Mon Nov 29 22:30:37 2021 +0200 Merge branch 'emacs-28' of git.savannah.gnu.org:/srv/git/emacs into emacs-28 commit 030a5c570487e2809a1ae902f43d1fecf381030c Author: Protesilaos Stavrou Date: Mon Nov 29 21:06:52 2021 +0200 Remove problematic characters from modus-themes.org (bug#52126) * doc/misc/modus-themes.org (Enable and load, Font configurations for Org and others) (Note on highlight-parentheses.el, Note on god-mode.el): Update links to headings so that they no longer include the removed portions of text. (Option for color-coding success state, Option for line highlighting) (Option for line numbers, Option for parenthesis matching) (Advanced customization, Per-theme customization settings) (Case-by-case face specs using the themes' palette) (Face specs at scale using the themes' palette) (Remap face with local value, Cycle through arbitrary colors) (Override colors, Override color saturation) (Font configurations for Org and others, Configure bold and italic faces) (Custom Org user faces, Update Org block delimiter fontification) (Measure color contrast, Load theme depending on time of day) (Backdrop for pdf-tools, Decrease mode line height) (A theme-agnostic hook for theme loading, Note on EWW and Elfeed fonts) (Frequently Asked Questions): Remove parentheses from headings as they can cause problems in the .texi version of the file. diff --git a/doc/misc/modus-themes.org b/doc/misc/modus-themes.org index f3c2e37b7d..f67a179567 100644 --- a/doc/misc/modus-themes.org +++ b/doc/misc/modus-themes.org @@ -279,9 +279,9 @@ With those granted, bear in mind a couple of technical points on 2. The functions will run the ~modus-themes-after-load-theme-hook~ as their final step. This can be employed for bespoke configurations - ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization (do-it-yourself)]]). Experienced users may not - wish to rely on such a hook and the functions that run it: they may - prefer a custom solution ([[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]]). + ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]). Experienced users may not wish to rely + on such a hook and the functions that run it: they may prefer a + custom solution ([[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]]). ** Sample configuration with and without use-package :properties: @@ -515,7 +515,7 @@ Enable this behaviour by setting this variable to ~nil~. Regardless of this option, the active theme must be reloaded for changes to user options to take effect ([[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]). -** Option for color-coding success state (deuteranopia) +** Option for color-coding success state :properties: :alt_title: Success' color-code :description: Toggle blue color for success or done states @@ -1151,7 +1151,7 @@ To disable fringe indicators for Flymake or Flycheck, refer to variables ~flymake-fringe-indicator-position~ and ~flycheck-indication-mode~, respectively. -** Option for line highlighting (hl-line-mode) +** Option for line highlighting :properties: :alt_title: Line highlighting :description: Choose style of current line (hl-line-mode) @@ -1205,7 +1205,7 @@ with underlines. This style affects several packages that enable ~hl-line-mode~, such as =elfeed=, =notmuch=, and =mu4e=. -** Option for line numbers (display-line-numbers-mode) +** Option for line numbers :properties: :alt_title: Line numbers :description: Toggle subtle style for line numbers @@ -1260,7 +1260,7 @@ combined with a subtle background. With a non-nil value (~t~), these constructs will use a more prominent background and foreground color combination instead. -** Option for parenthesis matching (show-paren-mode) +** Option for parenthesis matching :properties: :alt_title: Matching parentheses :description: Choose between various styles for matching delimiters/parentheses @@ -1913,7 +1913,7 @@ With a non-nil value (~t~) apply a proportionately spaced typeface, else [[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and others]]. -* Advanced customization (do-it-yourself) +* Advanced customization :properties: :custom_id: h:f4651d55-8c07-46aa-b52b-bed1e53463bb :end: @@ -1928,7 +1928,7 @@ their own local tweaks and who are willing to deal with any possible incompatibilities between versioned releases of the themes. As such, they are labelled as "do-it-yourself" or "DIY". -** Per-theme customization settings (DIY) +** Per-theme customization settings :properties: :custom_id: h:a897b302-8e10-4a26-beab-3caaee1e1193 :end: @@ -1963,7 +1963,7 @@ equivalent the themes provide. For a more elaborate design, it is better to inspect the source code of ~modus-themes-toggle~ and relevant functions. -** Case-by-case face specs using the themes' palette (DIY) +** Case-by-case face specs using the themes' palette :properties: :custom_id: h:1487c631-f4fe-490d-8d58-d72ffa3bd474 :end: @@ -2067,7 +2067,7 @@ Take the previous example with the ~cursor~ face: (set-face-attribute 'cursor nil :background (modus-themes-color-alts 'blue 'red)) #+end_src -** Face specs at scale using the themes' palette (DIY) +** Face specs at scale using the themes' palette :properties: :custom_id: h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae :end: @@ -2182,7 +2182,7 @@ the previous section. Adapt the above example like this: ...)) #+end_src -** Remap face with local value (DIY) +** Remap face with local value :properties: :custom_id: h:7a93cb6f-4eca-4d56-a85c-9dcd813d6b0f :end: @@ -2244,7 +2244,7 @@ Perhaps you may wish to generalise those findings in to a set of functions that also accept an arbitrary face. We shall leave the experimentation up to you. -** Cycle through arbitrary colors (DIY) +** Cycle through arbitrary colors :properties: :custom_id: h:77dc4a30-b96a-4849-85a8-fee3c2995305 :end: @@ -2408,7 +2408,7 @@ Must become this: ...) #+end_src -** Override colors (DIY) +** Override colors :properties: :custom_id: h:307d95dd-8dbd-4ece-a543-10ae86f155a6 :end: @@ -2524,7 +2524,7 @@ that we provide: [[#h:02e25930-e71a-493d-828a-8907fc80f874][test color combinati ratio between two color values, so it can help in overriding the palette (or a subset thereof) without making the end result inaccessible. -** Override color saturation (DIY) +** Override color saturation :properties: :custom_id: h:4589acdc-2505-41fc-9f5e-699cfc45ab00 :end: @@ -2644,7 +2644,7 @@ inspiration from the ~modus-themes-toggle~ we already provide: ('modus-vivendi (modus-themes-load-vivendi)))) #+end_src -** Font configurations for Org and others (DIY) +** Font configurations for Org and others :properties: :custom_id: h:defcf4fc-8fa8-4c29-b12e-7119582cc929 :end: @@ -2708,9 +2708,9 @@ scale gracefully when using something like the ~text-scale-adjust~ command which only operates on the base font size (i.e. the ~default~ face's absolute height). -[[#h:e6c5451f-6763-4be7-8fdb-b4706a422a4c][Note for EWW and Elfeed fonts (SHR fonts)]]. +[[#h:e6c5451f-6763-4be7-8fdb-b4706a422a4c][Note for EWW and Elfeed fonts]]. -** Configure bold and italic faces (DIY) +** Configure bold and italic faces :properties: :custom_id: h:2793a224-2109-4f61-a106-721c57c01375 :end: @@ -2805,7 +2805,7 @@ of the themes, which can make it easier to redefine faces in bulk). [[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]]. -** Custom Org user faces (DIY) +** Custom Org user faces :properties: :custom_id: h:89f0678d-c5c3-4a57-a526-668b2bb2d7ad :end: @@ -2893,7 +2893,7 @@ it if you plan to control face attributes. [[#h:02e25930-e71a-493d-828a-8907fc80f874][Check color combinations]]. -** Update Org block delimiter fontification (DIY) +** Update Org block delimiter fontification :properties: :custom_id: h:f44cc6e3-b0f1-4a5e-8a90-9e48fa557b50 :end: @@ -2935,7 +2935,7 @@ Run this function at the post theme load phase, such as with the (font-lock-flush))) #+end_src -** Measure color contrast (DIY) +** Measure color contrast :properties: :custom_id: h:02e25930-e71a-493d-828a-8907fc80f874 :end: @@ -3008,7 +3008,7 @@ minutia and relevant commentary. Such knowledge may prove valuable while attempting to override some of the themes' colors: [[#h:307d95dd-8dbd-4ece-a543-10ae86f155a6][Override colors]]. -** Load theme depending on time of day (DIY) +** Load theme depending on time of day :properties: :custom_id: h:1d1ef4b4-8600-4a09-993c-6de3af0ddd26 :end: @@ -3035,7 +3035,7 @@ package: (circadian-setup)) #+end_src -** Backdrop for pdf-tools (DIY) +** Backdrop for pdf-tools :properties: :custom_id: h:ff69dfe1-29c0-447a-915c-b5ff7c5509cd :end: @@ -3097,7 +3097,7 @@ With those in place, PDFs have a distinct backdrop for their page, while they automatically switch to their dark mode when ~modus-themes-toggle~ is called from inside a buffer whose major-mode is ~pdf-view-mode~. -** Decrease mode line height (DIY) +** Decrease mode line height :properties: :custom_id: h:03be4438-dae1-4961-9596-60a307c070b5 :end: @@ -3192,7 +3192,7 @@ to be specified as well: (add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces) #+end_src -** A theme-agnostic hook for theme loading (DIY) +** A theme-agnostic hook for theme loading :properties: :custom_id: h:86f6906b-f090-46cc-9816-1fe8aeb38776 :end: @@ -3806,7 +3806,7 @@ of the techniques that are discussed at length in the various "Do-It-Yourself" (DIY) sections, which provide insight into the more advanced customization options of the themes. -[[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization (do-it-yourself)]]. +[[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]. In the following example, we are assuming that the user wants to (i) re-use color variables provided by the themes, (ii) be able to retain @@ -4072,12 +4072,12 @@ examples with the 4, 8, 16 colors): :custom_id: h:4da1d515-3e05-47ef-9e45-8251fc7e986a :end: -The ~god-mode~ library does not provide faces that could be configured by -the Modus themes. Users who would like to get some visual feedback on -the status of {{{kbd(M-x god-mode)}}} are instead encouraged by upstream to -set up their own configurations, such as by changing the ~mode-line~ face -([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization (do-it-yourself)]]). This is an adaptation of the -approach followed in the upstream README: +The ~god-mode~ library does not provide faces that could be configured +by the Modus themes. Users who would like to get some visual feedback +on the status of {{{kbd(M-x god-mode)}}} are instead encouraged by upstream +to set up their own configurations, such as by changing the ~mode-line~ +face ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]). This is an adaptation of the approach +followed in the upstream README: #+begin_src emacs-lisp (defun my-god-mode-update-mode-line () @@ -4171,7 +4171,7 @@ specifications the webpage provides. Consult {{{kbd(C-h v shr-use-colors)}}}. -** Note on EWW and Elfeed fonts (SHR fonts) +** Note on EWW and Elfeed fonts :properties: :custom_id: h:e6c5451f-6763-4be7-8fdb-b4706a422a4c :end: @@ -4285,7 +4285,7 @@ you've customized any faces. "-draw" "text %X,%Y '%c'")))) #+end_src -* Frequently Asked Questions (FAQ) +* Frequently Asked Questions :properties: :custom_id: h:b3384767-30d3-4484-ba7f-081729f03a47 :end: commit ecf3bf66ba8c9f2805196ece2607d7f1c9cae3d5 Author: Protesilaos Stavrou Date: Mon Nov 29 21:13:55 2021 +0200 Remove problematic characters from modus-themes.org (bug#52126) * doc/misc/modus-themes.org (Enable and load, Font configurations for Org and others) (Note on highlight-parentheses.el, Note on god-mode.el): Update links to headings so that they no longer include the removed portions of text. (Option for color-coding success state, Option for line highlighting) (Option for line numbers, Option for parenthesis matching) (Advanced customization, Per-theme customization settings) (Case-by-case face specs using the themes' palette) (Face specs at scale using the themes' palette) (Remap face with local value, Cycle through arbitrary colors) (Override colors, Override color saturation) (Font configurations for Org and others, Configure bold and italic faces) (Custom Org user faces, Update Org block delimiter fontification) (Measure color contrast, Load theme depending on time of day) (Backdrop for pdf-tools) (A theme-agnostic hook for theme loading, Note on EWW and Elfeed fonts) (Frequently Asked Questions): Remove parentheses from headings as they can cause problems in the .texi version of the file. diff --git a/doc/misc/modus-themes.org b/doc/misc/modus-themes.org index 675144d517..9674a12e69 100644 --- a/doc/misc/modus-themes.org +++ b/doc/misc/modus-themes.org @@ -279,9 +279,9 @@ With those granted, bear in mind a couple of technical points on 2. The functions will run the ~modus-themes-after-load-theme-hook~ as their final step. This can be employed for bespoke configurations - ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization (do-it-yourself)]]). Experienced users may not - wish to rely on such a hook and the functions that run it: they may - prefer a custom solution ([[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]]). + ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]). Experienced users may not wish to rely + on such a hook and the functions that run it: they may prefer a + custom solution ([[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]]). ** Sample configuration for use-package :properties: @@ -483,7 +483,7 @@ currently active Modus theme. Enable this behaviour by setting this variable to ~nil~. -** Option for color-coding success state (deuteranopia) +** Option for color-coding success state :properties: :alt_title: Success' color-code :description: Toggle blue color for success or done states @@ -1056,7 +1056,7 @@ NOTE: The placement of the straight underline, though not the wave style, is controlled by the built-in variables ~underline-minimum-offset~, ~x-underline-at-descent-line~, ~x-use-underline-position-properties~. -** Option for line highlighting (hl-line-mode) +** Option for line highlighting :properties: :alt_title: Line highlighting :description: Choose style of current line (hl-line-mode) @@ -1108,7 +1108,7 @@ with underlines. This style affects several packages that enable ~hl-line-mode~, such as =elfeed=, =notmuch=, and =mu4e=. -** Option for line numbers (display-line-numbers-mode) +** Option for line numbers :properties: :alt_title: Line numbers :description: Toggle subtle style for line numbers @@ -1137,7 +1137,7 @@ Instead they retain the primary background of the theme, blending with the rest of the buffer. Foreground values for all relevant faces are updated to accommodate this aesthetic. -** Option for parenthesis matching (show-paren-mode) +** Option for parenthesis matching :properties: :alt_title: Matching parentheses :description: Choose between various styles for matching delimiters/parentheses @@ -1723,7 +1723,7 @@ With a non-nil value (~t~) apply a proportionately spaced typeface, else [[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and others]]. -* Advanced customization (do-it-yourself) +* Advanced customization :properties: :custom_id: h:f4651d55-8c07-46aa-b52b-bed1e53463bb :end: @@ -1738,7 +1738,7 @@ their own local tweaks and who are willing to deal with any possible incompatibilities between versioned releases of the themes. As such, they are labelled as "do-it-yourself" or "DIY". -** Per-theme customization settings (DIY) +** Per-theme customization settings :properties: :custom_id: h:a897b302-8e10-4a26-beab-3caaee1e1193 :end: @@ -1773,7 +1773,7 @@ equivalent the themes provide. For a more elaborate design, it is better to inspect the source code of ~modus-themes-toggle~ and relevant functions. -** Case-by-case face specs using the themes' palette (DIY) +** Case-by-case face specs using the themes' palette :properties: :custom_id: h:1487c631-f4fe-490d-8d58-d72ffa3bd474 :end: @@ -1877,7 +1877,7 @@ Take the previous example with the ~cursor~ face: (set-face-attribute 'cursor nil :background (modus-themes-color-alts 'blue 'red)) #+end_src -** Face specs at scale using the themes' palette (DIY) +** Face specs at scale using the themes' palette :properties: :custom_id: h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae :end: @@ -1992,7 +1992,7 @@ the previous section. Adapt the above example like this: ...)) #+end_src -** Remap face with local value (DIY) +** Remap face with local value :properties: :custom_id: h:7a93cb6f-4eca-4d56-a85c-9dcd813d6b0f :end: @@ -2054,7 +2054,7 @@ Perhaps you may wish to generalise those findings in to a set of functions that also accept an arbitrary face. We shall leave the experimentation up to you. -** Cycle through arbitrary colors (DIY) +** Cycle through arbitrary colors :properties: :custom_id: h:77dc4a30-b96a-4849-85a8-fee3c2995305 :end: @@ -2218,7 +2218,7 @@ Must become this: ...) #+end_src -** Override colors (DIY) +** Override colors :properties: :custom_id: h:307d95dd-8dbd-4ece-a543-10ae86f155a6 :end: @@ -2334,7 +2334,7 @@ that we provide: [[#h:02e25930-e71a-493d-828a-8907fc80f874][test color combinati ratio between two color values, so it can help in overriding the palette (or a subset thereof) without making the end result inaccessible. -** Override color saturation (DIY) +** Override color saturation :properties: :custom_id: h:4589acdc-2505-41fc-9f5e-699cfc45ab00 :end: @@ -2454,7 +2454,7 @@ inspiration from the ~modus-themes-toggle~ we already provide: ('modus-vivendi (modus-themes-load-vivendi)))) #+end_src -** Font configurations for Org and others (DIY) +** Font configurations for Org and others :properties: :custom_id: h:defcf4fc-8fa8-4c29-b12e-7119582cc929 :end: @@ -2511,9 +2511,9 @@ importance: it ensures that all fonts can scale gracefully when using something like the ~text-scale-adjust~ command which only operates on the base font size (i.e. the ~default~ face's absolute height). -[[#h:e6c5451f-6763-4be7-8fdb-b4706a422a4c][Note for EWW and Elfeed fonts (SHR fonts)]]. +[[#h:e6c5451f-6763-4be7-8fdb-b4706a422a4c][Note for EWW and Elfeed fonts]]. -** Configure bold and italic faces (DIY) +** Configure bold and italic faces :properties: :custom_id: h:2793a224-2109-4f61-a106-721c57c01375 :end: @@ -2605,7 +2605,7 @@ themes). (add-hook 'modus-themes-after-load-theme-hook #'my-modes-themes-bold-italic-faces) #+end_src -** Custom Org user faces (DIY) +** Custom Org user faces :properties: :custom_id: h:89f0678d-c5c3-4a57-a526-668b2bb2d7ad :end: @@ -2693,7 +2693,7 @@ it if you plan to control face attributes. [[#h:02e25930-e71a-493d-828a-8907fc80f874][Check color combinations]]. -** Update Org block delimiter fontification (DIY) +** Update Org block delimiter fontification :properties: :custom_id: h:f44cc6e3-b0f1-4a5e-8a90-9e48fa557b50 :end: @@ -2735,7 +2735,7 @@ Run this function at the post theme load phase, such as with the (font-lock-flush))) #+end_src -** Measure color contrast (DIY) +** Measure color contrast :properties: :custom_id: h:02e25930-e71a-493d-828a-8907fc80f874 :end: @@ -2808,7 +2808,7 @@ minutia and relevant commentary. Such knowledge may prove valuable while attempting to override some of the themes' colors: [[#h:307d95dd-8dbd-4ece-a543-10ae86f155a6][Override colors]]. -** Load theme depending on time of day (DIY) +** Load theme depending on time of day :properties: :custom_id: h:1d1ef4b4-8600-4a09-993c-6de3af0ddd26 :end: @@ -2835,7 +2835,7 @@ package: (circadian-setup)) #+end_src -** Backdrop for pdf-tools (DIY) +** Backdrop for pdf-tools :properties: :custom_id: h:ff69dfe1-29c0-447a-915c-b5ff7c5509cd :end: @@ -2897,7 +2897,7 @@ With those in place, PDFs have a distinct backdrop for their page, while they automatically switch to their dark mode when ~modus-themes-toggle~ is called from inside a buffer whose major-mode is ~pdf-view-mode~. -** A theme-agnostic hook for theme loading (DIY) +** A theme-agnostic hook for theme loading :properties: :custom_id: h:86f6906b-f090-46cc-9816-1fe8aeb38776 :end: @@ -3509,7 +3509,7 @@ of the techniques that are discussed at length in the various "Do-It-Yourself" (DIY) sections, which provide insight into the more advanced customization options of the themes. -[[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization (do-it-yourself)]]. +[[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]. In the following example, we are assuming that the user wants to (i) re-use color variables provided by the themes, (ii) be able to retain @@ -3775,12 +3775,12 @@ examples with the 4, 8, 16 colors): :custom_id: h:4da1d515-3e05-47ef-9e45-8251fc7e986a :end: -The ~god-mode~ library does not provide faces that could be configured by -the Modus themes. Users who would like to get some visual feedback on -the status of {{{kbd(M-x god-mode)}}} are instead encouraged by upstream to -set up their own configurations, such as by changing the ~mode-line~ face -([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization (do-it-yourself)]]). This is an adaptation of the -approach followed in the upstream README: +The ~god-mode~ library does not provide faces that could be configured +by the Modus themes. Users who would like to get some visual feedback +on the status of {{{kbd(M-x god-mode)}}} are instead encouraged by upstream +to set up their own configurations, such as by changing the ~mode-line~ +face ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]). This is an adaptation of the approach +followed in the upstream README: #+begin_src emacs-lisp (defun my-god-mode-update-mode-line () @@ -3874,7 +3874,7 @@ specifications the webpage provides. Consult {{{kbd(C-h v shr-use-colors)}}}. -** Note on EWW and Elfeed fonts (SHR fonts) +** Note on EWW and Elfeed fonts :properties: :custom_id: h:e6c5451f-6763-4be7-8fdb-b4706a422a4c :end: @@ -3988,7 +3988,7 @@ you've customized any faces. "-draw" "text %X,%Y '%c'")))) #+end_src -* Frequently Asked Questions (FAQ) +* Frequently Asked Questions :properties: :custom_id: h:b3384767-30d3-4484-ba7f-081729f03a47 :end: commit c2c9e7e3cbb485d4240f9c9c44694f310711e4e9 Author: Lars Ingebrigtsen Date: Mon Nov 29 17:18:49 2021 +0100 Don't return whitespace for thing-at-point in whitespace-only buffers * lisp/thingatpt.el (bounds-of-thing-at-point): If the buffer is empty, return nil for most things (bug#52098). diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 32e66184d7..2d1bf2013e 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -106,8 +106,17 @@ valid THING. Return a cons cell (START . END) giving the start and end positions of the thing found." - (if (get thing 'bounds-of-thing-at-point) - (funcall (get thing 'bounds-of-thing-at-point)) + (cond + ((get thing 'bounds-of-thing-at-point) + (funcall (get thing 'bounds-of-thing-at-point))) + ;; If the buffer is totally empty, give up. + ((and (not (eq thing 'whitespace)) + (save-excursion + (goto-char (point-min)) + (not (re-search-forward "[^\t\n ]" nil t)))) + nil) + ;; Find the thing. + (t (let ((orig (point))) (ignore-errors (save-excursion @@ -149,7 +158,7 @@ positions of the thing found." (lambda () (forward-thing thing -1)))) (point)))) (if (and (<= real-beg orig) (<= orig end) (< real-beg end)) - (cons real-beg end)))))))))) + (cons real-beg end))))))))))) ;;;###autoload (defun thing-at-point (thing &optional no-properties) commit 73cf27aa45d80fce85ae44874931bdccadb70964 Author: Lars Ingebrigtsen Date: Mon Nov 29 17:08:11 2021 +0100 Make Re: recognition in ispell-message less ambiguous * lisp/textmodes/ispell.el (ispell-message): Require a "Re" as a word, not as a word ending (bug#52104). diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index 4087f7e5f2..754ecb3a1d 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -3977,7 +3977,7 @@ You can bind this to the key C-c i in GNUS or mail by adding to (if (re-search-forward "^Subject: *" end-of-headers t) (progn (goto-char (match-end 0)) - (if (and (not (looking-at ".*Re\\>")) + (if (and (not (looking-at ".*\\")) (not (looking-at "\\["))) (progn (setq case-fold-search old-case-fold-search) commit f0eba4ea5e1eddebea5e75da49ecdfcefbf7fb73 Author: Brahimi Saifullah Date: Mon Nov 29 16:52:26 2021 +0100 Make `group' widgets prettier in Customize * lisp/wid-edit.el (group): Make the ":" invisible so that the buffer looks prettier (bug#52143). Copyright-paperwork-exempt: yes diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index fb06a95f51..a53add7d08 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -2968,7 +2968,8 @@ Save CHILD into the :last-deleted list, so it can be inserted later." "A widget which groups other widgets inside." :convert-widget 'widget-types-convert-widget :copy 'widget-types-copy - :format ":\n%v" + :format (concat (propertize ":" 'display "") + "\n%v") :value-create 'widget-group-value-create :value-get 'widget-editable-list-value-get :default-get 'widget-group-default-get commit 0d2f184a1107a910c2ebadbff1a88be32391bbf6 Author: Matthias Meulien Date: Mon Nov 29 16:42:02 2021 +0100 project-kill-buffers can display list of buffers to kill * lisp/progmodes/project.el (project-kill-buffers-display-buffer-list): Option to toggle temporarily display of the list of buffers to kill when calling project-kill-buffers (project-kill-buffers): Handle project-kill-buffers-display-buffer-list option (bug#52148). diff --git a/etc/NEWS b/etc/NEWS index ba28066800..715a57af65 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -427,6 +427,10 @@ it with new 'term-{faint,italic,slow-blink,fast-blink}' faces. *** 'project-find-file' and 'project-or-external-find-file' now accept a prefix argument which is interpreted to mean "include all files". +*** 'project-kill-buffers' can display the list of buffers to kill. +Customize the user option 'project-kill-buffers-display-buffer-list' +to enable the display of the buffer list. + +++ *** New command 'xref-go-forward'. It is bound to 'C-M-,' and jumps to the location where 'xref-go-back' diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index ed076a683d..c2e125a017 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1210,6 +1210,15 @@ current project, it will be killed." :group 'project :package-version '(project . "0.6.0")) +(defcustom project-kill-buffers-display-buffer-list nil + "Non-nil to display list of buffers to kill before killing project buffers. +Used by `project-kill-buffers'." + :type 'boolean + :version "29.1" + :group 'project + :package-version '(project . "0.8.1") + :safe #'booleanp) + (defun project--buffer-list (pr) "Return the list of all buffers in project PR." (let ((conn (file-remote-p (project-root pr))) @@ -1276,14 +1285,35 @@ NO-CONFIRM is always nil when the command is invoked interactively." (interactive) (let* ((pr (project-current t)) - (bufs (project--buffers-to-kill pr))) + (bufs (project--buffers-to-kill pr)) + (query-user (lambda () + (yes-or-no-p + (format "Kill %d buffers in %s? " + (length bufs) + (project-root pr)))))) (cond (no-confirm (mapc #'kill-buffer bufs)) ((null bufs) (message "No buffers to kill")) - ((yes-or-no-p (format "Kill %d buffers in %s? " - (length bufs) - (project-root pr))) + (project-kill-buffers-display-buffer-list + (when + (with-current-buffer-window + (get-buffer-create "*Buffer List*") + `(display-buffer--maybe-at-bottom + (dedicated . t) + (window-height . (fit-window-to-buffer)) + (preserve-size . (nil . t)) + (body-function + . ,#'(lambda (_window) + (list-buffers-noselect nil bufs)))) + #'(lambda (window _value) + (with-selected-window window + (unwind-protect + (funcall query-user) + (when (window-live-p window) + (quit-restore-window window 'kill)))))) + (mapc #'kill-buffer bufs))) + ((funcall query-user) (mapc #'kill-buffer bufs))))) commit 4de13ef147a4c88c33fe608ee7ca5bd4212476ee Author: Lars Ingebrigtsen Date: Mon Nov 29 16:39:02 2021 +0100 Signal a better error in tabulated-list-sort * lisp/emacs-lisp/tabulated-list.el (tabulated-list-sort): Signal error earlier on invalid column numbers (bug#52154). diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 8f6c655dbe..075fe836f6 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -684,6 +684,10 @@ With a numeric prefix argument N, sort the Nth column. If the numeric prefix is -1, restore order the list was originally displayed in." (interactive "P") + (when (and n + (or (>= n (length tabulated-list-format)) + (< n -1))) + (user-error "Invalid column number")) (if (equal n -1) ;; Restore original order. (progn commit e3351f61529b196a5ad8c772746646a82da2f3a5 Author: Daniel Martín Date: Mon Nov 29 15:48:03 2021 +0100 Use mupdf in doc-view-mode if gs is not installed * lisp/doc-view.el (doc-view-mode-p): Use mupdf to render PDF and related formats if gs is not installed (bug#52170). diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 7e113e4f34..11559bf2f5 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -811,9 +811,10 @@ OpenDocument format)." (and doc-view-dvipdfm-program (executable-find doc-view-dvipdfm-program))))) ((memq type '(postscript ps eps pdf)) - ;; FIXME: allow mupdf here - (and doc-view-ghostscript-program - (executable-find doc-view-ghostscript-program))) + (or (and doc-view-ghostscript-program + (executable-find doc-view-ghostscript-program)) + (and doc-view-pdfdraw-program + (executable-find doc-view-pdfdraw-program)))) ((eq type 'odf) (and doc-view-odf->pdf-converter-program (executable-find doc-view-odf->pdf-converter-program) commit 247ed6ccbcf0d2b0887181a90632d4e461a2f519 Author: Ikumi Keita Date: Mon Nov 29 15:40:19 2021 +0100 Make fill-region-as-paragraph clear the markers it creates * lisp/textmodes/fill.el (fill-region-as-paragraph): Clear temporary markers (bug#52175). Copyright-paperwork-exempt: yes diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el index 73d76a8ac6..4e161099cd 100644 --- a/lisp/textmodes/fill.el +++ b/lisp/textmodes/fill.el @@ -705,7 +705,10 @@ space does not end a sentence, so don't break a line there." (goto-char from-plus-indent)) (if (not (> to (point))) - nil ;; There is no paragraph, only whitespace: exit now. + ;; There is no paragraph, only whitespace: exit now. + (progn + (set-marker to nil) + nil) (or justify (setq justify (current-justification))) @@ -791,6 +794,7 @@ space does not end a sentence, so don't break a line there." ;; Leave point after final newline. (goto-char to) (unless (eobp) (forward-char 1)) + (set-marker to nil) ;; Return the fill-prefix we used fill-prefix))) commit 49422d2e6986d3ec161e194c73c38f2a7c4b3c64 Author: Gregory Heytings Date: Mon Nov 29 15:13:31 2021 +0100 Do not buttonize key bindings outside of *Help* buffers * etc/NEWS: Mention the new variable. * lisp/apropos.el (apropos-describe-plist): Bind the new variable (bug#52053). * lisp/button.el (button-describe): Bind the new variable. * lisp/help-fns.el (describe-function, describe-variable) (describe-face, describe-symbol, describe-syntax) (describe-categories, describe-keymap, describe-mode) (describe-widget): Bind the new variable. * lisp/help-macro.el (make-help-screen): Bind the new variable. * lisp/help.el (help-buffer-under-preparation): New variable that is bound to t by commands that create a *Help* buffer. (substitute-command-keys): Use the new variable: help-link-key-to-documentation is supposed to have an effect only "in *Help* buffers". Fixes bug#52053. (view-lossage, describe-bindings, describe-key): Bind the new variable. * lisp/repeat.el (describe-repeat-maps): Bind the new variable. * lisp/international/mule-cmds.el (describe-input-method) (describe-language-environment): Bind the new variable. * lisp/international/mule-diag.el (describe-character-set) (describe-coding-system, describe-font, describe-fontset) ((list-fontsets): Bind the new variable. diff --git a/etc/NEWS b/etc/NEWS index 87a7a43a5e..ba28066800 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -992,6 +992,9 @@ that should be displayed, and the xwidget that asked to display it. This function is used to control where and if an xwidget stores cookies set by web pages on disk. +** New variable 'help-buffer-under-preparation'. +This variable is bound to t during the preparation of a *Help* buffer. + * Changes in Emacs 29.1 on Non-Free Operating Systems diff --git a/lisp/apropos.el b/lisp/apropos.el index 00919ed91b..66a594d588 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -1322,17 +1322,18 @@ as a heading." (defun apropos-describe-plist (symbol) "Display a pretty listing of SYMBOL's plist." - (help-setup-xref (list 'apropos-describe-plist symbol) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - (set-buffer standard-output) - (princ "Symbol ") - (prin1 symbol) - (princ (substitute-command-keys "'s plist is\n (")) - (put-text-property (+ (point-min) 7) (- (point) 14) - 'face 'apropos-symbol) - (insert (apropos-format-plist symbol "\n ")) - (princ ")"))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list 'apropos-describe-plist symbol) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (set-buffer standard-output) + (princ "Symbol ") + (prin1 symbol) + (princ (substitute-command-keys "'s plist is\n (")) + (put-text-property (+ (point-min) 7) (- (point) 14) + 'face 'apropos-symbol) + (insert (apropos-format-plist symbol "\n ")) + (princ ")")))) (provide 'apropos) diff --git a/lisp/button.el b/lisp/button.el index e3f91cb4a6..dd5a71d116 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -604,7 +604,8 @@ When called from Lisp, pass BUTTON-OR-POS as the button to describe, or a buffer position where a button is present. If BUTTON-OR-POS is nil, the button at point is the button to describe." (interactive "d") - (let* ((button (cond ((integer-or-marker-p button-or-pos) + (let* ((help-buffer-under-preparation t) + (button (cond ((integer-or-marker-p button-or-pos) (button-at button-or-pos)) ((null button-or-pos) (button-at (point))) ((overlayp button-or-pos) button-or-pos))) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 17fabe4f63..32698420e1 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -249,7 +249,8 @@ handling of autoloaded functions." ;; calling that. (let ((describe-function-orig-buffer (or describe-function-orig-buffer - (current-buffer)))) + (current-buffer))) + (help-buffer-under-preparation t)) (help-setup-xref (list (lambda (function buffer) @@ -1078,7 +1079,8 @@ it is displayed along with the global value." (if (symbolp v) (symbol-name v)))) (list (if (equal val "") v (intern val))))) - (let (file-name) + (let (file-name + (help-buffer-under-preparation t)) (unless (buffer-live-p buffer) (setq buffer (current-buffer))) (unless (frame-live-p frame) (setq frame (selected-frame))) (if (not (symbolp variable)) @@ -1461,77 +1463,78 @@ If FRAME is omitted or nil, use the selected frame." (interactive (list (read-face-name "Describe face" (or (face-at-point t) 'default) t))) - (help-setup-xref (list #'describe-face face) - (called-interactively-p 'interactive)) - (unless face - (setq face 'default)) - (if (not (listp face)) - (setq face (list face))) - (with-help-window (help-buffer) - (with-current-buffer standard-output - (dolist (f face (buffer-string)) - (if (stringp f) (setq f (intern f))) - ;; We may get called for anonymous faces (i.e., faces - ;; expressed using prop-value plists). Those can't be - ;; usefully customized, so ignore them. - (when (symbolp f) - (insert "Face: " (symbol-name f)) - (if (not (facep f)) - (insert " undefined face.\n") - (let ((customize-label "customize this face") - file-name) - (insert (concat " (" (propertize "sample" 'font-lock-face f) ")")) - (princ (concat " (" customize-label ")\n")) - ;; FIXME not sure how much of this belongs here, and - ;; how much in `face-documentation'. The latter is - ;; not used much, but needs to return nil for - ;; undocumented faces. - (let ((alias (get f 'face-alias)) - (face f) - obsolete) - (when alias - (setq face alias) - (insert - (format-message - "\n %s is an alias for the face `%s'.\n%s" - f alias - (if (setq obsolete (get f 'obsolete-face)) - (format-message - " This face is obsolete%s; use `%s' instead.\n" - (if (stringp obsolete) - (format " since %s" obsolete) - "") - alias) - "")))) - (insert "\nDocumentation:\n" - (substitute-command-keys - (or (face-documentation face) - "Not documented as a face.")) - "\n\n")) - (with-current-buffer standard-output - (save-excursion - (re-search-backward - (concat "\\(" customize-label "\\)") nil t) - (help-xref-button 1 'help-customize-face f))) - (setq file-name (find-lisp-object-file-name f 'defface)) - (if (not file-name) - (setq help-mode--current-data (list :symbol f)) - (setq help-mode--current-data (list :symbol f - :file file-name)) - (princ (substitute-command-keys "Defined in `")) - (princ (help-fns-short-filename file-name)) - (princ (substitute-command-keys "'")) - ;; Make a hyperlink to the library. - (save-excursion - (re-search-backward - (substitute-command-keys "`\\([^`']+\\)'") nil t) - (help-xref-button 1 'help-face-def f file-name)) - (princ ".") - (terpri) - (terpri)))) - (terpri) - (help-fns--run-describe-functions - help-fns-describe-face-functions f frame)))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'describe-face face) + (called-interactively-p 'interactive)) + (unless face + (setq face 'default)) + (if (not (listp face)) + (setq face (list face))) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (dolist (f face (buffer-string)) + (if (stringp f) (setq f (intern f))) + ;; We may get called for anonymous faces (i.e., faces + ;; expressed using prop-value plists). Those can't be + ;; usefully customized, so ignore them. + (when (symbolp f) + (insert "Face: " (symbol-name f)) + (if (not (facep f)) + (insert " undefined face.\n") + (let ((customize-label "customize this face") + file-name) + (insert (concat " (" (propertize "sample" 'font-lock-face f) ")")) + (princ (concat " (" customize-label ")\n")) + ;; FIXME not sure how much of this belongs here, and + ;; how much in `face-documentation'. The latter is + ;; not used much, but needs to return nil for + ;; undocumented faces. + (let ((alias (get f 'face-alias)) + (face f) + obsolete) + (when alias + (setq face alias) + (insert + (format-message + "\n %s is an alias for the face `%s'.\n%s" + f alias + (if (setq obsolete (get f 'obsolete-face)) + (format-message + " This face is obsolete%s; use `%s' instead.\n" + (if (stringp obsolete) + (format " since %s" obsolete) + "") + alias) + "")))) + (insert "\nDocumentation:\n" + (substitute-command-keys + (or (face-documentation face) + "Not documented as a face.")) + "\n\n")) + (with-current-buffer standard-output + (save-excursion + (re-search-backward + (concat "\\(" customize-label "\\)") nil t) + (help-xref-button 1 'help-customize-face f))) + (setq file-name (find-lisp-object-file-name f 'defface)) + (if (not file-name) + (setq help-mode--current-data (list :symbol f)) + (setq help-mode--current-data (list :symbol f + :file file-name)) + (princ (substitute-command-keys "Defined in `")) + (princ (help-fns-short-filename file-name)) + (princ (substitute-command-keys "'")) + ;; Make a hyperlink to the library. + (save-excursion + (re-search-backward + (substitute-command-keys "`\\([^`']+\\)'") nil t) + (help-xref-button 1 'help-face-def f file-name)) + (princ ".") + (terpri) + (terpri)))) + (terpri) + (help-fns--run-describe-functions + help-fns-describe-face-functions f frame))))))) (add-hook 'help-fns-describe-face-functions #'help-fns--face-custom-version-info) @@ -1602,43 +1605,44 @@ current buffer and the selected frame, respectively." (if found (symbol-name v-or-f))))) (list (if (equal val "") (or v-or-f "") (intern val))))) - (if (not (symbolp symbol)) - (user-error "You didn't specify a function or variable")) - (unless (buffer-live-p buffer) (setq buffer (current-buffer))) - (unless (frame-live-p frame) (setq frame (selected-frame))) - (with-current-buffer (help-buffer) - ;; Push the previous item on the stack before clobbering the output buffer. - (help-setup-xref nil nil) - (let* ((docs - (nreverse - (delq nil - (mapcar (pcase-lambda (`(,name ,testfn ,descfn)) - (when (funcall testfn symbol) - ;; Don't record the current entry in the stack. - (setq help-xref-stack-item nil) - (cons name - (funcall descfn symbol buffer frame)))) - describe-symbol-backends)))) - (single (null (cdr docs)))) - (while (cdr docs) - (goto-char (point-min)) - (let ((inhibit-read-only t) - (name (caar docs)) ;Name of doc currently at BOB. - (doc (cdr (cadr docs)))) ;Doc to add at BOB. - (when doc - (insert doc) - (delete-region (point) - (progn (skip-chars-backward " \t\n") (point))) - (insert "\n\n" (make-separator-line) "\n") - (when name - (insert (symbol-name symbol) - " is also a " name "." "\n\n")))) - (setq docs (cdr docs))) - (unless single - ;; Don't record the `describe-variable' item in the stack. - (setq help-xref-stack-item nil) - (help-setup-xref (list #'describe-symbol symbol) nil)) - (goto-char (point-min))))) + (let ((help-buffer-under-preparation t)) + (if (not (symbolp symbol)) + (user-error "You didn't specify a function or variable")) + (unless (buffer-live-p buffer) (setq buffer (current-buffer))) + (unless (frame-live-p frame) (setq frame (selected-frame))) + (with-current-buffer (help-buffer) + ;; Push the previous item on the stack before clobbering the output buffer. + (help-setup-xref nil nil) + (let* ((docs + (nreverse + (delq nil + (mapcar (pcase-lambda (`(,name ,testfn ,descfn)) + (when (funcall testfn symbol) + ;; Don't record the current entry in the stack. + (setq help-xref-stack-item nil) + (cons name + (funcall descfn symbol buffer frame)))) + describe-symbol-backends)))) + (single (null (cdr docs)))) + (while (cdr docs) + (goto-char (point-min)) + (let ((inhibit-read-only t) + (name (caar docs)) ;Name of doc currently at BOB. + (doc (cdr (cadr docs)))) ;Doc to add at BOB. + (when doc + (insert doc) + (delete-region (point) + (progn (skip-chars-backward " \t\n") (point))) + (insert "\n\n" (make-separator-line) "\n") + (when name + (insert (symbol-name symbol) + " is also a " name "." "\n\n")))) + (setq docs (cdr docs))) + (unless single + ;; Don't record the `describe-variable' item in the stack. + (setq help-xref-stack-item nil) + (help-setup-xref (list #'describe-symbol symbol) nil)) + (goto-char (point-min)))))) ;;;###autoload (defun describe-syntax (&optional buffer) @@ -1647,15 +1651,16 @@ The descriptions are inserted in a help buffer, which is then displayed. BUFFER defaults to the current buffer." (interactive) (setq buffer (or buffer (current-buffer))) - (help-setup-xref (list #'describe-syntax buffer) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - (let ((table (with-current-buffer buffer (syntax-table)))) - (with-current-buffer standard-output - (describe-vector table 'internal-describe-syntax-value) - (while (setq table (char-table-parent table)) - (insert "\nThe parent syntax table is:") - (describe-vector table 'internal-describe-syntax-value)))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'describe-syntax buffer) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (let ((table (with-current-buffer buffer (syntax-table)))) + (with-current-buffer standard-output + (describe-vector table 'internal-describe-syntax-value) + (while (setq table (char-table-parent table)) + (insert "\nThe parent syntax table is:") + (describe-vector table 'internal-describe-syntax-value))))))) (defun help-describe-category-set (value) (insert (cond @@ -1672,59 +1677,60 @@ The descriptions are inserted in a buffer, which is then displayed. If BUFFER is non-nil, then describe BUFFER's category table instead. BUFFER should be a buffer or a buffer name." (interactive) - (setq buffer (or buffer (current-buffer))) - (help-setup-xref (list #'describe-categories buffer) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - (let* ((table (with-current-buffer buffer (category-table))) - (docs (char-table-extra-slot table 0))) - (if (or (not (vectorp docs)) (/= (length docs) 95)) - (error "Invalid first extra slot in this category table\n")) - (with-current-buffer standard-output - (setq-default help-button-cache (make-marker)) - (insert "Legend of category mnemonics ") - (insert-button "(longer descriptions at the bottom)" - 'action help-button-cache - 'follow-link t - 'help-echo "mouse-2, RET: show full legend") - (insert "\n") - (let ((pos (point)) (items 0) lines n) - (dotimes (i 95) - (if (aref docs i) (setq items (1+ items)))) - (setq lines (1+ (/ (1- items) 4))) - (setq n 0) + (let ((help-buffer-under-preparation t)) + (setq buffer (or buffer (current-buffer))) + (help-setup-xref (list #'describe-categories buffer) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (let* ((table (with-current-buffer buffer (category-table))) + (docs (char-table-extra-slot table 0))) + (if (or (not (vectorp docs)) (/= (length docs) 95)) + (error "Invalid first extra slot in this category table\n")) + (with-current-buffer standard-output + (setq-default help-button-cache (make-marker)) + (insert "Legend of category mnemonics ") + (insert-button "(longer descriptions at the bottom)" + 'action help-button-cache + 'follow-link t + 'help-echo "mouse-2, RET: show full legend") + (insert "\n") + (let ((pos (point)) (items 0) lines n) + (dotimes (i 95) + (if (aref docs i) (setq items (1+ items)))) + (setq lines (1+ (/ (1- items) 4))) + (setq n 0) + (dotimes (i 95) + (let ((elt (aref docs i))) + (when elt + (string-match ".*" elt) + (setq elt (match-string 0 elt)) + (if (>= (length elt) 17) + (setq elt (concat (substring elt 0 14) "..."))) + (if (< (point) (point-max)) + (move-to-column (* 20 (/ n lines)) t)) + (insert (+ i ?\s) ?: elt) + (if (< (point) (point-max)) + (forward-line 1) + (insert "\n")) + (setq n (1+ n)) + (if (= (% n lines) 0) + (goto-char pos)))))) + (goto-char (point-max)) + (insert "\n" + "character(s)\tcategory mnemonics\n" + "------------\t------------------") + (describe-vector table 'help-describe-category-set) + (set-marker help-button-cache (point)) + (insert "Legend of category mnemonics:\n") (dotimes (i 95) (let ((elt (aref docs i))) (when elt - (string-match ".*" elt) - (setq elt (match-string 0 elt)) - (if (>= (length elt) 17) - (setq elt (concat (substring elt 0 14) "..."))) - (if (< (point) (point-max)) - (move-to-column (* 20 (/ n lines)) t)) - (insert (+ i ?\s) ?: elt) - (if (< (point) (point-max)) - (forward-line 1) - (insert "\n")) - (setq n (1+ n)) - (if (= (% n lines) 0) - (goto-char pos)))))) - (goto-char (point-max)) - (insert "\n" - "character(s)\tcategory mnemonics\n" - "------------\t------------------") - (describe-vector table 'help-describe-category-set) - (set-marker help-button-cache (point)) - (insert "Legend of category mnemonics:\n") - (dotimes (i 95) - (let ((elt (aref docs i))) - (when elt - (if (string-match "\n" elt) - (setq elt (substring elt (match-end 0)))) - (insert (+ i ?\s) ": " elt "\n")))) - (while (setq table (char-table-parent table)) - (insert "\nThe parent category table is:") - (describe-vector table 'help-describe-category-set)))))) + (if (string-match "\n" elt) + (setq elt (substring elt (match-end 0)))) + (insert (+ i ?\s) ": " elt "\n")))) + (while (setq table (char-table-parent table)) + (insert "\nThe parent category table is:") + (describe-vector table 'help-describe-category-set))))))) (defun help-fns-find-keymap-name (keymap) "Find the name of the variable with value KEYMAP. @@ -1778,7 +1784,8 @@ keymap value." (unless (and km (keymapp (symbol-value km))) (user-error "Not a keymap: %s" km)) (list km))) - (let (used-gentemp) + (let (used-gentemp + (help-buffer-under-preparation t)) (unless (and (symbolp keymap) (boundp keymap) (keymapp (symbol-value keymap))) @@ -1844,106 +1851,107 @@ whose documentation describes the minor mode. If called from Lisp with a non-nil BUFFER argument, display documentation for the major and minor modes of that buffer." (interactive "@") - (unless buffer (setq buffer (current-buffer))) - (help-setup-xref (list #'describe-mode buffer) - (called-interactively-p 'interactive)) - ;; For the sake of help-do-xref and help-xref-go-back, - ;; don't switch buffers before calling `help-buffer'. - (with-help-window (help-buffer) - (with-current-buffer buffer - (let (minors) - ;; Older packages do not register in minor-mode-list but only in - ;; minor-mode-alist. - (dolist (x minor-mode-alist) - (setq x (car x)) - (unless (memq x minor-mode-list) - (push x minor-mode-list))) - ;; Find enabled minor mode we will want to mention. - (dolist (mode minor-mode-list) - ;; Document a minor mode if it is listed in minor-mode-alist, - ;; non-nil, and has a function definition. - (let ((fmode (or (get mode :minor-mode-function) mode))) - (and (boundp mode) (symbol-value mode) - (fboundp fmode) - (let ((pretty-minor-mode - (if (string-match "\\(\\(-minor\\)?-mode\\)?\\'" - (symbol-name fmode)) - (capitalize - (substring (symbol-name fmode) - 0 (match-beginning 0))) - fmode))) - (push (list fmode pretty-minor-mode - (format-mode-line (assq mode minor-mode-alist))) - minors))))) - ;; Narrowing is not a minor mode, but its indicator is part of - ;; mode-line-modes. - (when (buffer-narrowed-p) - (push '(narrow-to-region "Narrow" " Narrow") minors)) - (setq minors - (sort minors - (lambda (a b) (string-lessp (cadr a) (cadr b))))) - (when minors - (princ "Enabled minor modes:\n") - (make-local-variable 'help-button-cache) - (with-current-buffer standard-output - (dolist (mode minors) - (let ((mode-function (nth 0 mode)) - (pretty-minor-mode (nth 1 mode)) - (indicator (nth 2 mode))) - (save-excursion - (goto-char (point-max)) - (princ "\n\f\n") - (push (point-marker) help-button-cache) - ;; Document the minor modes fully. - (insert-text-button - pretty-minor-mode 'type 'help-function - 'help-args (list mode-function) - 'button '(t)) - (princ (format " minor mode (%s):\n" - (if (zerop (length indicator)) - "no indicator" - (format "indicator%s" - indicator)))) - (princ (help-split-fundoc (documentation mode-function) - nil 'doc))) - (insert-button pretty-minor-mode - 'action (car help-button-cache) - 'follow-link t - 'help-echo "mouse-2, RET: show full information") - (newline))) - (forward-line -1) - (fill-paragraph nil) - (forward-line 1)) - - (princ "\n(Information about these minor modes follows the major mode info.)\n\n")) - ;; Document the major mode. - (let ((mode mode-name)) - (with-current-buffer standard-output - (let ((start (point))) - (insert (format-mode-line mode nil nil buffer)) - (add-text-properties start (point) '(face bold))))) - (princ " mode") - (let* ((mode major-mode) - (file-name (find-lisp-object-file-name mode nil))) - (if (not file-name) - (setq help-mode--current-data (list :symbol mode)) - (princ (format-message " defined in `%s'" - (help-fns-short-filename file-name))) - ;; Make a hyperlink to the library. + (let ((help-buffer-under-preparation t)) + (unless buffer (setq buffer (current-buffer))) + (help-setup-xref (list #'describe-mode buffer) + (called-interactively-p 'interactive)) + ;; For the sake of help-do-xref and help-xref-go-back, + ;; don't switch buffers before calling `help-buffer'. + (with-help-window (help-buffer) + (with-current-buffer buffer + (let (minors) + ;; Older packages do not register in minor-mode-list but only in + ;; minor-mode-alist. + (dolist (x minor-mode-alist) + (setq x (car x)) + (unless (memq x minor-mode-list) + (push x minor-mode-list))) + ;; Find enabled minor mode we will want to mention. + (dolist (mode minor-mode-list) + ;; Document a minor mode if it is listed in minor-mode-alist, + ;; non-nil, and has a function definition. + (let ((fmode (or (get mode :minor-mode-function) mode))) + (and (boundp mode) (symbol-value mode) + (fboundp fmode) + (let ((pretty-minor-mode + (if (string-match "\\(\\(-minor\\)?-mode\\)?\\'" + (symbol-name fmode)) + (capitalize + (substring (symbol-name fmode) + 0 (match-beginning 0))) + fmode))) + (push (list fmode pretty-minor-mode + (format-mode-line (assq mode minor-mode-alist))) + minors))))) + ;; Narrowing is not a minor mode, but its indicator is part of + ;; mode-line-modes. + (when (buffer-narrowed-p) + (push '(narrow-to-region "Narrow" " Narrow") minors)) + (setq minors + (sort minors + (lambda (a b) (string-lessp (cadr a) (cadr b))))) + (when minors + (princ "Enabled minor modes:\n") + (make-local-variable 'help-button-cache) (with-current-buffer standard-output - (save-excursion - (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") - nil t) - (setq help-mode--current-data (list :symbol mode - :file file-name)) - (help-xref-button 1 'help-function-def mode file-name))))) - (let ((fundoc (help-split-fundoc (documentation major-mode) nil 'doc))) - (with-current-buffer standard-output - (insert ":\n") - (insert fundoc) - (insert (help-fns--list-local-commands))))))) - ;; For the sake of IELM and maybe others - nil) + (dolist (mode minors) + (let ((mode-function (nth 0 mode)) + (pretty-minor-mode (nth 1 mode)) + (indicator (nth 2 mode))) + (save-excursion + (goto-char (point-max)) + (princ "\n\f\n") + (push (point-marker) help-button-cache) + ;; Document the minor modes fully. + (insert-text-button + pretty-minor-mode 'type 'help-function + 'help-args (list mode-function) + 'button '(t)) + (princ (format " minor mode (%s):\n" + (if (zerop (length indicator)) + "no indicator" + (format "indicator%s" + indicator)))) + (princ (help-split-fundoc (documentation mode-function) + nil 'doc))) + (insert-button pretty-minor-mode + 'action (car help-button-cache) + 'follow-link t + 'help-echo "mouse-2, RET: show full information") + (newline))) + (forward-line -1) + (fill-paragraph nil) + (forward-line 1)) + + (princ "\n(Information about these minor modes follows the major mode info.)\n\n")) + ;; Document the major mode. + (let ((mode mode-name)) + (with-current-buffer standard-output + (let ((start (point))) + (insert (format-mode-line mode nil nil buffer)) + (add-text-properties start (point) '(face bold))))) + (princ " mode") + (let* ((mode major-mode) + (file-name (find-lisp-object-file-name mode nil))) + (if (not file-name) + (setq help-mode--current-data (list :symbol mode)) + (princ (format-message " defined in `%s'" + (help-fns-short-filename file-name))) + ;; Make a hyperlink to the library. + (with-current-buffer standard-output + (save-excursion + (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") + nil t) + (setq help-mode--current-data (list :symbol mode + :file file-name)) + (help-xref-button 1 'help-function-def mode file-name))))) + (let ((fundoc (help-split-fundoc (documentation major-mode) nil 'doc))) + (with-current-buffer standard-output + (insert ":\n") + (insert fundoc) + (insert (help-fns--list-local-commands)))))))) + ;; For the sake of IELM and maybe others + nil) (defun help-fns--list-local-commands () (let ((functions nil)) @@ -1998,7 +2006,8 @@ one of them returns non-nil." (event-end key)) ((eq key ?\C-g) (signal 'quit nil)) (t (user-error "You didn't specify a widget")))))) - (let (buf) + (let (buf + (help-buffer-under-preparation t)) ;; Allow describing a widget in a different window. (when (posnp pos) (setq buf (window-buffer (posn-window pos)) diff --git a/lisp/help-macro.el b/lisp/help-macro.el index 588efee66b..cd1b51e57a 100644 --- a/lisp/help-macro.el +++ b/lisp/help-macro.el @@ -93,7 +93,8 @@ and then returns." "Help command." (interactive) (let ((line-prompt - (substitute-command-keys ,help-line))) + (substitute-command-keys ,help-line)) + (help-buffer-under-preparation t)) (when three-step-help (message "%s" line-prompt)) (let* ((help-screen ,help-text) diff --git a/lisp/help.el b/lisp/help.el index 9122d96271..1917ef425d 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -50,6 +50,11 @@ (defvar help-window-old-frame nil "Frame selected at the time `with-help-window' is invoked.") +(defvar help-buffer-under-preparation nil + "Whether a *Help* buffer is being prepared. +This variable is bound to t during the preparation of a *Help* +buffer.") + (defvar help-map (let ((map (make-sparse-keymap))) (define-key map (char-to-string help-char) 'help-for-help) @@ -524,30 +529,31 @@ See `lossage-size' to update the number of recorded keystrokes. To record all your input, use `open-dribble-file'." (interactive) - (help-setup-xref (list #'view-lossage) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - (princ " ") - (princ (mapconcat (lambda (key) - (cond - ((and (consp key) (null (car key))) - (format ";; %s\n" (if (symbolp (cdr key)) (cdr key) - "anonymous-command"))) - ((or (integerp key) (symbolp key) (listp key)) - (single-key-description key)) - (t - (prin1-to-string key nil)))) - (recent-keys 'include-cmds) - " ")) - (with-current-buffer standard-output - (goto-char (point-min)) - (let ((comment-start ";; ") - (comment-column 24)) - (while (not (eobp)) - (comment-indent) - (forward-line 1))) - ;; Show point near the end of "lossage", as we did in Emacs 24. - (set-marker help-window-point-marker (point))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'view-lossage) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (princ " ") + (princ (mapconcat (lambda (key) + (cond + ((and (consp key) (null (car key))) + (format ";; %s\n" (if (symbolp (cdr key)) (cdr key) + "anonymous-command"))) + ((or (integerp key) (symbolp key) (listp key)) + (single-key-description key)) + (t + (prin1-to-string key nil)))) + (recent-keys 'include-cmds) + " ")) + (with-current-buffer standard-output + (goto-char (point-min)) + (let ((comment-start ";; ") + (comment-column 24)) + (while (not (eobp)) + (comment-indent) + (forward-line 1))) + ;; Show point near the end of "lossage", as we did in Emacs 24. + (set-marker help-window-point-marker (point)))))) ;; Key bindings @@ -579,31 +585,32 @@ The optional argument BUFFER specifies which buffer's bindings to display (default, the current buffer). BUFFER can be a buffer or a buffer name." (interactive) - (or buffer (setq buffer (current-buffer))) - (help-setup-xref (list #'describe-bindings prefix buffer) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - (with-current-buffer (help-buffer) - (describe-buffer-bindings buffer prefix) - - (when describe-bindings-outline - (setq-local outline-regexp ".*:$") - (setq-local outline-heading-end-regexp ":\n") - (setq-local outline-level (lambda () 1)) - (setq-local outline-minor-mode-cycle t - outline-minor-mode-highlight t) - (setq-local outline-minor-mode-use-buttons t) - (outline-minor-mode 1) - (save-excursion - (goto-char (point-min)) - (let ((inhibit-read-only t)) - ;; Hide the longest body. - (when (re-search-forward "Key translations" nil t) - (outline-hide-subtree)) - ;; Hide ^Ls. - (while (search-forward "\n\f\n" nil t) - (put-text-property (1+ (match-beginning 0)) (1- (match-end 0)) - 'invisible t)))))))) + (let ((help-buffer-under-preparation t)) + (or buffer (setq buffer (current-buffer))) + (help-setup-xref (list #'describe-bindings prefix buffer) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (describe-buffer-bindings buffer prefix) + + (when describe-bindings-outline + (setq-local outline-regexp ".*:$") + (setq-local outline-heading-end-regexp ":\n") + (setq-local outline-level (lambda () 1)) + (setq-local outline-minor-mode-cycle t + outline-minor-mode-highlight t) + (setq-local outline-minor-mode-use-buttons t) + (outline-minor-mode 1) + (save-excursion + (goto-char (point-min)) + (let ((inhibit-read-only t)) + ;; Hide the longest body. + (when (re-search-forward "Key translations" nil t) + (outline-hide-subtree)) + ;; Hide ^Ls. + (while (search-forward "\n\f\n" nil t) + (put-text-property (1+ (match-beginning 0)) (1- (match-end 0)) + 'invisible t))))))))) (defun where-is (definition &optional insert) "Print message listing key sequences that invoke the command DEFINITION. @@ -907,7 +914,8 @@ current buffer." (let ((raw (if (numberp buffer) (this-single-command-raw-keys) buffer))) (setf (cdar (last key-list)) raw))) (setq buffer nil)) - (let* ((buf (or buffer (current-buffer))) + (let* ((help-buffer-under-preparation t) + (buf (or buffer (current-buffer))) (on-link (mapcar (lambda (kr) (let ((raw (cdr kr))) @@ -1181,6 +1189,7 @@ Otherwise, return a new string." (delete-char (- end-point (point))) (let ((key (help--key-description-fontified key))) (insert (if (and help-link-key-to-documentation + help-buffer-under-preparation (functionp fun)) ;; The `fboundp' fixes bootstrap. (if (fboundp 'help-mode--add-function-link) diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index b922f192a9..9f3f2a2084 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -1638,30 +1638,31 @@ If `default-transient-input-method' was not yet defined, prompt for it." (interactive (list (read-input-method-name (format-prompt "Describe input method" current-input-method)))) - (if (and input-method (symbolp input-method)) - (setq input-method (symbol-name input-method))) - (help-setup-xref (list #'describe-input-method - (or input-method current-input-method)) - (called-interactively-p 'interactive)) - - (if (null input-method) - (describe-current-input-method) - (let ((current current-input-method)) - (condition-case nil - (progn - (save-excursion - (activate-input-method input-method) - (describe-current-input-method)) - (activate-input-method current)) - (error - (activate-input-method current) - (help-setup-xref (list #'describe-input-method input-method) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (let ((elt (assoc input-method input-method-alist))) - (princ (format-message - "Input method: %s (`%s' in mode line) for %s\n %s\n" - input-method (nth 3 elt) (nth 1 elt) (nth 4 elt)))))))))) + (let ((help-buffer-under-preparation t)) + (if (and input-method (symbolp input-method)) + (setq input-method (symbol-name input-method))) + (help-setup-xref (list #'describe-input-method + (or input-method current-input-method)) + (called-interactively-p 'interactive)) + + (if (null input-method) + (describe-current-input-method) + (let ((current current-input-method)) + (condition-case nil + (progn + (save-excursion + (activate-input-method input-method) + (describe-current-input-method)) + (activate-input-method current)) + (error + (activate-input-method current) + (help-setup-xref (list #'describe-input-method input-method) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (let ((elt (assoc input-method input-method-alist))) + (princ (format-message + "Input method: %s (`%s' in mode line) for %s\n %s\n" + input-method (nth 3 elt) (nth 1 elt) (nth 4 elt))))))))))) (defun describe-current-input-method () "Describe the input method currently in use. @@ -2162,89 +2163,90 @@ See `set-language-info-alist' for use in programs." (list (read-language-name 'documentation (format-prompt "Describe language environment" current-language-environment)))) - (if (null language-name) - (setq language-name current-language-environment)) - (if (or (null language-name) - (null (get-language-info language-name 'documentation))) - (error "No documentation for the specified language")) - (if (symbolp language-name) - (setq language-name (symbol-name language-name))) - (dolist (feature (get-language-info language-name 'features)) - (require feature)) - (let ((doc (get-language-info language-name 'documentation))) - (help-setup-xref (list #'describe-language-environment language-name) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (with-current-buffer standard-output - (insert language-name " language environment\n\n") - (if (stringp doc) - (insert (substitute-command-keys doc) "\n\n")) - (condition-case nil - (let ((str (eval (get-language-info language-name 'sample-text)))) - (if (stringp str) - (insert "Sample text:\n " - (string-replace "\n" "\n " str) - "\n\n"))) - (error nil)) - (let ((input-method (get-language-info language-name 'input-method)) - (l (copy-sequence input-method-alist)) - (first t)) - (when (and input-method - (setq input-method (assoc input-method l))) - (insert "Input methods (default " (car input-method) ")\n") - (setq l (cons input-method (delete input-method l)) - first nil)) - (dolist (elt l) - (when (or (eq input-method elt) - (eq t (compare-strings language-name nil nil - (nth 1 elt) nil nil t))) - (when first - (insert "Input methods:\n") - (setq first nil)) - (insert " " (car elt)) - (search-backward (car elt)) - (help-xref-button 0 'help-input-method (car elt)) - (goto-char (point-max)) - (insert " (\"" - (if (stringp (nth 3 elt)) (nth 3 elt) (car (nth 3 elt))) - "\" in mode line)\n"))) - (or first - (insert "\n"))) - (insert "Character sets:\n") - (let ((l (get-language-info language-name 'charset))) - (if (null l) - (insert " nothing specific to " language-name "\n") - (while l - (insert " " (symbol-name (car l))) - (search-backward (symbol-name (car l))) - (help-xref-button 0 'help-character-set (car l)) - (goto-char (point-max)) - (insert ": " (charset-description (car l)) "\n") - (setq l (cdr l))))) - (insert "\n") - (insert "Coding systems:\n") - (let ((l (get-language-info language-name 'coding-system))) - (if (null l) - (insert " nothing specific to " language-name "\n") - (while l - (insert " " (symbol-name (car l))) - (search-backward (symbol-name (car l))) - (help-xref-button 0 'help-coding-system (car l)) - (goto-char (point-max)) - (insert (substitute-command-keys " (`") - (coding-system-mnemonic (car l)) - (substitute-command-keys "' in mode line):\n\t") - (substitute-command-keys - (coding-system-doc-string (car l))) - "\n") - (let ((aliases (coding-system-aliases (car l)))) - (when aliases - (insert "\t(alias:") - (while aliases - (insert " " (symbol-name (car aliases))) - (setq aliases (cdr aliases))) - (insert ")\n"))) - (setq l (cdr l))))))))) + (let ((help-buffer-under-preparation t)) + (if (null language-name) + (setq language-name current-language-environment)) + (if (or (null language-name) + (null (get-language-info language-name 'documentation))) + (error "No documentation for the specified language")) + (if (symbolp language-name) + (setq language-name (symbol-name language-name))) + (dolist (feature (get-language-info language-name 'features)) + (require feature)) + (let ((doc (get-language-info language-name 'documentation))) + (help-setup-xref (list #'describe-language-environment language-name) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (insert language-name " language environment\n\n") + (if (stringp doc) + (insert (substitute-command-keys doc) "\n\n")) + (condition-case nil + (let ((str (eval (get-language-info language-name 'sample-text)))) + (if (stringp str) + (insert "Sample text:\n " + (string-replace "\n" "\n " str) + "\n\n"))) + (error nil)) + (let ((input-method (get-language-info language-name 'input-method)) + (l (copy-sequence input-method-alist)) + (first t)) + (when (and input-method + (setq input-method (assoc input-method l))) + (insert "Input methods (default " (car input-method) ")\n") + (setq l (cons input-method (delete input-method l)) + first nil)) + (dolist (elt l) + (when (or (eq input-method elt) + (eq t (compare-strings language-name nil nil + (nth 1 elt) nil nil t))) + (when first + (insert "Input methods:\n") + (setq first nil)) + (insert " " (car elt)) + (search-backward (car elt)) + (help-xref-button 0 'help-input-method (car elt)) + (goto-char (point-max)) + (insert " (\"" + (if (stringp (nth 3 elt)) (nth 3 elt) (car (nth 3 elt))) + "\" in mode line)\n"))) + (or first + (insert "\n"))) + (insert "Character sets:\n") + (let ((l (get-language-info language-name 'charset))) + (if (null l) + (insert " nothing specific to " language-name "\n") + (while l + (insert " " (symbol-name (car l))) + (search-backward (symbol-name (car l))) + (help-xref-button 0 'help-character-set (car l)) + (goto-char (point-max)) + (insert ": " (charset-description (car l)) "\n") + (setq l (cdr l))))) + (insert "\n") + (insert "Coding systems:\n") + (let ((l (get-language-info language-name 'coding-system))) + (if (null l) + (insert " nothing specific to " language-name "\n") + (while l + (insert " " (symbol-name (car l))) + (search-backward (symbol-name (car l))) + (help-xref-button 0 'help-coding-system (car l)) + (goto-char (point-max)) + (insert (substitute-command-keys " (`") + (coding-system-mnemonic (car l)) + (substitute-command-keys "' in mode line):\n\t") + (substitute-command-keys + (coding-system-doc-string (car l))) + "\n") + (let ((aliases (coding-system-aliases (car l)))) + (when aliases + (insert "\t(alias:") + (while aliases + (insert " " (symbol-name (car aliases))) + (setq aliases (cdr aliases))) + (insert ")\n"))) + (setq l (cdr l)))))))))) ;;; Locales. diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el index 5cc73e4367..efb9296c11 100644 --- a/lisp/international/mule-diag.el +++ b/lisp/international/mule-diag.el @@ -299,65 +299,66 @@ meanings of these arguments." (defun describe-character-set (charset) "Display information about built-in character set CHARSET." (interactive (list (read-charset "Charset: "))) - (or (charsetp charset) - (error "Invalid charset: %S" charset)) - (help-setup-xref (list #'describe-character-set charset) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (with-current-buffer standard-output - (insert "Character set: " (symbol-name charset)) - (let ((name (get-charset-property charset :name))) - (if (not (eq name charset)) - (insert " (alias of " (symbol-name name) ?\)))) - (insert "\n\n" (charset-description charset) "\n\n") - (insert "Number of contained characters: ") - (dotimes (i (charset-dimension charset)) - (unless (= i 0) - (insert ?x)) - (insert (format "%d" (charset-chars charset (1+ i))))) - (insert ?\n) - (let ((char (charset-iso-final-char charset))) - (when (> char 0) - (insert "Final char of ISO2022 designation sequence: ") - (insert (format-message "`%c'\n" char)))) - (let (aliases) - (dolist (c charset-list) - (if (and (not (eq c charset)) - (eq charset (get-charset-property c :name))) - (push c aliases))) - (if aliases - (insert "Aliases: " (mapconcat #'symbol-name aliases ", ") ?\n))) - - (dolist (elt `((:ascii-compatible-p "ASCII compatible." nil) - (:map "Map file: " identity) - (:unify-map "Unification map file: " identity) - (:invalid-code - nil - ,(lambda (c) - (format "Invalid character: %c (code %d)" c c))) - (:emacs-mule-id "Id in emacs-mule coding system: " - number-to-string) - (:parents "Parents: " - (lambda (parents) - (mapconcat ,(lambda (elt) - (format "%s" elt)) - parents - ", "))) - (:code-space "Code space: " ,(lambda (c) - (format "%s" c))) - (:code-offset "Code offset: " number-to-string) - (:iso-revision-number "ISO revision number: " - number-to-string) - (:supplementary-p - "Used only as a parent or a subset of some other charset, + (let ((help-buffer-under-preparation t)) + (or (charsetp charset) + (error "Invalid charset: %S" charset)) + (help-setup-xref (list #'describe-character-set charset) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (insert "Character set: " (symbol-name charset)) + (let ((name (get-charset-property charset :name))) + (if (not (eq name charset)) + (insert " (alias of " (symbol-name name) ?\)))) + (insert "\n\n" (charset-description charset) "\n\n") + (insert "Number of contained characters: ") + (dotimes (i (charset-dimension charset)) + (unless (= i 0) + (insert ?x)) + (insert (format "%d" (charset-chars charset (1+ i))))) + (insert ?\n) + (let ((char (charset-iso-final-char charset))) + (when (> char 0) + (insert "Final char of ISO2022 designation sequence: ") + (insert (format-message "`%c'\n" char)))) + (let (aliases) + (dolist (c charset-list) + (if (and (not (eq c charset)) + (eq charset (get-charset-property c :name))) + (push c aliases))) + (if aliases + (insert "Aliases: " (mapconcat #'symbol-name aliases ", ") ?\n))) + + (dolist (elt `((:ascii-compatible-p "ASCII compatible." nil) + (:map "Map file: " identity) + (:unify-map "Unification map file: " identity) + (:invalid-code + nil + ,(lambda (c) + (format "Invalid character: %c (code %d)" c c))) + (:emacs-mule-id "Id in emacs-mule coding system: " + number-to-string) + (:parents "Parents: " + (lambda (parents) + (mapconcat ,(lambda (elt) + (format "%s" elt)) + parents + ", "))) + (:code-space "Code space: " ,(lambda (c) + (format "%s" c))) + (:code-offset "Code offset: " number-to-string) + (:iso-revision-number "ISO revision number: " + number-to-string) + (:supplementary-p + "Used only as a parent or a subset of some other charset, or provided just for backward compatibility." nil))) - (let ((val (get-charset-property charset (car elt)))) - (when val - (if (cadr elt) (insert (cadr elt))) - (if (nth 2 elt) - (let ((print-length 10) (print-level 2)) - (princ (funcall (nth 2 elt) val) (current-buffer)))) - (insert ?\n))))))) + (let ((val (get-charset-property charset (car elt)))) + (when val + (if (cadr elt) (insert (cadr elt))) + (if (nth 2 elt) + (let ((print-length 10) (print-level 2)) + (princ (funcall (nth 2 elt) val) (current-buffer)))) + (insert ?\n)))))))) ;;; CODING-SYSTEM @@ -406,89 +407,90 @@ or provided just for backward compatibility." nil))) (defun describe-coding-system (coding-system) "Display information about CODING-SYSTEM." (interactive "zDescribe coding system (default current choices): ") - (if (null coding-system) - (describe-current-coding-system) - (help-setup-xref (list #'describe-coding-system coding-system) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (print-coding-system-briefly coding-system 'doc-string) - (let ((type (coding-system-type coding-system)) - ;; Fixme: use this - ;; (extra-spec (coding-system-plist coding-system)) - ) - (princ "Type: ") - (princ type) - (cond ((eq type 'undecided) - (princ " (do automatic conversion)")) - ((eq type 'utf-8) - (princ " (UTF-8: Emacs internal multibyte form)")) - ((eq type 'utf-16) - ;; (princ " (UTF-16)") - ) - ((eq type 'shift-jis) - (princ " (Shift-JIS, MS-KANJI)")) - ((eq type 'iso-2022) - (princ " (variant of ISO-2022)\n") - (princ "Initial designations:\n") - (print-designation (coding-system-get coding-system - :designation)) - - (when (coding-system-get coding-system :flags) - (princ "Other specifications: \n ") - (apply #'print-list - (coding-system-get coding-system :flags)))) - ((eq type 'charset) - (princ " (charset)")) - ((eq type 'ccl) - (princ " (do conversion by CCL program)")) - ((eq type 'raw-text) - (princ " (text with random binary characters)")) - ((eq type 'emacs-mule) - (princ " (Emacs 21 internal encoding)")) - ((eq type 'big5)) - (t (princ ": invalid coding-system."))) - (princ "\nEOL type: ") - (let ((eol-type (coding-system-eol-type coding-system))) - (cond ((vectorp eol-type) - (princ "Automatic selection from:\n\t") - (princ eol-type) - (princ "\n")) - ((or (null eol-type) (eq eol-type 0)) (princ "LF\n")) - ((eq eol-type 1) (princ "CRLF\n")) - ((eq eol-type 2) (princ "CR\n")) - (t (princ "invalid\n"))))) - (let ((postread (coding-system-get coding-system :post-read-conversion))) - (when postread - (princ "After decoding text normally,") - (princ " perform post-conversion using the function: ") - (princ "\n ") - (princ postread) - (princ "\n"))) - (let ((prewrite (coding-system-get coding-system :pre-write-conversion))) - (when prewrite - (princ "Before encoding text normally,") - (princ " perform pre-conversion using the function: ") - (princ "\n ") - (princ prewrite) - (princ "\n"))) - (with-current-buffer standard-output - (let ((charsets (coding-system-charset-list coding-system))) - (when (and (not (eq (coding-system-base coding-system) 'raw-text)) - charsets) - (cond - ((eq charsets 'iso-2022) - (insert "This coding system can encode all ISO 2022 charsets.")) - ((eq charsets 'emacs-mule) - (insert "This coding system can encode all emacs-mule charsets\ + (let ((help-buffer-under-preparation t)) + (if (null coding-system) + (describe-current-coding-system) + (help-setup-xref (list #'describe-coding-system coding-system) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (print-coding-system-briefly coding-system 'doc-string) + (let ((type (coding-system-type coding-system)) + ;; Fixme: use this + ;; (extra-spec (coding-system-plist coding-system)) + ) + (princ "Type: ") + (princ type) + (cond ((eq type 'undecided) + (princ " (do automatic conversion)")) + ((eq type 'utf-8) + (princ " (UTF-8: Emacs internal multibyte form)")) + ((eq type 'utf-16) + ;; (princ " (UTF-16)") + ) + ((eq type 'shift-jis) + (princ " (Shift-JIS, MS-KANJI)")) + ((eq type 'iso-2022) + (princ " (variant of ISO-2022)\n") + (princ "Initial designations:\n") + (print-designation (coding-system-get coding-system + :designation)) + + (when (coding-system-get coding-system :flags) + (princ "Other specifications: \n ") + (apply #'print-list + (coding-system-get coding-system :flags)))) + ((eq type 'charset) + (princ " (charset)")) + ((eq type 'ccl) + (princ " (do conversion by CCL program)")) + ((eq type 'raw-text) + (princ " (text with random binary characters)")) + ((eq type 'emacs-mule) + (princ " (Emacs 21 internal encoding)")) + ((eq type 'big5)) + (t (princ ": invalid coding-system."))) + (princ "\nEOL type: ") + (let ((eol-type (coding-system-eol-type coding-system))) + (cond ((vectorp eol-type) + (princ "Automatic selection from:\n\t") + (princ eol-type) + (princ "\n")) + ((or (null eol-type) (eq eol-type 0)) (princ "LF\n")) + ((eq eol-type 1) (princ "CRLF\n")) + ((eq eol-type 2) (princ "CR\n")) + (t (princ "invalid\n"))))) + (let ((postread (coding-system-get coding-system :post-read-conversion))) + (when postread + (princ "After decoding text normally,") + (princ " perform post-conversion using the function: ") + (princ "\n ") + (princ postread) + (princ "\n"))) + (let ((prewrite (coding-system-get coding-system :pre-write-conversion))) + (when prewrite + (princ "Before encoding text normally,") + (princ " perform pre-conversion using the function: ") + (princ "\n ") + (princ prewrite) + (princ "\n"))) + (with-current-buffer standard-output + (let ((charsets (coding-system-charset-list coding-system))) + (when (and (not (eq (coding-system-base coding-system) 'raw-text)) + charsets) + (cond + ((eq charsets 'iso-2022) + (insert "This coding system can encode all ISO 2022 charsets.")) + ((eq charsets 'emacs-mule) + (insert "This coding system can encode all emacs-mule charsets\ .""")) - (t - (insert "This coding system encodes the following charsets:\n ") - (while charsets - (insert " " (symbol-name (car charsets))) - (search-backward (symbol-name (car charsets))) - (help-xref-button 0 'help-character-set (car charsets)) - (goto-char (point-max)) - (setq charsets (cdr charsets))))))))))) + (t + (insert "This coding system encodes the following charsets:\n ") + (while charsets + (insert " " (symbol-name (car charsets))) + (search-backward (symbol-name (car charsets))) + (help-xref-button 0 'help-character-set (car charsets)) + (goto-char (point-max)) + (setq charsets (cdr charsets)))))))))))) ;;;###autoload (defun describe-current-coding-system-briefly () @@ -845,7 +847,8 @@ The IGNORED argument is ignored." (or (and window-system (fboundp 'fontset-list)) (error "No fonts being used")) (let ((xref-item (list #'describe-font fontname)) - font-info) + font-info + (help-buffer-under-preparation t)) (if (or (not fontname) (= (length fontname) 0)) (setq fontname (face-attribute 'default :font))) (setq font-info (font-info fontname)) @@ -1006,14 +1009,15 @@ This shows which font is used for which character(s)." (list (completing-read (format-prompt "Fontset" "used by the current frame") fontset-list nil t))))) - (if (= (length fontset) 0) - (setq fontset (face-attribute 'default :fontset)) - (setq fontset (query-fontset fontset))) - (help-setup-xref (list #'describe-fontset fontset) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (with-current-buffer standard-output - (print-fontset fontset t)))) + (let ((help-buffer-under-preparation t)) + (if (= (length fontset) 0) + (setq fontset (face-attribute 'default :fontset)) + (setq fontset (query-fontset fontset))) + (help-setup-xref (list #'describe-fontset fontset) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (print-fontset fontset t))))) (declare-function fontset-plain-name "fontset" (fontset)) @@ -1024,39 +1028,41 @@ This shows the name, size, and style of each fontset. With prefix arg, also list the fonts contained in each fontset; see the function `describe-fontset' for the format of the list." (interactive "P") - (if (not (and window-system (fboundp 'fontset-list))) - (error "No fontsets being used") - (help-setup-xref (list #'list-fontsets arg) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (with-current-buffer standard-output - ;; This code is duplicated near the end of mule-diag. - (let ((fontsets - (sort (fontset-list) - (lambda (x y) - (string< (fontset-plain-name x) - (fontset-plain-name y)))))) - (while fontsets - (if arg - (print-fontset (car fontsets) nil) - (insert "Fontset: " (car fontsets) "\n")) - (setq fontsets (cdr fontsets)))))))) + (let ((help-buffer-under-preparation t)) + (if (not (and window-system (fboundp 'fontset-list))) + (error "No fontsets being used") + (help-setup-xref (list #'list-fontsets arg) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + ;; This code is duplicated near the end of mule-diag. + (let ((fontsets + (sort (fontset-list) + (lambda (x y) + (string< (fontset-plain-name x) + (fontset-plain-name y)))))) + (while fontsets + (if arg + (print-fontset (car fontsets) nil) + (insert "Fontset: " (car fontsets) "\n")) + (setq fontsets (cdr fontsets))))))))) ;;;###autoload (defun list-input-methods () "Display information about all input methods." (interactive) - (help-setup-xref '(list-input-methods) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (list-input-methods-1) - (with-current-buffer standard-output - (save-excursion - (goto-char (point-min)) - (while (re-search-forward - (substitute-command-keys "^ \\([^ ]+\\) (`.*' in mode line)$") - nil t) - (help-xref-button 1 'help-input-method (match-string 1))))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref '(list-input-methods) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (list-input-methods-1) + (with-current-buffer standard-output + (save-excursion + (goto-char (point-min)) + (while (re-search-forward + (substitute-command-keys "^ \\([^ ]+\\) (`.*' in mode line)$") + nil t) + (help-xref-button 1 'help-input-method (match-string 1)))))))) (defun list-input-methods-1 () (if (not input-method-alist) diff --git a/lisp/repeat.el b/lisp/repeat.el index 32ffb1884f..7bbb398873 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -515,31 +515,32 @@ See `describe-repeat-maps' for a list of all repeatable commands." Used in `repeat-mode'." (interactive) (require 'help-fns) - (help-setup-xref (list #'describe-repeat-maps) - (called-interactively-p 'interactive)) - (let ((keymaps nil)) - (all-completions - "" obarray (lambda (s) - (and (commandp s) - (get s 'repeat-map) - (push s (alist-get (get s 'repeat-map) keymaps))))) - (with-help-window (help-buffer) - (with-current-buffer standard-output - (princ "A list of keymaps used by commands with the symbol property `repeat-map'.\n\n") - - (dolist (keymap (sort keymaps (lambda (a b) (string-lessp (car a) (car b))))) - (princ (format-message "`%s' keymap is repeatable by these commands:\n" - (car keymap))) - (dolist (command (sort (cdr keymap) 'string-lessp)) - (let* ((info (help-fns--analyze-function command)) - (map (list (symbol-value (car keymap)))) - (desc (mapconcat (lambda (key) - (format-message "`%s'" (key-description key))) - (or (where-is-internal command map) - (where-is-internal (nth 3 info) map)) - ", "))) - (princ (format-message " `%s' (bound to %s)\n" command desc)))) - (princ "\n")))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'describe-repeat-maps) + (called-interactively-p 'interactive)) + (let ((keymaps nil)) + (all-completions + "" obarray (lambda (s) + (and (commandp s) + (get s 'repeat-map) + (push s (alist-get (get s 'repeat-map) keymaps))))) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (princ "A list of keymaps used by commands with the symbol property `repeat-map'.\n\n") + + (dolist (keymap (sort keymaps (lambda (a b) (string-lessp (car a) (car b))))) + (princ (format-message "`%s' keymap is repeatable by these commands:\n" + (car keymap))) + (dolist (command (sort (cdr keymap) 'string-lessp)) + (let* ((info (help-fns--analyze-function command)) + (map (list (symbol-value (car keymap)))) + (desc (mapconcat (lambda (key) + (format-message "`%s'" (key-description key))) + (or (where-is-internal command map) + (where-is-internal (nth 3 info) map)) + ", "))) + (princ (format-message " `%s' (bound to %s)\n" command desc)))) + (princ "\n"))))))) (provide 'repeat) commit de9d27f679d5e040c0ed4b974bc9225f6a330852 Author: Andreas Schwab Date: Mon Nov 29 10:29:40 2021 +0100 Avoid undefined behaviour when copying part of structure * src/dispnew.c (copy_row_except_pointers): Don't use address of subobject as starting point. (cherry picked from commit 6943786b5c1fe76ea05a3a810512bd6777883710) diff --git a/src/dispnew.c b/src/dispnew.c index 53eb898474..4a9f2bae44 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -1034,7 +1034,7 @@ copy_row_except_pointers (struct glyph_row *to, struct glyph_row *from) { enum { off = offsetof (struct glyph_row, x) }; - memcpy (&to->x, &from->x, sizeof *to - off); + memcpy ((char *) to + off, (char *) from + off, sizeof *to - off); } commit d8dd705e9d82df96d67d88e1bf90373b6b4fbaa9 Author: Po Lu Date: Mon Nov 29 18:25:10 2021 +0800 Really make `x-scroll-event-delta-factor' dependent on system * lisp/cus-start.el: Move X specific builtins that start with "x-" before the catch-all test. diff --git a/lisp/cus-start.el b/lisp/cus-start.el index 45b81e5bc5..33b861b340 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -857,6 +857,11 @@ since it could result in memory overflow and make Emacs crash." (featurep 'gtk)) ((string-match "clipboard-manager" (symbol-name symbol)) (boundp 'x-select-enable-clipboard-manager)) + ((or (equal "scroll-bar-adjust-thumb-portion" + (symbol-name symbol)) + (equal "x-scroll-event-delta-factor" + (symbol-name symbol))) + (featurep 'x)) ((string-match "\\`x-" (symbol-name symbol)) (fboundp 'x-create-frame)) ((string-match "selection" (symbol-name symbol)) @@ -877,11 +882,6 @@ since it could result in memory overflow and make Emacs crash." (symbol-name symbol)) ;; Any function from fontset.c will do. (fboundp 'new-fontset)) - ((or (equal "scroll-bar-adjust-thumb-portion" - (symbol-name symbol)) - (equal "x-scroll-event-delta-factor" - (symbol-name symbol))) - (featurep 'x)) (t t)))) (if (not (boundp symbol)) ;; If variables are removed from C code, give an error here! commit 6943786b5c1fe76ea05a3a810512bd6777883710 Author: Andreas Schwab Date: Mon Nov 29 10:29:40 2021 +0100 Avoid undefined behaviour when copying part of structure * src/dispnew.c (copy_row_except_pointers): Don't use address of subobject as starting point. diff --git a/src/dispnew.c b/src/dispnew.c index f3f110a8f2..a976bf94c5 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -1034,7 +1034,7 @@ copy_row_except_pointers (struct glyph_row *to, struct glyph_row *from) { enum { off = offsetof (struct glyph_row, x) }; - memcpy (&to->x, &from->x, sizeof *to - off); + memcpy ((char *) to + off, (char *) from + off, sizeof *to - off); } commit 4320180111422ad803f26a30e616f1f18efedb65 Author: Po Lu Date: Mon Nov 29 17:19:27 2021 +0800 Fix last change for non-X platforms * lisp/cus-start.el: Don't announce `scroll-bar-adjust-thumb-portion' on non-X systems. diff --git a/lisp/cus-start.el b/lisp/cus-start.el index e895ebd569..45b81e5bc5 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -877,8 +877,10 @@ since it could result in memory overflow and make Emacs crash." (symbol-name symbol)) ;; Any function from fontset.c will do. (fboundp 'new-fontset)) - ((equal "scroll-bar-adjust-thumb-portion" - (symbol-name symbol)) + ((or (equal "scroll-bar-adjust-thumb-portion" + (symbol-name symbol)) + (equal "x-scroll-event-delta-factor" + (symbol-name symbol))) (featurep 'x)) (t t)))) (if (not (boundp symbol)) commit 618070d4b414c20f19a1f873ffb1d7015743599e Author: Po Lu Date: Mon Nov 29 15:36:15 2021 +0800 Allow customizing the pixel delta of wheel events on X * lisp/cus-start.el: Add `x-scroll-event-delta-factor'. * src/xterm.c (handle_one_xevent): Apply scroll event delta factor to wheel events with pixel data. (Vx_scroll_event_delta_factor): New user option. diff --git a/lisp/cus-start.el b/lisp/cus-start.el index 68019c038e..e895ebd569 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -826,6 +826,7 @@ since it could result in memory overflow and make Emacs crash." (x-underline-at-descent-line display boolean "22.1") (x-stretch-cursor display boolean "21.1") (scroll-bar-adjust-thumb-portion windows boolean "24.4") + (x-scroll-event-delta-factor mouse float "29.1") ;; xselect.c (x-select-enable-clipboard-manager killing boolean "24.1") ;; xsettings.c diff --git a/src/xterm.c b/src/xterm.c index 253e0eb20b..a6d9c8c7a1 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10045,6 +10045,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, scroll_unit = pow (FRAME_PIXEL_HEIGHT (f), 2.0 / 3.0); + if (FLOATP (Vx_scroll_event_delta_factor)) + scroll_unit *= XFLOAT_DATA (Vx_scroll_event_delta_factor); + if (val->horizontal) { inev.ie.arg @@ -15217,4 +15220,10 @@ Otherwise, a wheel event will be sent every time the mouse wheel is moved. This option is only effective when Emacs is built with XInput 2, with Haiku windowing support, or with NS. */); x_coalesce_scroll_events = true; + + DEFVAR_LISP ("x-scroll-event-delta-factor", Vx_scroll_event_delta_factor, + doc: /* A scale to apply to pixel deltas reported in scroll events. +This option is only effective when Emacs is built with XInput 2 +support. */); + Vx_scroll_event_delta_factor = make_float (1.0); } commit a1aa9cbf57a08f1c17b92b13a2bf07d504684fcc Author: Po Lu Date: Mon Nov 29 07:12:25 2021 +0000 Make overhangs in ftcrfont work on Haiku * src/ftcrfont.c (ftcrfont_draw): Dump left overhang clipping on Haiku and always set `background_filled_p'. diff --git a/src/ftcrfont.c b/src/ftcrfont.c index 5d75f18357..820b3c0bd0 100644 --- a/src/ftcrfont.c +++ b/src/ftcrfont.c @@ -539,13 +539,19 @@ ftcrfont_draw (struct glyph_string *s, return 0; } BView_cr_dump_clipping (FRAME_HAIKU_VIEW (f), cr); + + if (s->left_overhang && s->clip_head && !s->for_overlaps) + { + cairo_rectangle (cr, s->clip_head->x, 0, + FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f)); + cairo_clip (cr); + } #endif if (with_background) { #ifndef USE_BE_CAIRO x_set_cr_source_with_gc_background (f, s->gc); - s->background_filled_p = 1; #else struct face *face = s->face; @@ -556,6 +562,7 @@ ftcrfont_draw (struct glyph_string *s, GREEN_FROM_ULONG (col) / 255.0, BLUE_FROM_ULONG (col) / 255.0); #endif + s->background_filled_p = 1; cairo_rectangle (cr, x, y - FONT_BASE (face->font), s->width, FONT_HEIGHT (face->font)); cairo_fill (cr); commit 0400b3c329b4bcfaea68ab24ae2d1857707a983d Author: Po Lu Date: Mon Nov 29 06:55:58 2021 +0000 * doc/emacs/haiku.texi (Haiku Basics): Fix a typo. diff --git a/doc/emacs/haiku.texi b/doc/emacs/haiku.texi index a41804b233..d2b7eb8408 100644 --- a/doc/emacs/haiku.texi +++ b/doc/emacs/haiku.texi @@ -32,7 +32,7 @@ Haiku-specific application metadata, with the name @code{Emacs}. @cindex tty Emacs in haiku If you are launching Emacs from the Tracker, or want to make the Tracker open files using Emacs, you should use the binary named -@code{Emacs}; ff you are going to use Emacs in the terminal, or wish +@code{Emacs}; if you are going to use Emacs in the terminal, or wish to launch separate instances of Emacs, or do not care for the aforementioned system integration features, use the binary named @code{emacs} instead. commit d648874110bdfe54d6f35f1748e27d96495ccfa3 Merge: 390361cb24 c4daff9cf8 Author: Stefan Kangas Date: Mon Nov 29 07:00:25 2021 +0100 Merge from origin/emacs-28 c4daff9cf8 * Makefile.in (PREFERRED_BRANCH): Now emacs-28. bca57086be ; Remove an obsolete comment 455b64c336 * src/coding.c (Fdecode_coding_region, Fencode_coding_regi... commit c4daff9cf844ec85930bdcd2064787c92c260861 Author: Stefan Kangas Date: Mon Nov 29 05:57:13 2021 +0100 * Makefile.in (PREFERRED_BRANCH): Now emacs-28. diff --git a/Makefile.in b/Makefile.in index 5fc1edc7a3..c36882d5be 100644 --- a/Makefile.in +++ b/Makefile.in @@ -1164,7 +1164,7 @@ ChangeLog: ./$(emacslog) -o $(CHANGELOG) -n $(CHANGELOG_HISTORY_INDEX_MAX) # Check that we are in a good state for changing history. -PREFERRED_BRANCH = emacs-27 +PREFERRED_BRANCH = emacs-28 preferred-branch-is-current: git branch | grep -q '^\* $(PREFERRED_BRANCH)$$' unchanged-history-files: commit 390361cb24e376e8a00647a7625a06d6cdcf9b4d Author: Po Lu Date: Mon Nov 29 12:39:16 2021 +0800 Update XKB map on MappingNotify * src/xterm.c (handle_one_xevent): Update XKB map when X tells us the keyboard map has been updated. diff --git a/src/xterm.c b/src/xterm.c index 8045470bdd..253e0eb20b 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -9813,6 +9813,11 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_find_modifier_meanings (dpyinfo); FALLTHROUGH; case MappingKeyboard: +#ifdef HAVE_XKB + if (dpyinfo->xkb_desc) + XkbGetUpdatedMap (dpyinfo->display, XkbAllComponentsMask, + dpyinfo->xkb_desc); +#endif XRefreshKeyboardMapping ((XMappingEvent *) &event->xmapping); } goto OTHER; commit c8df4d1ca350e421adf49fb533627a6b1ef565bc Author: Lars Ingebrigtsen Date: Sun Nov 28 22:59:35 2021 +0100 Tweak gnus-art key binding * lisp/gnus/gnus-art.el (:keymap): Fix mnemonic key binding. diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 9a56e3a901..02f0d50be5 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -4440,7 +4440,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is "?" #'gnus-article-describe-briefly "<" #'beginning-of-buffer ">" #'end-of-buffer - "C-c TAB" #'gnus-info-find-node + "C-c C-i" #'gnus-info-find-node "C-c C-b" #'gnus-bug "R" #'gnus-article-reply-with-original "F" #'gnus-article-followup-with-original commit bca57086bef276cdd918edfa9f6e133899bbbbbb Author: Karl Fogel Date: Sun Nov 28 13:34:57 2021 -0600 ; Remove an obsolete comment * src/editfns.c (Ftranspose_regions): Remove an obsolete comment about memmove, following up to commit 72af86bd8cf of 8 Jul 2010 by Andreas Schwab and commit 354f9f0fc6cc of 23 Feb 2016 by Fredrik Bergroth, both of which added calls to memmove. diff --git a/src/editfns.c b/src/editfns.c index c8219decb0..5c9c34dc35 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -4265,9 +4265,6 @@ ring. */) enough to use as the temporary storage? That would avoid an allocation... interesting. Later, don't fool with it now. */ - /* Working without memmove, for portability (sigh), so must be - careful of overlapping subsections of the array... */ - if (end1 == start2) /* adjacent regions */ { modify_text (start1, end2); commit 455b64c33657f05f614007947cc9028621ba21d7 Author: Eli Zaretskii Date: Sun Nov 28 20:18:16 2021 +0200 * src/coding.c (Fdecode_coding_region, Fencode_coding_region): Doc fix. diff --git a/src/coding.c b/src/coding.c index 02dccf5bdb..f8004d202e 100644 --- a/src/coding.c +++ b/src/coding.c @@ -9454,8 +9454,9 @@ code_convert_region (Lisp_Object start, Lisp_Object end, DEFUN ("decode-coding-region", Fdecode_coding_region, Sdecode_coding_region, 3, 4, "r\nzCoding system: ", - doc: /* Decode the current region from the specified coding system. -Interactively, prompt for the coding system to decode the region. + doc: /* Decode the current region using the specified coding system. +Interactively, prompt for the coding system to decode the region, and +replace the region with the decoded text. \"Decoding\" means transforming bytes into readable text (characters). If, for instance, you have a region that contains data that represents @@ -9485,7 +9486,9 @@ not fully specified.) */) DEFUN ("encode-coding-region", Fencode_coding_region, Sencode_coding_region, 3, 4, "r\nzCoding system: ", - doc: /* Encode the current region by specified coding system. + doc: /* Encode the current region using th specified coding system. +Interactively, prompt for the coding system to encode the region, and +replace the region with the bytes that are the result of the encoding. What's meant by \"encoding\" is transforming textual data (characters) into bytes. If, for instance, you have a region that contains the commit 9a0492ca7c343cdad75573c17c517f7369067ea8 Author: Mattias Engdegård Date: Sun Nov 28 19:06:33 2021 +0100 ; Don't use remq (breaks bootstrapping) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index ac3bb86a59..2ce2efd2aa 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -134,7 +134,7 @@ The return value of this function is not used." :autoload-end (eval-and-compile (defun ,cfname (,@(car data) ,@args) - (ignore ,@(remq '&rest (remq '&optional args))) + (ignore ,@(delq '&rest (delq '&optional (copy-sequence args)))) ,@(cdr data)))))))) (defalias 'byte-run--set-doc-string commit d50e0bdbac8e6683c6af4efa172c1b801d250486 Author: Mattias Engdegård Date: Sun Nov 28 18:04:06 2021 +0100 Use compiler macros for the key syntax checks Compile-time key string syntax checks are better written using compiler macros than with byte-hunk-handlers inside the compiler proper. * lisp/emacs-lisp/bytecomp.el (byte-compile-define-keymap) (byte-compile-define-keymap--define): Remove. * lisp/keymap.el (keymap--compile-check): New. (keymap-set, keymap-global-set, keymap-local-set, keymap-global-unset) (keymap-local-unset, keymap-unset, keymap-substitute) (keymap-set-after, key-translate, keymap-lookup, keymap-local-lookup) (keymap-global-lookup): Use compiler-macro for argument checks. * lisp/subr.el (define-keymap--compile): New. (define-keymap--define): Fold into define-keymap. (define-keymap): Use compiler-macro. (defvar-keymap): Use define-keymap. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 566a3fdf99..5ce5b2952b 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5050,69 +5050,6 @@ binding slots have been popped." (_ (byte-compile-keep-pending form)))) - -;; Key syntax warnings. - -(mapc - (lambda (elem) - (put (car elem) 'byte-hunk-handler - (lambda (form) - (dolist (idx (cdr elem)) - (let ((key (elt form idx))) - (when (or (vectorp key) - (and (stringp key) - (not (key-valid-p key)))) - (byte-compile-warn "Invalid `kbd' syntax: %S" key)))) - form))) - ;; Functions and the place(s) for the key definition(s). - '((keymap-set 2) - (keymap-global-set 1) - (keymap-local-set 1) - (keymap-unset 2) - (keymap-global-unset 1) - (keymap-local-unset 1) - (keymap-substitute 2 3) - (keymap-set-after 2) - (key-translate 1 2) - (keymap-lookup 2) - (keymap-global-lookup 1) - (keymap-local-lookup 1))) - -(put 'define-keymap 'byte-hunk-handler #'byte-compile-define-keymap) -(defun byte-compile-define-keymap (form) - (let ((result nil) - (orig-form form)) - (push (pop form) result) - (while (and form - (keywordp (car form)) - (not (eq (car form) :menu))) - (unless (memq (car form) - '(:full :keymap :parent :suppress :name :prefix)) - (byte-compile-warn "Invalid keyword: %s" (car form))) - (push (pop form) result) - (when (null form) - (byte-compile-warn "Uneven number of keywords in %S" form)) - (push (pop form) result)) - ;; Bindings. - (while form - (let ((key (pop form))) - (when (stringp key) - (unless (key-valid-p key) - (byte-compile-warn "Invalid `kbd' syntax: %S" key))) - ;; No improvement. - (push key result)) - (when (null form) - (byte-compile-warn "Uneven number of key bindings in %S" form)) - (push (pop form) result)) - orig-form)) - -(put 'define-keymap--define 'byte-hunk-handler - #'byte-compile-define-keymap--define) -(defun byte-compile-define-keymap--define (form) - (when (consp (nth 1 form)) - (byte-compile-define-keymap (nth 1 form))) - form) - ;;; tags diff --git a/lisp/keymap.el b/lisp/keymap.el index a9331e1604..770a6ed20d 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -31,6 +31,12 @@ (unless (key-valid-p key) (error "%S is not a valid key definition; see `key-valid-p'" key))) +(defun keymap--compile-check (&rest keys) + (dolist (key keys) + (when (or (vectorp key) + (and (stringp key) (not (key-valid-p key)))) + (byte-compile-warn "Invalid `kbd' syntax: %S" key)))) + (defun keymap-set (keymap key definition) "Set key sequence KEY to DEFINITION in KEYMAP. KEY is a string that satisfies `key-valid-p'. @@ -50,6 +56,7 @@ DEFINITION is anything that can be a key's definition: or a cons (MAP . CHAR), meaning use definition of CHAR in keymap MAP, or an extended menu item definition. (See info node `(elisp)Extended Menu Items'.)" + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) (keymap--check key) (define-key keymap (key-parse key) definition)) @@ -63,6 +70,7 @@ KEY is a string that satisfies `key-valid-p'. Note that if KEY has a local binding in the current buffer, that local binding will continue to shadow any global binding that you make with this function." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) (interactive (let* ((menu-prompting nil) (key (read-key-sequence "Set key globally: " nil t))) @@ -80,6 +88,7 @@ KEY is a string that satisfies `key-valid-p'. The binding goes in the current buffer's local map, which in most cases is shared with all other buffers in the same major mode." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) (interactive "KSet key locally: \nCSet key %s locally to command: ") (let ((map (current-local-map))) (unless map @@ -92,6 +101,7 @@ KEY is a string that satisfies `key-valid-p'. If REMOVE (interactively, the prefix arg), remove the binding instead of unsetting it. See `keymap-unset' for details." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) (interactive (list (key-description (read-key-sequence "Set key locally: ")) current-prefix-arg)) @@ -103,6 +113,7 @@ KEY is a string that satisfies `key-valid-p'. If REMOVE (interactively, the prefix arg), remove the binding instead of unsetting it. See `keymap-unset' for details." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) (interactive (list (key-description (read-key-sequence "Unset key locally: ")) current-prefix-arg)) @@ -118,6 +129,7 @@ makes a difference when there's a parent keymap. When unsetting a key in a child map, it will still shadow the same key in the parent keymap. Removing the binding will allow the key in the parent keymap to be used." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) (keymap--check key) (define-key keymap (key-parse key) nil remove)) @@ -131,6 +143,8 @@ If you don't specify OLDMAP, you can usually get the same results in a cleaner way with command remapping, like this: (define-key KEYMAP [remap OLDDEF] NEWDEF) \n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)" + (declare (compiler-macro + (lambda (form) (keymap--compile-check olddef newdef) form))) ;; Don't document PREFIX in the doc string because we don't want to ;; advertise it. It's meant for recursive calls only. Here's its ;; meaning @@ -170,7 +184,8 @@ Bindings are always added before any inherited map. The order of bindings in a keymap matters only when it is used as a menu, so this function is not useful for non-menu keymaps." - (declare (indent defun)) + (declare (indent defun) + (compiler-macro (lambda (form) (keymap--compile-check key) form))) (keymap--check key) (when after (keymap--check after)) @@ -350,6 +365,8 @@ This function creates a `keyboard-translate-table' if necessary and then modifies one entry in it. Both KEY and TO are strings that satisfy `key-valid-p'." + (declare (compiler-macro + (lambda (form) (keymap--compile-check from to) form))) (keymap--check from) (keymap--check to) (or (char-table-p keyboard-translate-table) @@ -389,6 +406,7 @@ position as returned by `event-start' and `event-end', and the lookup occurs in the keymaps associated with it instead of KEY. It can also be a number or marker, in which case the keymap properties at the specified buffer position instead of point are used." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) (keymap--check key) (when (and keymap (not position)) (error "Can't pass in both keymap and position")) @@ -408,6 +426,7 @@ The binding is probably a symbol with a function definition. If optional argument ACCEPT-DEFAULT is non-nil, recognize default bindings; see the description of `keymap-lookup' for more details about this." + (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form))) (when-let ((map (current-local-map))) (keymap-lookup map keys accept-default))) @@ -424,6 +443,7 @@ bindings; see the description of `keymap-lookup' for more details about this. If MESSAGE (and interactively), message the result." + (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form))) (interactive (list (key-description (read-key-sequence "Look up key in global keymap: ")) nil t)) diff --git a/lisp/subr.el b/lisp/subr.el index 06ea503da6..78c72838f3 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -6525,6 +6525,28 @@ not a list, return a one-element list containing OBJECT." object (list object))) +(defun define-keymap--compile (form &rest args) + ;; This compiler macro is only there for compile-time + ;; error-checking; it does not change the call in any way. + (while (and args + (keywordp (car args)) + (not (eq (car args) :menu))) + (unless (memq (car args) '(:full :keymap :parent :suppress :name :prefix)) + (byte-compile-warn "Invalid keyword: %s" (car args))) + (setq args (cdr args)) + (when (null args) + (byte-compile-warn "Uneven number of keywords in %S" form)) + (setq args (cdr args))) + ;; Bindings. + (while args + (let ((key (pop args))) + (when (and (stringp key) (not (key-valid-p key))) + (byte-compile-warn "Invalid `kbd' syntax: %S" key))) + (when (null args) + (byte-compile-warn "Uneven number of key bindings in %S" form)) + (setq args (cdr args))) + form) + (defun define-keymap (&rest definitions) "Create a new keymap and define KEY/DEFEFINITION pairs as key sequences. The new keymap is returned. @@ -6557,10 +6579,8 @@ also be the special symbol `:menu', in which case DEFINITION should be a MENU form as accepted by `easy-menu-define'. \(fn &key FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" - (declare (indent defun)) - (define-keymap--define definitions)) - -(defun define-keymap--define (definitions) + (declare (indent defun) + (compiler-macro define-keymap--compile)) (let (full suppress parent name prefix keymap) ;; Handle keywords. (while (and definitions @@ -6632,7 +6652,7 @@ as the variable documentation string. (unless (zerop (% (length defs) 2)) (error "Uneven number of key/definition pairs: %s" defs)) `(defvar ,variable-name - (define-keymap--define (list ,@(nreverse opts) ,@defs)) + (define-keymap ,@(nreverse opts) ,@defs) ,@(and doc (list doc))))) (defmacro with-delayed-message (args &rest body) commit 1e8074f5ea9e61a6fba33ab2af0c79b9af7d7a24 Author: Mattias Engdegård Date: Sun Nov 28 18:00:44 2021 +0100 Avoid unused argument warnings in lambda compiler macros * lisp/emacs-lisp/byte-run.el (byte-run--set-compiler-macro): Don't warn when a compiler macro with lambda-form expander does not use all the arguments of the function. Nobody expected any warning since the arguments look like free variables inside the lambda form. diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index d82d9454e8..ac3bb86a59 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -134,6 +134,7 @@ The return value of this function is not used." :autoload-end (eval-and-compile (defun ,cfname (,@(car data) ,@args) + (ignore ,@(remq '&rest (remq '&optional args))) ,@(cdr data)))))))) (defalias 'byte-run--set-doc-string commit 58128f9b0554f2a7fb1c6638b463f5d4fcd98c7c Author: Michael Albinus Date: Sun Nov 28 17:05:32 2021 +0100 ; Use /usr/bin/find in gitlab-ci.yml diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index d12876e772..4b97f5f0a8 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -93,8 +93,8 @@ default: # Prepare test artifacts. - test -n "$(docker ps -aq -f name=${test_name})" && docker cp ${test_name}:checkout/test ${test_name} - test -n "$(docker ps -aq -f name=${test_name})" && docker rm ${test_name} - - find ${test_name} ! -name "*.log" -type f -delete - - find ${test_name} -empty -type d -delete + - /usr/bin/find ${test_name} ! -name "*.log" -type f -delete + - /usr/bin/find ${test_name} -empty -type d -delete .build-template: needs: [] commit f5498a608fe85b66a4068a5ccf88c9b3d3b88f98 Merge: 1272a2cb63 1fffe9a210 Author: Stefan Kangas Date: Sun Nov 28 14:59:44 2021 +0100 Merge from origin/emacs-28 1fffe9a210 ; * lisp/org/org.el: Fix version header. 2a4de5e5e5 Fix Subject when forwarding message with 2-line From b8b2dd17c5 Update to Org 9.5.1-11-g96d91b a937f536b3 * doc/lispref/commands.texi (Click Events): Fix wording (b... commit 1fffe9a210d328559da2af8facbb75286a31c74e Author: Stefan Kangas Date: Sun Nov 28 14:54:24 2021 +0100 ; * lisp/org/org.el: Fix version header. diff --git a/lisp/org/org.el b/lisp/org/org.el index 83b3d79cb1..1a13754619 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -9,7 +9,7 @@ ;; Homepage: https://orgmode.org ;; Package-Requires: ((emacs "25.1")) -;; Version: 9.5 +;; Version: 9.5.1 ;; This file is part of GNU Emacs. ;; commit 1272a2cb6384e1d99586486a4903e17b43cbc3cd Author: Michael Albinus Date: Sun Nov 28 13:45:43 2021 +0100 Adapt gitlab-ci.yml * test/infra/gitlab-ci.yml (variables): Set EMACS_TEST_TIMEOUT to 3600. (.job-template, .test-template): Another approach to catch test artifacts on emba. diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 759b8f6980..d12876e772 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -44,8 +44,7 @@ workflow: variables: GIT_STRATEGY: fetch EMACS_EMBA_CI: 1 - # Three hours, see below. - EMACS_TEST_TIMEOUT: 10800 + EMACS_TEST_TIMEOUT: 3600 EMACS_TEST_VERBOSE: 1 # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled # DOCKER_HOST: tcp://docker:2376 @@ -91,9 +90,11 @@ default: # - docker ps -a # - printenv # - test -n "$(docker ps -aq -f name=${test_name})" && ( docker export ${test_name} | tar -tvf - ) + # Prepare test artifacts. - test -n "$(docker ps -aq -f name=${test_name})" && docker cp ${test_name}:checkout/test ${test_name} - test -n "$(docker ps -aq -f name=${test_name})" && docker rm ${test_name} - # - ls -alR ${test_name} + - find ${test_name} ! -name "*.log" -type f -delete + - find ${test_name} -empty -type d -delete .build-template: needs: [] @@ -133,7 +134,7 @@ default: public: true expire_in: 1 week paths: - - "${test_name}/**/*.log" + - ${test_name}/ when: always .gnustep-template: commit 44c856dccc7891a9f762ebef1e386ac9eef0a920 Author: Po Lu Date: Sun Nov 28 07:39:22 2021 +0000 Make haiku-win build correctly on non-Haiku systems * lisp/term/haiku-win.el (haiku-selection-targets): Add missing declaration. diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index 7861cfb900..3c4d00f7f9 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -49,6 +49,7 @@ (declare-function x-handle-args "common-win") (declare-function haiku-selection-data "haikuselect.c") (declare-function haiku-selection-put "haikuselect.c") +(declare-function haiku-selection-targets "haikuselect.c") (declare-function haiku-put-resource "haikufns.c") (defun haiku--handle-x-command-line-resources (command-line-resources) commit 3ce591804badfde86870aa02a1432e870028e531 Author: Po Lu Date: Sun Nov 28 13:43:19 2021 +0800 Fix xwidget popups on XI2 again * src/xwidget.c (xwidget_button_1): Release seat grab. diff --git a/src/xwidget.c b/src/xwidget.c index e07b290acb..a5b96d0110 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -910,6 +910,8 @@ xwidget_button_1 (struct xwidget_view *view, #ifdef HAVE_XINPUT2 struct x_display_info *dpyinfo; struct xi_device_t *xi_device; + GdkSeat *seat; + GdkDevice *device; #endif /* X and Y should be relative to the origin of view->wdesc. */ @@ -936,12 +938,20 @@ xwidget_button_1 (struct xwidget_view *view, #ifdef HAVE_XINPUT2 dpyinfo = FRAME_DISPLAY_INFO (view->frame); + device = xg_event->button.device; + for (int idx = 0; idx < dpyinfo->num_devices; ++idx) { xi_device = &dpyinfo->devices[idx]; XIUngrabDevice (view->dpy, xi_device->device_id, CurrentTime); } + + if (device) + { + seat = gdk_device_get_seat (device); + gdk_seat_ungrab (seat); + } #endif gtk_main_do_event (xg_event); commit bd321f78eb8db839147a13a8543c0d3ca878f242 Author: Po Lu Date: Sun Nov 28 13:13:06 2021 +0800 Fix xwidget popups on XI2 * src/gtkutil.c (xg_is_menu_window): Determine whether wdesc is a menu generated by a menu bar more reliably. * src/xwidget.c (xwidget_button_1): Release all XI2 grabs on click. diff --git a/src/gtkutil.c b/src/gtkutil.c index 9e676cd025..8f8db4ed37 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -853,7 +853,11 @@ xg_is_menu_window (Display *dpy, Window wdesc) { GtkWidget *fw = gtk_bin_get_child (GTK_BIN (gwdesc)); if (GTK_IS_MENU (fw)) - return true; + { + GtkWidget *parent + = gtk_menu_shell_get_parent_shell (GTK_MENU_SHELL (fw)); + return GTK_IS_MENU_BAR (parent); + } } return false; diff --git a/src/xwidget.c b/src/xwidget.c index 5da2aa1743..e07b290acb 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -907,6 +907,10 @@ xwidget_button_1 (struct xwidget_view *view, GdkEvent *xg_event = gdk_event_new (down_p ? GDK_BUTTON_PRESS : GDK_BUTTON_RELEASE); struct xwidget *model = XXWIDGET (view->model); GtkWidget *target; +#ifdef HAVE_XINPUT2 + struct x_display_info *dpyinfo; + struct xi_device_t *xi_device; +#endif /* X and Y should be relative to the origin of view->wdesc. */ x += view->clip_left; @@ -930,6 +934,16 @@ xwidget_button_1 (struct xwidget_view *view, xg_event->button.time = time; xg_event->button.device = find_suitable_pointer (view->frame); +#ifdef HAVE_XINPUT2 + dpyinfo = FRAME_DISPLAY_INFO (view->frame); + for (int idx = 0; idx < dpyinfo->num_devices; ++idx) + { + xi_device = &dpyinfo->devices[idx]; + + XIUngrabDevice (view->dpy, xi_device->device_id, CurrentTime); + } +#endif + gtk_main_do_event (xg_event); gdk_event_free (xg_event); } commit 08d1c405073f614d89bcdf7f6bd19e8c8aaf8356 Author: Po Lu Date: Sun Nov 28 10:11:53 2021 +0800 Fix typos in configure.ac * configure.ac: Fix typos in wording of XInput 2 options. diff --git a/configure.ac b/configure.ac index 9cf192d4ba..c36dffde84 100644 --- a/configure.ac +++ b/configure.ac @@ -487,7 +487,7 @@ OPTION_DEFAULT_ON([modules],[don't compile with dynamic modules support]) OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support]) OPTION_DEFAULT_OFF([native-compilation],[compile with Emacs Lisp native compiler support]) OPTION_DEFAULT_OFF([cygwin32-native-compilation],[use native compilation on 32-bit Cygwin]) -OPTION_DEFAULT_OFF([xinput2],[use version 2.0 the X Input Extension for input]) +OPTION_DEFAULT_OFF([xinput2],[use version 2 of the X Input Extension for input]) AC_ARG_WITH([file-notification],[AS_HELP_STRING([--with-file-notification=LIB], [use a file notification library (LIB one of: yes, inotify, kqueue, gfile, w32, no)])], @@ -4389,7 +4389,7 @@ if test "${HAVE_X11}" = "yes" && test "${with_xinput2}" != "no"; then [AC_CHECK_LIB(Xi, XIGrabButton, HAVE_XINPUT2=yes)]) fi if test $HAVE_XINPUT2 = yes; then - AC_DEFINE(HAVE_XINPUT2, 1, [Define to 1 if the X Input Extension version 2.0 is present.]) + AC_DEFINE(HAVE_XINPUT2, 1, [Define to 1 if the X Input Extension version 2.0 or later is present.]) if test "$USE_GTK_TOOLKIT" = "GTK2"; then AC_MSG_WARN([You are building Emacs with GTK+ 2 and the X Input Extension version 2. This might lead to problems if your version of GTK+ is not built with support for XInput 2.]) commit 3c2afa66a217da84760849ed954245856f7e5810 Author: Po Lu Date: Sun Nov 28 09:06:11 2021 +0800 Make `pixel-scroll-precision-scroll-up' work better with overlays * lisp/pixel-scroll.el (pixel-scroll-precision-scroll-up): Just set vscroll when on overlay. diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 4280dc2587..888320cf1a 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -456,9 +456,14 @@ the height of the current window." (window-header-line-height)))) (desired-start (posn-point desired-pos)) (desired-vscroll (cdr (posn-object-x-y desired-pos)))) - (unless (eq (window-start) desired-start) - (set-window-start nil desired-start t)) - (set-window-vscroll nil desired-vscroll t)))))) + (let ((object (posn-object desired-pos))) + (if (or (consp object) (stringp object)) + (set-window-vscroll nil (+ (window-vscroll nil t) + (- delta)) + t) + (unless (eq (window-start) desired-start) + (set-window-start nil desired-start t)) + (set-window-vscroll nil desired-vscroll t)))))))) ;; FIXME: This doesn't work when there's an image above the current ;; line that is taller than the window. commit 2a4de5e5e5c3bb1d1022baf2b9a6f8b2acab4aa1 Author: Mike Kupfer Date: Fri Nov 26 13:59:14 2021 -0800 Fix Subject when forwarding message with 2-line From * lisp/mh-e/mh-comp.el (mh-forwarded-letter-subject): Collapse two-line From headers into a single line (SF#266). Based on a suggestion from Lester Buck (many thanks!). diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el index 404b6b3ce7..e44c42e280 100644 --- a/lisp/mh-e/mh-comp.el +++ b/lisp/mh-e/mh-comp.el @@ -638,6 +638,8 @@ See also `mh-compose-forward-as-mime-flag', (defun mh-forwarded-letter-subject (from subject) "Return a Subject suitable for a forwarded message. Original message has headers FROM and SUBJECT." + ;; Join continued lines. + (setq from (replace-regexp-in-string "\\s *\n\\s +" " " from)) (let ((addr-start (string-search "<" from)) (comment (string-search "(" from))) (cond ((and addr-start (> addr-start 0)) commit b8b2dd17c57b73357cae229e010138fd2352a46f Author: Kyle Meyer Date: Sat Nov 27 16:24:31 2021 -0500 Update to Org 9.5.1-11-g96d91b diff --git a/doc/misc/org.org b/doc/misc/org.org index df2724dd9c..85117714ee 100644 --- a/doc/misc/org.org +++ b/doc/misc/org.org @@ -10811,6 +10811,18 @@ To turn off fontification for marked up text, you can set ~org-fontify-emphasized-text~ to ~nil~. To narrow down the list of available markup syntax, you can customize ~org-emphasis-alist~. +Sometimes, when marked text also contains the marker character itself, +the result may be unsettling. For example, + +#+begin_example +/One may expect this whole sentence to be italicized, but the +following ~user/?variable~ contains =/= character, which effectively +stops emphasis there./ +#+end_example + +You can use zero width space to help Org sorting out the ambiguity. +See [[*Escape Character]] for more details. + ** Subscripts and Superscripts :PROPERTIES: :DESCRIPTION: Simple syntax for raising/lowering text. diff --git a/etc/refcards/orgcard.tex b/etc/refcards/orgcard.tex index d3715948d6..181516172d 100644 --- a/etc/refcards/orgcard.tex +++ b/etc/refcards/orgcard.tex @@ -1,5 +1,5 @@ % Reference Card for Org Mode -\def\orgversionnumber{9.5} +\def\orgversionnumber{9.5.1} \def\versionyear{2021} % latest update \input emacsver.tex diff --git a/lisp/org/oc-csl.el b/lisp/org/oc-csl.el index 7cd63c3ff3..7f078d139b 100644 --- a/lisp/org/oc-csl.el +++ b/lisp/org/oc-csl.el @@ -283,7 +283,8 @@ Label is in match group 1.") ;;; Internal functions (defun org-cite-csl--barf-without-citeproc () "Raise an error if Citeproc library is not loaded." - (unless (featurep 'citeproc) "Citeproc library is not loaded")) + (unless (featurep 'citeproc) + (error "Citeproc library is not loaded"))) (defun org-cite-csl--note-style-p (info) "Non-nil when bibliography style implies wrapping citations in footnotes. diff --git a/lisp/org/oc.el b/lisp/org/oc.el index 41fd688c06..427c087c03 100644 --- a/lisp/org/oc.el +++ b/lisp/org/oc.el @@ -1141,17 +1141,14 @@ and must return either a string, an object, or a secondary string." ;;; Internal interface with fontification (activate capability) -(defun org-cite-fontify-default (datum) - "Fontify DATUM with `org-cite' and `org-cite-key' face. -DATUM is a citation object, or a citation reference. In any case, apply -`org-cite' face on the whole citation, and `org-cite-key' face on each key." - (let* ((cite (if (eq 'citation-reference (org-element-type datum)) - (org-element-property :parent datum) - datum)) - (beg (org-element-property :begin cite)) - (end (org-with-point-at (org-element-property :end cite) - (skip-chars-backward " \t") - (point)))) +(defun org-cite-fontify-default (cite) + "Fontify CITE with `org-cite' and `org-cite-key' faces. +CITE is a citation object. The function applies `org-cite' face +on the whole citation, and `org-cite-key' face on each key." + (let ((beg (org-element-property :begin cite)) + (end (org-with-point-at (org-element-property :end cite) + (skip-chars-backward " \t") + (point)))) (add-text-properties beg end '(font-lock-multiline t)) (add-face-text-property beg end 'org-cite) (dolist (reference (org-cite-get-references cite)) @@ -1163,16 +1160,20 @@ DATUM is a citation object, or a citation reference. In any case, apply "Activate citations from up to LIMIT buffer position. Each citation encountered is activated using the appropriate function from the processor set in `org-cite-activate-processor'." - (let ((name org-cite-activate-processor)) - (let ((activate - (or (and name - (org-cite-processor-has-capability-p name 'activate) - (org-cite-processor-activate (org-cite--get-processor name))) - #'org-cite-fontify-default))) - (while (re-search-forward org-element-citation-prefix-re limit t) - (let ((cite (org-with-point-at (match-beginning 0) - (org-element-citation-parser)))) - (when cite (save-excursion (funcall activate cite)))))))) + (let* ((name org-cite-activate-processor) + (activate + (or (and name + (org-cite-processor-has-capability-p name 'activate) + (org-cite-processor-activate (org-cite--get-processor name))) + #'org-cite-fontify-default))) + (when (re-search-forward org-element-citation-prefix-re limit t) + (let ((cite (org-with-point-at (match-beginning 0) + (org-element-citation-parser)))) + (when cite + (funcall activate cite) + ;; Move after cite object and make sure to return + ;; a non-nil value. + (goto-char (org-element-property :end cite))))))) ;;; Internal interface with Org Export library (export capability) diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el index 89c57fb06c..e34872fb49 100644 --- a/lisp/org/org-table.el +++ b/lisp/org/org-table.el @@ -4436,7 +4436,7 @@ Optional argument NEW may specify text to replace the current field content." (col (org-table-current-column))) (when (> col 0) (skip-chars-backward "^|") - (if (not (looking-at " *\\([^|\n]*?\\) *\\(|\\|$\\)")) + (if (not (looking-at " *\\(?:\\([^|\n]*?\\) *\\(|\\)\\|\\([^|\n]+?\\) *\\($\\)\\)")) (setq org-table-may-need-update t) (let* ((align (nth (1- col) org-table-last-alignment)) (width (nth (1- col) org-table-last-column-widths)) diff --git a/lisp/org/org-version.el b/lisp/org/org-version.el index 77b1cf4e5f..212069e668 100644 --- a/lisp/org/org-version.el +++ b/lisp/org/org-version.el @@ -5,13 +5,13 @@ (defun org-release () "The release version of Org. Inserted by installing Org mode or when a release is made." - (let ((org-release "9.5")) + (let ((org-release "9.5.1")) org-release)) ;;;###autoload (defun org-git-version () "The Git version of Org mode. Inserted by installing Org or when a release is made." - (let ((org-git-version "release_9.5-72-gc5d6656")) + (let ((org-git-version "release_9.5.1-11-g96d91b")) org-git-version)) (provide 'org-version) diff --git a/lisp/org/ox.el b/lisp/org/ox.el index 9ab813a1b1..b27ec56c08 100644 --- a/lisp/org/ox.el +++ b/lisp/org/ox.el @@ -1048,6 +1048,7 @@ BACKEND is a structure with `org-export-backend' type." (unless (org-export-backend-p backend) (error "Unknown \"%s\" back-end: Aborting export" backend))) +;;;###autoload (defun org-export-derived-backend-p (backend &rest backends) "Non-nil if BACKEND is derived from one of BACKENDS. BACKEND is an export back-end, as returned by, e.g., @@ -1858,6 +1859,7 @@ INFO is a plist containing export directives." (let ((transcoder (cdr (assq type (plist-get info :translate-alist))))) (and (functionp transcoder) transcoder))))) +;;;###autoload (defun org-export-data (data info) "Convert DATA into current back-end format. @@ -4586,6 +4588,7 @@ objects of the same type." ;; `org-export-raw-string' builds a pseudo-object out of a string ;; that any export back-end returns as-is. +;;;###autoload (defun org-export-raw-string (s) "Return a raw object containing string S. A raw string is exported as-is, with no additional processing commit 338f7802373f1cfcc1b3749bbd46091fdef727f4 Author: Michael Albinus Date: Sat Nov 27 16:53:05 2021 +0100 Simplify use of artifacts in emba files * test/infra/gitlab-ci.yml (.test-template): Re-insert. (test-all-inotify, test-filenotify-gio, test-gnustep) (test-native-comp-speed0): * test/infra/Makefile.in (subdir_template): Use it when appropriate. Remove artifacts. * test/infra/test-jobs.yml: Regenerate. diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in index d9fc019625..fd11d36798 100644 --- a/test/infra/Makefile.in +++ b/test/infra/Makefile.in @@ -71,7 +71,7 @@ define subdir_template @echo >>$(FILE) @echo 'test-$(subst /,-,$(1))-inotify:' >>$(FILE) @echo ' stage: normal' >>$(FILE) - @echo ' extends: [.job-template]' >>$(FILE) + @echo ' extends: [.job-template, .test-template]' >>$(FILE) @echo ' needs:' >>$(FILE) @echo ' - job: build-image-inotify' >>$(FILE) @echo ' optional: true' >>$(FILE) @@ -82,13 +82,6 @@ define subdir_template $(changes) @echo ' - test/$(1)/*.el' >>$(FILE) @echo ' - test/$(1)/*resources/**' >>$(FILE) - @echo ' artifacts:' >>$(FILE) - @echo ' name: $(tn)' >>$(FILE) - @echo ' public: true' >>$(FILE) - @echo ' expire_in: 1 week' >>$(FILE) - @echo ' paths:' >>$(FILE) - @echo ' - $(tn)/$(1)/*.log' >>$(FILE) - @echo ' when: always' >>$(FILE) @echo ' variables:' >>$(FILE) @echo ' target: emacs-inotify' >>$(FILE) @echo ' make_params: "-C test $(target)"' >>$(FILE) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index dd36d19b3d..759b8f6980 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -127,6 +127,15 @@ default: - docker build --pull --target ${target} -t ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} -f test/infra/Dockerfile.emba . - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} +.test-template: + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - "${test_name}/**/*.log" + when: always + .gnustep-template: rules: - if: '$CI_PIPELINE_SOURCE == "web"' @@ -189,7 +198,7 @@ include: '/test/infra/test-jobs.yml' test-all-inotify: # This tests also file monitor libraries inotify and inotifywatch. stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -197,13 +206,6 @@ test-all-inotify: # Note there's no "changes" section, so this always runs on a schedule. - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - "${test_name}/**/*.log" - when: always variables: target: emacs-inotify make_params: check-expensive @@ -217,17 +219,10 @@ build-image-filenotify-gio: test-filenotify-gio: # This tests file monitor libraries gfilemonitor and gio. stage: platforms - extends: [.job-template, .filenotify-gio-template] + extends: [.job-template, .test-template, .filenotify-gio-template] needs: - job: build-image-filenotify-gio optional: true - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - "${test_name}/**/*.log" - when: always variables: target: emacs-filenotify-gio make_params: "-k -C test autorevert-tests.log filenotify-tests.log" @@ -245,13 +240,6 @@ test-gnustep: needs: - job: build-image-gnustep optional: true - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - "${test_name}/**/*.log" - when: always variables: target: emacs-gnustep make_params: install @@ -276,17 +264,10 @@ build-native-comp-speed2: test-native-comp-speed0: stage: native-comp - extends: [.job-template, .native-comp-template] + extends: [.job-template, .test-template, .native-comp-template] needs: - job: build-native-comp-speed0 optional: true - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - "${test_name}/**/*.log" - when: always variables: target: emacs-native-comp-speed0 make_params: "-C test check SELECTOR='(not (tag :unstable))'" diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml index 33a90d6f2c..bad8575b5c 100644 --- a/test/infra/test-jobs.yml +++ b/test/infra/test-jobs.yml @@ -1,7 +1,7 @@ test-lib-src-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -12,20 +12,13 @@ test-lib-src-inotify: - lib-src/*.{h,c} - test/lib-src/*.el - test/lib-src/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lib-src/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lib-src" test-lisp-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -36,20 +29,13 @@ test-lisp-inotify: - lisp/*.el - test/lisp/*.el - test/lisp/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp" test-lisp-calc-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -60,20 +46,13 @@ test-lisp-calc-inotify: - lisp/calc/*.el - test/lisp/calc/*.el - test/lisp/calc/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/calc/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-calc" test-lisp-calendar-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -84,20 +63,13 @@ test-lisp-calendar-inotify: - lisp/calendar/*.el - test/lisp/calendar/*.el - test/lisp/calendar/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/calendar/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-calendar" test-lisp-cedet-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -108,20 +80,13 @@ test-lisp-cedet-inotify: - lisp/cedet/*.el - test/lisp/cedet/*.el - test/lisp/cedet/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/cedet/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-cedet" test-lisp-cedet-semantic-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -132,20 +97,13 @@ test-lisp-cedet-semantic-inotify: - lisp/cedet/semantic/*.el - test/lisp/cedet/semantic/*.el - test/lisp/cedet/semantic/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/cedet/semantic/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-cedet-semantic" test-lisp-cedet-semantic-bovine-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -156,20 +114,13 @@ test-lisp-cedet-semantic-bovine-inotify: - lisp/cedet/semantic/bovine/*.el - test/lisp/cedet/semantic/bovine/*.el - test/lisp/cedet/semantic/bovine/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/cedet/semantic/bovine/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-cedet-semantic-bovine" test-lisp-cedet-srecode-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -180,20 +131,13 @@ test-lisp-cedet-srecode-inotify: - lisp/cedet/srecode/*.el - test/lisp/cedet/srecode/*.el - test/lisp/cedet/srecode/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/cedet/srecode/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-cedet-srecode" test-lisp-emacs-lisp-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -204,20 +148,13 @@ test-lisp-emacs-lisp-inotify: - lisp/emacs-lisp/*.el - test/lisp/emacs-lisp/*.el - test/lisp/emacs-lisp/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/emacs-lisp/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-emacs-lisp" test-lisp-emacs-lisp-eieio-tests-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -228,20 +165,13 @@ test-lisp-emacs-lisp-eieio-tests-inotify: - lisp/emacs-lisp/eieio*.el - test/lisp/emacs-lisp/eieio-tests/*.el - test/lisp/emacs-lisp/eieio-tests/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/emacs-lisp/eieio-tests/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-emacs-lisp-eieio-tests" test-lisp-emacs-lisp-faceup-tests-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -252,20 +182,13 @@ test-lisp-emacs-lisp-faceup-tests-inotify: - lisp/emacs-lisp/faceup*.el - test/lisp/emacs-lisp/faceup-tests/*.el - test/lisp/emacs-lisp/faceup-tests/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/emacs-lisp/faceup-tests/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-emacs-lisp-faceup-tests" test-lisp-emulation-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -276,20 +199,13 @@ test-lisp-emulation-inotify: - lisp/emulation/*.el - test/lisp/emulation/*.el - test/lisp/emulation/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/emulation/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-emulation" test-lisp-erc-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -300,20 +216,13 @@ test-lisp-erc-inotify: - lisp/erc/*.el - test/lisp/erc/*.el - test/lisp/erc/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/erc/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-erc" test-lisp-eshell-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -324,20 +233,13 @@ test-lisp-eshell-inotify: - lisp/eshell/*.el - test/lisp/eshell/*.el - test/lisp/eshell/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/eshell/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-eshell" test-lisp-gnus-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -348,20 +250,13 @@ test-lisp-gnus-inotify: - lisp/gnus/*.el - test/lisp/gnus/*.el - test/lisp/gnus/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/gnus/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-gnus" test-lisp-image-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -372,20 +267,13 @@ test-lisp-image-inotify: - lisp/image/*.el - test/lisp/image/*.el - test/lisp/image/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/image/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-image" test-lisp-international-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -396,20 +284,13 @@ test-lisp-international-inotify: - lisp/international/*.el - test/lisp/international/*.el - test/lisp/international/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/international/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-international" test-lisp-mail-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -420,20 +301,13 @@ test-lisp-mail-inotify: - lisp/mail/*.el - test/lisp/mail/*.el - test/lisp/mail/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/mail/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-mail" test-lisp-mh-e-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -444,20 +318,13 @@ test-lisp-mh-e-inotify: - lisp/mh-e/*.el - test/lisp/mh-e/*.el - test/lisp/mh-e/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/mh-e/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-mh-e" test-lisp-net-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -468,20 +335,13 @@ test-lisp-net-inotify: - lisp/net/*.el - test/lisp/net/*.el - test/lisp/net/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/net/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-net" test-lisp-nxml-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -492,20 +352,13 @@ test-lisp-nxml-inotify: - lisp/nxml/*.el - test/lisp/nxml/*.el - test/lisp/nxml/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/nxml/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-nxml" test-lisp-obsolete-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -516,20 +369,13 @@ test-lisp-obsolete-inotify: - lisp/obsolete/*.el - test/lisp/obsolete/*.el - test/lisp/obsolete/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/obsolete/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-obsolete" test-lisp-org-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -540,20 +386,13 @@ test-lisp-org-inotify: - lisp/org/*.el - test/lisp/org/*.el - test/lisp/org/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/org/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-org" test-lisp-play-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -564,20 +403,13 @@ test-lisp-play-inotify: - lisp/play/*.el - test/lisp/play/*.el - test/lisp/play/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/play/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-play" test-lisp-progmodes-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -588,20 +420,13 @@ test-lisp-progmodes-inotify: - lisp/progmodes/*.el - test/lisp/progmodes/*.el - test/lisp/progmodes/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/progmodes/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-progmodes" test-lisp-so-long-tests-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -612,20 +437,13 @@ test-lisp-so-long-tests-inotify: - lisp/so-long*.el - test/lisp/so-long-tests/*.el - test/lisp/so-long-tests/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/so-long-tests/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-so-long-tests" test-lisp-term-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -636,20 +454,13 @@ test-lisp-term-inotify: - lisp/term/*.el - test/lisp/term/*.el - test/lisp/term/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/term/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-term" test-lisp-textmodes-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -660,20 +471,13 @@ test-lisp-textmodes-inotify: - lisp/textmodes/*.el - test/lisp/textmodes/*.el - test/lisp/textmodes/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/textmodes/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-textmodes" test-lisp-url-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -684,20 +488,13 @@ test-lisp-url-inotify: - lisp/url/*.el - test/lisp/url/*.el - test/lisp/url/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/url/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-url" test-lisp-vc-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -708,20 +505,13 @@ test-lisp-vc-inotify: - lisp/vc/*.el - test/lisp/vc/*.el - test/lisp/vc/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/lisp/vc/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-lisp-vc" test-misc-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -732,20 +522,13 @@ test-misc-inotify: - admin/*.el - test/misc/*.el - test/misc/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/misc/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-misc" test-src-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] needs: - job: build-image-inotify optional: true @@ -756,13 +539,6 @@ test-src-inotify: - src/*.{h,c} - test/src/*.el - test/src/*resources/** - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/src/*.log - when: always variables: target: emacs-inotify make_params: "-C test check-src" commit 8d67a70e97a7002682f641c05b10e1a9d4586e8b Author: Stefan Monnier Date: Sat Nov 27 10:10:26 2021 -0500 * test/src/comp-tests.el: Rework last patch Move `require`s out of `eval-when-compile` if the functions are called at run-time. Don't use #' to quote symbols (i.e. at those places where a lambda expression couldn't be used). Don't pre-load comp-test-45603.el and comp-test-pure.el any more. (comp-deftest pure): Use `declare-function` after loading `comp-test-pure.el` to silence the byte-compiler. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index f66a193205..5b20cf38ec 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -27,27 +27,24 @@ (require 'ert) (require 'ert-x) -(eval-when-compile - (require 'cl-lib) - (require 'comp)) +(require 'cl-lib) +(require 'comp) +(require 'comp-cstr) + (eval-and-compile - (require 'comp-cstr) ;in eval-and-compile for its defstruct (defconst comp-test-src (ert-resource-file "comp-test-funcs.el")) - (defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el")) - (defconst comp-test-pure-src (ert-resource-file "comp-test-pure.el")) - (defconst comp-test-45603-src (ert-resource-file "comp-test-45603.el")) - ;; Load the test code here so the compiler can check the function - ;; names used in this file. - (load comp-test-src nil t) - (load comp-test-dyn-src nil t) - (load comp-test-pure-src nil t) - (load comp-test-45603-src nil t)) + (defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el"))) (when (native-comp-available-p) (message "Compiling tests...") (load (native-compile comp-test-src)) (load (native-compile comp-test-dyn-src))) +;; Load the test code here so the compiler can check the function +;; names used in this file. +(require 'comp-test-funcs comp-test-src) +(require 'comp-test-dyn-funcs comp-test-dyn-src) ;Non-standard feature name! + (defmacro comp-deftest (name args &rest docstring-and-body) "Define a test for the native compiler tagging it as :nativecomp." (declare (indent defun) @@ -75,7 +72,7 @@ Check that the resulting binaries do not differ." (copy-file comp-src comp2-src t) (let ((load-no-native t)) (load (concat comp-src "c") nil nil t t)) - (should-not (subr-native-elisp-p (symbol-function #'native-compile))) + (should-not (subr-native-elisp-p (symbol-function 'native-compile))) (message "Compiling stage1...") (let* ((t0 (current-time)) (comp1-eln (native-compile comp1-src))) @@ -372,7 +369,7 @@ Check that the resulting binaries do not differ." t) (native-compile #'comp-tests-free-fun-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-free-fun-f))) (should (= (comp-tests-free-fun-f) 3)) (should (string= (documentation #'comp-tests-free-fun-f) "Some doc.")) @@ -386,7 +383,7 @@ Check that the resulting binaries do not differ." "Check we are able to compile a single function." (eval '(defun comp-tests/free\fun-f ()) t) (native-compile #'comp-tests/free\fun-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests/free\fun-f)))) + (should (subr-native-elisp-p (symbol-function 'comp-tests/free\fun-f)))) (comp-deftest bug-40187 () "Check function name shadowing. @@ -397,7 +394,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest speed--1 () "Check that at speed -1 we do not native compile." (should (= (comp-test-speed--1-f) 3)) - (should-not (subr-native-elisp-p (symbol-function #'comp-test-speed--1-f)))) + (should-not (subr-native-elisp-p (symbol-function 'comp-test-speed--1-f)))) (comp-deftest bug-42360 () "." @@ -446,7 +443,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest primitive-redefine () "Test effectiveness of primitive redefinition." (cl-letf ((comp-test-primitive-redefine-args nil) - ((symbol-function #'-) + ((symbol-function '-) (lambda (&rest args) (setq comp-test-primitive-redefine-args args) 'xxx))) @@ -467,11 +464,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest comp-test-defsubst () ;; Bug#42664, Bug#43280, Bug#44209. - (should-not (subr-native-elisp-p (symbol-function #'comp-test-defsubst-f)))) + (should-not (subr-native-elisp-p (symbol-function 'comp-test-defsubst-f)))) (comp-deftest primitive-redefine-compile-44221 () "Test the compiler still works while primitives are redefined (bug#44221)." - (cl-letf (((symbol-function #'delete-region) + (cl-letf (((symbol-function 'delete-region) (lambda (_ _)))) (should (subr-native-elisp-p (native-compile @@ -506,13 +503,13 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest 45603-1 () "" - (load (native-compile comp-test-45603-src)) - (should (fboundp #'comp-test-45603--file-local-name))) + (load (native-compile (ert-resource-file "comp-test-45603.el"))) + (should (fboundp 'comp-test-45603--file-local-name))) (comp-deftest 46670-1 () "" (should (string= (comp-test-46670-2-f "foo") "foo")) - (should (equal (subr-type (symbol-function #'comp-test-46670-2-f)) + (should (equal (subr-type (symbol-function 'comp-test-46670-2-f)) '(function (t) t)))) (comp-deftest 46824-1 () @@ -742,7 +739,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest dynamic-help-arglist () "Test `help-function-arglist' works on lisp/d (bug#42572)." (should (equal (help-function-arglist - (symbol-function #'comp-tests-ffuncall-callee-opt-rest-dyn-f) + (symbol-function 'comp-tests-ffuncall-callee-opt-rest-dyn-f) t) '(a b &optional c &rest d)))) @@ -815,7 +812,7 @@ Return a list of results." (comp-tests-tco-f (+ a b) a (- count 1)))) t) (native-compile #'comp-tests-tco-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests-tco-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-tco-f))) (should (= (comp-tests-tco-f 1 0 10) 55)))) (defun comp-tests-fw-prop-checker-1 (_) @@ -842,7 +839,7 @@ Return a list of results." (length c))) ; <= has to optimize t) (native-compile #'comp-tests-fw-prop-1-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-fw-prop-1-f))) (should (= (comp-tests-fw-prop-1-f) 6)))) (defun comp-tests-check-ret-type-spec (func-form ret-type) @@ -1421,12 +1418,14 @@ folded." (let ((native-comp-speed 3) (comp-post-pass-hooks '((comp-final comp-tests-pure-checker-1 comp-tests-pure-checker-2)))) - (load (native-compile comp-test-pure-src)) + (load (native-compile (ert-resource-file "comp-test-pure.el"))) + (declare-function comp-tests-pure-caller-f nil) + (declare-function comp-tests-pure-fibn-entry-f nil) - (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-caller-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-pure-caller-f))) (should (= (comp-tests-pure-caller-f) 4)) - (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-fibn-entry-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-pure-fibn-entry-f))) (should (= (comp-tests-pure-fibn-entry-f) 6765)))) (defvar comp-tests-cond-rw-checked-function nil commit a89731a78c8cb019a18d2e70fe43d21286d88ab1 Author: Eli Zaretskii Date: Sat Nov 27 17:09:51 2021 +0200 Avoid assertion violations in --enable-checking builds * src/xdisp.c (gui_produce_glyphs): Make sure character glyphs don't trigger assertion violation due to negative ascent or descent. This was reporte dto happen with some fonts used by the xfont backend. diff --git a/src/xdisp.c b/src/xdisp.c index 24049ab4e3..9f93799783 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -31199,6 +31199,11 @@ gui_produce_glyphs (struct it *it) it->max_ascent = max (it->max_ascent, font_ascent); it->max_descent = max (it->max_descent, font_descent); } + + if (it->ascent < 0) + it->ascent = 0; + if (it->descent < 0) + it->descent = 0; } else if (it->what == IT_COMPOSITION && it->cmp_it.ch < 0) { commit a937f536b35351842756bac939f21ae5f937fa61 Author: Eli Zaretskii Date: Sat Nov 27 15:01:46 2021 +0200 * doc/lispref/commands.texi (Click Events): Fix wording (bug#52142). diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index 6e1d09ebb4..35ef61700c 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -1558,8 +1558,10 @@ corner of @var{object}, which is @code{(0 . 0)}. If @var{object} is the top left corner of the character glyph clicked on. @item @var{width}, @var{height} -These are the pixel width and height of @var{object} or, if this is -@code{nil}, those of the character glyph clicked on. +If the click is on a character, either from buffer text or from +overlay or display string, these are the pixel width and height of +that character's glyph; otherwise they are dimensions of @var{object} +clicked on. @end table For clicks on a scroll bar, @var{position} has this form: commit f97539876af597e2497bfde68a68878166406302 Author: Po Lu Date: Sat Nov 27 19:14:43 2021 +0800 Improve documentation of wheel events * doc/lispref/commands.texi (Misc Events): Add missing parameters to `wheel-up' and `wheel-down'. diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index c12a97cc7d..86f84684b4 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -1995,15 +1995,19 @@ frame has already been made visible, Emacs has no work to do. @cindex @code{wheel-up} event @cindex @code{wheel-down} event -@item (wheel-up @var{position}) -@itemx (wheel-down @var{position}) +@item (wheel-up @var{position} @var{clicks} @var{lines} @var{pixel-delta}) +@itemx (wheel-down @var{position} @var{clicks} @var{lines} @var{pixel-delta}) These kinds of event are generated by moving a mouse wheel. The @var{position} element is a mouse position list (@pxref{Click Events}), specifying the position of the mouse cursor when the event -occurred. The event may have additional arguments after -@var{position}. The third argument after @var{position}, if present, -is a pair of the form @w{@code{(@var{x} . @var{y})}}, where @var{x} -and @var{y} are the number of pixels to scroll by in each axis. +occurred. + +@var{clicks}, if present, is the number of times in quick succession +the wheel has been moved. @xref{Repeat Events}. @var{lines}, if +present and not @code{nil}, is the number of screen lines that should +be scrolled. @var{pixel-delta}, if present, is a pair of the form +@w{@code{(@var{x} . @var{y})}}, where @var{x} and @var{y} are the +number of pixels to scroll by in each axis. @cindex pixel-resolution wheel events You can use @var{x} and @var{y} to determine how much the mouse wheel commit f9457b8b011aa7ba9df84d3d6ab1ba88a4220345 Author: Po Lu Date: Sat Nov 27 19:23:31 2021 +0800 Fix pixel scroll for overlays and text in display properties * lisp/pixel-scroll.el (pixel-scroll-precision-scroll-down): Just set vscroll if we're scrolling through an overlay or something to that effect. diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 92f66c89ce..4280dc2587 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -408,11 +408,18 @@ the height of the current window." (let* ((desired-pos (posn-at-x-y 0 (+ delta (window-tab-line-height) (window-header-line-height)))) + (object (posn-object desired-pos)) (desired-start (posn-point desired-pos)) (desired-vscroll (cdr (posn-object-x-y desired-pos)))) - (unless (eq (window-start) desired-start) - (set-window-start nil desired-start t)) - (set-window-vscroll nil desired-vscroll t)))) + (if (or (consp object) (stringp object)) + ;; We are either on an overlay or a string, so set vscroll + ;; directly. + (set-window-vscroll nil (+ (window-vscroll nil t) + delta) + t) + (unless (eq (window-start) desired-start) + (set-window-start nil desired-start t)) + (set-window-vscroll nil desired-vscroll t))))) (defun pixel-scroll-precision-scroll-up (delta) "Scroll the current window up by DELTA pixels." commit 6072370db7244a13470252e5369c4c9de3e3a9ef Author: Eli Zaretskii Date: Sat Nov 27 09:02:12 2021 +0200 ; Improve doc string of 'glyphless-char-display-control' * lisp/international/characters.el (glyphless-char-display-control): Doc fix. diff --git a/lisp/international/characters.el b/lisp/international/characters.el index ec995743f5..3a8e968c34 100644 --- a/lisp/international/characters.el +++ b/lisp/international/characters.el @@ -1594,12 +1594,14 @@ GROUP must be one of these symbols: such as U+200C (ZWNJ), U+200E (LRM), but excluding characters that have graphic images, such as U+00AD (SHY). - `variation-selectors': U+FE00..U+FE0F, used for choosing between - glyph variations (e.g. Emoji vs Text - presentation). - `no-font': characters for which no suitable font is found. - For character terminals, characters that cannot - be encoded by `terminal-coding-system'. + `variation-selectors': + Characters in the range U+FE00..U+FE0F, used for + selecting alternate glyph presentations, such as + Emoji vs Text presentation, of the preceding + character(s). + `no-font': For GUI frames, characters for which no suitable + font is found; for text-mode frames, characters + that cannot be encoded by `terminal-coding-system'. METHOD must be one of these symbols: `zero-width': don't display. commit 828a193066bace5785ac87be75d312dace06ad68 Author: Po Lu Date: Sat Nov 27 14:57:59 2021 +0800 Set motion event time when handling XI2 motion events * src/xterm.c (handle_one_xevent): Set motion event time when handling XI_Motion. diff --git a/src/xterm.c b/src/xterm.c index c7950c6f9f..8045470bdd 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10085,6 +10085,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, ev.x = lrint (xev->event_x); ev.y = lrint (xev->event_y); ev.window = xev->event; + ev.time = xev->time; previous_help_echo_string = help_echo_string; help_echo_string = Qnil; commit 3dc9eb8bbd977b0d81d49c7b79492f6ef30e270f Author: Po Lu Date: Sat Nov 27 14:10:49 2021 +0800 Remove GC prone call in `pixel-point-and-height-at-unseen-line' * lisp/pixel-scroll.el (pixel-point-and-height-at-unseen-line): Remove call to unnecessary call to `beginning-of-visual-line'. diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 84e1f66fa5..92f66c89ce 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -346,14 +346,9 @@ window, and the pixel height of that line." (goto-char pos0) (if (bobp) (point-min) - ;; When there's an overlay string at window-start, - ;; (beginning-of-visual-line 0) stays put. - (let ((ppos (point)) - (tem (beginning-of-visual-line 0))) - (if (eq tem ppos) - (vertical-motion -1)) - (setq line-height (line-pixel-height)) - (point)))))) + (vertical-motion -1) + (setq line-height (line-pixel-height)) + (point))))) ;; restore initial position (set-window-start nil pos0 t) (set-window-vscroll nil vscroll0 t) commit 141425ce3b8646d589f6a3aaf16d981821b32631 Author: Po Lu Date: Sat Nov 27 13:46:35 2021 +0800 Make `pixel-scroll-precision-scroll-up' slightly more robust * lisp/pixel-scroll.el (pixel-scroll-precision-scroll-up): Subtract from existing vscroll if feasible. diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 131519a258..84e1f66fa5 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -432,21 +432,31 @@ the height of the current window." (vertical-motion -1) (setq current-y (- current-y (line-pixel-height))))) (let ((current-vscroll (window-vscroll nil t))) - (setq delta (- delta current-vscroll)) - (set-window-vscroll nil 0 t)) - (while (> delta 0) - (let ((position (pixel-point-and-height-at-unseen-line))) - (set-window-start nil (car position) t) - (setq delta (- delta (cdr position))))) - (when (< delta 0) - (when-let* ((desired-pos (posn-at-x-y 0 (+ (- delta) - (window-tab-line-height) - (window-header-line-height)))) - (desired-start (posn-point desired-pos)) - (desired-vscroll (cdr (posn-object-x-y desired-pos)))) - (unless (eq (window-start) desired-start) - (set-window-start nil desired-start t)) - (set-window-vscroll nil desired-vscroll t)))) + (if (<= delta current-vscroll) + (set-window-vscroll nil (- current-vscroll delta) t) + (setq delta (- delta current-vscroll)) + (set-window-vscroll nil 0 t) + (while (> delta 0) + (let ((position (pixel-point-and-height-at-unseen-line))) + (unless (cdr position) + (signal 'beginning-of-buffer nil)) + (set-window-start nil (car position) t) + ;; If the line above is taller than the window height (i.e. there's + ;; a very tall image), keep point on it. + (when (> (cdr position) (window-text-height nil t)) + (let ((vs (window-vscroll nil t))) + (goto-char (car position)) + (set-window-vscroll nil vs t))) + (setq delta (- delta (cdr position))))) + (when (< delta 0) + (when-let* ((desired-pos (posn-at-x-y 0 (+ (- delta) + (window-tab-line-height) + (window-header-line-height)))) + (desired-start (posn-point desired-pos)) + (desired-vscroll (cdr (posn-object-x-y desired-pos)))) + (unless (eq (window-start) desired-start) + (set-window-start nil desired-start t)) + (set-window-vscroll nil desired-vscroll t)))))) ;; FIXME: This doesn't work when there's an image above the current ;; line that is taller than the window. commit d329014574575b3f98ac68e22bdcb1ab4ddd5419 Author: Po Lu Date: Sat Nov 27 13:02:10 2021 +0800 Make `pixel-scroll-precision-scroll-up' use existing logic * lisp/pixel-scroll.el (pixel-point-at-unseen-line): Rewrite to use `pixel-point-and-height-at-unseen-line'. (pixel-point-and-height-at-unseen-line): New function. (pixel-scroll-precision-scroll-up): Use existing logic to determine unseen line position. diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index f6d1d0ff8c..131519a258 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -333,12 +333,14 @@ returns nil." (setq pos-list (cdr pos-list)))) visible-pos)) -(defun pixel-point-at-unseen-line () - "Return the character position of line above the selected window. -The returned value is the position of the first character on the -unseen line just above the scope of current window." +(defun pixel-point-and-height-at-unseen-line () + "Return the position and pixel height of line above the selected window. +The returned value is a cons of the position of the first +character on the unseen line just above the scope of current +window, and the pixel height of that line." (let* ((pos0 (window-start)) (vscroll0 (window-vscroll nil t)) + (line-height nil) (pos (save-excursion (goto-char pos0) @@ -350,11 +352,18 @@ unseen line just above the scope of current window." (tem (beginning-of-visual-line 0))) (if (eq tem ppos) (vertical-motion -1)) + (setq line-height (line-pixel-height)) (point)))))) ;; restore initial position (set-window-start nil pos0 t) (set-window-vscroll nil vscroll0 t) - pos)) + (cons pos line-height))) + +(defun pixel-point-at-unseen-line () + "Return the character position of line above the selected window. +The returned value is the position of the first character on the +unseen line just above the scope of current window." + (car (pixel-point-and-height-at-unseen-line))) (defun pixel-scroll-down-and-set-window-vscroll (vscroll) "Scroll down a line and set VSCROLL in pixels. @@ -426,14 +435,9 @@ the height of the current window." (setq delta (- delta current-vscroll)) (set-window-vscroll nil 0 t)) (while (> delta 0) - (set-window-start nil (save-excursion - (goto-char (window-start)) - (when (zerop (vertical-motion -1)) - (set-window-vscroll nil 0) - (signal 'beginning-of-buffer nil)) - (setq delta (- delta (line-pixel-height))) - (point)) - t)) + (let ((position (pixel-point-and-height-at-unseen-line))) + (set-window-start nil (car position) t) + (setq delta (- delta (cdr position))))) (when (< delta 0) (when-let* ((desired-pos (posn-at-x-y 0 (+ (- delta) (window-tab-line-height) commit b0ef00f370a10398c0271b24582e10bf12a90566 Author: Stephen Gildea Date: Fri Nov 26 20:48:45 2021 -0800 time-stamp-tests.el: Test more formats * test/lisp/time-stamp-tests.el (time-stamp-format-ignored-modifiers): Additional testing with illegal formats, including "%". (time-stamp-format-multiple-conversions): Add a test with "%%%". diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index cb446eb486..a049e5de58 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -595,8 +595,12 @@ ;; incorrectly nested parens do not crash us (should-not (equal (time-stamp-string "%(stuffB" ref-time3) May)) (should-not (equal (time-stamp-string "%)B" ref-time3) May)) + ;; unterminated format does not crash us + (should-not (equal (time-stamp-string "%" ref-time3) May)) ;; not all punctuation is allowed - (should-not (equal (time-stamp-string "%&B" ref-time3) May))))) + (should-not (equal (time-stamp-string "%&B" ref-time3) May)) + (should-not (equal (time-stamp-string "%/B" ref-time3) May)) + (should-not (equal (time-stamp-string "%;B" ref-time3) May))))) (ert-deftest time-stamp-format-non-conversions () "Test that without a %, the text is copied literally." @@ -635,8 +639,8 @@ (concat Mon "." Monday "." Mon))) (should (equal (time-stamp-string "%5z.%5::z.%5z" ref-time1) "+0000.+00:00:00.+0000")) - ;; format letter is independent - (should (equal (time-stamp-string "%H:%M" ref-time1) "15:04"))))) + ;; format character is independent + (should (equal (time-stamp-string "%H:%M%%%S" ref-time1) "15:04%05"))))) (ert-deftest time-stamp-format-string-width () "Test time-stamp string width modifiers." commit f1116f45bcabc5628e7443a2c792971c7c23b8b1 Author: Po Lu Date: Sat Nov 27 08:34:51 2021 +0800 Set initial tab bar parameter on NS * src/nsfns.m (Fx_create_frame): Initialize `tab-bar-lines' frame parameter during frame creation. diff --git a/src/nsfns.m b/src/nsfns.m index f4d8172246..c2791aa15a 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -1365,6 +1365,10 @@ Turn the input menu (an NSMenu) into a lisp list for tracking on lisp side. NILP (Vmenu_bar_mode) ? make_fixnum (0) : make_fixnum (1), NULL, NULL, RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qtab_bar_lines, + NILP (Vtab_bar_mode) + ? make_fixnum (0) : make_fixnum (1), + NULL, NULL, RES_TYPE_NUMBER); gui_default_parameter (f, parms, Qtool_bar_lines, NILP (Vtool_bar_mode) ? make_fixnum (0) : make_fixnum (1), commit 9721dcf2754ebad28ac60a9d3152fd26e4c652c4 Author: Alan Third Date: Fri Nov 26 19:57:07 2021 +0000 Silence NS warnings * src/nsterm.m ([EmacsView mouseDown:]): Move variables into the block where they're used. diff --git a/src/nsterm.m b/src/nsterm.m index 80117a41a5..747539eae6 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -6529,7 +6529,6 @@ - (void)mouseDown: (NSEvent *)theEvent { struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (emacsframe); NSPoint p = [self convertPoint: [theEvent locationInWindow] fromView: nil]; - int x = 0, y = 0; NSTRACE ("[EmacsView mouseDown:]"); @@ -6561,6 +6560,7 @@ - (void)mouseDown: (NSEvent *)theEvent */ bool horizontal; int lines = 0; + int x = 0, y = 0; int scrollUp = NO; /* FIXME: At the top or bottom of the buffer we should commit 11860f89a593a8cfe7efb94e86370bbbe4318fba Author: Stephen Gildea Date: Fri Nov 26 08:51:38 2021 -0800 * test/src/comp-tests.el: Eliminate byte-compiler warnings (Bug#52105). diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 025bc2058e..f66a193205 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -27,14 +27,23 @@ (require 'ert) (require 'ert-x) -(require 'cl-lib) - -(defconst comp-test-src (ert-resource-file "comp-test-funcs.el")) - -(defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el")) - -(when (featurep 'native-compile) - (require 'comp) +(eval-when-compile + (require 'cl-lib) + (require 'comp)) +(eval-and-compile + (require 'comp-cstr) ;in eval-and-compile for its defstruct + (defconst comp-test-src (ert-resource-file "comp-test-funcs.el")) + (defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el")) + (defconst comp-test-pure-src (ert-resource-file "comp-test-pure.el")) + (defconst comp-test-45603-src (ert-resource-file "comp-test-45603.el")) + ;; Load the test code here so the compiler can check the function + ;; names used in this file. + (load comp-test-src nil t) + (load comp-test-dyn-src nil t) + (load comp-test-pure-src nil t) + (load comp-test-45603-src nil t)) + +(when (native-comp-available-p) (message "Compiling tests...") (load (native-compile comp-test-src)) (load (native-compile comp-test-dyn-src))) @@ -352,6 +361,8 @@ Check that the resulting binaries do not differ." comp-test-interactive-form2-f))) (should-not (commandp #'comp-tests-doc-f))) +(declare-function comp-tests-free-fun-f nil) + (comp-deftest free-fun () "Check we are able to compile a single function." (eval '(defun comp-tests-free-fun-f () @@ -369,6 +380,8 @@ Check that the resulting binaries do not differ." (should (equal (interactive-form #'comp-tests-free-fun-f) '(interactive)))) +(declare-function comp-tests/free\fun-f nil) + (comp-deftest free-fun-silly-name () "Check we are able to compile a single function." (eval '(defun comp-tests/free\fun-f ()) t) @@ -493,7 +506,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest 45603-1 () "" - (load (native-compile (ert-resource-file "comp-test-45603.el"))) + (load (native-compile comp-test-45603-src)) (should (fboundp #'comp-test-45603--file-local-name))) (comp-deftest 46670-1 () @@ -786,6 +799,8 @@ Return a list of results." (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t) insn))))))) +(declare-function comp-tests-tco-f nil) + (comp-deftest tco () "Check for tail recursion elimination." (let ((native-comp-speed 3) @@ -814,6 +829,8 @@ Return a list of results." (or (comp-tests-mentioned-p 'concat insn) (comp-tests-mentioned-p 'length insn))))))) +(declare-function comp-tests-fw-prop-1-f nil) + (comp-deftest fw-prop-1 () "Some tests for forward propagation." (let ((native-comp-speed 2) @@ -1404,7 +1421,7 @@ folded." (let ((native-comp-speed 3) (comp-post-pass-hooks '((comp-final comp-tests-pure-checker-1 comp-tests-pure-checker-2)))) - (load (native-compile (ert-resource-file "comp-test-pure.el"))) + (load (native-compile comp-test-pure-src)) (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-caller-f))) (should (= (comp-tests-pure-caller-f) 4)) commit dd6b151c25551fe125d61a54890756d9454cc402 Author: Robert Pluim Date: Fri Nov 26 15:54:49 2021 +0100 Specify initial values for glyphless-char-display-control elements * lisp/international/characters.el (glyphless-char-display-control): Specify :value for all the elements, since nil is not a valid value. diff --git a/lisp/international/characters.el b/lisp/international/characters.el index 5aefda2328..ec995743f5 100644 --- a/lisp/international/characters.el +++ b/lisp/international/characters.el @@ -1618,31 +1618,36 @@ function (`update-glyphless-char-display'), which updates :type '(alist :key-type (symbol :tag "Character Group") :value-type (symbol :tag "Display Method")) :options '((c0-control - (choice (const :tag "Don't display" zero-width) + (choice :value thin-space + (const :tag "Don't display" zero-width) (const :tag "Display as thin space" thin-space) (const :tag "Display as empty box" empty-box) (const :tag "Display acronym" acronym) (const :tag "Display hex code in a box" hex-code))) (c1-control - (choice (const :tag "Don't display" zero-width) + (choice :value thin-space + (const :tag "Don't display" zero-width) (const :tag "Display as thin space" thin-space) (const :tag "Display as empty box" empty-box) (const :tag "Display acronym" acronym) (const :tag "Display hex code in a box" hex-code))) (format-control - (choice (const :tag "Don't display" zero-width) + (choice :value thin-space + (const :tag "Don't display" zero-width) (const :tag "Display as thin space" thin-space) (const :tag "Display as empty box" empty-box) (const :tag "Display acronym" acronym) (const :tag "Display hex code in a box" hex-code))) (variation-selectors - (choice (const :tag "Don't display" zero-width) + (choice :value thin-space + (const :tag "Don't display" zero-width) (const :tag "Display as thin space" thin-space) (const :tag "Display as empty box" empty-box) (const :tag "Display acronym" acronym) (const :tag "Display hex code in a box" hex-code))) (no-font - (choice (const :tag "Don't display" zero-width) + (choice :value hex-code + (const :tag "Don't display" zero-width) (const :tag "Display as thin space" thin-space) (const :tag "Display as empty box" empty-box) (const :tag "Display acronym" acronym) commit 051e49fe3cec47f28ad8ca721d95e5b6db0c2b9c Author: Michael Albinus Date: Fri Nov 26 15:41:22 2021 +0100 Adapt test/infra/gitlab-ci.yml * test/infra/gitlab-ci.yml (test-all-inotify) (test-filenotify-gio, test-gnustep, test-native-comp-speed0): Add or adapt artifacts. diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 15d8b252e2..dd36d19b3d 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -202,7 +202,7 @@ test-all-inotify: public: true expire_in: 1 week paths: - - "**/*.log" + - "${test_name}/**/*.log" when: always variables: target: emacs-inotify @@ -221,6 +221,13 @@ test-filenotify-gio: needs: - job: build-image-filenotify-gio optional: true + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - "${test_name}/**/*.log" + when: always variables: target: emacs-filenotify-gio make_params: "-k -C test autorevert-tests.log filenotify-tests.log" @@ -238,6 +245,13 @@ test-gnustep: needs: - job: build-image-gnustep optional: true + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - "${test_name}/**/*.log" + when: always variables: target: emacs-gnustep make_params: install @@ -266,6 +280,13 @@ test-native-comp-speed0: needs: - job: build-native-comp-speed0 optional: true + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - "${test_name}/**/*.log" + when: always variables: target: emacs-native-comp-speed0 make_params: "-C test check SELECTOR='(not (tag :unstable))'" commit 57bb675cde25bc1b54d8eb8716b0024d5c1d5687 Author: Lars Ingebrigtsen Date: Fri Nov 26 15:26:14 2021 +0100 Add new face `gnus-header' * lisp/gnus/gnus-art.el (gnus-header): New face. (gnus-header-from, gnus-header-subject, gnus-header-newsgroups) (gnus-header-name, gnus-header-content): Inherit from this new face. diff --git a/etc/NEWS b/etc/NEWS index b23c63c990..87a7a43a5e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -348,6 +348,10 @@ the common "utm_" trackers from URLs. ** Gnus +--- +*** New face 'gnus-header'. +All other 'gnus-header-*' faces inherit from this face now. + +++ *** New user option 'gnus-treat-emojize-symbols'. If non-nil, symbols that have an emoji representation will be diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 9594c32e81..9a56e3a901 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -768,28 +768,37 @@ Obsolete; use the face `gnus-signature' for customizations instead." :group 'gnus-article-highlight :group 'gnus-article-signature) +(defface gnus-header + '((t nil)) + "Base face used for all Gnus header faces. +All the other `gnus-header-' faces inherit from this face." + :version "29.1" + :group 'gnus-article-headers + :group 'gnus-article-highlight) + (defface gnus-header-from '((((class color) (background dark)) - (:foreground "PaleGreen1")) + (:foreground "PaleGreen1" :inherit gnus-header)) (((class color) (background light)) - (:foreground "red3")) + (:foreground "red3" :inherit gnus-header)) (t - (:italic t))) + (:italic t :inherit gnus-header))) "Face used for displaying from headers." + :version "29.1" :group 'gnus-article-headers :group 'gnus-article-highlight) (defface gnus-header-subject '((((class color) (background dark)) - (:foreground "SeaGreen1")) + (:foreground "SeaGreen1" :inherit gnus-header)) (((class color) (background light)) - (:foreground "red4")) + (:foreground "red4" :inherit gnus-header)) (t - (:bold t :italic t))) + (:bold t :italic t :inherit gnus-header))) "Face used for displaying subject headers." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -797,7 +806,7 @@ Obsolete; use the face `gnus-signature' for customizations instead." (defface gnus-header-newsgroups '((((class color) (background dark)) - (:foreground "yellow" :italic t)) + (:foreground "yellow" :italic t :inherit gnus-header)) (((class color) (background light)) (:foreground "MidnightBlue" :italic t)) @@ -812,12 +821,12 @@ articles." (defface gnus-header-name '((((class color) (background dark)) - (:foreground "SpringGreen2")) + (:foreground "SpringGreen2" :inherit gnus-header)) (((class color) (background light)) - (:foreground "maroon")) + (:foreground "maroon" :inherit gnus-header)) (t - (:bold t))) + (:bold t :inherit gnus-header))) "Face used for displaying header names." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -825,12 +834,13 @@ articles." (defface gnus-header-content '((((class color) (background dark)) - (:foreground "SpringGreen1" :italic t)) + (:foreground "SpringGreen1" :italic t :inherit gnus-header)) (((class color) (background light)) - (:foreground "indianred4" :italic t)) + (:foreground "indianred4" :italic t :inherit gnus-header)) (t - (:italic t))) "Face used for displaying header content." + (:italic t :inherit gnus-header))) + "Face used for displaying header content." :group 'gnus-article-headers :group 'gnus-article-highlight) commit c32e8bdc23214793ffcb065ba8478570679c1f0a Author: Eli Zaretskii Date: Fri Nov 26 15:50:46 2021 +0200 ; * etc/NEWS: Fix wording of a recently-added entry. diff --git a/etc/NEWS b/etc/NEWS index 372d237772..b23c63c990 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -101,11 +101,11 @@ and pop-up menus. --- ** New minor mode 'pixel-scroll-precision-mode'. -When enabled, you can scroll the display up or down by individual -pixels in a way that corresponds with the movement of your mouse -wheel, if supported by the mouse wheel. Unlike 'pixel-scroll-mode', -this mode scrolls the display pixel-by-pixel, as opposed to only -animating line-by-line scrolls. +When enabled, and if your mouse supports it, you can scroll the +display up or down at pixel resolution, according to what your mouse +wheel reports. Unlike 'pixel-scroll-mode', this mode scrolls the +display pixel-by-pixel, as opposed to only animating line-by-line +scrolls. ** Terminal Emacs commit 43a595788de876b33cac0976548a0ce1c9add9c5 Author: Robert Pluim Date: Fri Nov 26 14:08:24 2021 +0100 Adjust custom-face-attributes for 'regular' weight Following the changes to support "medium" weight fonts, the weight for "normal" fonts is now reported as 'regular', which caused customize-face to display faces as lisp-expressions, since it didn't recognize that. This has been corrected. * lisp/cus-face.el (custom-face-attributes): Recognize 'regular' as a weight. diff --git a/lisp/cus-face.el b/lisp/cus-face.el index f83f1a2daa..c78a327fdf 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -102,7 +102,7 @@ (const :tag "semi-light" semi-light) (const :tag "demilight" semi-light) (const :tag "normal" normal) - (const :tag "regular" normal) + (const :tag "regular" regular) (const :tag "book" normal) (const :tag "medium" medium) (const :tag "semibold" semi-bold) commit 3f843b25dc96867043feebb1d928bde4a7a777a3 Author: Lars Ingebrigtsen Date: Fri Nov 26 14:17:10 2021 +0100 Add an intermediary face for mode lines: `mode-line-active' * doc/emacs/display.texi (Standard Faces): Document the new face. * lisp/faces.el (mode-line-active): New face. (mode-line): Don't inherit from vaiable-pitch. * src/xfaces.c (lookup_basic_face, realize_basic_faces) (syms_of_xfaces): * src/xdisp.c (window_box_height, window_text_pixel_size) (display_mode_lines, Fformat_mode_line): * src/dispextern.h (CURRENT_MODE_LINE_ACTIVE_FACE_ID_3) (CURRENT_MODE_LINE_ACTIVE_FACE_ID, enum face_id): Rename from *MODE_LINE_FACE_ID to *MODE_LINE_ACTIVE_FACE_ID. diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi index 7ea754612e..90044b1d4b 100644 --- a/doc/emacs/display.texi +++ b/doc/emacs/display.texi @@ -716,46 +716,62 @@ frame: @table @code @item mode-line @cindex @code{mode-line} face -@cindex faces for mode lines -This face is used for the mode line of the currently selected window, +This is the base face used for the mode lines, as well as header lines and for menu bars when toolkit menus are not used. By default, it's drawn with shadows for a raised effect on graphical displays, and drawn as the inverse of the default face on non-windowed terminals. + +The @code{mode-line-active} and @code{mode-line-inactive} faces (which +are the ones used on the mode lines) inherit from this face. + +@item mode-line-active +@cindex faces for mode lines +Like @code{mode-line}, but used for the mode line of the currently +selected window. This face inherits from @code{mode-line}, so changes +in that face affect mode lines in all windows. + @item mode-line-inactive @cindex @code{mode-line-inactive} face Like @code{mode-line}, but used for mode lines of the windows other than the selected one (if @code{mode-line-in-non-selected-windows} is non-@code{nil}). This face inherits from @code{mode-line}, so changes in that face affect mode lines in all windows. + @item mode-line-highlight @cindex @code{mode-line-highlight} face Like @code{highlight}, but used for mouse-sensitive portions of text on mode lines. Such portions of text typically pop up tooltips (@pxref{Tooltips}) when the mouse pointer hovers above them. + @item mode-line-buffer-id @cindex @code{mode-line-buffer-id} face This face is used for buffer identification parts in the mode line. + @item header-line @cindex @code{header-line} face Similar to @code{mode-line} for a window's header line, which appears at the top of a window just as the mode line appears at the bottom. Most windows do not have a header line---only some special modes, such Info mode, create one. + @item header-line-highlight @cindex @code{header-line-highlight} face Similar to @code{highlight} and @code{mode-line-highlight}, but used for mouse-sensitive portions of text on header lines. This is a separate face because the @code{header-line} face might be customized in a way that does not interact well with @code{highlight}. + @item tab-line @cindex @code{tab-line} face Similar to @code{mode-line} for a window's tab line, which appears at the top of a window with tabs representing window buffers. @xref{Tab Line}. + @item vertical-border @cindex @code{vertical-border} face This face is used for the vertical divider between windows on text terminals. + @item minibuffer-prompt @cindex @code{minibuffer-prompt} face @vindex minibuffer-prompt-properties @@ -765,19 +781,23 @@ By default, Emacs automatically adds this face to the value of properties (@pxref{Text Properties,,, elisp, the Emacs Lisp Reference Manual}) used to display the prompt text. (This variable takes effect when you enter the minibuffer.) + @item fringe @cindex @code{fringe} face The face for the fringes to the left and right of windows on graphic displays. (The fringes are the narrow portions of the Emacs frame between the text area and the window's right and left borders.) @xref{Fringes}. + @item cursor The @code{:background} attribute of this face specifies the color of the text cursor. @xref{Cursor Display}. + @item tooltip This face is used for tooltip text. By default, if Emacs is built with GTK+ support, tooltips are drawn via GTK+ and this face has no effect. @xref{Tooltips}. + @item mouse This face determines the color of the mouse pointer. @end table diff --git a/etc/NEWS b/etc/NEWS index 3a0b46d399..372d237772 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -75,13 +75,19 @@ time. * Changes in Emacs 29.1 ++++ +** New face 'mode-line-active'. +This inherits from the 'mode-line' face, but is the face actually used +on the mode lines (along with 'mode-line-inactive'). + --- ** The mode line now uses a proportional font by default. -To get the old monospaced mode line back, customize the 'mode-line' -face not to inherit from the 'variable-pitch' face, or add this to -your ~/.emacs: +To get the old monospaced mode line back, customize the +'mode-line-active' and 'mode-line-inactive' faces not to inherit from +the 'variable-pitch' face, or add this to your ~/.emacs: - (set-face-attribute 'mode-line nil :inherit 'default) + (set-face-attribute 'mode-line-active nil :inherit 'mode-line) + (set-face-attribute 'mode-line-inactive nil :inherit 'mode-line) +++ ** New function 'buffer-text-pixel-size'. diff --git a/lisp/faces.el b/lisp/faces.el index 38feefba48..5ed6bd1766 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2611,19 +2611,26 @@ non-nil." (defface mode-line '((((class color) (min-colors 88)) :box (:line-width -1 :style released-button) - :inherit variable-pitch :background "grey75" :foreground "black") (t - :inverse-video t - :inherit variable-pitch)) - "Basic mode line face for selected window." + :inverse-video t)) + "Face for the mode lines (for the selected window) as well as header lines. +See `mode-line-display' for the face used on mode lines." :version "21.1" :group 'mode-line-faces :group 'basic-faces) +(defface mode-line-active + '((t :inherit (mode-line variable-pitch))) + "Face for the selected mode line. +This inherits from the `mode-line' face." + :version "29.1" + :group 'mode-line-faces + :group 'basic-faces) + (defface mode-line-inactive '((default - :inherit mode-line) + :inherit (mode-line variable-pitch)) (((class color) (min-colors 88) (background light)) :weight light :box (:line-width -1 :color "grey75" :style nil) diff --git a/src/dispextern.h b/src/dispextern.h index 088297157a..ff4e7293d8 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -1477,21 +1477,23 @@ struct glyph_string compared against minibuf_window (if SELW doesn't match), and SCRW which is compared against minibuf_selected_window (if MBW matches). */ -#define CURRENT_MODE_LINE_FACE_ID_3(SELW, MBW, SCRW) \ +#define CURRENT_MODE_LINE_ACTIVE_FACE_ID_3(SELW, MBW, SCRW) \ ((!mode_line_in_non_selected_windows \ || (SELW) == XWINDOW (selected_window) \ || (minibuf_level > 0 \ && !NILP (minibuf_selected_window) \ && (MBW) == XWINDOW (minibuf_window) \ && (SCRW) == XWINDOW (minibuf_selected_window))) \ - ? MODE_LINE_FACE_ID \ + ? MODE_LINE_ACTIVE_FACE_ID \ : MODE_LINE_INACTIVE_FACE_ID) /* Return the desired face id for the mode line of window W. */ -#define CURRENT_MODE_LINE_FACE_ID(W) \ - (CURRENT_MODE_LINE_FACE_ID_3((W), XWINDOW (selected_window), (W))) +#define CURRENT_MODE_LINE_ACTIVE_FACE_ID(W) \ + (CURRENT_MODE_LINE_ACTIVE_FACE_ID_3((W), \ + XWINDOW (selected_window), \ + (W))) /* Return the current height of the mode line of window W. If not known from W->mode_line_height, look at W's current glyph matrix, or return @@ -1504,7 +1506,7 @@ struct glyph_string = (MATRIX_MODE_LINE_HEIGHT ((W)->current_matrix) \ ? MATRIX_MODE_LINE_HEIGHT ((W)->current_matrix) \ : estimate_mode_line_height \ - (XFRAME ((W)->frame), CURRENT_MODE_LINE_FACE_ID (W))))) + (XFRAME ((W)->frame), CURRENT_MODE_LINE_ACTIVE_FACE_ID (W))))) /* Return the current height of the header line of window W. If not known from W->header_line_height, look at W's current glyph matrix, or return @@ -1818,7 +1820,7 @@ face_tty_specified_color (unsigned long color) enum face_id { DEFAULT_FACE_ID, - MODE_LINE_FACE_ID, + MODE_LINE_ACTIVE_FACE_ID, MODE_LINE_INACTIVE_FACE_ID, TOOL_BAR_FACE_ID, FRINGE_FACE_ID, @@ -1836,6 +1838,7 @@ enum face_id CHILD_FRAME_BORDER_FACE_ID, TAB_BAR_FACE_ID, TAB_LINE_FACE_ID, + MODE_LINE_FACE_ID, BASIC_FACE_ID_SENTINEL }; @@ -2545,7 +2548,8 @@ struct it enum line_wrap_method line_wrap; /* The ID of the default face to use. One of DEFAULT_FACE_ID, - MODE_LINE_FACE_ID, etc, depending on what we are displaying. */ + MODE_LINE_ACTIVE_FACE_ID, etc, depending on what we are + displaying. */ int base_face_id; /* If `what' == IT_CHARACTER, the character and the length in bytes diff --git a/src/xdisp.c b/src/xdisp.c index d6b53eacea..24049ab4e3 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -1285,8 +1285,8 @@ window_box_height (struct window *w) if (ml_row && ml_row->mode_line_p) height -= ml_row->height; else - height -= estimate_mode_line_height (f, - CURRENT_MODE_LINE_FACE_ID (w)); + height -= estimate_mode_line_height + (f, CURRENT_MODE_LINE_ACTIVE_FACE_ID (w)); } } @@ -1691,7 +1691,7 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y, = window_parameter (w, Qmode_line_format); w->mode_line_height - = display_mode_line (w, CURRENT_MODE_LINE_FACE_ID (w), + = display_mode_line (w, CURRENT_MODE_LINE_ACTIVE_FACE_ID (w), NILP (window_mode_line_format) ? BVAR (current_buffer, mode_line_format) : window_mode_line_format); @@ -3146,11 +3146,11 @@ CHECK_WINDOW_END (struct window *w) will produce glyphs in that row. BASE_FACE_ID is the id of a base face to use. It must be one of - DEFAULT_FACE_ID for normal text, MODE_LINE_FACE_ID, + DEFAULT_FACE_ID for normal text, MODE_LINE_ACTIVE_FACE_ID, MODE_LINE_INACTIVE_FACE_ID, or HEADER_LINE_FACE_ID for displaying mode lines, or TOOL_BAR_FACE_ID for displaying the tool-bar. - If ROW is null and BASE_FACE_ID is equal to MODE_LINE_FACE_ID, + If ROW is null and BASE_FACE_ID is equal to MODE_LINE_ACTIVE_FACE_ID, MODE_LINE_INACTIVE_FACE_ID, or HEADER_LINE_FACE_ID, the iterator will be initialized to use the corresponding mode line glyph row of the desired matrix of W. */ @@ -3196,7 +3196,7 @@ init_iterator (struct it *it, struct window *w, appropriate. */ if (row == NULL) { - if (base_face_id == MODE_LINE_FACE_ID + if (base_face_id == MODE_LINE_ACTIVE_FACE_ID || base_face_id == MODE_LINE_INACTIVE_FACE_ID) row = MATRIX_MODE_LINE_ROW (w->desired_matrix); else if (base_face_id == TAB_LINE_FACE_ID) @@ -11020,7 +11020,7 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to, Li Lisp_Object window_mode_line_format = window_parameter (w, Qmode_line_format); - y = y + display_mode_line (w, CURRENT_MODE_LINE_FACE_ID (w), + y = y + display_mode_line (w, CURRENT_MODE_LINE_ACTIVE_FACE_ID (w), NILP (window_mode_line_format) ? BVAR (current_buffer, mode_line_format) : window_mode_line_format); @@ -25813,7 +25813,8 @@ display_mode_lines (struct window *w) struct window *sel_w = XWINDOW (old_selected_window); /* Select mode line face based on the real selected window. */ - display_mode_line (w, CURRENT_MODE_LINE_FACE_ID_3 (sel_w, sel_w, w), + display_mode_line (w, + CURRENT_MODE_LINE_ACTIVE_FACE_ID_3 (sel_w, sel_w, w), NILP (window_mode_line_format) ? BVAR (current_buffer, mode_line_format) : window_mode_line_format); @@ -25852,11 +25853,11 @@ display_mode_lines (struct window *w) } -/* Display mode or header/tab line of window W. FACE_ID specifies which - line to display; it is either MODE_LINE_FACE_ID, HEADER_LINE_FACE_ID or - TAB_LINE_FACE_ID. FORMAT is the mode/header/tab line format to - display. Value is the pixel height of the mode/header/tab line - displayed. */ +/* Display mode or header/tab line of window W. FACE_ID specifies + which line to display; it is either MODE_LINE_ACTIVE_FACE_ID, + HEADER_LINE_FACE_ID or TAB_LINE_FACE_ID. FORMAT is the + mode/header/tab line format to display. Value is the pixel height + of the mode/header/tab line displayed. */ static int display_mode_line (struct window *w, enum face_id face_id, Lisp_Object format) @@ -26649,8 +26650,8 @@ are the selected window and the WINDOW's buffer). */) face_id = (NILP (face) || EQ (face, Qdefault)) ? DEFAULT_FACE_ID : EQ (face, Qt) ? (EQ (window, selected_window) - ? MODE_LINE_FACE_ID : MODE_LINE_INACTIVE_FACE_ID) - : EQ (face, Qmode_line) ? MODE_LINE_FACE_ID + ? MODE_LINE_ACTIVE_FACE_ID : MODE_LINE_INACTIVE_FACE_ID) + : EQ (face, Qmode_line_active) ? MODE_LINE_ACTIVE_FACE_ID : EQ (face, Qmode_line_inactive) ? MODE_LINE_INACTIVE_FACE_ID : EQ (face, Qheader_line) ? HEADER_LINE_FACE_ID : EQ (face, Qtab_line) ? TAB_LINE_FACE_ID diff --git a/src/xfaces.c b/src/xfaces.c index 174a1ca47c..813d89e5a3 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -4857,7 +4857,7 @@ lookup_basic_face (struct window *w, struct frame *f, int face_id) switch (face_id) { case DEFAULT_FACE_ID: name = Qdefault; break; - case MODE_LINE_FACE_ID: name = Qmode_line; break; + case MODE_LINE_ACTIVE_FACE_ID: name = Qmode_line_active; break; case MODE_LINE_INACTIVE_FACE_ID: name = Qmode_line_inactive; break; case HEADER_LINE_FACE_ID: name = Qheader_line; break; case TAB_LINE_FACE_ID: name = Qtab_line; break; @@ -5569,6 +5569,7 @@ realize_basic_faces (struct frame *f) if (realize_default_face (f)) { realize_named_face (f, Qmode_line, MODE_LINE_FACE_ID); + realize_named_face (f, Qmode_line_active, MODE_LINE_ACTIVE_FACE_ID); realize_named_face (f, Qmode_line_inactive, MODE_LINE_INACTIVE_FACE_ID); realize_named_face (f, Qtool_bar, TOOL_BAR_FACE_ID); realize_named_face (f, Qfringe, FRINGE_FACE_ID); @@ -6945,6 +6946,7 @@ syms_of_xfaces (void) DEFSYM (Qborder, "border"); DEFSYM (Qmouse, "mouse"); DEFSYM (Qmode_line_inactive, "mode-line-inactive"); + DEFSYM (Qmode_line_active, "mode-line-active"); DEFSYM (Qvertical_border, "vertical-border"); DEFSYM (Qwindow_divider, "window-divider"); DEFSYM (Qwindow_divider_first_pixel, "window-divider-first-pixel"); commit 5d6e1c749a669d33db2936b106ae41ce59473ea1 Author: Po Lu Date: Fri Nov 26 17:42:45 2021 +0800 Move the precision pixel scrolling feature to pixel-scroll.el * etc/NEWS: Update NEWS entry for 'pixel-scroll-precision-mode' * lisp/better-pixel-scroll.el: Remove file. * src/pixel-scroll.el (x-coalesce-scroll-events): New variable declaration. (pixel-scroll-precision-mode-map): New variable. (pixel-scroll-precision-scroll-down): (pixel-scroll-precision-scroll-up): (pixel-scroll-precision): New functions. (pixel-scroll-precision-mode): New minor mode. diff --git a/etc/NEWS b/etc/NEWS index 329de2f811..3a0b46d399 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -94,10 +94,12 @@ This controls the thickness of the external borders of the menu bars and pop-up menus. --- -** New minor mode 'better-pixel-scroll-mode'. -When enabled, using this mode with a capable scroll wheel will result -in the display being scrolled precisely according to the turning of -that wheel. +** New minor mode 'pixel-scroll-precision-mode'. +When enabled, you can scroll the display up or down by individual +pixels in a way that corresponds with the movement of your mouse +wheel, if supported by the mouse wheel. Unlike 'pixel-scroll-mode', +this mode scrolls the display pixel-by-pixel, as opposed to only +animating line-by-line scrolls. ** Terminal Emacs diff --git a/lisp/better-pixel-scroll.el b/lisp/better-pixel-scroll.el deleted file mode 100644 index c1469108e0..0000000000 --- a/lisp/better-pixel-scroll.el +++ /dev/null @@ -1,147 +0,0 @@ -;;; better-pixel-scroll.el --- Pixel scrolling support -*- lexical-binding:t -*- - -;; Copyright (C) 2021 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: - -;; This enables the use of smooth scroll events provided by XInput 2 -;; or NS to scroll the display according to the user's precise turning -;; of the mouse wheel. - -;;; Code: - -(require 'mwheel) -(require 'subr-x) - -(defvar x-coalesce-scroll-events) - -(defvar better-pixel-scroll-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [wheel-down] #'better-pixel-scroll) - (define-key map [wheel-up] #'better-pixel-scroll) - map) - "The key map used by `better-pixel-scroll-mode'.") - -(defun better-pixel-scroll-scroll-down (delta) - "Scroll the current window down by DELTA pixels. -Note that this function doesn't work if DELTA is larger than -the height of the current window." - (when-let* ((posn (posn-at-point)) - (current-y (cdr (posn-x-y posn))) - (min-y (+ (window-tab-line-height) - (window-header-line-height))) - (cursor-height (line-pixel-height)) - (window-height (window-text-height nil t)) - (next-height (save-excursion - (vertical-motion 1) - (line-pixel-height)))) - (if (and (> delta 0) - (<= cursor-height window-height)) - (while (< (- current-y min-y) delta) - (vertical-motion 1) - (setq current-y (+ current-y - (line-pixel-height))) - (when (eobp) - (error "End of buffer"))) - (when (< (- (cdr (posn-object-width-height posn)) - (cdr (posn-object-x-y posn))) - (- window-height next-height)) - (vertical-motion 1) - (setq posn (posn-at-point) - current-y (cdr (posn-x-y posn))) - (while (< (- current-y min-y) delta) - (vertical-motion 1) - (setq current-y (+ current-y - (line-pixel-height))) - (when (eobp) - (error "End of buffer"))))) - (let* ((desired-pos (posn-at-x-y 0 (+ delta - (window-tab-line-height) - (window-header-line-height)))) - (desired-start (posn-point desired-pos)) - (desired-vscroll (cdr (posn-object-x-y desired-pos)))) - (unless (eq (window-start) desired-start) - (set-window-start nil desired-start t)) - (set-window-vscroll nil desired-vscroll t)))) - -(defun better-pixel-scroll-scroll-up (delta) - "Scroll the current window up by DELTA pixels." - (when-let* ((max-y (- (window-text-height nil t) - (window-tab-line-height) - (window-header-line-height))) - (posn (posn-at-point)) - (current-y (+ (cdr (posn-x-y posn)) - (cdr (posn-object-width-height posn))))) - (while (< (- max-y current-y) delta) - (vertical-motion -1) - (setq current-y (- current-y (line-pixel-height))))) - (let ((current-vscroll (window-vscroll nil t))) - (setq delta (- delta current-vscroll)) - (set-window-vscroll nil 0 t)) - (while (> delta 0) - (set-window-start nil (save-excursion - (goto-char (window-start)) - (when (zerop (vertical-motion -1)) - (set-window-vscroll nil 0) - (signal 'beginning-of-buffer nil)) - (setq delta (- delta (line-pixel-height))) - (point)) - t)) - (when (< delta 0) - (when-let* ((desired-pos (posn-at-x-y 0 (+ (- delta) - (window-tab-line-height) - (window-header-line-height)))) - (desired-start (posn-point desired-pos)) - (desired-vscroll (cdr (posn-object-x-y desired-pos)))) - (unless (eq (window-start) desired-start) - (set-window-start nil desired-start t)) - (set-window-vscroll nil desired-vscroll t)))) - -(defun better-pixel-scroll (event &optional arg) - "Scroll the display according to EVENT. -Take into account any pixel deltas in EVENT to scroll the display -according to the user's turning the mouse wheel. If EVENT does -not have precise scrolling deltas, call `mwheel-scroll' instead. -ARG is passed to `mwheel-scroll', should that be called." - (interactive (list last-input-event current-prefix-arg)) - (let ((window (mwheel-event-window event))) - (if (and (nth 4 event) - (zerop (window-hscroll window))) - (let ((delta (round (cdr (nth 4 event))))) - (if (> (abs delta) (window-text-height window t)) - (mwheel-scroll event arg) - (with-selected-window window - (if (< delta 0) - (better-pixel-scroll-scroll-down (- delta)) - (better-pixel-scroll-scroll-up delta))))) - (mwheel-scroll event arg)))) - -;;;###autoload -(define-minor-mode better-pixel-scroll-mode - "Toggle pixel scrolling. -When enabled, this minor mode allows to scroll the display -precisely, according to the turning of the mouse wheel." - :global t - :group 'mouse - :keymap better-pixel-scroll-mode-map - (setq x-coalesce-scroll-events - (not better-pixel-scroll-mode))) - -(provide 'better-pixel-scroll) - -;;; better-pixel-scroll.el ends here. diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 249484cf58..f6d1d0ff8c 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -67,6 +67,7 @@ ;;; Code: (require 'mwheel) +(require 'subr-x) (defvar pixel-wait 0 "Idle time on each step of pixel scroll specified in second. @@ -90,6 +91,15 @@ is always with pixel resolution.") (defvar pixel-last-scroll-time 0 "Time when the last scrolling was made, in second since the epoch.") +(defvar x-coalesce-scroll-events) + +(defvar pixel-scroll-precision-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [wheel-down] #'pixel-scroll-precision) + (define-key map [wheel-up] #'pixel-scroll-precision) + map) + "The key map used by `pixel-scroll-precision-mode'.") + (defun pixel-scroll-in-rush-p () "Return non-nil if next scroll should be non-smooth. When scrolling request is delivered soon after the previous one, @@ -354,5 +364,116 @@ Otherwise, redisplay will reset the window's vscroll." (set-window-start nil (pixel-point-at-unseen-line) t) (set-window-vscroll nil vscroll t)) +;; FIXME: This doesn't work when DELTA is larger than the height +;; of the current window, and someone should probably fix that +;; at some point. +(defun pixel-scroll-precision-scroll-down (delta) + "Scroll the current window down by DELTA pixels. +Note that this function doesn't work if DELTA is larger than +the height of the current window." + (when-let* ((posn (posn-at-point)) + (current-y (cdr (posn-x-y posn))) + (min-y (+ (frame-char-height) + (window-tab-line-height) + (window-header-line-height))) + (cursor-height (line-pixel-height)) + (window-height (window-text-height nil t)) + (next-height (save-excursion + (vertical-motion 1) + (line-pixel-height)))) + (if (and (> delta 0) + (<= cursor-height window-height)) + (while (< (- current-y min-y) delta) + (vertical-motion 1) + (setq current-y (+ current-y + (line-pixel-height))) + (when (eobp) + (signal 'end-of-buffer nil))) + (when (< (- (cdr (posn-object-width-height posn)) + (cdr (posn-object-x-y posn))) + (- window-height next-height)) + (vertical-motion 1) + (setq posn (posn-at-point) + current-y (cdr (posn-x-y posn))) + (while (< (- current-y min-y) delta) + (vertical-motion 1) + (setq current-y (+ current-y + (line-pixel-height))) + (when (eobp) + (signal 'end-of-buffer nil))))) + (let* ((desired-pos (posn-at-x-y 0 (+ delta + (window-tab-line-height) + (window-header-line-height)))) + (desired-start (posn-point desired-pos)) + (desired-vscroll (cdr (posn-object-x-y desired-pos)))) + (unless (eq (window-start) desired-start) + (set-window-start nil desired-start t)) + (set-window-vscroll nil desired-vscroll t)))) + +(defun pixel-scroll-precision-scroll-up (delta) + "Scroll the current window up by DELTA pixels." + (when-let* ((max-y (- (window-text-height nil t) + (frame-char-height) + (window-tab-line-height) + (window-header-line-height))) + (posn (posn-at-point)) + (current-y (+ (cdr (posn-x-y posn)) + (line-pixel-height)))) + (while (< (- max-y current-y) delta) + (vertical-motion -1) + (setq current-y (- current-y (line-pixel-height))))) + (let ((current-vscroll (window-vscroll nil t))) + (setq delta (- delta current-vscroll)) + (set-window-vscroll nil 0 t)) + (while (> delta 0) + (set-window-start nil (save-excursion + (goto-char (window-start)) + (when (zerop (vertical-motion -1)) + (set-window-vscroll nil 0) + (signal 'beginning-of-buffer nil)) + (setq delta (- delta (line-pixel-height))) + (point)) + t)) + (when (< delta 0) + (when-let* ((desired-pos (posn-at-x-y 0 (+ (- delta) + (window-tab-line-height) + (window-header-line-height)))) + (desired-start (posn-point desired-pos)) + (desired-vscroll (cdr (posn-object-x-y desired-pos)))) + (unless (eq (window-start) desired-start) + (set-window-start nil desired-start t)) + (set-window-vscroll nil desired-vscroll t)))) + +;; FIXME: This doesn't work when there's an image above the current +;; line that is taller than the window. +(defun pixel-scroll-precision (event) + "Scroll the display vertically by pixels according to EVENT. +Move the display up or down by the pixel deltas in EVENT to +scroll the display according to the user's turning the mouse +wheel." + (interactive "e") + (let ((window (mwheel-event-window event))) + (if (and (nth 4 event) + (zerop (window-hscroll window))) + (let ((delta (round (cdr (nth 4 event))))) + (if (> (abs delta) (window-text-height window t)) + (mwheel-scroll event nil) + (with-selected-window window + (if (< delta 0) + (pixel-scroll-precision-scroll-down (- delta)) + (pixel-scroll-precision-scroll-up delta))))) + (mwheel-scroll event nil)))) + +;;;###autoload +(define-minor-mode pixel-scroll-precision-mode + "Toggle pixel scrolling. +When enabled, this minor mode allows to scroll the display +precisely, according to the turning of the mouse wheel." + :global t + :group 'mouse + :keymap pixel-scroll-precision-mode-map + (setq x-coalesce-scroll-events + (not pixel-scroll-precision-mode))) + (provide 'pixel-scroll) ;;; pixel-scroll.el ends here commit 673eadaeb55de71016fab371613d8e930f6d7c04 Author: Po Lu Date: Fri Nov 26 19:59:54 2021 +0800 Explain confusing aspects of XInput 2 scroll wheel reporting * src/xterm.c (x_init_master_valuators): Explain how XInput 2 reports scroll wheel movement. (handle_one_xevent): Explain why XI2 scroll valuators are reset after each enter events. diff --git a/src/xterm.c b/src/xterm.c index 821c92c4dd..c7950c6f9f 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -372,6 +372,29 @@ x_free_xi_devices (struct x_display_info *dpyinfo) unblock_input (); } +/* The code below handles the tracking of scroll valuators on XInput + 2, in order to support scroll wheels that report information more + granular than a screen line. + + On X, when the XInput 2 extension is being utilized, the states of + the mouse wheels in each axis are stored as absolute values inside + "valuators" attached to each mouse device. To obtain the delta of + the scroll wheel from a motion event (which is used to report that + some valuator has changed), it is necessary to iterate over every + valuator that changed, and compare its previous value to the + current value of the valuator. + + Each individual valuator also has an "interval", which is the + amount you must divide that delta by in order to obtain a delta in + the terms of scroll units. + + This delta however is still intermediate, to make driver + implementations easier. The XInput developers recommend (and most + programs use) the following algorithm to convert from scroll unit + deltas to pixel deltas: + + pixels_scrolled = pow (window_height, 2.0 / 3.0) * delta; */ + /* Setup valuator tracking for XI2 master devices on DPYINFO->display. */ @@ -9874,6 +9897,19 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_display_set_last_user_time (dpyinfo, xi_event->time); x_detect_focus_change (dpyinfo, any, event, &inev.ie); + /* One problem behind the design of XInput 2 scrolling is + that valuators are not unique to each window, but only + the window that has grabbed the valuator's device or + the window that the device's pointer is on top of can + receive motion events. There is also no way to + retrieve the value of a valuator outside of each motion + event. + + As such, to prevent wildly inaccurate results when the + valuators have changed outside Emacs, we reset our + records of each valuator's value whenever the pointer + re-enters a frame after its valuators have potentially + been changed elsewhere. */ if (enter->detail != XINotifyInferior && enter->mode != XINotifyPassiveUngrab && enter->mode != XINotifyUngrab && any) @@ -9947,6 +9983,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, struct xi_scroll_valuator_t *val; double delta, scroll_unit; + + /* See the comment on top of + x_init_master_valuators for more details on how + scroll wheel movement is reported on XInput 2. */ delta = x_get_scroll_valuator_delta (dpyinfo, xev->deviceid, i, *values, &val); @@ -9972,7 +10012,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto XI_OTHER; } - scroll_unit = pow (FRAME_PIXEL_HEIGHT (f), 2.0 / 3.0); found_valuator = true; if (signbit (delta) != signbit (val->emacs_value)) @@ -9999,6 +10038,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, |= x_x_to_emacs_modifiers (dpyinfo, xev->mods.effective); + scroll_unit = pow (FRAME_PIXEL_HEIGHT (f), 2.0 / 3.0); + if (val->horizontal) { inev.ie.arg commit 824d31e3bf22d57bc8f8011e6719b15059bea55b Author: Dmitry Gutov Date: Fri Nov 26 16:03:30 2021 +0300 Remove empty lines from stash read prompt * lisp/vc/vc-git.el (vc-git-stash-read): Pass OMIT-NULLS (bug#52119). (vc-git-stash-list): Simplify. diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 2d35061b26..4b6cd93074 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1688,7 +1688,7 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (let ((stash (completing-read prompt (split-string - (or (vc-git--run-command-string nil "stash" "list") "") "\n") + (or (vc-git--run-command-string nil "stash" "list") "") "\n" t) nil :require-match nil 'vc-git-stash-read-history))) (if (string-equal stash "") (user-error "Not a stash") @@ -1733,12 +1733,11 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (defun vc-git-stash-list () (when-let ((out (vc-git--run-command-string nil "stash" "list"))) - (delete - "" - (split-string - (replace-regexp-in-string - "^stash@" " " out) - "\n")))) + (split-string + (replace-regexp-in-string + "^stash@" " " out) + "\n" + t))) (defun vc-git-stash-get-at-point (point) (save-excursion commit c56e05b968d437b807a194ecdcd308b045143846 Author: Po Lu Date: Fri Nov 26 17:42:51 2021 +0800 Make XInput 2 builds work without cairo * src/xterm.c: Move some defines around so XI2 code doesn't get ifdef'd out if Cairo is disabled. diff --git a/src/xterm.c b/src/xterm.c index 0a3aeeed70..821c92c4dd 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -345,6 +345,7 @@ x_extension_initialize (struct x_display_info *dpyinfo) dpyinfo->ext_codes = ext_codes; } +#endif /* HAVE_CAIRO */ #ifdef HAVE_XINPUT2 @@ -564,6 +565,8 @@ xi_reset_scroll_valuators_for_device_id (struct x_display_info *dpyinfo, int id) #endif +#ifdef USE_CAIRO + void x_cr_destroy_frame_context (struct frame *f) { commit 3e40a56d52b932fa13d3093e15e39277a6684fec Author: Robert Pluim Date: Fri Nov 26 09:35:25 2021 +0100 ; * lisp/cus-face.el: Remove duplicated width entry. diff --git a/lisp/cus-face.el b/lisp/cus-face.el index 16fa55e826..f83f1a2daa 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -67,7 +67,6 @@ (const :tag "extra-condensed" extra-condensed) (const :tag "extraexpanded" extra-expanded) (const :tag "extra-expanded" extra-expanded) - (const :tag "medium" normal) (const :tag "narrow" condensed) (const :tag "normal" normal) (const :tag "medium" normal) commit 62d7ddb57c3db8f1e5cb20c6d82566b644faaa8c Merge: 09c28ca073 cfaf681d3d Author: Stefan Kangas Date: Fri Nov 26 07:17:21 2021 +0100 Merge from origin/emacs-28 cfaf681d3d ; * src/emacs.c (main): Add commentary about command-line ... 4d16a2f737 Fix pdf generation with Texinfo 6.7 a22c9a34bd Fix 'posn-at-point' near some overlays d1aa552d11 ; * CONTRIBUTE: No cleanups on release branches, even in d... 588caf0b27 * lisp/repeat.el (repeat-post-hook): Add check symbolp rep... commit 09c28ca073e3d4fb68fb7685d6e6ce6dd521fd0e Author: Po Lu Date: Fri Nov 26 06:13:27 2021 +0000 Fix sign of pixel scroll events on Haiku * src/haikuterm.c (haiku_read_socket): Fix sign of scroll events. diff --git a/src/haikuterm.c b/src/haikuterm.c index 97dbe3c8d3..6bf4589406 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -3033,8 +3033,8 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) XSETINT (inev.x, x); XSETINT (inev.y, y); - inev.arg = list3 (Qnil, make_float (px), - make_float (py)); + inev.arg = list3 (Qnil, make_float (-px), + make_float (-py)); XSETFRAME (inev.frame_or_window, f); inev.modifiers |= (signbit (inev.kind == HORIZ_WHEEL_EVENT commit 8887213dcf502269fb81deda640a204a801b602c Author: Po Lu Date: Fri Nov 26 13:33:39 2021 +0800 Make tab bar option visible in the menu bar on NS * lisp/menu-bar.el (menu-bar-showhide-menu): Make `showhide-tab-bar' visible on NS as well. diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index 274f594f69..8c04e35a51 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -1347,14 +1347,13 @@ mail status in mode line")) (frame-parameter (menu-bar-frame-for-menubar) 'menu-bar-lines))))) - (unless (featurep 'ns) - (bindings--define-key menu [showhide-tab-bar] - '(menu-item "Tab Bar" toggle-tab-bar-mode-from-frame - :help "Turn tab bar on/off" - :button - (:toggle . (menu-bar-positive-p - (frame-parameter (menu-bar-frame-for-menubar) - 'tab-bar-lines)))))) + (bindings--define-key menu [showhide-tab-bar] + '(menu-item "Tab Bar" toggle-tab-bar-mode-from-frame + :help "Turn tab bar on/off" + :button + (:toggle . (menu-bar-positive-p + (frame-parameter (menu-bar-frame-for-menubar) + 'tab-bar-lines))))) (if (and (boundp 'menu-bar-showhide-tool-bar-menu) (keymapp menu-bar-showhide-tool-bar-menu)) commit 897a101cd3b7d6b46e3b14e80e3c77373246be6a Author: Po Lu Date: Fri Nov 26 13:21:48 2021 +0800 Make pixel scrolling through images at the first line smoother * lisp/better-pixel-scroll.el (better-pixel-scroll-scroll-up): Try to reset vscroll if already vscrolled. diff --git a/lisp/better-pixel-scroll.el b/lisp/better-pixel-scroll.el index 6101778ac0..c1469108e0 100644 --- a/lisp/better-pixel-scroll.el +++ b/lisp/better-pixel-scroll.el @@ -88,10 +88,11 @@ the height of the current window." (current-y (+ (cdr (posn-x-y posn)) (cdr (posn-object-width-height posn))))) (while (< (- max-y current-y) delta) - (when (zerop (vertical-motion -1)) - (set-window-vscroll nil 0) - (signal 'beginning-of-buffer nil)) + (vertical-motion -1) (setq current-y (- current-y (line-pixel-height))))) + (let ((current-vscroll (window-vscroll nil t))) + (setq delta (- delta current-vscroll)) + (set-window-vscroll nil 0 t)) (while (> delta 0) (set-window-start nil (save-excursion (goto-char (window-start)) commit fc8b87d904f63a73c3bb4db69341f0308b2bc8fa Author: Po Lu Date: Fri Nov 26 13:07:54 2021 +0800 Don't perform pixel scrolling when window is hscrolled * lisp/better-pixel-scroll.el (better-pixel-scroll): Call mwheel-scroll instead if window is hscrolled. diff --git a/lisp/better-pixel-scroll.el b/lisp/better-pixel-scroll.el index ac342a425a..6101778ac0 100644 --- a/lisp/better-pixel-scroll.el +++ b/lisp/better-pixel-scroll.el @@ -118,16 +118,17 @@ according to the user's turning the mouse wheel. If EVENT does not have precise scrolling deltas, call `mwheel-scroll' instead. ARG is passed to `mwheel-scroll', should that be called." (interactive (list last-input-event current-prefix-arg)) - (if (nth 4 event) - (let ((delta (round (cdr (nth 4 event)))) - (window (mwheel-event-window event))) - (if (> (abs delta) (window-text-height window t)) - (mwheel-scroll event arg) - (with-selected-window window + (let ((window (mwheel-event-window event))) + (if (and (nth 4 event) + (zerop (window-hscroll window))) + (let ((delta (round (cdr (nth 4 event))))) + (if (> (abs delta) (window-text-height window t)) + (mwheel-scroll event arg) + (with-selected-window window (if (< delta 0) (better-pixel-scroll-scroll-down (- delta)) (better-pixel-scroll-scroll-up delta))))) - (mwheel-scroll event arg))) + (mwheel-scroll event arg)))) ;;;###autoload (define-minor-mode better-pixel-scroll-mode commit db3fbe884fb992376a6e00f2a051e5de9579df85 Author: Po Lu Date: Fri Nov 26 08:41:39 2021 +0800 Add `better-pixel-scroll-mode' * etc/NEWS: Announce `better-pixel-scroll-mode'. * lisp/better-pixel-scroll.el: New file. diff --git a/etc/NEWS b/etc/NEWS index da56d0a338..329de2f811 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -93,6 +93,12 @@ buffer isn't displayed. This controls the thickness of the external borders of the menu bars and pop-up menus. +--- +** New minor mode 'better-pixel-scroll-mode'. +When enabled, using this mode with a capable scroll wheel will result +in the display being scrolled precisely according to the turning of +that wheel. + ** Terminal Emacs --- diff --git a/lisp/better-pixel-scroll.el b/lisp/better-pixel-scroll.el new file mode 100644 index 0000000000..ac342a425a --- /dev/null +++ b/lisp/better-pixel-scroll.el @@ -0,0 +1,145 @@ +;;; better-pixel-scroll.el --- Pixel scrolling support -*- lexical-binding:t -*- + +;; Copyright (C) 2021 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: + +;; This enables the use of smooth scroll events provided by XInput 2 +;; or NS to scroll the display according to the user's precise turning +;; of the mouse wheel. + +;;; Code: + +(require 'mwheel) +(require 'subr-x) + +(defvar x-coalesce-scroll-events) + +(defvar better-pixel-scroll-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [wheel-down] #'better-pixel-scroll) + (define-key map [wheel-up] #'better-pixel-scroll) + map) + "The key map used by `better-pixel-scroll-mode'.") + +(defun better-pixel-scroll-scroll-down (delta) + "Scroll the current window down by DELTA pixels. +Note that this function doesn't work if DELTA is larger than +the height of the current window." + (when-let* ((posn (posn-at-point)) + (current-y (cdr (posn-x-y posn))) + (min-y (+ (window-tab-line-height) + (window-header-line-height))) + (cursor-height (line-pixel-height)) + (window-height (window-text-height nil t)) + (next-height (save-excursion + (vertical-motion 1) + (line-pixel-height)))) + (if (and (> delta 0) + (<= cursor-height window-height)) + (while (< (- current-y min-y) delta) + (vertical-motion 1) + (setq current-y (+ current-y + (line-pixel-height))) + (when (eobp) + (error "End of buffer"))) + (when (< (- (cdr (posn-object-width-height posn)) + (cdr (posn-object-x-y posn))) + (- window-height next-height)) + (vertical-motion 1) + (setq posn (posn-at-point) + current-y (cdr (posn-x-y posn))) + (while (< (- current-y min-y) delta) + (vertical-motion 1) + (setq current-y (+ current-y + (line-pixel-height))) + (when (eobp) + (error "End of buffer"))))) + (let* ((desired-pos (posn-at-x-y 0 (+ delta + (window-tab-line-height) + (window-header-line-height)))) + (desired-start (posn-point desired-pos)) + (desired-vscroll (cdr (posn-object-x-y desired-pos)))) + (unless (eq (window-start) desired-start) + (set-window-start nil desired-start t)) + (set-window-vscroll nil desired-vscroll t)))) + +(defun better-pixel-scroll-scroll-up (delta) + "Scroll the current window up by DELTA pixels." + (when-let* ((max-y (- (window-text-height nil t) + (window-tab-line-height) + (window-header-line-height))) + (posn (posn-at-point)) + (current-y (+ (cdr (posn-x-y posn)) + (cdr (posn-object-width-height posn))))) + (while (< (- max-y current-y) delta) + (when (zerop (vertical-motion -1)) + (set-window-vscroll nil 0) + (signal 'beginning-of-buffer nil)) + (setq current-y (- current-y (line-pixel-height))))) + (while (> delta 0) + (set-window-start nil (save-excursion + (goto-char (window-start)) + (when (zerop (vertical-motion -1)) + (set-window-vscroll nil 0) + (signal 'beginning-of-buffer nil)) + (setq delta (- delta (line-pixel-height))) + (point)) + t)) + (when (< delta 0) + (when-let* ((desired-pos (posn-at-x-y 0 (+ (- delta) + (window-tab-line-height) + (window-header-line-height)))) + (desired-start (posn-point desired-pos)) + (desired-vscroll (cdr (posn-object-x-y desired-pos)))) + (unless (eq (window-start) desired-start) + (set-window-start nil desired-start t)) + (set-window-vscroll nil desired-vscroll t)))) + +(defun better-pixel-scroll (event &optional arg) + "Scroll the display according to EVENT. +Take into account any pixel deltas in EVENT to scroll the display +according to the user's turning the mouse wheel. If EVENT does +not have precise scrolling deltas, call `mwheel-scroll' instead. +ARG is passed to `mwheel-scroll', should that be called." + (interactive (list last-input-event current-prefix-arg)) + (if (nth 4 event) + (let ((delta (round (cdr (nth 4 event)))) + (window (mwheel-event-window event))) + (if (> (abs delta) (window-text-height window t)) + (mwheel-scroll event arg) + (with-selected-window window + (if (< delta 0) + (better-pixel-scroll-scroll-down (- delta)) + (better-pixel-scroll-scroll-up delta))))) + (mwheel-scroll event arg))) + +;;;###autoload +(define-minor-mode better-pixel-scroll-mode + "Toggle pixel scrolling. +When enabled, this minor mode allows to scroll the display +precisely, according to the turning of the mouse wheel." + :global t + :group 'mouse + :keymap better-pixel-scroll-mode-map + (setq x-coalesce-scroll-events + (not better-pixel-scroll-mode))) + +(provide 'better-pixel-scroll) + +;;; better-pixel-scroll.el ends here. commit 9d37be35227fcb419e7b52978f8d5a8b1379567f Author: Alan Third Date: Thu Nov 25 20:58:37 2021 +0000 Fix selection for old GNUstep and GCC * src/nsselect.m (ns_get_foreign_selection): Remove language features not yet supported by GCC. Be more selective with which pasteboard types we use. * src/nsterm.h: Set up some more #defines for deprecated variables. diff --git a/src/nsselect.m b/src/nsselect.m index e999835014..8b23f6f51a 100644 --- a/src/nsselect.m +++ b/src/nsselect.m @@ -215,7 +215,7 @@ Updated by Christian Limpach (chris@nice.ch) static Lisp_Object ns_get_foreign_selection (Lisp_Object symbol, Lisp_Object target) { - NSDictionary *typeLookup; + NSDictionary *typeLookup; id pb; pb = ns_symbol_to_pb (symbol); @@ -229,10 +229,14 @@ Updated by Christian Limpach (chris@nice.ch) #else @"text/plain", NSFilenamesPboardType, #endif - @"text/html", NSPasteboardTypeHTML, +#ifdef NS_IMPL_COCOA + /* FIXME: I believe these are actually available in recent + versions of GNUstep. */ @"text/plain", NSPasteboardTypeMultipleTextSelection, - @"application/pdf", NSPasteboardTypePDF, @"image/png", NSPasteboardTypePNG, +#endif + @"text/html", NSPasteboardTypeHTML, + @"application/pdf", NSPasteboardTypePDF, @"application/rtf", NSPasteboardTypeRTF, @"application/rtfd", NSPasteboardTypeRTFD, @"STRING", NSPasteboardTypeString, @@ -272,7 +276,7 @@ Updated by Christian Limpach (chris@nice.ch) = [typeLookup allKeysForObject: [NSString stringWithLispString:SYMBOL_NAME (target)]]; else - availableTypes = @[NSPasteboardTypeString]; + availableTypes = [NSArray arrayWithObject:NSPasteboardTypeString]; t = [pb availableTypeFromArray:availableTypes]; diff --git a/src/nsterm.h b/src/nsterm.h index 8175f99664..a32b8fe149 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -1346,9 +1346,18 @@ enum NSWindowTabbingMode #if !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_14) /* Deprecated in macOS 10.14. */ +/* FIXME: Some of these new names, if not all, are actually available + in some recent version of GNUstep. */ #define NSPasteboardTypeString NSStringPboardType #define NSPasteboardTypeTabularText NSTabularTextPboardType #define NSPasteboardTypeURL NSURLPboardType +#define NSPasteboardTypeHTML NSHTMLPboardType +#define NSPasteboardTypeMultipleTextSelection NSMultipleTextSelectionPboardType +#define NSPasteboardTypePDF NSPDFPboardType +#define NSPasteboardTypePNG NSPNGPboardType +#define NSPasteboardTypeRTF NSRTFPboardType +#define NSPasteboardTypeRTFD NSRTFDPboardType +#define NSPasteboardTypeTIFF NSTIFFPboardType #define NSControlStateValueOn NSOnState #define NSControlStateValueOff NSOffState #define NSBezelStyleRounded NSRoundedBezelStyle commit cfaf681d3d292ceccc89c0eaaa47827665115dc6 Author: Eli Zaretskii Date: Thu Nov 25 22:31:47 2021 +0200 ; * src/emacs.c (main): Add commentary about command-line processing. diff --git a/src/emacs.c b/src/emacs.c index 41c92a4615..c99b007ea7 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1342,6 +1342,39 @@ main (int argc, char **argv) init_standard_fds (); atexit (close_output_streams); + /* Command-line argument processing. + + The arguments in the argv[] array are sorted in the descending + order of their priority as defined in the standard_args[] array + below. Then the sorted arguments are processed from the highest + to the lowest priority. Each command-line argument that is + recognized by 'main', if found in argv[], causes skip_args to be + incremented, effectively removing the processed argument from the + command line. + + Then init_cmdargs is called, and conses a list of the unprocessed + command-line arguments, as strings, in 'command-line-args'. It + ignores all the arguments up to the one indexed by skip_args, as + those were already processed. + + The arguments in 'command-line-args' are further processed by + startup.el, functions 'command-line' and 'command-line-1'. The + first of them handles the arguments which need to be processed + before loading the user init file and initializing the + window-system. The second one processes the arguments that are + related to the GUI system, like -font, -geometry, and -title, and + then processes the rest of arguments whose priority is below + those that are related to the GUI system. The arguments + porcessed by 'command-line' are removed from 'command-line-args'; + the arguments processed by 'command-line-1' aren't, they are only + removed from 'command-line-args-left'. + + 'command-line-1' emits an error message for any argument it + doesn't recognize, so any command-line arguments processed in C + below whose priority is below the GUI system related switches + should be explicitly recognized, ignored, and removed from + 'command-line-args-left' in 'command-line-1'. */ + sort_args (argc, argv); argc = 0; while (argv[argc]) argc++; commit 4cd6bc88090d75df54ef5af684c21454954e1cd3 Author: Eli Zaretskii Date: Thu Nov 25 21:55:38 2021 +0200 ; * src/font.c: Comment about synchronizing with cus-face.el. diff --git a/src/font.c b/src/font.c index d423fd46b7..d780d781f6 100644 --- a/src/font.c +++ b/src/font.c @@ -60,6 +60,8 @@ struct table_entry const char *names[6]; }; +/* The following tables should be in sync with 'custom-face-attributes'. */ + /* Table of weight numeric values and their names. This table must be sorted by numeric values in ascending order and the numeric values must approximately match the weights in the font files. */ commit aa3a74d9a1173438ab351909441e50439f66b1e2 Author: Eli Zaretskii Date: Thu Nov 25 21:29:21 2021 +0200 Update 'custom-face-attributes' * lisp/cus-face.el (custom-face-attributes): Synchronize with tables in font.c. diff --git a/lisp/cus-face.el b/lisp/cus-face.el index 5037ee77c7..16fa55e826 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -54,6 +54,7 @@ (string :tag "Font Foundry" :help-echo "Font foundry name.")) + ;; The width, weight, and slant should be in sync with font.c. (:width (choice :tag "Width" :help-echo "Font width." @@ -63,15 +64,22 @@ (const :tag "demiexpanded" semi-expanded) (const :tag "expanded" expanded) (const :tag "extracondensed" extra-condensed) + (const :tag "extra-condensed" extra-condensed) (const :tag "extraexpanded" extra-expanded) + (const :tag "extra-expanded" extra-expanded) (const :tag "medium" normal) (const :tag "narrow" condensed) (const :tag "normal" normal) + (const :tag "medium" normal) (const :tag "regular" normal) (const :tag "semicondensed" semi-condensed) + (const :tag "demicondensed" semi-condensed) + (const :tag "semi-condensed" semi-condensed) (const :tag "semiexpanded" semi-expanded) (const :tag "ultracondensed" ultra-condensed) + (const :tag "ultra-condensed" ultra-condensed) (const :tag "ultraexpanded" ultra-expanded) + (const :tag "ultra-expanded" ultra-expanded) (const :tag "wide" extra-expanded))) (:height @@ -85,22 +93,32 @@ (choice :tag "Weight" :help-echo "Font weight." :value normal ; default + (const :tag "thin" thin) (const :tag "ultralight" ultra-light) - (const :tag "extralight" extra-light) + (const :tag "ultra-light" ultra-light) + (const :tag "extralight" ultra-light) + (const :tag "extra-light" ultra-light) (const :tag "light" light) - (const :tag "thin" thin) (const :tag "semilight" semi-light) - (const :tag "book" semi-light) + (const :tag "semi-light" semi-light) + (const :tag "demilight" semi-light) (const :tag "normal" normal) (const :tag "regular" normal) - (const :tag "medium" normal) + (const :tag "book" normal) + (const :tag "medium" medium) (const :tag "semibold" semi-bold) + (const :tag "semi-bold" semi-bold) (const :tag "demibold" semi-bold) + (const :tag "demi-bold" semi-bold) (const :tag "bold" bold) (const :tag "extrabold" extra-bold) - (const :tag "heavy" extra-bold) - (const :tag "ultrabold" ultra-bold) - (const :tag "black" ultra-bold))) + (const :tag "extra-bold" extra-bold) + (const :tag "ultrabold" extra-bold) + (const :tag "ultra-bold" extra-bold) + (const :tag "heavy" heavy) + (const :tag "black" heavy) + (const :tag "ultra-heavy" ultra-heavy) + (const :tag "ultraheavy" ultra-heavy))) (:slant (choice :tag "Slant" commit 92d1bb3e38324ccd7ecdac7392801a223cf4e7af Author: Andreas Schwab Date: Thu Nov 25 20:05:21 2021 +0100 * src/emacs.c (usage_message): Fix name of --seccomp option. diff --git a/src/emacs.c b/src/emacs.c index ad409c2887..7ae52b1f9a 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -265,7 +265,7 @@ Initialization options:\n\ #endif #if SECCOMP_USABLE "\ ---sandbox=FILE read Seccomp BPF filter from FILE\n\ +--seccomp=FILE read Seccomp BPF filter from FILE\n\ " #endif "\ commit 0c44b8edb4778bbbc536d67b617e93a152b948de Author: Eli Zaretskii Date: Thu Nov 25 20:54:07 2021 +0200 Fix handling of '--dump-file' command-line option * lisp/startup.el (command-line-1): Handle "--dump-file" and "--seccomp" if they are left on the command-line. (Bug#52106) diff --git a/lisp/startup.el b/lisp/startup.el index e1106419f1..fc085e6d0e 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -2393,6 +2393,7 @@ A fancy display is used on graphic displays, normal otherwise." ;; and long versions of what's on command-switch-alist. (longopts (append '("--funcall" "--load" "--insert" "--kill" + "--dump-file" "--seccomp" "--directory" "--eval" "--execute" "--no-splash" "--find-file" "--visit" "--file" "--no-desktop") (mapcar (lambda (elt) (concat "-" (car elt))) @@ -2554,6 +2555,11 @@ nil default-directory" name) (error "File name omitted from `-insert' option")) (insert-file-contents (command-line-normalize-file-name tem))) + ((or (equal argi "-dump-file") + (equal argi "-seccomp")) + ;; This was processed in C. + (or argval (pop command-line-args-left))) + ((equal argi "-kill") (kill-emacs t)) commit 7f14723aa2b6c89f4e2e3895ff0fb1b931f83755 Author: Eli Zaretskii Date: Thu Nov 25 20:17:58 2021 +0200 ; * etc/NEWS: Fix entry about reverting to old 'mode-line' face. diff --git a/etc/NEWS b/etc/NEWS index 8b7c2f7850..da56d0a338 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -81,7 +81,7 @@ To get the old monospaced mode line back, customize the 'mode-line' face not to inherit from the 'variable-pitch' face, or add this to your ~/.emacs: - (set-face-attribute 'mode-line t :inherit nil) + (set-face-attribute 'mode-line nil :inherit 'default) +++ ** New function 'buffer-text-pixel-size'. commit d24ad504fcc342725febc187e17d6b69cc527b6b Author: Stephen Gildea Date: Thu Nov 25 10:12:30 2021 -0800 MH-E: support Mailutils "folders +/" * lisp/mh-e/mh-utils.el (mh-sub-folders-parse): Support Mailutils style of "folders +/" output. * test/lisp/mh-e/mh-utils.el: Test "folders +/" with GNU Mailutils 3.13.91 and later. diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el index ad23bd1911..b75025d6a4 100644 --- a/lisp/mh-e/mh-utils.el +++ b/lisp/mh-e/mh-utils.el @@ -592,10 +592,14 @@ This function is a testable helper of `mh-sub-folders-actual'." (cl-incf start-pos)) (let* ((name (buffer-substring start-pos has-pos)) (first-char (aref name 0)) + (second-char (and (length> name 1) (aref name 1))) (last-char (aref name (1- (length name))))) (unless (member first-char '(?. ?# ?,)) (when (and (equal last-char ?+) (equal name current-folder)) (setq name (substring name 0 (1- (length name))))) + ;; nmh outputs double slash in root folder, e.g., "//tmp" + (when (and (equal first-char ?/) (equal second-char ?/)) + (setq name (substring name 1))) (push (cons name (search-forward "(others)" (line-end-position) t)) @@ -605,6 +609,9 @@ This function is a testable helper of `mh-sub-folders-actual'." (when (stringp folder) (setq results (cdr results)) (let ((folder-name-len (length (format "%s/" (substring folder 1))))) + (when (equal "+/" folder) + ;; folder "+/" includes a trailing slash + (cl-decf folder-name-len)) (setq results (mapcar (lambda (f) (cons (substring (car f) folder-name-len) (cdr f))) diff --git a/test/lisp/mh-e/mh-utils-tests.el b/test/lisp/mh-e/mh-utils-tests.el index 83949204a6..f282a0b08f 100644 --- a/test/lisp/mh-e/mh-utils-tests.el +++ b/test/lisp/mh-e/mh-utils-tests.el @@ -121,10 +121,12 @@ "Test `mh-sub-folders-parse' with root folder." (with-temp-buffer (insert "/+ has no messages.\n") + (insert "/ has no messages.\n") (insert "//nmh-style has no messages.\n") + (insert "/mu-style has no messages.\n") (should (equal (mh-sub-folders-parse "+/" "inbox+") - '(("nmh-style")))))) + '(("") ("nmh-style") ("mu-style")))))) ;; Folder names that are used by the following tests. @@ -259,8 +261,8 @@ The tests use this method if no configured MH variant is found." "/abso-folder/food has no messages.")) (("folders" "-noheader" "-norecurse" "-nototal" "+/") . ("/+ has no messages ; (others)." - "//abso-folder has no messages ; (others)." - "//tmp has no messages ; (others).")) + "/abso-folder has no messages ; (others)." + "/tmp has no messages ; (others).")) )) (arglist (cons (file-name-base program) args))) (let ((response-list-cons (assoc arglist argument-responses))) @@ -358,7 +360,8 @@ if `mh-test-utils-debug-mocks' is non-nil." Mailutils 3.5, 3.7, and 3.13 are known not to." (cond ((not (stringp variant))) ;our mock handles it ((string-search "GNU Mailutils" variant) - nil) + (let ((mu-version (string-remove-prefix "GNU Mailutils " variant))) + (version<= "3.13.91" mu-version))) (t))) ;no other known failures commit 96f58718a043bb50408592aa1975721396de274e Author: Robert Pluim Date: Thu Nov 25 18:07:04 2021 +0100 Correct the :inherit property on some faces Otherwise M-x customize-face will show them as lisp-expressions rather than nice widgets. * lisp/ansi-color.el (ansi-color-bold): (ansi-color-italic): (ansi-color-underline): * lisp/faces.el (mode-line): Don't quote the face we're inheriting from. diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el index 2e51264ec3..c962cbd478 100644 --- a/lisp/ansi-color.el +++ b/lisp/ansi-color.el @@ -91,7 +91,7 @@ as a PDF file." :group 'processes) (defface ansi-color-bold - '((t :inherit 'bold)) + '((t :inherit bold)) "Face used to render bold text." :group 'ansi-colors :version "28.1") @@ -103,13 +103,13 @@ as a PDF file." :version "28.1") (defface ansi-color-italic - '((t :inherit 'italic)) + '((t :inherit italic)) "Face used to render italic text." :group 'ansi-colors :version "28.1") (defface ansi-color-underline - '((t :inherit 'underline)) + '((t :inherit underline)) "Face used to render underlined text." :group 'ansi-colors :version "28.1") diff --git a/lisp/faces.el b/lisp/faces.el index e9f795caad..38feefba48 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2611,11 +2611,11 @@ non-nil." (defface mode-line '((((class color) (min-colors 88)) :box (:line-width -1 :style released-button) - :inherit 'variable-pitch + :inherit variable-pitch :background "grey75" :foreground "black") (t :inverse-video t - :inherit 'variable-pitch)) + :inherit variable-pitch)) "Basic mode line face for selected window." :version "21.1" :group 'mode-line-faces commit b711847f59143724c6c13102a08df141e4bf5589 Author: Robert Pluim Date: Thu Nov 25 17:53:27 2021 +0100 * doc/misc/flymake.texi: Correct local variable mode specification diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi index 5f02a1568e..ca464aff66 100644 --- a/doc/misc/flymake.texi +++ b/doc/misc/flymake.texi @@ -1,4 +1,4 @@ -\input texinfo @c -*-texinfo; coding: utf-8 -*- +\input texinfo @c -*- mode: texinfo; coding: utf-8 -*- @comment %**start of header @setfilename ../../info/flymake.info @set VERSION 1.2 commit 3dcb629f6ac227eb0f9ca46203035b16bf387911 Author: Robert Pluim Date: Thu Nov 25 15:55:40 2021 +0100 Don't display redundant 'see' in info-mode * lisp/info.el (Info-fontify-node): Don't show 'see' when displaying the result of "(See @ref" or "also @ref", but leave "Also @ref" alone. diff --git a/lisp/info.el b/lisp/info.el index cd4c867f4e..94537c2417 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -4896,9 +4896,16 @@ first line or header line, and for breadcrumb links.") ;; an end of sentence (skip-syntax-backward " (")) (setq other-tag - (cond ((save-match-data (looking-back "\\(^\\| \\)see" + (cond ((save-match-data (looking-back "\\(^\\|[ (]\\)see" (- (point) 4))) "") + ;; We want "Also *note" to produce + ;; "Also see", but "See also *note" to produce + ;; "See also", so match case-sensitively. + ((save-match-data (let ((case-fold-search nil)) + (looking-back "\\(^\\| \\)also" + (- (point) 5)))) + "") ((save-match-data (looking-back "\\(^\\| \\)in" (- (point) 3))) "") commit 223c956fc6568864440fd5bc70b7f4321e0c0fb2 Author: Michael Albinus Date: Thu Nov 25 16:44:12 2021 +0100 ; * admin/MAINTAINERS: Add test/infra/* diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS index b881e76e25..33aeb52865 100644 --- a/admin/MAINTAINERS +++ b/admin/MAINTAINERS @@ -231,6 +231,7 @@ Michael Albinus lisp/net/ange-ftp.el lisp/notifications.el lisp/shadowfile.el + test/infra/* test/lisp/autorevert-tests.el test/lisp/files-tests.el (file-name-non-special) test/lisp/shadowfile-tests.el commit 1b12af26ea1d552629799ddb4fccdd9df3180ac5 Author: Michael Albinus Date: Thu Nov 25 16:24:19 2021 +0100 Tag a test from process-tests.el as :unstable on emba. * test/src/process-tests.el (process-tests/multiple-threads-waiting): Tag it as :unstable on emba. diff --git a/test/src/process-tests.el b/test/src/process-tests.el index b831ca3bda..f14a460d1a 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -787,6 +787,7 @@ have written output." (list (list process "finished\n")))))))))) (ert-deftest process-tests/multiple-threads-waiting () + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (fboundp 'make-thread)) (with-timeout (60 (ert-fail "Test timed out")) (process-tests--with-processes processes commit 4d16a2f7373a8d328f589b61ade3a2da7275501e Author: Robert Pluim Date: Thu Nov 25 15:29:00 2021 +0100 Fix pdf generation with Texinfo 6.7 * doc/lispref/display.texi (Size of Displayed Text): Put @group inside @example (bug#52102). diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 386d51a91a..b1fb9f8b95 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -2026,14 +2026,14 @@ means hide the excess parts of @var{string} with a @code{display} text property (@pxref{Display Property}) showing the ellipsis, instead of actually truncating the string. -@group @example +@group (truncate-string-to-width "\tab\t" 12 4) @result{} "ab" (truncate-string-to-width "\tab\t" 12 4 ?\s) @result{} " ab " -@end example @end group +@end example This function uses @code{string-width} and @code{char-width} to find the suitable truncation point when @var{string} is too wide, so it commit 6e5fd99139bb82b384ad27a8097938ea934f512d Author: Lars Ingebrigtsen Date: Thu Nov 25 15:14:22 2021 +0100 Add temporary mode-line-position change * lisp/bindings.el (mode-line-position): Add interim solution to make `min-width' work here; this should be fixed for real in the display_line machinery somewhere. diff --git a/lisp/bindings.el b/lisp/bindings.el index 29a1baffe7..e28b06a1dc 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -501,7 +501,7 @@ mouse-1: Display Line and Column Mode Menu")) (defvar mode-line-position `((:propertize - mode-line-percent-position + (" " mode-line-percent-position) local-map ,mode-line-column-line-number-mode-map display (min-width (5.0)) mouse-face mode-line-highlight commit f1606047c49d86df99c4528abd932d0cdcb2befb Author: Lars Ingebrigtsen Date: Thu Nov 25 14:23:58 2021 +0100 Indent `closure' forms better * lisp/emacs-lisp/lisp-mode.el (closure): Indent `closure' forms better (bug#52063). diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index d90d0f5f6a..416d64558d 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1308,6 +1308,7 @@ Lisp function does not specify a special indentation." (put 'handler-bind 'lisp-indent-function 1) ;CL (put 'unwind-protect 'lisp-indent-function 1) (put 'with-output-to-temp-buffer 'lisp-indent-function 1) +(put 'closure 'lisp-indent-function 2) (defun indent-sexp (&optional endpos) "Indent each line of the list starting just after point. commit a22c9a34bd1cc3683b965383a59b4a50e9091776 Author: Eli Zaretskii Date: Thu Nov 25 15:06:08 2021 +0200 Fix 'posn-at-point' near some overlays * src/xdisp.c (pos_visible_p): Fix 'posn-at-point' for positions just after a display property that draws a fringe bitmap. (Bug#52097) diff --git a/src/xdisp.c b/src/xdisp.c index 34add80798..4642541823 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -1992,7 +1992,17 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y, } *x = top_x; - *y = max (top_y + max (0, it.max_ascent - it.ascent), window_top_y); + /* The condition below is a heuristic fix for the situation + where move_it_to stops just after finishing the display + of a fringe bitmap, which resets it.ascent to zero, and + thus causes Y to be offset by it.max_ascent. */ + if (it.ascent == 0 && it.what == IT_IMAGE + && it.method != GET_FROM_IMAGE + && it.image_id < 0 + && it.max_ascent > 0) + *y = max (top_y, window_top_y); + else + *y = max (top_y + max (0, it.max_ascent - it.ascent), window_top_y); *rtop = max (0, window_top_y - top_y); *rbot = max (0, bottom_y - it.last_visible_y); *rowh = max (0, (min (bottom_y, it.last_visible_y) @@ -2020,7 +2030,13 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y, RESTORE_IT (&it2, &it2, it2data); move_it_to (&it2, charpos, -1, -1, -1, MOVE_TO_POS); *x = it2.current_x; - *y = it2.current_y + it2.max_ascent - it2.ascent; + if (it2.ascent == 0 && it2.what == IT_IMAGE + && it2.method != GET_FROM_IMAGE + && it2.image_id < 0 + && it2.max_ascent > 0) + *y = it2.current_y; + else + *y = it2.current_y + it2.max_ascent - it2.ascent; *rtop = max (0, -it2.current_y); *rbot = max (0, ((it2.current_y + it2.max_ascent + it2.max_descent) - it.last_visible_y)); commit d0ea2a87f4d7a1afbe959fe53099222e120e8858 Author: Po Lu Date: Thu Nov 25 19:02:32 2021 +0800 Fix scroll wheel reporting on NS * src/nsterm.m (- mouseDown): Clear scroll wheel accumulators. diff --git a/src/nsterm.m b/src/nsterm.m index 17f5b98c57..80117a41a5 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -6604,7 +6604,10 @@ - (void)mouseDown: (NSEvent *)theEvent lines = abs (totalDeltaX / lineHeight); x = totalDeltaX; - totalDeltaX = totalDeltaX % lineHeight; + if (!x_coalesce_scroll_events) + totalDeltaX = 0; + else + totalDeltaX = totalDeltaX % lineHeight; totalDeltaY = 0; } else if (abs (totalDeltaY) >= abs (totalDeltaX) @@ -6616,7 +6619,10 @@ - (void)mouseDown: (NSEvent *)theEvent lines = abs (totalDeltaY / lineHeight); y = totalDeltaY; - totalDeltaY = totalDeltaY % lineHeight; + if (!x_coalesce_scroll_events) + totalDeltaY = 0; + else + totalDeltaY = totalDeltaY % lineHeight; totalDeltaX = 0; } commit 7fea9c8415bd04100be7857a138ad03e5a7ec4aa Author: Lars Ingebrigtsen Date: Wed Nov 24 22:01:21 2021 +0100 Define a face for shr text * lisp/net/shr.el (shr-text): New face. (shr-insert): Use it instead of hard-coding `variable-pitch'. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 87bacd4fbf..d59b0ed362 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -162,6 +162,10 @@ cid: URL as the argument.") (defvar shr-put-image-function #'shr-put-image "Function called to put image and alt string.") +(defface shr-text '((t :inherit variable-pitch)) + "Face used for rendering text." + :version "29.1") + (defface shr-strike-through '((t :strike-through t)) "Face for elements." :version "24.1") @@ -742,7 +746,7 @@ size, and full-buffer size." (when shr-use-fonts (put-text-property font-start (point) 'face - (or shr-current-font 'variable-pitch))))))))) + (or shr-current-font 'shr-text))))))))) (defun shr-fill-lines (start end) (if (<= shr-internal-width 0) commit d1aa552d11484ab15944a1f3c15f607dda811d8d Author: Eli Zaretskii Date: Thu Nov 25 10:43:35 2021 +0200 ; * CONTRIBUTE: No cleanups on release branches, even in docs. diff --git a/CONTRIBUTE b/CONTRIBUTE index 8295a8e6ad..5740004637 100644 --- a/CONTRIBUTE +++ b/CONTRIBUTE @@ -342,7 +342,9 @@ Documentation fixes (in doc strings, in manuals, in NEWS, and in comments) should always go to the release branch, if the documentation to be fixed exists and is relevant to the release-branch codebase. Doc fixes are always considered "safe" -- even when a release branch -is in feature freeze, it can still receive doc fixes. +is in feature freeze, it can still receive doc fixes. However, this +rule is limited to fixing real problems in the documentation; cleanups +and stylistic changes are excluded. When you know that the change will be difficult to merge to the master (e.g., because the code on master has changed a lot), you can commit 588caf0b274e763bab0ac511f2cb95750e83f7f6 Author: Narendra Joshi Date: Thu Nov 25 09:58:53 2021 +0200 * lisp/repeat.el (repeat-post-hook): Add check symbolp rep-map. Copyright-paperwork-exempt: yes diff --git a/lisp/repeat.el b/lisp/repeat.el index 4dcd353e34..32ffb1884f 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -416,7 +416,7 @@ See `describe-repeat-maps' for a list of all repeatable commands." (and (symbolp real-this-command) (get real-this-command 'repeat-map))))) (when rep-map - (when (boundp rep-map) + (when (and (symbolp rep-map) (boundp rep-map)) (setq rep-map (symbol-value rep-map))) (let ((map (copy-keymap rep-map))) commit b469a0155140cf0c319963717cb43f2bf43864ec Author: Po Lu Date: Thu Nov 25 13:20:56 2021 +0800 Set serial when filtering XI_KeyPress events This fixes fcitx flicker for whatever reason. * src/xterm.c (handle_one_xevent): Set serial when filtering XI_KeyPress events. diff --git a/src/xterm.c b/src/xterm.c index 346cd0c38a..0a3aeeed70 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10648,7 +10648,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, memset (&xkey, 0, sizeof xkey); xkey.type = KeyRelease; - xkey.serial = 0; + xkey.serial = xev->serial; xkey.send_event = xev->send_event; xkey.display = xev->display; xkey.window = xev->event; commit e37eb7f5c67f7da2c78688eda8968562fe75b767 Author: Po Lu Date: Thu Nov 25 11:01:19 2021 +0800 Add support for pixel wheel deltas on NS * src/xterm.c (x_coalesce_scroll_events): Update doc string. * src/nsterm.c (- mouseDown): Report pixel scroll deltas. (x_coalesce_scroll_events): New variable diff --git a/src/nsterm.m b/src/nsterm.m index e29dda684a..17f5b98c57 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -6529,6 +6529,7 @@ - (void)mouseDown: (NSEvent *)theEvent { struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (emacsframe); NSPoint p = [self convertPoint: [theEvent locationInWindow] fromView: nil]; + int x = 0, y = 0; NSTRACE ("[EmacsView mouseDown:]"); @@ -6595,22 +6596,26 @@ - (void)mouseDown: (NSEvent *)theEvent * reset the total delta for the direction we're NOT * scrolling so that small movements don't add up. */ if (abs (totalDeltaX) > abs (totalDeltaY) - && abs (totalDeltaX) > lineHeight) + && (!x_coalesce_scroll_events + || abs (totalDeltaX) > lineHeight)) { horizontal = YES; scrollUp = totalDeltaX > 0; lines = abs (totalDeltaX / lineHeight); - totalDeltaX = totalDeltaX % lineHeight; + x = totalDeltaX; + totalDeltaX = totalDeltaX % lineHeight; totalDeltaY = 0; } else if (abs (totalDeltaY) >= abs (totalDeltaX) - && abs (totalDeltaY) > lineHeight) + && (!x_coalesce_scroll_events + || abs (totalDeltaY) > lineHeight)) { horizontal = NO; scrollUp = totalDeltaY > 0; lines = abs (totalDeltaY / lineHeight); + y = totalDeltaY; totalDeltaY = totalDeltaY % lineHeight; totalDeltaX = 0; } @@ -6637,13 +6642,17 @@ - (void)mouseDown: (NSEvent *)theEvent ? ceil (fabs (delta)) : 1; scrollUp = delta > 0; + x = [theEvent scrollingDeltaX]; + y = [theEvent scrollingDeltaY]; } - if (lines == 0) + if (lines == 0 && x_coalesce_scroll_events) return; emacs_event->kind = horizontal ? HORIZ_WHEEL_EVENT : WHEEL_EVENT; - emacs_event->arg = (make_fixnum (lines)); + emacs_event->arg = list3 (make_fixnum (lines), + make_float (x), + make_float (y)); emacs_event->code = 0; emacs_event->modifiers = EV_MODIFIERS (theEvent) | @@ -10005,6 +10014,11 @@ Nil means use fullscreen the old (< 10.7) way. The old way works better with x_underline_at_descent_line, doc: /* SKIP: real doc in xterm.c. */); x_underline_at_descent_line = 0; + + DEFVAR_BOOL ("x-coalesce-scroll-events", x_coalesce_scroll_events, + doc: /* SKIP: real doc in xterm.c. */); + x_coalesce_scroll_events = true; + DEFSYM (Qx_underline_at_descent_line, "x-underline-at-descent-line"); /* Tell Emacs about this window system. */ diff --git a/src/xterm.c b/src/xterm.c index 7e0d58745e..346cd0c38a 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -15165,6 +15165,6 @@ always uses gtk_window_move and ignores the value of this variable. */); doc: /* Non-nil means send a wheel event only for scrolling at least one screen line. Otherwise, a wheel event will be sent every time the mouse wheel is moved. This option is only effective when Emacs is built with XInput -2 or with Haiku windowing support. */); +2, with Haiku windowing support, or with NS. */); x_coalesce_scroll_events = true; } commit 82233c2c1dcf0c55cb56a65499e57a69a25f47bf Author: Stephen Gildea Date: Wed Nov 24 18:38:24 2021 -0800 mh-utils-tests: 'mh-sub-folders-actual' coverage * test/lisp/mh-e/mh-utils.el (mh-sub-folders-parse-no-folder) (mh-sub-folders-parse-relative-folder, mh-sub-folders-parse-root-folder): New tests. * lisp/mh-e/mh-utils.el (mh-sub-folders-parse): New function, refactored out of 'mh-sub-folders-actual' to create a testing seam. diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el index 992943e304..ad23bd1911 100644 --- a/lisp/mh-e/mh-utils.el +++ b/lisp/mh-e/mh-utils.el @@ -562,7 +562,6 @@ Expects FOLDER to have already been normalized with (let ((arg-list `(,(expand-file-name "folders" mh-progs) nil (t nil) nil "-noheader" "-norecurse" "-nototal" ,@(if (stringp folder) (list folder) ()))) - (results ()) (current-folder (concat (with-temp-buffer (call-process (expand-file-name "folder" mh-progs) @@ -571,29 +570,37 @@ Expects FOLDER to have already been normalized with "+"))) (with-temp-buffer (apply #'call-process arg-list) - (goto-char (point-min)) - (while (not (and (eolp) (bolp))) - (goto-char (line-end-position)) - (let ((start-pos (line-beginning-position)) - (has-pos (search-backward " has " - (line-beginning-position) t))) - (when (integerp has-pos) - (while (equal (char-after has-pos) ? ) - (cl-decf has-pos)) - (cl-incf has-pos) - (while (equal (char-after start-pos) ? ) - (cl-incf start-pos)) - (let* ((name (buffer-substring start-pos has-pos)) - (first-char (aref name 0)) - (last-char (aref name (1- (length name))))) - (unless (member first-char '(?. ?# ?,)) - (when (and (equal last-char ?+) (equal name current-folder)) - (setq name (substring name 0 (1- (length name))))) - (push - (cons name - (search-forward "(others)" (line-end-position) t)) - results)))) - (forward-line 1)))) + (mh-sub-folders-parse folder current-folder)))) + +(defun mh-sub-folders-parse (folder current-folder) + "Parse the results of \"folders FOLDER\" and return a list of sub-folders. +CURRENT-FOLDER is the result of \"folder -fast\". +FOLDER will be nil or start with '+'; CURRENT-FOLDER will end with '+'. +This function is a testable helper of `mh-sub-folders-actual'." + (let ((results ())) + (goto-char (point-min)) + (while (not (and (eolp) (bolp))) + (goto-char (line-end-position)) + (let ((start-pos (line-beginning-position)) + (has-pos (search-backward " has " + (line-beginning-position) t))) + (when (integerp has-pos) + (while (equal (char-after has-pos) ? ) + (cl-decf has-pos)) + (cl-incf has-pos) + (while (equal (char-after start-pos) ? ) + (cl-incf start-pos)) + (let* ((name (buffer-substring start-pos has-pos)) + (first-char (aref name 0)) + (last-char (aref name (1- (length name))))) + (unless (member first-char '(?. ?# ?,)) + (when (and (equal last-char ?+) (equal name current-folder)) + (setq name (substring name 0 (1- (length name))))) + (push + (cons name + (search-forward "(others)" (line-end-position) t)) + results)))) + (forward-line 1))) (setq results (nreverse results)) (when (stringp folder) (setq results (cdr results)) diff --git a/test/lisp/mh-e/mh-utils-tests.el b/test/lisp/mh-e/mh-utils-tests.el index 5f6accc647..83949204a6 100644 --- a/test/lisp/mh-e/mh-utils-tests.el +++ b/test/lisp/mh-e/mh-utils-tests.el @@ -80,6 +80,52 @@ (mh-normalize-folder-name "+inbox////../news/" nil t))) (should (equal "+inbox/news" (mh-normalize-folder-name "+inbox////./news")))) +(ert-deftest mh-sub-folders-parse-no-folder () + "Test `mh-sub-folders-parse' with no starting folder." + (let (others-position) + (with-temp-buffer + (insert "lines without has-string are ignored\n") + (insert "onespace has no messages.\n") + (insert "twospace has no messages.\n") + (insert " precedingblanks has no messages.\n") + (insert ".leadingdot has no messages.\n") + (insert "#leadinghash has no messages.\n") + (insert ",leadingcomma has no messages.\n") + (insert "withothers has no messages ; (others)") + (setq others-position (point)) + (insert ".\n") + (insert "curf has no messages.\n") + (insert "curf+ has 123 messages.\n") + (insert "curf2+ has 17 messages.\n") + (insert "\ntotal after blank line is ignored has no messages.\n") + (should (equal + (mh-sub-folders-parse nil "curf+") + (list '("onespace") '("twospace") '("precedingblanks") + (cons "withothers" others-position) + '("curf") '("curf") '("curf2+"))))))) + +(ert-deftest mh-sub-folders-parse-relative-folder () + "Test `mh-sub-folders-parse' with folder." + (let (others-position) + (with-temp-buffer + (insert "testf+ has no messages.\n") + (insert "testf/sub1 has no messages.\n") + (insert "testf/sub2 has no messages ; (others)") + (setq others-position (point)) + (insert ".\n") + (should (equal + (mh-sub-folders-parse "+testf" "testf+") + (list '("sub1") (cons "sub2" others-position))))))) + +(ert-deftest mh-sub-folders-parse-root-folder () + "Test `mh-sub-folders-parse' with root folder." + (with-temp-buffer + (insert "/+ has no messages.\n") + (insert "//nmh-style has no messages.\n") + (should (equal + (mh-sub-folders-parse "+/" "inbox+") + '(("nmh-style")))))) + ;; Folder names that are used by the following tests. (defvar mh-test-rel-folder "rela-folder") commit 11e5c7d8ca58cc946930048b5c88c8f582d4d5d8 Author: Matt Kramer Date: Wed Nov 24 21:41:52 2021 +0200 Fix tab-line cycling when using buffer groups (bug#52050) * lisp/tab-line.el (tab-line-switch-to-prev-tab, tab-line-switch-to-next-tab): Remove tabs that aren't associated with a buffer, such as the `group-tab' that exists when `tab-line-tabs-function' is `tab-line-tabs-buffer-groups'. Copyright-paperwork-exempt: yes diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 110c6e9696..af0647acf7 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -792,7 +792,9 @@ Its effect is the same as using the `previous-buffer' command (if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers) (switch-to-prev-buffer window) (with-selected-window (or window (selected-window)) - (let* ((tabs (funcall tab-line-tabs-function)) + (let* ((tabs (seq-filter + (lambda (tab) (or (bufferp tab) (assq 'buffer tab))) + (funcall tab-line-tabs-function))) (pos (seq-position tabs (current-buffer) (lambda (tab buffer) @@ -816,7 +818,9 @@ Its effect is the same as using the `next-buffer' command (if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers) (switch-to-next-buffer window) (with-selected-window (or window (selected-window)) - (let* ((tabs (funcall tab-line-tabs-function)) + (let* ((tabs (seq-filter + (lambda (tab) (or (bufferp tab) (assq 'buffer tab))) + (funcall tab-line-tabs-function))) (pos (seq-position tabs (current-buffer) (lambda (tab buffer) commit 05c084cebb3d4c857a5aa20219d8c638913f07f3 Merge: d546659752 0854453ec2 Author: Eli Zaretskii Date: Wed Nov 24 21:36:30 2021 +0200 ; Merge from origin/emacs-28 The following commit was skipped: 0854453 Revert "Use @pxref when necessary" commit d546659752d3cd3c3e9c8ac0ec013b64987f5a62 Merge: 982439401b b4f47d2ee2 Author: Eli Zaretskii Date: Wed Nov 24 21:36:28 2021 +0200 Merge from origin/emacs-28 b4f47d2 Use @pxref when necessary commit 982439401bd6c8309b050a2c2b8448e243a70776 Merge: 39e2c214df 764ffa76ed Author: Eli Zaretskii Date: Wed Nov 24 21:36:27 2021 +0200 ; Merge from origin/emacs-28 The following commit was skipped: 764ffa7 Backport Tramp fixes, don't merge commit 39e2c214df7899dddbc86d063f31fe02f7987d49 Author: Michael Albinus Date: Wed Nov 24 20:27:34 2021 +0100 Some optimizations for emba jobs * test/infra/gitlab-ci.yml (.test-template): Remove. (test-all-inotify, test-filenotify-gio, test-gnustep) (test-native-comp-speed0): * test/infra/Makefile.in (subdir_template): Remove .test-template from extends. Add or adapt needs and artifacts. * test/infra/test-jobs.yml: Regenerate. diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in index e55a6edaff..d9fc019625 100644 --- a/test/infra/Makefile.in +++ b/test/infra/Makefile.in @@ -71,7 +71,10 @@ define subdir_template @echo >>$(FILE) @echo 'test-$(subst /,-,$(1))-inotify:' >>$(FILE) @echo ' stage: normal' >>$(FILE) - @echo ' extends: [.job-template, .test-template]' >>$(FILE) + @echo ' extends: [.job-template]' >>$(FILE) + @echo ' needs:' >>$(FILE) + @echo ' - job: build-image-inotify' >>$(FILE) + @echo ' optional: true' >>$(FILE) @echo ' rules:' >>$(FILE) @echo " - if: '"'${cps} == "schedule"'"'" >>$(FILE) @echo ' when: never' >>$(FILE) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 588ca04f3b..15d8b252e2 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -127,21 +127,6 @@ default: - docker build --pull --target ${target} -t ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} -f test/infra/Dockerfile.emba . - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} -.test-template: - needs: [] - # Do not run fast and normal test jobs when scheduled. - rules: - - if: '$CI_JOB_STAGE =~ "fast|normal" && $CI_PIPELINE_SOURCE == "schedule"' - when: never - - when: always - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - "**.log" - when: always - .gnustep-template: rules: - if: '$CI_PIPELINE_SOURCE == "web"' @@ -204,11 +189,21 @@ include: '/test/infra/test-jobs.yml' test-all-inotify: # This tests also file monitor libraries inotify and inotifywatch. stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: # Note there's no "changes" section, so this always runs on a schedule. - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - "**/*.log" + when: always variables: target: emacs-inotify make_params: check-expensive @@ -222,8 +217,10 @@ build-image-filenotify-gio: test-filenotify-gio: # This tests file monitor libraries gfilemonitor and gio. stage: platforms - extends: [.job-template, .test-template, .filenotify-gio-template] - needs: [build-image-filenotify-gio] + extends: [.job-template, .filenotify-gio-template] + needs: + - job: build-image-filenotify-gio + optional: true variables: target: emacs-filenotify-gio make_params: "-k -C test autorevert-tests.log filenotify-tests.log" @@ -238,7 +235,9 @@ test-gnustep: # This tests the GNUstep build process. stage: platforms extends: [.job-template, .gnustep-template] - needs: [build-image-gnustep] + needs: + - job: build-image-gnustep + optional: true variables: target: emacs-gnustep make_params: install @@ -263,8 +262,10 @@ build-native-comp-speed2: test-native-comp-speed0: stage: native-comp - extends: [.job-template, .test-template, .native-comp-template] - needs: [build-native-comp-speed0] + extends: [.job-template, .native-comp-template] + needs: + - job: build-native-comp-speed0 + optional: true variables: target: emacs-native-comp-speed0 make_params: "-C test check SELECTOR='(not (tag :unstable))'" diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml index 7af671d641..33a90d6f2c 100644 --- a/test/infra/test-jobs.yml +++ b/test/infra/test-jobs.yml @@ -1,7 +1,10 @@ test-lib-src-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -22,7 +25,10 @@ test-lib-src-inotify: test-lisp-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -43,7 +49,10 @@ test-lisp-inotify: test-lisp-calc-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -64,7 +73,10 @@ test-lisp-calc-inotify: test-lisp-calendar-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -85,7 +97,10 @@ test-lisp-calendar-inotify: test-lisp-cedet-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -106,7 +121,10 @@ test-lisp-cedet-inotify: test-lisp-cedet-semantic-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -127,7 +145,10 @@ test-lisp-cedet-semantic-inotify: test-lisp-cedet-semantic-bovine-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -148,7 +169,10 @@ test-lisp-cedet-semantic-bovine-inotify: test-lisp-cedet-srecode-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -169,7 +193,10 @@ test-lisp-cedet-srecode-inotify: test-lisp-emacs-lisp-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -190,7 +217,10 @@ test-lisp-emacs-lisp-inotify: test-lisp-emacs-lisp-eieio-tests-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -211,7 +241,10 @@ test-lisp-emacs-lisp-eieio-tests-inotify: test-lisp-emacs-lisp-faceup-tests-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -232,7 +265,10 @@ test-lisp-emacs-lisp-faceup-tests-inotify: test-lisp-emulation-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -253,7 +289,10 @@ test-lisp-emulation-inotify: test-lisp-erc-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -274,7 +313,10 @@ test-lisp-erc-inotify: test-lisp-eshell-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -295,7 +337,10 @@ test-lisp-eshell-inotify: test-lisp-gnus-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -316,7 +361,10 @@ test-lisp-gnus-inotify: test-lisp-image-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -337,7 +385,10 @@ test-lisp-image-inotify: test-lisp-international-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -358,7 +409,10 @@ test-lisp-international-inotify: test-lisp-mail-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -379,7 +433,10 @@ test-lisp-mail-inotify: test-lisp-mh-e-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -400,7 +457,10 @@ test-lisp-mh-e-inotify: test-lisp-net-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -421,7 +481,10 @@ test-lisp-net-inotify: test-lisp-nxml-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -442,7 +505,10 @@ test-lisp-nxml-inotify: test-lisp-obsolete-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -463,7 +529,10 @@ test-lisp-obsolete-inotify: test-lisp-org-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -484,7 +553,10 @@ test-lisp-org-inotify: test-lisp-play-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -505,7 +577,10 @@ test-lisp-play-inotify: test-lisp-progmodes-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -526,7 +601,10 @@ test-lisp-progmodes-inotify: test-lisp-so-long-tests-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -547,7 +625,10 @@ test-lisp-so-long-tests-inotify: test-lisp-term-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -568,7 +649,10 @@ test-lisp-term-inotify: test-lisp-textmodes-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -589,7 +673,10 @@ test-lisp-textmodes-inotify: test-lisp-url-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -610,7 +697,10 @@ test-lisp-url-inotify: test-lisp-vc-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -631,7 +721,10 @@ test-lisp-vc-inotify: test-misc-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never @@ -652,7 +745,10 @@ test-misc-inotify: test-src-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] + needs: + - job: build-image-inotify + optional: true rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never commit 0854453ec2343cbfac3ac8e233cdc7bd2c8554a9 Author: Eli Zaretskii Date: Wed Nov 24 21:27:15 2021 +0200 Revert "Use @pxref when necessary" This reverts commit b4f47d2ee2203a9f22bebeb3d09e0fb3fce2f65e. Cleanups should not be done on the release branch: that's unnecessary risk. diff --git a/doc/lispref/customize.texi b/doc/lispref/customize.texi index 00287a7212..b93b8bc015 100644 --- a/doc/lispref/customize.texi +++ b/doc/lispref/customize.texi @@ -737,7 +737,7 @@ If omitted, @var{key-type} and @var{value-type} default to The user can add any key matching the specified key type, but you can give some keys a preferential treatment by specifying them with the -@code{:options} (@pxref{Variable Definitions}). The specified keys +@code{:options} (see @ref{Variable Definitions}). The specified keys will always be shown in the customize buffer (together with a suitable value), with a checkbox to include or exclude or disable the key/value pair from the alist. The user will not be able to edit the keys diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi index 0db77255a6..7d67cc3af1 100644 --- a/doc/lispref/edebug.texi +++ b/doc/lispref/edebug.texi @@ -1267,7 +1267,7 @@ balanced parentheses, recursive processing of forms, and recursion via indirect specifications. Here's a table of the possible elements of a specification list, with -their meanings (@pxref{Specification Examples}, for the referenced +their meanings (see @ref{Specification Examples}, for the referenced examples): @table @code diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index 0d022a2a50..a1d1919b4b 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -363,7 +363,7 @@ where you are in Emacs. @cindex evaluation error @cindex infinite recursion This variable defines the limit on the total number of local variable -bindings and @code{unwind-protect} cleanups (@pxref{Cleanups,, +bindings and @code{unwind-protect} cleanups (see @ref{Cleanups,, Cleaning Up from Nonlocal Exits}) that are allowed before Emacs signals an error (with data @code{"Variable binding depth exceeds max-specpdl-size"}). diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index 757418a67c..cdb6f9b584 100644 --- a/doc/misc/efaq.texi +++ b/doc/misc/efaq.texi @@ -151,7 +151,7 @@ and @key{Meta} @item @key{DEL}: @key{Delete}, usually @strong{not} the same as -@key{Backspace}; same as @kbd{C-?} (@pxref{Backspace invokes help}, if +@key{Backspace}; same as @kbd{C-?} (see @ref{Backspace invokes help}, if deleting invokes Emacs help) @item @@ -793,7 +793,7 @@ informational files about Emacs and relevant aspects of the GNU project are available for you to read. The following files (and others) are available in the @file{etc} -directory of the Emacs distribution (@pxref{File-name conventions}, if +directory of the Emacs distribution (see @ref{File-name conventions}, if you're not sure where that is). Many of these files are available via the Emacs @samp{Help} menu, or by typing @kbd{C-h ?} (@kbd{M-x help-for-help}). diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi index 5f02a1568e..f741ee5d72 100644 --- a/doc/misc/flymake.texi +++ b/doc/misc/flymake.texi @@ -1145,7 +1145,7 @@ file are parsed. For @file{file.h}, the include directives to look for are @code{#include "file.h"}, @code{#include "../file.h"}, etc. Each include is checked against a list of include directories -(@pxref{Getting the include directories}) to be sure it points to the +(see @ref{Getting the include directories}) to be sure it points to the correct @file{file.h}. First matching master file found stops the search. The master file is then diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 31e3c7d1f6..6c892bc80a 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -1004,7 +1004,7 @@ The fundamental building blocks of Gnus are @dfn{servers}, @dfn{groups}, and @dfn{articles}. Servers can be local or remote. Each server maintains a list of groups, and those groups contain articles. Because Gnus presents a unified interface to a wide variety -of servers, the vocabulary doesn't always quite line up (@pxref{FAQ +of servers, the vocabulary doesn't always quite line up (see @ref{FAQ - Glossary}, for a more complete glossary). Thus a local maildir is referred to as a ``server'' (@pxref{Finding the News}) the same as a Usenet or IMAP server is; ``groups'' (@pxref{Group Buffer}) might mean @@ -28881,7 +28881,7 @@ gnus-agent-cache nil)} reverts to the old behavior. @item Dired integration -@code{gnus-dired-minor-mode} (@pxref{Other modes}) installs key +@code{gnus-dired-minor-mode} (see @ref{Other modes}) installs key bindings in dired buffers to send a file as an attachment, open a file using the appropriate mailcap entry, and print a file using the mailcap entry. diff --git a/doc/misc/htmlfontify.texi b/doc/misc/htmlfontify.texi index b2216924e2..1674565cda 100644 --- a/doc/misc/htmlfontify.texi +++ b/doc/misc/htmlfontify.texi @@ -633,7 +633,7 @@ Convert an Emacs :foreground property to a CSS color property. (hfy-flatten-style @var{style}) @end lisp -Take @var{style} (@pxref{hfy-face-to-style-i}, @pxref{hfy-face-to-style}) +Take @var{style} (see @ref{hfy-face-to-style-i}, @ref{hfy-face-to-style}) and merge any multiple attributes appropriately. Currently only font-size is merged down to a single occurrence---others may need special handling, but I haven't encountered them yet. Returns a @ref{hfy-style-assoc}. @@ -841,7 +841,7 @@ See @ref{hfy-display-class} for details of valid values for @var{class}. @end lisp Find face in effect at point P@. If overlays are to be considered -(@pxref{hfy-optimizations}) then this may return a @code{defface} style +(see @ref{hfy-optimizations}) then this may return a @code{defface} style list of face properties instead of a face symbol. @item hfy-bgcol diff --git a/doc/misc/mh-e.texi b/doc/misc/mh-e.texi index d96c243f52..bc788ebae0 100644 --- a/doc/misc/mh-e.texi +++ b/doc/misc/mh-e.texi @@ -1018,16 +1018,16 @@ Send multimedia messages (@pxref{Adding Attachments}). Read HTML messages (@pxref{HTML}). @c ------------------------- @item -Use aliases and identities (@pxref{Aliases}, @pxref{Identities}). +Use aliases and identities (see @ref{Aliases}, @pxref{Identities}). @c ------------------------- @item -Create different views of your mail (@pxref{Threading}, @pxref{Limits}). +Create different views of your mail (see @ref{Threading}, @pxref{Limits}). @c ------------------------- @item Deal with junk mail (@pxref{Junk}). @c ------------------------- @item -Handle signed and encrypted messages (@pxref{Reading PGP}, +Handle signed and encrypted messages (see @ref{Reading PGP}, @pxref{Sending PGP}). @c ------------------------- @item @@ -1038,7 +1038,7 @@ Process mail that was sent with @command{shar} or @command{uuencode} Use sequences conveniently (@pxref{Sequences}). @c ------------------------- @item -Use the speedbar, tool bar, and menu bar (@pxref{Speedbar}, @pxref{Tool +Use the speedbar, tool bar, and menu bar (see @ref{Speedbar}, see @ref{Tool Bar}, @pxref{Menu Bar}). @c ------------------------- @item diff --git a/doc/misc/pcl-cvs.texi b/doc/misc/pcl-cvs.texi index 833326c089..4ba067fd81 100644 --- a/doc/misc/pcl-cvs.texi +++ b/doc/misc/pcl-cvs.texi @@ -524,8 +524,8 @@ you can use in PCL-CVS@. They are grouped together by type. Most commands in PCL-CVS require that you have a @file{*cvs*} buffer. The commands that you use to get one are listed below. For each, a @samp{cvs} process will be run, the output will be parsed by -PCL-CVS, and the result will be printed in the @file{*cvs*} buffer -(@pxref{Buffer contents}, for a description of the buffer's contents). +PCL-CVS, and the result will be printed in the @file{*cvs*} buffer (see +@ref{Buffer contents}, for a description of the buffer's contents). @table @kbd @item M-x cvs-update diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index a9794eb4b7..a17a8d67e5 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -3389,8 +3389,8 @@ returns the exit code for it. When the user option indication that the process has been interrupted, and returns a corresponding string. -This remote process handling does not apply to @acronym{GVFS} -(@pxref{GVFS-based methods}) because the remote file system is mounted on +This remote process handling does not apply to @acronym{GVFS} (see +@ref{GVFS-based methods}) because the remote file system is mounted on the local host and @value{tramp} accesses it by changing the @code{default-directory}. @@ -3411,7 +3411,7 @@ might also add their name to this environment variable, like For @value{tramp} to find the command on the remote, it must be accessible through the default search path as setup by @value{tramp} upon first connection. Alternatively, use an absolute path or extend -@code{tramp-remote-path} (@pxref{Remote programs}): +@code{tramp-remote-path} (see @ref{Remote programs}): @lisp @group diff --git a/doc/misc/vhdl-mode.texi b/doc/misc/vhdl-mode.texi index 7022582db5..fef98a7463 100644 --- a/doc/misc/vhdl-mode.texi +++ b/doc/misc/vhdl-mode.texi @@ -243,7 +243,7 @@ components. Also notice that the first component, @vindex vhdl-offsets-alist @vindex offsets-alist @r{(vhdl-)} Indentation for the current line is calculated using the syntactic -component list derived in step 1 above (@pxref{Syntactic +component list derived in step 1 above (see @ref{Syntactic Analysis}). Each component contributes to the final total indentation of the line in two ways. @@ -668,7 +668,7 @@ not handled by the mode directly. @cindex custom indentation functions One of the most common ways to customize VHDL Mode is by writing @dfn{custom indentation functions} and associating them with specific -syntactic symbols (@pxref{Syntactic Symbols}). VHDL Mode itself +syntactic symbols (see @ref{Syntactic Symbols}). VHDL Mode itself uses custom indentation functions to provide more sophisticated indentation, for example when lining up selected signal assignments: @example @@ -732,7 +732,7 @@ operator on the first line of the statement. Here is the lisp code @end example @noindent Custom indent functions take a single argument, which is a syntactic -component cons cell (@pxref{Syntactic Analysis}). The +component cons cell (see @ref{Syntactic Analysis}). The function returns an integer offset value that will be added to the running total indentation for the line. Note that what actually gets returned is the difference between the column that the signal assignment commit e99bf271587399650a6d52beea4c8f1340d66689 Author: Lars Ingebrigtsen Date: Wed Nov 24 20:10:14 2021 +0100 Remove APPEND argument from add-display-text-property * doc/lispref/display.texi (Display Property): Update doc. * lisp/emacs-lisp/subr-x.el (add-display-text-property): Remove the append argument -- it's nonsensical. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 7204581e40..6742f0ea2d 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -4904,7 +4904,7 @@ with @code{get-char-property}, for instance (@pxref{Examining Properties}). @end defun -@defun add-display-text-property start end prop value &optional append object +@defun add-display-text-property start end prop value &optional object Add @code{display} property @var{prop} of @var{value} to the text from @var{start} to @var{end}. @@ -4922,9 +4922,6 @@ After doing this, the region from 2 to 4 will have the @code{raise} the region from 8 to 12 will only have the @code{raise} @code{display} property. -If @var{append} is non-@code{nil}, append to the list of display -properties; otherwise prepend. - If @var{object} is non-@code{nil}, it should be a string or a buffer. If @code{nil}, this defaults to the current buffer. @end defun diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 3ec880f8b8..b53245b9b5 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -471,14 +471,11 @@ This takes into account combining characters and grapheme clusters." ;;;###autoload (defun add-display-text-property (start end prop value - &optional append object) + &optional object) "Add display property PROP with VALUE to the text from START to END. If any text in the region has a non-nil `display' property, those properties are retained. -If APPEND is non-nil, append to the list of display properties; -otherwise prepend. - If OBJECT is non-nil, it should be a string or a buffer. If nil, this defaults to the current buffer." (let ((sub-start start) @@ -504,10 +501,10 @@ this defaults to the current buffer." (list disp)) (t disp))) - (setq disp - (if append - (append disp (list (list prop value))) - (append (list (list prop value)) disp))) + ;; Remove any old instances. + (when-let ((old (assoc prop disp))) + (setq disp (delete old disp))) + (setq disp (cons (list prop value) disp)) (when vector (setq disp (seq-into disp 'vector))) ;; Finally update the range. commit 833a42fbcf78ec99b84a98dd6bc7c2eea6eeaef6 Author: Lars Ingebrigtsen Date: Wed Nov 24 20:04:25 2021 +0100 Fix min-width problem with "overlapping" regions * src/xdisp.c (handle_display_prop): Fix problem with overlapping regions. diff --git a/src/xdisp.c b/src/xdisp.c index a0efefa3a5..b7fd2249dc 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -5352,7 +5352,8 @@ handle_display_prop (struct it *it) Qdisplay, object, &overlay); /* Handle min-width ends. */ - if (!NILP (it->min_width_property)) + if (!NILP (it->min_width_property) + && NILP (find_display_property (propval, Qmin_width))) display_min_width (it, bufpos, object, Qnil); if (NILP (propval)) commit 388b4a12f58855f24eca8f00cd20659a9d2b81d6 Author: Juri Linkov Date: Wed Nov 24 20:46:53 2021 +0200 * lisp/outline.el (outline-font-lock-keywords): Replace ‘.+’ with ‘.*’. Make the regexp less restrictive and don't require the outline heading to have more text after outline-regexp until the end of the heading line (bug#51016). diff --git a/lisp/outline.el b/lisp/outline.el index a4d2a3b7d7..2ede4e23ea 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -221,7 +221,7 @@ in the file it applies to.") (defvar outline-font-lock-keywords '( ;; Highlight headings according to the level. - (eval . (list (concat "^\\(?:" outline-regexp "\\).+") + (eval . (list (concat "^\\(?:" outline-regexp "\\).*") 0 '(if outline-minor-mode (if outline-minor-mode-cycle (if outline-minor-mode-highlight commit fde9363a57d0d38d592122fe5ca01aaafd0afa52 Author: Lars Ingebrigtsen Date: Wed Nov 24 19:38:41 2021 +0100 Add new function 'add-display-text-property' * doc/lispref/display.texi (Display Property): Document it. * lisp/emacs-lisp/subr-x.el (add-display-text-property): New function. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index fdebba939b..7204581e40 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -4904,6 +4904,31 @@ with @code{get-char-property}, for instance (@pxref{Examining Properties}). @end defun +@defun add-display-text-property start end prop value &optional append object +Add @code{display} property @var{prop} of @var{value} to the text from +@var{start} to @var{end}. + +If any text in the region has a non-@code{nil} @code{display} +property, those properties are retained. For instance: + +@lisp +(add-display-text-property 4 8 'height 2.0) +(add-display-text-property 2 12 'raise 0.5) +@end lisp + +After doing this, the region from 2 to 4 will have the @code{raise} +@code{display} property, the region from 4 to 8 will have both the +@code{raise} and @code{height} @code{display} properties, and finally +the region from 8 to 12 will only have the @code{raise} @code{display} +property. + +If @var{append} is non-@code{nil}, append to the list of display +properties; otherwise prepend. + +If @var{object} is non-@code{nil}, it should be a string or a buffer. +If @code{nil}, this defaults to the current buffer. +@end defun + @cindex display property, unsafe evaluation @cindex security, and display specifications Some of the display specifications allow inclusion of Lisp forms, diff --git a/etc/NEWS b/etc/NEWS index 24b8cb2796..8b7c2f7850 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -676,10 +676,17 @@ Use 'exif-parse-file' and 'exif-field' instead. * Lisp Changes in Emacs 29.1 ++++ ** New function 'get-display-property'. This is like 'get-text-property', but works on the 'display' text property. ++++ +** New function 'add-text-display-property'. +This is like 'put-text-property', but works on the 'display' text +property. + ++++ ** New 'min-width' 'display' property. This allows setting a minimum display width for a region of text. diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 95254b946e..3ec880f8b8 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -469,6 +469,51 @@ This takes into account combining characters and grapheme clusters." (setq start (1+ start)))) (nreverse result))) +;;;###autoload +(defun add-display-text-property (start end prop value + &optional append object) + "Add display property PROP with VALUE to the text from START to END. +If any text in the region has a non-nil `display' property, those +properties are retained. + +If APPEND is non-nil, append to the list of display properties; +otherwise prepend. + +If OBJECT is non-nil, it should be a string or a buffer. If nil, +this defaults to the current buffer." + (let ((sub-start start) + (sub-end 0) + disp) + (while (< sub-end end) + (setq sub-end (next-single-property-change sub-start 'display object + (if (stringp object) + (min (length object) end) + (min end (point-max))))) + (if (not (setq disp (get-text-property sub-start 'display object))) + ;; No old properties in this range. + (put-text-property sub-start sub-end 'display (list prop value)) + ;; We have old properties. + (let ((vector nil)) + ;; Make disp into a list. + (setq disp + (cond + ((vectorp disp) + (setq vector t) + (seq-into disp 'list)) + ((not (consp (car disp))) + (list disp)) + (t + disp))) + (setq disp + (if append + (append disp (list (list prop value))) + (append (list (list prop value)) disp))) + (when vector + (setq disp (seq-into disp 'vector))) + ;; Finally update the range. + (put-text-property sub-start sub-end 'display disp))) + (setq sub-start sub-end)))) + (provide 'subr-x) ;;; subr-x.el ends here diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index f9cfea888c..69d59e84f6 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -676,5 +676,23 @@ (buffer-string)) "foo\n"))) +(ert-deftest test-add-display-text-property () + (with-temp-buffer + (insert "Foo bar zot gazonk") + (add-display-text-property 4 8 'height 2.0) + (add-display-text-property 2 12 'raise 0.5) + (should (equal (get-text-property 2 'display) '(raise 0.5))) + (should (equal (get-text-property 5 'display) + '((raise 0.5) (height 2.0)))) + (should (equal (get-text-property 9 'display) '(raise 0.5)))) + (with-temp-buffer + (insert "Foo bar zot gazonk") + (put-text-property 4 8 'display [(height 2.0)]) + (add-display-text-property 2 12 'raise 0.5) + (should (equal (get-text-property 2 'display) '(raise 0.5))) + (should (equal (get-text-property 5 'display) + [(raise 0.5) (height 2.0)])) + (should (equal (get-text-property 9 'display) '(raise 0.5))))) + (provide 'subr-x-tests) ;;; subr-x-tests.el ends here commit 34f2878ce25a74c1283266b67575a56554684be5 Author: Lars Ingebrigtsen Date: Wed Nov 24 18:38:14 2021 +0100 Change eshell-mode mode-line-format insinuation * lisp/eshell/esh-mode.el (eshell-mode): Tweak how the mode line is altered after recent mode-line-format changes. diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index a054cd66e2..cae5236d89 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -308,7 +308,7 @@ and the hook `eshell-exit-hook'." (make-local-variable 'eshell-command-running-string) (let ((fmt (copy-sequence mode-line-format))) (setq-local mode-line-format fmt)) - (let ((mode-line-elt (memq 'mode-line-modified mode-line-format))) + (let ((mode-line-elt (cdr (memq 'mode-line-front-space mode-line-format)))) (if mode-line-elt (setcar mode-line-elt 'eshell-command-running-string)))) commit de9359d1d7b512e6b3488a3b9d8e12a747367055 Author: Eli Zaretskii Date: Wed Nov 24 19:19:21 2021 +0200 Fix documentation of 'min-width' display spec. * doc/lispref/display.texi (Other Display Specs): Clarify documentation of the 'min-width' display spec. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index dc53eeff9b..fdebba939b 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -5180,19 +5180,21 @@ be an integer or float. Characters other than spaces are not affected at all; in particular, this has no effect on tab characters. @item (min-width (@var{width})) -This display specification adds padding to the end of the text if the -text is shorter than @var{width}. The text is partitioned using the -identity of the parameter, which is why the parameter is a list with -one element. For instance: +This display specification ensures the text that has it takes at least +@var{width} space on display, by adding a stretch of white space to +the end of the text if the text is shorter than @var{width}. The text +is partitioned using the identity of the parameter, which is why the +parameter is a list with one element. For instance: @lisp (insert (propertize "foo" '(display (min-width (6.0))))) @end lisp This will add padding after @samp{foo} bringing the total width up to -the width of six normal characters. Note that the ``range'' is -identified by the @code{(6.0)} list, compared with @code{eq}. The -width can be either a character width or a pixel specification +the width of six normal characters. Note that the affected characters +are identified by the @code{(6.0)} list in the display property, +compared with @code{eq}. The element @var{width} can be either an +integer or a float specifying the required minimum width of the text (@pxref{Pixel Specification}). @item (height @var{height}) commit 20ab639d8946ca4c07c5238f015f8da17799c4e2 Author: Narendra Joshi Date: Wed Nov 24 11:58:03 2021 -0500 * lisp/vcursor.el (vcursor-get-char-count): Preserve point Copyright-paperwork-exempt: yes diff --git a/lisp/vcursor.el b/lisp/vcursor.el index e219dc2d1a..df65db39e3 100644 --- a/lisp/vcursor.el +++ b/lisp/vcursor.el @@ -788,9 +788,9 @@ out how much to copy." (vcursor-check) (with-current-buffer (overlay-buffer vcursor-overlay) - (let ((start (goto-char (overlay-start vcursor-overlay)))) - (- (progn (apply func args) (point)) start))) - ) + (save-excursion + (let ((start (goto-char (overlay-start vcursor-overlay)))) + (- (progn (apply func args) (point)) start))))) ;; Make sure the virtual cursor is active. Unless arg is non-nil, ;; report an error if it is not. commit b4f47d2ee2203a9f22bebeb3d09e0fb3fce2f65e Author: Robert Pluim Date: Wed Nov 24 17:28:45 2021 +0100 Use @pxref when necessary * doc/lispref/customize.texi (Composite Types): * doc/lispref/edebug.texi (Specification List): * doc/lispref/variables.texi (Local Variables): * doc/misc/efaq.texi (Basic keys): (Informational files for Emacs): * doc/misc/flymake.texi (Locating a master file): * doc/misc/gnus.texi (Don't Panic): (Oort Gnus): * doc/misc/htmlfontify.texi (Non-interactive): * doc/misc/mh-e.texi (More About MH-E): * doc/misc/pcl-cvs.texi (Entering PCL-CVS): * doc/misc/tramp.texi (Remote processes): * doc/misc/vhdl-mode.texi (Indentation Calculation): (Custom Indentation Functions): Use @pxref when inside parens. diff --git a/doc/lispref/customize.texi b/doc/lispref/customize.texi index b93b8bc015..00287a7212 100644 --- a/doc/lispref/customize.texi +++ b/doc/lispref/customize.texi @@ -737,7 +737,7 @@ If omitted, @var{key-type} and @var{value-type} default to The user can add any key matching the specified key type, but you can give some keys a preferential treatment by specifying them with the -@code{:options} (see @ref{Variable Definitions}). The specified keys +@code{:options} (@pxref{Variable Definitions}). The specified keys will always be shown in the customize buffer (together with a suitable value), with a checkbox to include or exclude or disable the key/value pair from the alist. The user will not be able to edit the keys diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi index 7d67cc3af1..0db77255a6 100644 --- a/doc/lispref/edebug.texi +++ b/doc/lispref/edebug.texi @@ -1267,7 +1267,7 @@ balanced parentheses, recursive processing of forms, and recursion via indirect specifications. Here's a table of the possible elements of a specification list, with -their meanings (see @ref{Specification Examples}, for the referenced +their meanings (@pxref{Specification Examples}, for the referenced examples): @table @code diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index a1d1919b4b..0d022a2a50 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -363,7 +363,7 @@ where you are in Emacs. @cindex evaluation error @cindex infinite recursion This variable defines the limit on the total number of local variable -bindings and @code{unwind-protect} cleanups (see @ref{Cleanups,, +bindings and @code{unwind-protect} cleanups (@pxref{Cleanups,, Cleaning Up from Nonlocal Exits}) that are allowed before Emacs signals an error (with data @code{"Variable binding depth exceeds max-specpdl-size"}). diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index cdb6f9b584..757418a67c 100644 --- a/doc/misc/efaq.texi +++ b/doc/misc/efaq.texi @@ -151,7 +151,7 @@ and @key{Meta} @item @key{DEL}: @key{Delete}, usually @strong{not} the same as -@key{Backspace}; same as @kbd{C-?} (see @ref{Backspace invokes help}, if +@key{Backspace}; same as @kbd{C-?} (@pxref{Backspace invokes help}, if deleting invokes Emacs help) @item @@ -793,7 +793,7 @@ informational files about Emacs and relevant aspects of the GNU project are available for you to read. The following files (and others) are available in the @file{etc} -directory of the Emacs distribution (see @ref{File-name conventions}, if +directory of the Emacs distribution (@pxref{File-name conventions}, if you're not sure where that is). Many of these files are available via the Emacs @samp{Help} menu, or by typing @kbd{C-h ?} (@kbd{M-x help-for-help}). diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi index f741ee5d72..5f02a1568e 100644 --- a/doc/misc/flymake.texi +++ b/doc/misc/flymake.texi @@ -1145,7 +1145,7 @@ file are parsed. For @file{file.h}, the include directives to look for are @code{#include "file.h"}, @code{#include "../file.h"}, etc. Each include is checked against a list of include directories -(see @ref{Getting the include directories}) to be sure it points to the +(@pxref{Getting the include directories}) to be sure it points to the correct @file{file.h}. First matching master file found stops the search. The master file is then diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 6c892bc80a..31e3c7d1f6 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -1004,7 +1004,7 @@ The fundamental building blocks of Gnus are @dfn{servers}, @dfn{groups}, and @dfn{articles}. Servers can be local or remote. Each server maintains a list of groups, and those groups contain articles. Because Gnus presents a unified interface to a wide variety -of servers, the vocabulary doesn't always quite line up (see @ref{FAQ +of servers, the vocabulary doesn't always quite line up (@pxref{FAQ - Glossary}, for a more complete glossary). Thus a local maildir is referred to as a ``server'' (@pxref{Finding the News}) the same as a Usenet or IMAP server is; ``groups'' (@pxref{Group Buffer}) might mean @@ -28881,7 +28881,7 @@ gnus-agent-cache nil)} reverts to the old behavior. @item Dired integration -@code{gnus-dired-minor-mode} (see @ref{Other modes}) installs key +@code{gnus-dired-minor-mode} (@pxref{Other modes}) installs key bindings in dired buffers to send a file as an attachment, open a file using the appropriate mailcap entry, and print a file using the mailcap entry. diff --git a/doc/misc/htmlfontify.texi b/doc/misc/htmlfontify.texi index 1674565cda..b2216924e2 100644 --- a/doc/misc/htmlfontify.texi +++ b/doc/misc/htmlfontify.texi @@ -633,7 +633,7 @@ Convert an Emacs :foreground property to a CSS color property. (hfy-flatten-style @var{style}) @end lisp -Take @var{style} (see @ref{hfy-face-to-style-i}, @ref{hfy-face-to-style}) +Take @var{style} (@pxref{hfy-face-to-style-i}, @pxref{hfy-face-to-style}) and merge any multiple attributes appropriately. Currently only font-size is merged down to a single occurrence---others may need special handling, but I haven't encountered them yet. Returns a @ref{hfy-style-assoc}. @@ -841,7 +841,7 @@ See @ref{hfy-display-class} for details of valid values for @var{class}. @end lisp Find face in effect at point P@. If overlays are to be considered -(see @ref{hfy-optimizations}) then this may return a @code{defface} style +(@pxref{hfy-optimizations}) then this may return a @code{defface} style list of face properties instead of a face symbol. @item hfy-bgcol diff --git a/doc/misc/mh-e.texi b/doc/misc/mh-e.texi index bc788ebae0..d96c243f52 100644 --- a/doc/misc/mh-e.texi +++ b/doc/misc/mh-e.texi @@ -1018,16 +1018,16 @@ Send multimedia messages (@pxref{Adding Attachments}). Read HTML messages (@pxref{HTML}). @c ------------------------- @item -Use aliases and identities (see @ref{Aliases}, @pxref{Identities}). +Use aliases and identities (@pxref{Aliases}, @pxref{Identities}). @c ------------------------- @item -Create different views of your mail (see @ref{Threading}, @pxref{Limits}). +Create different views of your mail (@pxref{Threading}, @pxref{Limits}). @c ------------------------- @item Deal with junk mail (@pxref{Junk}). @c ------------------------- @item -Handle signed and encrypted messages (see @ref{Reading PGP}, +Handle signed and encrypted messages (@pxref{Reading PGP}, @pxref{Sending PGP}). @c ------------------------- @item @@ -1038,7 +1038,7 @@ Process mail that was sent with @command{shar} or @command{uuencode} Use sequences conveniently (@pxref{Sequences}). @c ------------------------- @item -Use the speedbar, tool bar, and menu bar (see @ref{Speedbar}, see @ref{Tool +Use the speedbar, tool bar, and menu bar (@pxref{Speedbar}, @pxref{Tool Bar}, @pxref{Menu Bar}). @c ------------------------- @item diff --git a/doc/misc/pcl-cvs.texi b/doc/misc/pcl-cvs.texi index 4ba067fd81..833326c089 100644 --- a/doc/misc/pcl-cvs.texi +++ b/doc/misc/pcl-cvs.texi @@ -524,8 +524,8 @@ you can use in PCL-CVS@. They are grouped together by type. Most commands in PCL-CVS require that you have a @file{*cvs*} buffer. The commands that you use to get one are listed below. For each, a @samp{cvs} process will be run, the output will be parsed by -PCL-CVS, and the result will be printed in the @file{*cvs*} buffer (see -@ref{Buffer contents}, for a description of the buffer's contents). +PCL-CVS, and the result will be printed in the @file{*cvs*} buffer +(@pxref{Buffer contents}, for a description of the buffer's contents). @table @kbd @item M-x cvs-update diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index a17a8d67e5..a9794eb4b7 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -3389,8 +3389,8 @@ returns the exit code for it. When the user option indication that the process has been interrupted, and returns a corresponding string. -This remote process handling does not apply to @acronym{GVFS} (see -@ref{GVFS-based methods}) because the remote file system is mounted on +This remote process handling does not apply to @acronym{GVFS} +(@pxref{GVFS-based methods}) because the remote file system is mounted on the local host and @value{tramp} accesses it by changing the @code{default-directory}. @@ -3411,7 +3411,7 @@ might also add their name to this environment variable, like For @value{tramp} to find the command on the remote, it must be accessible through the default search path as setup by @value{tramp} upon first connection. Alternatively, use an absolute path or extend -@code{tramp-remote-path} (see @ref{Remote programs}): +@code{tramp-remote-path} (@pxref{Remote programs}): @lisp @group diff --git a/doc/misc/vhdl-mode.texi b/doc/misc/vhdl-mode.texi index fef98a7463..7022582db5 100644 --- a/doc/misc/vhdl-mode.texi +++ b/doc/misc/vhdl-mode.texi @@ -243,7 +243,7 @@ components. Also notice that the first component, @vindex vhdl-offsets-alist @vindex offsets-alist @r{(vhdl-)} Indentation for the current line is calculated using the syntactic -component list derived in step 1 above (see @ref{Syntactic +component list derived in step 1 above (@pxref{Syntactic Analysis}). Each component contributes to the final total indentation of the line in two ways. @@ -668,7 +668,7 @@ not handled by the mode directly. @cindex custom indentation functions One of the most common ways to customize VHDL Mode is by writing @dfn{custom indentation functions} and associating them with specific -syntactic symbols (see @ref{Syntactic Symbols}). VHDL Mode itself +syntactic symbols (@pxref{Syntactic Symbols}). VHDL Mode itself uses custom indentation functions to provide more sophisticated indentation, for example when lining up selected signal assignments: @example @@ -732,7 +732,7 @@ operator on the first line of the statement. Here is the lisp code @end example @noindent Custom indent functions take a single argument, which is a syntactic -component cons cell (see @ref{Syntactic Analysis}). The +component cons cell (@pxref{Syntactic Analysis}). The function returns an integer offset value that will be added to the running total indentation for the line. Note that what actually gets returned is the difference between the column that the signal assignment commit 9d3d972f9798f6c14d700c51900bf444a916310e Author: Lars Ingebrigtsen Date: Wed Nov 24 17:29:39 2021 +0100 Fix typo in display_min_width comment * src/xdisp.c (display_min_width): Fix typo in comment. diff --git a/src/xdisp.c b/src/xdisp.c index 5950941879..a0efefa3a5 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -5214,7 +5214,7 @@ display_min_width (struct it *it, ptrdiff_t bufpos, if (!it->glyph_row) return; - /* When called form display_string (i.e., the mode line), + /* When called from display_string (i.e., the mode line), we're being called with a string as the object, and we may be called with many sub-strings belonging to the same :propertize run. */ commit 0ccbb6f6d321df0683c6aebe5f4387618d9c85db Author: Lars Ingebrigtsen Date: Wed Nov 24 17:12:21 2021 +0100 Make min-width of the U:-- wider * lisp/bindings.el (standard-mode-line-format): Make the modified bits larger since there's often a big difference between - and % characters. diff --git a/lisp/bindings.el b/lisp/bindings.el index a4458ccd1e..29a1baffe7 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -610,7 +610,7 @@ By default, this shows the information specified by `global-mode-string'.") 'mode-line-client 'mode-line-modified 'mode-line-remote) - 'display '(min-width (4.0))) + 'display '(min-width (5.0))) 'mode-line-frame-identification 'mode-line-buffer-identification " " commit 764ffa76ed00f7a69e56a6898c22383a204421eb Author: Michael Albinus Date: Wed Nov 24 16:54:59 2021 +0100 Backport Tramp fixes, don't merge * lisp/net/tramp-sshfs.el (tramp-sshfs-file-name-handler-alist): Use `tramp-handle-file-readable-p'. * test/lisp/net/tramp-archive-tests.el (tramp-archive-test02-file-name-dissect): Use `make-tramp-file-name'. diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index a100786345..1886031dec 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -110,7 +110,7 @@ (file-notify-rm-watch . ignore) (file-notify-valid-p . ignore) (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-fuse-handle-file-readable-p) + (file-readable-p . tramp-handle-file-readable-p) (file-regular-p . tramp-handle-file-regular-p) (file-remote-p . tramp-handle-file-remote-p) (file-selinux-context . tramp-handle-file-selinux-context) diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 98012f4e90..0a484ff9bd 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -265,21 +265,20 @@ variables, so we check the Emacs version directly." (concat (tramp-gvfs-url-file-name (tramp-make-tramp-file-name - tramp-archive-method - ;; User and Domain. - nil nil - ;; Host. - (url-hexify-string - (concat - "file://" - ;; `directory-file-name' does not leave file - ;; archive boundaries. So we must cut the - ;; trailing slash ourselves. - (substring - (file-name-directory - (tramp-archive-test-file-archive-hexlified)) - 0 -1))) - nil "/")) + (make-tramp-file-name + :method tramp-archive-method + :host + (url-hexify-string + (concat + "file://" + ;; `directory-file-name' does not leave file + ;; archive boundaries. So we must cut the + ;; trailing slash ourselves. + (substring + (file-name-directory + (tramp-archive-test-file-archive-hexlified)) + 0 -1))) + :localname "/"))) (file-name-nondirectory tramp-archive-test-file-archive))))) (should-not port) (should (string-equal localname "/bar")) commit f1fcd321ff40315442cd77084c444585948bea85 Author: Stephen Gildea Date: Wed Nov 24 07:27:18 2021 -0800 mh-utils-tests: Add new tests of "folders +/" * test/lisp/mh-e/mh-utils-tests.el (mh-sub-folders-actual, mh-sub-folders): Add new tests of "folders +/". Rewrite tests that were using 'assoc' to use 'member' instead, so that on failure, ERT logs the list of which the element was not a member, rather than the 'nil' returned by 'assoc'. (mh-test-variant-handles-plus-slash): Factor out new helper function. (mh-folder-completion-function-08-plus-slash) (mh-folder-completion-function-09-plus-slash-tmp): Use new helper function. * test/lisp/mh-e/test-all-mh-variants.sh: LD_LIBRARY_PATH unnecessary. diff --git a/test/lisp/mh-e/mh-utils-tests.el b/test/lisp/mh-e/mh-utils-tests.el index 0066c00b5b..5f6accc647 100644 --- a/test/lisp/mh-e/mh-utils-tests.el +++ b/test/lisp/mh-e/mh-utils-tests.el @@ -307,6 +307,14 @@ if `mh-test-utils-debug-mocks' is non-nil." (message "file-directory-p: %S -> %s" filename result)) result)) +(defun mh-test-variant-handles-plus-slash (variant) + "Returns non-nil if this MH variant handles \"folders +/\". +Mailutils 3.5, 3.7, and 3.13 are known not to." + (cond ((not (stringp variant))) ;our mock handles it + ((string-search "GNU Mailutils" variant) + nil) + (t))) ;no other known failures + (ert-deftest mh-sub-folders-actual () "Test `mh-sub-folders-actual'." @@ -314,14 +322,15 @@ if `mh-test-utils-debug-mocks' is non-nil." ;; already been normalized with ;; (mh-normalize-folder-name folder nil nil t) (with-mh-test-env - (should (equal + (should (member mh-test-rel-folder - (car (assoc mh-test-rel-folder (mh-sub-folders-actual nil))))) + (mapcar (lambda (x) (car x)) (mh-sub-folders-actual nil)))) ;; Empty string and "+" not tested since mh-normalize-folder-name ;; would change them to nil. - (should (equal "foo" - (car (assoc "foo" (mh-sub-folders-actual - (format "+%s" mh-test-rel-folder)))))) + (should (member "foo" + (mapcar (lambda (x) (car x)) + (mh-sub-folders-actual + (format "+%s" mh-test-rel-folder))))) ;; Folder with trailing slash not tested since ;; mh-normalize-folder-name would strip it. (should (equal @@ -332,6 +341,10 @@ if `mh-test-utils-debug-mocks' is non-nil." (list (list "bar") (list "foo") (list "food")) (mh-sub-folders-actual (format "+%s" mh-test-abs-folder)))) + (when (mh-test-variant-handles-plus-slash mh-variant-in-use) + (should (member "tmp" (mapcar (lambda (x) (car x)) + (mh-sub-folders-actual "+/"))))) + ;; FIXME: mh-sub-folders-actual doesn't (yet) expect to be given a ;; nonexistent folder. ;; (should (equal nil @@ -343,13 +356,12 @@ if `mh-test-utils-debug-mocks' is non-nil." (ert-deftest mh-sub-folders () "Test `mh-sub-folders'." (with-mh-test-env - (should (equal mh-test-rel-folder - (car (assoc mh-test-rel-folder (mh-sub-folders nil))))) - (should (equal mh-test-rel-folder - (car (assoc mh-test-rel-folder (mh-sub-folders ""))))) - (should (equal nil - (car (assoc mh-test-no-such-folder (mh-sub-folders - "+"))))) + (should (member mh-test-rel-folder + (mapcar (lambda (x) (car x)) (mh-sub-folders nil)))) + (should (member mh-test-rel-folder + (mapcar (lambda (x) (car x)) (mh-sub-folders "")))) + (should-not (member mh-test-no-such-folder + (mapcar (lambda (x) (car x)) (mh-sub-folders "+")))) (should (equal (list (list "bar") (list "foo") (list "food")) (mh-sub-folders (format "+%s" mh-test-rel-folder)))) (should (equal (list (list "bar") (list "foo") (list "food")) @@ -360,6 +372,9 @@ if `mh-test-utils-debug-mocks' is non-nil." (mh-sub-folders (format "+%s/foo" mh-test-rel-folder)))) (should (equal (list (list "bar") (list "foo") (list "food")) (mh-sub-folders (format "+%s" mh-test-abs-folder)))) + (when (mh-test-variant-handles-plus-slash mh-variant-in-use) + (should (member "tmp" + (mapcar (lambda (x) (car x)) (mh-sub-folders "+/"))))) ;; FIXME: mh-sub-folders doesn't (yet) expect to be given a ;; nonexistent folder. @@ -441,10 +456,8 @@ and the `should' macro requires idempotent evaluation anyway." (ert-deftest mh-folder-completion-function-08-plus-slash () "Test `mh-folder-completion-function' with `+/'." - ;; This test fails with Mailutils 3.5, 3.7, and 3.13. (with-mh-test-env - (skip-unless (not (and (stringp mh-variant-in-use) - (string-search "GNU Mailutils" mh-variant-in-use))))) + (skip-unless (mh-test-variant-handles-plus-slash mh-variant-in-use))) (mh-test-folder-completion-1 "+/" "+/" "tmp/" t) ;; case "bb" (with-mh-test-env @@ -454,10 +467,8 @@ and the `should' macro requires idempotent evaluation anyway." (ert-deftest mh-folder-completion-function-09-plus-slash-tmp () "Test `mh-folder-completion-function' with `+/tmp'." - ;; This test fails with Mailutils 3.5, 3.7, and 3.13. (with-mh-test-env - (skip-unless (not (and (stringp mh-variant-in-use) - (string-search "GNU Mailutils" mh-variant-in-use))))) + (skip-unless (mh-test-variant-handles-plus-slash mh-variant-in-use))) (mh-test-folder-completion-1 "+/tmp" "+/tmp/" "tmp/" t)) (ert-deftest mh-folder-completion-function-10-plus-slash-abs-folder () diff --git a/test/lisp/mh-e/test-all-mh-variants.sh b/test/lisp/mh-e/test-all-mh-variants.sh index e917d8155b..eaee98fcf4 100755 --- a/test/lisp/mh-e/test-all-mh-variants.sh +++ b/test/lisp/mh-e/test-all-mh-variants.sh @@ -79,12 +79,10 @@ for path in "${mh_sys_path[@]}"; do continue fi fi - echo "Testing with PATH $path" + echo "** Testing with PATH $path" ((++tests_total)) - # The LD_LIBRARY_PATH setting is needed - # to run locally installed Mailutils. TEST_MH_PATH=$path TEST_MH_DEBUG=$debug \ - LD_LIBRARY_PATH=/usr/local/lib HOME=/nonexistent \ + HOME=/nonexistent \ "${emacs[@]}" -l ert \ --eval "(setq load-prefer-newer t)" \ --eval "(load \"$PWD/test/lisp/mh-e/mh-utils-tests\" nil t)" \ commit 7dfa758fef58dbfcd00baaea374260d5d3510b7f Author: Eli Zaretskii Date: Wed Nov 24 16:34:25 2021 +0200 ; * etc/NEWS: Fix recently added entries. diff --git a/etc/NEWS b/etc/NEWS index 17568976cb..24b8cb2796 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -77,7 +77,11 @@ time. --- ** The mode line now uses a proportional font by default. -To get the old monospaced mode line back, customize the 'mode-line' face. +To get the old monospaced mode line back, customize the 'mode-line' +face not to inherit from the 'variable-pitch' face, or add this to +your ~/.emacs: + + (set-face-attribute 'mode-line t :inherit nil) +++ ** New function 'buffer-text-pixel-size'. @@ -677,7 +681,7 @@ This is like 'get-text-property', but works on the 'display' text property. ** New 'min-width' 'display' property. -This allows setting a minimum width for a region. +This allows setting a minimum display width for a region of text. ** Keymaps and key definitions commit c8e28813af0ece36a78872c67f419cb0a0bbb6b9 Author: Eli Zaretskii Date: Wed Nov 24 16:19:25 2021 +0200 Minor fixes for a recent commit * src/xdisp.c (find_display_property): Fix style of comments. (Fget_display_property): Doc fix. (get_display_property): Fix style and whitespace. diff --git a/src/xdisp.c b/src/xdisp.c index cda7e04522..5950941879 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -5150,7 +5150,7 @@ find_display_property (Lisp_Object disp, Lisp_Object prop) { if (NILP (disp)) return Qnil; - /* We have a vector of display specs. */ + /* We have a vector of display specs. */ if (VECTORP (disp)) { for (ptrdiff_t i = 0; i < ASIZE (disp); i++) @@ -5163,7 +5163,7 @@ find_display_property (Lisp_Object disp, Lisp_Object prop) } return Qnil; } - /* We have a list of display specs. */ + /* We have a list of display specs. */ else if (CONSP (disp) && CONSP (XCAR (disp))) { @@ -5176,7 +5176,7 @@ find_display_property (Lisp_Object disp, Lisp_Object prop) return XCAR (XCDR (elem)); /* Check that we have a proper list before going to the next - element. */ + element. */ if (CONSP (XCDR (disp))) disp = XCDR (disp); else @@ -5184,7 +5184,7 @@ find_display_property (Lisp_Object disp, Lisp_Object prop) } return Qnil; } - /* A simple display spec. */ + /* A simple display spec. */ else if (CONSP (disp) && CONSP (XCDR (disp)) && EQ (XCAR (disp), prop)) @@ -5193,11 +5193,11 @@ find_display_property (Lisp_Object disp, Lisp_Object prop) return Qnil; } -static Lisp_Object get_display_property (ptrdiff_t bufpos, Lisp_Object prop, - Lisp_Object object) +static +Lisp_Object get_display_property (ptrdiff_t bufpos, Lisp_Object prop, + Lisp_Object object) { return find_display_property (Fget_text_property (make_fixnum (bufpos), - Qdisplay, object), prop); } @@ -5282,12 +5282,12 @@ display_min_width (struct it *it, ptrdiff_t bufpos, DEFUN ("get-display-property", Fget_display_property, Sget_display_property, 2, 4, 0, - doc: /* Get the `display' property PROP at POSITION. + doc: /* Get the value of the `display' property PROP at POSITION. If OBJECT, this should be a buffer or string where the property is -fetched from. This defaults to the current buffer. +fetched from. If omitted, OBJECT defaults to the current buffer. -If PROPERTIES, use those properties instead of the properties at -POSITION. */) +If PROPERTIES, look for value of PROP in PROPERTIES instead of the +properties at POSITION. */) (Lisp_Object position, Lisp_Object prop, Lisp_Object object, Lisp_Object properties) { commit 6e1b984563c3ea2fdc06ec1ea57c13a6f0114c6f Author: Mattias Engdegård Date: Wed Nov 24 15:05:07 2021 +0100 Add sample of -fanalyzer output (bug#51882) * etc/compilation.txt (file): Add fragment of GCC diagnostics from -fanalyzer (from Philip Kaludercic). diff --git a/etc/compilation.txt b/etc/compilation.txt index 01d4df1b09..34d8c53c9a 100644 --- a/etc/compilation.txt +++ b/etc/compilation.txt @@ -310,6 +310,9 @@ G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found. file:G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found. {standard input}:27041: Warning: end of file not at end of a line; newline inserted boost/container/detail/flat_tree.hpp:589:25: [ skipping 5 instantiation contexts, use -ftemplate-backtrace-limit=0 to disable ] + | + |board.h:60:21: + | 60 | #define I(b, C) ((C).y * (b)->width + (C).x) * Guile backtrace, 2.0.11 commit 1a84b7a3289829d6f404c323f0f673e32234484f Author: Mattias Engdegård Date: Wed Nov 24 10:21:49 2021 +0100 Tighten `gnu` compile regexp further * lisp/progmodes/compile.el (compilation-error-regexp-alist-alist): The -fanalyzer ASCII art does not contain tabs. diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 2d4070c389..6e3589df7a 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -347,9 +347,8 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) ;; which is used for non-interactive programs other than ;; compilers (e.g. the "jade:" entry in compilation.txt). (? (| (: alpha (+ (in ?. ?- alnum)) ":" (? " ")) - ;; Skip indentation generated by tools like GCC's - ;; -fanalyzer. - (: (+ (in " \t")) "|"))) + ;; Skip indentation generated by GCC's -fanalyzer. + (: (+ " ") "|"))) ;; File name group. (group-n 1 commit 84bf9549860aae22931951d52b194b1fcfca1556 Author: Lars Ingebrigtsen Date: Wed Nov 24 14:48:13 2021 +0100 Use a proportional font for the mode line * lisp/bindings.el (mode-line-position): Add min-width specs. (standard-mode-line-format): Ditto. * lisp/faces.el (mode-line): Inherit from `variable-pitch'. diff --git a/etc/NEWS b/etc/NEWS index 1cd49c5289..17568976cb 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -75,6 +75,10 @@ time. * Changes in Emacs 29.1 +--- +** The mode line now uses a proportional font by default. +To get the old monospaced mode line back, customize the 'mode-line' face. + +++ ** New function 'buffer-text-pixel-size'. This is similar to 'window-text-pixel-size', but can be used when the diff --git a/lisp/bindings.el b/lisp/bindings.el index 121e484a0e..a4458ccd1e 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -503,6 +503,7 @@ mouse-1: Display Line and Column Mode Menu")) `((:propertize mode-line-percent-position local-map ,mode-line-column-line-number-mode-map + display (min-width (5.0)) mouse-face mode-line-highlight ;; XXX needs better description help-echo "Window Scroll Percentage @@ -521,26 +522,31 @@ mouse-1: Display Line and Column Mode Menu"))) (10 (:propertize mode-line-position-column-line-format + display (min-width (10.0)) ,@mode-line-position--column-line-properties)) (10 (:propertize (:eval (string-replace "%c" "%C" (car mode-line-position-column-line-format))) + display (min-width (10.0)) ,@mode-line-position--column-line-properties))) (6 (:propertize mode-line-position-line-format + display (min-width (6.0)) ,@mode-line-position--column-line-properties)))) (column-number-mode (column-number-indicator-zero-based (6 (:propertize mode-line-position-column-format + display (min-width (6.0)) (,@mode-line-position--column-line-properties))) (6 (:propertize (:eval (string-replace "%c" "%C" (car mode-line-position-column-format))) + display (min-width (6.0)) ,@mode-line-position--column-line-properties)))))) "Mode line construct for displaying the position in the buffer. Normally displays the buffer percentage and, optionally, the @@ -597,10 +603,14 @@ By default, this shows the information specified by `global-mode-string'.") (let ((standard-mode-line-format (list "%e" 'mode-line-front-space - 'mode-line-mule-info - 'mode-line-client - 'mode-line-modified - 'mode-line-remote + (list + :propertize + (list "" + 'mode-line-mule-info + 'mode-line-client + 'mode-line-modified + 'mode-line-remote) + 'display '(min-width (4.0))) 'mode-line-frame-identification 'mode-line-buffer-identification " " diff --git a/lisp/faces.el b/lisp/faces.el index a07f8c652e..e9f795caad 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2611,9 +2611,11 @@ non-nil." (defface mode-line '((((class color) (min-colors 88)) :box (:line-width -1 :style released-button) + :inherit 'variable-pitch :background "grey75" :foreground "black") (t - :inverse-video t)) + :inverse-video t + :inherit 'variable-pitch)) "Basic mode line face for selected window." :version "21.1" :group 'mode-line-faces commit 4bfa73f9207b47d0a6a0641bbdd39963242fa2c7 Author: Lars Ingebrigtsen Date: Wed Nov 24 14:43:37 2021 +0100 Make display_min_width work from the mode line * src/xdisp.c (display_min_width): Make this work from mode line constructs via display_string. diff --git a/src/xdisp.c b/src/xdisp.c index e8de0634a1..cda7e04522 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -5214,11 +5214,18 @@ display_min_width (struct it *it, ptrdiff_t bufpos, if (!it->glyph_row) return; - /* Check that we're really right after the sequence of - characters covered by this `min-width'. */ - if (bufpos > BEGV - && EQ (it->min_width_property, - get_display_property (bufpos - 1, Qmin_width, object))) + /* When called form display_string (i.e., the mode line), + we're being called with a string as the object, and we + may be called with many sub-strings belonging to the same + :propertize run. */ + if ((bufpos == 0 + && !EQ (it->min_width_property, + get_display_property (0, Qmin_width, object))) + /* In a buffer -- check that we're really right after the + sequence of characters covered by this `min-width'. */ + || (bufpos > BEGV + && EQ (it->min_width_property, + get_display_property (bufpos - 1, Qmin_width, object)))) { Lisp_Object w = Qnil; double width; @@ -5258,6 +5265,11 @@ display_min_width (struct it *it, ptrdiff_t bufpos, if (CONSP (width_spec)) { if (bufpos == BEGV + /* Mode line (see above). */ + || (bufpos == 0 + && !EQ (it->min_width_property, + get_display_property (0, Qmin_width, object))) + /* Buffer. */ || (bufpos > BEGV && !EQ (width_spec, get_display_property (bufpos - 1, Qmin_width, object)))) commit 5b2ba7da4f03100dd5b889104b5256f7b8ac7927 Author: Michael Albinus Date: Wed Nov 24 14:47:55 2021 +0100 ; Fix syntax error in generated test/infra/test-jobs.yml diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in index ae5a9fe50b..e55a6edaff 100644 --- a/test/infra/Makefile.in +++ b/test/infra/Makefile.in @@ -34,6 +34,7 @@ SUBDIRS ?= $(shell make -s -C .. subdirs) SUBDIR_TARGETS = FILE = test-jobs.yml tn = $$$${test_name} +cps = $$$$CI_PIPELINE_SOURCE define subdir_template $(eval target = check-$(subst /,-,$(1))) @@ -72,7 +73,7 @@ define subdir_template @echo ' stage: normal' >>$(FILE) @echo ' extends: [.job-template, .test-template]' >>$(FILE) @echo ' rules:' >>$(FILE) - @echo ' - if: $CI_PIPELINE_SOURCE == "schedule"' >>$(FILE) + @echo " - if: '"'${cps} == "schedule"'"'" >>$(FILE) @echo ' when: never' >>$(FILE) @echo ' - changes:' >>$(FILE) $(changes) diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml index 93a409723d..7af671d641 100644 --- a/test/infra/test-jobs.yml +++ b/test/infra/test-jobs.yml @@ -3,7 +3,7 @@ test-lib-src-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lib-src/*.{h,c} @@ -24,7 +24,7 @@ test-lisp-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/*.el @@ -45,7 +45,7 @@ test-lisp-calc-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/calc/*.el @@ -66,7 +66,7 @@ test-lisp-calendar-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/calendar/*.el @@ -87,7 +87,7 @@ test-lisp-cedet-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/cedet/*.el @@ -108,7 +108,7 @@ test-lisp-cedet-semantic-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/cedet/semantic/*.el @@ -129,7 +129,7 @@ test-lisp-cedet-semantic-bovine-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/cedet/semantic/bovine/*.el @@ -150,7 +150,7 @@ test-lisp-cedet-srecode-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/cedet/srecode/*.el @@ -171,7 +171,7 @@ test-lisp-emacs-lisp-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/emacs-lisp/*.el @@ -192,7 +192,7 @@ test-lisp-emacs-lisp-eieio-tests-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/emacs-lisp/eieio*.el @@ -213,7 +213,7 @@ test-lisp-emacs-lisp-faceup-tests-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/emacs-lisp/faceup*.el @@ -234,7 +234,7 @@ test-lisp-emulation-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/emulation/*.el @@ -255,7 +255,7 @@ test-lisp-erc-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/erc/*.el @@ -276,7 +276,7 @@ test-lisp-eshell-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/eshell/*.el @@ -297,7 +297,7 @@ test-lisp-gnus-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/gnus/*.el @@ -318,7 +318,7 @@ test-lisp-image-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/image/*.el @@ -339,7 +339,7 @@ test-lisp-international-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/international/*.el @@ -360,7 +360,7 @@ test-lisp-mail-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/mail/*.el @@ -381,7 +381,7 @@ test-lisp-mh-e-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/mh-e/*.el @@ -402,7 +402,7 @@ test-lisp-net-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/net/*.el @@ -423,7 +423,7 @@ test-lisp-nxml-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/nxml/*.el @@ -444,7 +444,7 @@ test-lisp-obsolete-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/obsolete/*.el @@ -465,7 +465,7 @@ test-lisp-org-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/org/*.el @@ -486,7 +486,7 @@ test-lisp-play-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/play/*.el @@ -507,7 +507,7 @@ test-lisp-progmodes-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/progmodes/*.el @@ -528,7 +528,7 @@ test-lisp-so-long-tests-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/so-long*.el @@ -549,7 +549,7 @@ test-lisp-term-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/term/*.el @@ -570,7 +570,7 @@ test-lisp-textmodes-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/textmodes/*.el @@ -591,7 +591,7 @@ test-lisp-url-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/url/*.el @@ -612,7 +612,7 @@ test-lisp-vc-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - lisp/vc/*.el @@ -633,7 +633,7 @@ test-misc-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - admin/*.el @@ -654,7 +654,7 @@ test-src-inotify: stage: normal extends: [.job-template, .test-template] rules: - - if: I_PIPELINE_SOURCE == "schedule" + - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never - changes: - src/*.{h,c} commit 9fe409f958cc9d4ca43532dfd2343826677f5bae Author: Robert Pluim Date: Mon Nov 22 17:42:03 2021 +0100 * admin/unidata/emoji-zwj.awk: Quote functions properly. diff --git a/admin/unidata/emoji-zwj.awk b/admin/unidata/emoji-zwj.awk index d4e2944ca3..e704cb4526 100644 --- a/admin/unidata/emoji-zwj.awk +++ b/admin/unidata/emoji-zwj.awk @@ -114,7 +114,7 @@ END { print " (nconc (char-table-range composition-function-table (car elt))" print " (list (vector (cdr elt)" print " 0" - print " 'compose-gstring-for-graphic)))))" + print " #'compose-gstring-for-graphic)))))" print ";; The following two blocks are derived by hand from emoji-sequences.txt" print ";; FIXME: add support for Emoji_Keycap_Sequence once we learn how to respect FE0F/VS-16" @@ -126,7 +126,7 @@ END { print " (nconc (char-table-range composition-function-table '(#x1F1E6 . #x1F1FF))" print " (list (vector \"[\\U0001F1E6-\\U0001F1FF][\\U0001F1E6-\\U0001F1FF]\"" print " 0" - print " 'compose-gstring-for-graphic))))" + print " #'compose-gstring-for-graphic))))" print ";; UK Flags" print "(set-char-table-range composition-function-table" @@ -134,7 +134,7 @@ END { print " (nconc (char-table-range composition-function-table #x1F3F4)" print " (list (vector \"\\U0001F3F4\\U000E0067\\U000E0062\\\\(?:\\U000E0065\\U000E006E\\U000E0067\\\\|\\U000E0073\\U000E0063\\U000E0074\\\\|\\U000E0077\\U000E006C\\U000E0073\\\\)\\U000E007F\"" print " 0" - print " 'compose-gstring-for-graphic))))" + print " #'compose-gstring-for-graphic))))" printf "\n(provide 'emoji-zwj)" } commit fc35928ec2b3be40ff7323515f948fc82ca487ca Author: Po Lu Date: Wed Nov 24 12:48:01 2021 +0000 Make `yank-media' work on Haiku This works with what WebPositive does with images, at least. I don't know about other programs, but Haiku doesn't seem to standardize this very well. * lisp/term/haiku-win.el (haiku--selection-type-to-mime): Handle regular symbols. (gui-backend-get-selection): Handle special type `TARGETS'. (gui-backend-set-selection): Always clear clipboard. * src/haiku_select.cc (BClipboard_get_targets): New function. (BClipboard_set_data): New argument `clear'. All callers changed. (BClipboard_set_system_data) (BClipboard_set_primary_selection_data) (BClipboard_set_secondary_selection_data): New argument `clear'. (BClipboard_system_targets, BClipboard_primary_targets) (BClipboard_secondary_targets): New functions. * src/haikuselect.c (haiku_selection_data_1): New function. (Fhaiku_selection_targets): New function. (Fhaiku_selection_put): Allow controlling if the clipboard is cleared. (syms_of_haikuselect): New symbols and subrs. * src/haikuselect.h (BClipboard_set_system_data) (BClipboard_set_primary_selection_data) (BClipboard_set_secondary_selection_data): New argument `clear'. (BClipboard_system_targets, BClipboard_primary_targets) (BClipboard_secondary_targets): New functions. diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index 36af10d2c7..7861cfb900 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -86,15 +86,19 @@ If TYPE is nil, return \"text/plain\"." (cond ((memq type '(TEXT COMPOUND_TEXT STRING UTF8_STRING)) "text/plain") ((stringp type) type) + ((symbolp type) (symbol-name type)) (t "text/plain"))) (cl-defmethod gui-backend-get-selection (type data-type &context (window-system haiku)) - (haiku-selection-data type (haiku--selection-type-to-mime data-type))) + (if (eq data-type 'TARGETS) + (apply #'vector (mapcar #'intern + (haiku-selection-targets type))) + (haiku-selection-data type (haiku--selection-type-to-mime data-type)))) (cl-defmethod gui-backend-set-selection (type value &context (window-system haiku)) - (haiku-selection-put type "text/plain" value)) + (haiku-selection-put type "text/plain" value t)) (cl-defmethod gui-backend-selection-exists-p (selection &context (window-system haiku)) diff --git a/src/haiku_select.cc b/src/haiku_select.cc index 8d345ca661..6cd6ee879e 100644 --- a/src/haiku_select.cc +++ b/src/haiku_select.cc @@ -63,13 +63,63 @@ BClipboard_find_data (BClipboard *cb, const char *type, ssize_t *len) return strndup (ptr, bt); } +static void +BClipboard_get_targets (BClipboard *cb, char **buf, int buf_size) +{ + BMessage *data; + char *name; + int32 count_found; + type_code type; + int32 i; + int index; + + if (!cb->Lock ()) + { + buf[0] = NULL; + return; + } + + data = cb->Data (); + index = 0; + + if (!data) + { + buf[0] = NULL; + cb->Unlock (); + return; + } + + for (i = 0; (data->GetInfo (B_ANY_TYPE, i, &name, + &type, &count_found) + == B_OK); ++i) + { + if (type == B_MIME_TYPE) + { + if (index < (buf_size - 1)) + { + buf[index++] = strdup (name); + + if (!buf[index - 1]) + break; + } + } + } + + buf[index] = NULL; + + cb->Unlock (); +} + static void BClipboard_set_data (BClipboard *cb, const char *type, const char *dat, - ssize_t len) + ssize_t len, bool clear) { if (!cb->Lock ()) return; - cb->Clear (); + + if (clear) + cb->Clear (); + BMessage *mdat = cb->Data (); if (!mdat) { @@ -78,7 +128,13 @@ BClipboard_set_data (BClipboard *cb, const char *type, const char *dat, } if (dat) - mdat->AddData (type, B_MIME_TYPE, dat, len); + { + if (mdat->ReplaceData (type, B_MIME_TYPE, dat, len) + == B_NAME_NOT_FOUND) + mdat->AddData (type, B_MIME_TYPE, dat, len); + } + else + mdat->RemoveName (type); cb->Commit (); cb->Unlock (); } @@ -112,32 +168,32 @@ BClipboard_find_secondary_selection_data (const char *type, ssize_t *len) void BClipboard_set_system_data (const char *type, const char *data, - ssize_t len) + ssize_t len, bool clear) { if (!system_clipboard) return; - BClipboard_set_data (system_clipboard, type, data, len); + BClipboard_set_data (system_clipboard, type, data, len, clear); } void BClipboard_set_primary_selection_data (const char *type, const char *data, - ssize_t len) + ssize_t len, bool clear) { if (!primary) return; - BClipboard_set_data (primary, type, data, len); + BClipboard_set_data (primary, type, data, len, clear); } void BClipboard_set_secondary_selection_data (const char *type, const char *data, - ssize_t len) + ssize_t len, bool clear) { if (!secondary) return; - BClipboard_set_data (secondary, type, data, len); + BClipboard_set_data (secondary, type, data, len, clear); } void @@ -146,6 +202,24 @@ BClipboard_free_data (void *ptr) std::free (ptr); } +void +BClipboard_system_targets (char **buf, int len) +{ + BClipboard_get_targets (system_clipboard, buf, len); +} + +void +BClipboard_primary_targets (char **buf, int len) +{ + BClipboard_get_targets (primary, buf, len); +} + +void +BClipboard_secondary_targets (char **buf, int len) +{ + BClipboard_get_targets (secondary, buf, len); +} + void init_haiku_select (void) { diff --git a/src/haikuselect.c b/src/haikuselect.c index 3f0441e077..38cceb1de7 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -24,6 +24,46 @@ along with GNU Emacs. If not, see . */ #include "haikuselect.h" #include "haikuterm.h" +static Lisp_Object +haiku_selection_data_1 (Lisp_Object clipboard) +{ + Lisp_Object result = Qnil; + char *targets[256]; + + block_input (); + if (EQ (clipboard, QPRIMARY)) + BClipboard_primary_targets ((char **) &targets, 256); + else if (EQ (clipboard, QSECONDARY)) + BClipboard_secondary_targets ((char **) &targets, 256); + else if (EQ (clipboard, QCLIPBOARD)) + BClipboard_system_targets ((char **) &targets, 256); + else + { + unblock_input (); + signal_error ("Bad clipboard", clipboard); + } + + for (int i = 0; targets[i]; ++i) + { + result = Fcons (build_unibyte_string (targets[i]), + result); + free (targets[i]); + } + unblock_input (); + + return result; +} + +DEFUN ("haiku-selection-targets", Fhaiku_selection_targets, + Shaiku_selection_targets, 1, 1, 0, + doc: /* Find the types of data available from CLIPBOARD. +CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'. +Return the available types as a list of strings. */) + (Lisp_Object clipboard) +{ + return haiku_selection_data_1 (clipboard); +} + DEFUN ("haiku-selection-data", Fhaiku_selection_data, Shaiku_selection_data, 2, 2, 0, doc: /* Retrieve content typed as NAME from the clipboard @@ -78,15 +118,17 @@ fetch. */) } DEFUN ("haiku-selection-put", Fhaiku_selection_put, Shaiku_selection_put, - 3, 3, 0, + 3, 4, 0, doc: /* Add or remove content from the clipboard CLIPBOARD. CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'. NAME is a MIME type denoting the type of the data to add. DATA is the string that will be placed in the clipboard, or nil if the content is -to be removed. If NAME is the string `text/utf-8' or the string -`text/plain', encode it as UTF-8 before storing it into the +to be removed. If NAME is the string "text/utf-8" or the string +"text/plain", encode it as UTF-8 before storing it into the clipboard. +CLEAR, if non-nil, means to erase all the previous contents of the clipboard. */) - (Lisp_Object clipboard, Lisp_Object name, Lisp_Object data) + (Lisp_Object clipboard, Lisp_Object name, Lisp_Object data, + Lisp_Object clear) { CHECK_SYMBOL (clipboard); CHECK_STRING (name); @@ -105,11 +147,13 @@ clipboard. */) ptrdiff_t len = !NILP (data) ? SBYTES (data) : 0; if (EQ (clipboard, QPRIMARY)) - BClipboard_set_primary_selection_data (SSDATA (name), dat, len); + BClipboard_set_primary_selection_data (SSDATA (name), dat, len, + !NILP (clear)); else if (EQ (clipboard, QSECONDARY)) - BClipboard_set_secondary_selection_data (SSDATA (name), dat, len); + BClipboard_set_secondary_selection_data (SSDATA (name), dat, len, + !NILP (clear)); else if (EQ (clipboard, QCLIPBOARD)) - BClipboard_set_system_data (SSDATA (name), dat, len); + BClipboard_set_system_data (SSDATA (name), dat, len, !NILP (clear)); else { unblock_input (); @@ -128,7 +172,9 @@ syms_of_haikuselect (void) DEFSYM (QSTRING, "STRING"); DEFSYM (QUTF8_STRING, "UTF8_STRING"); DEFSYM (Qforeign_selection, "foreign-selection"); + DEFSYM (QTARGETS, "TARGETS"); defsubr (&Shaiku_selection_data); defsubr (&Shaiku_selection_put); + defsubr (&Shaiku_selection_targets); } diff --git a/src/haikuselect.h b/src/haikuselect.h index 542d550d64..1a3a945f98 100644 --- a/src/haikuselect.h +++ b/src/haikuselect.h @@ -46,15 +46,25 @@ extern "C" BClipboard_find_secondary_selection_data (const char *type, ssize_t *len); extern void - BClipboard_set_system_data (const char *type, const char *data, ssize_t len); + BClipboard_set_system_data (const char *type, const char *data, ssize_t len, + bool clear); extern void BClipboard_set_primary_selection_data (const char *type, const char *data, - ssize_t len); + ssize_t len, bool clear); extern void BClipboard_set_secondary_selection_data (const char *type, const char *data, - ssize_t len); + ssize_t len, bool clear); + + extern void + BClipboard_system_targets (char **buf, int len); + + extern void + BClipboard_primary_targets (char **buf, int len); + + extern void + BClipboard_secondary_targets (char **buf, int len); /* Free the returned data. */ extern void BClipboard_free_data (void *ptr); commit 7878c7f596d69efb68501503da391ed645ae151e Author: Michael Albinus Date: Wed Nov 24 13:43:32 2021 +0100 * admin/notes/emba (Emacs jobset): Remove stage slow. * test/infra/Makefile.in (subdir_template): Add rule. * test/infra/gitlab-ci.yml (.job-template): Remove changes section. (.build-template, .gnustep-template, .filenotify-gio-template): (.native-comp-template): Adapt changes section. (.test-template): Add needs. Adapt artifacts paths. (stages): Remove slow. (test-all-inotify): Move up. Change stage to normal. Remove timeout. (test-filenotify-gio, test-gnustep, test-native-comp-speed0): Move needs up. * test/infra/test-jobs.yml: Regenerate. diff --git a/admin/notes/emba b/admin/notes/emba index a30e570fd4..f1b52b2cde 100644 --- a/admin/notes/emba +++ b/admin/notes/emba @@ -35,7 +35,7 @@ The Emacs jobset is defined in the Emacs source tree, file A jobset on Gitlab is called pipeline. Emacs pipelines run through the stages 'build-images', 'platform-images' and 'native-comp-images' (create an Emacs instance by 'make bootstrap' with different -configuration parameters) as well as 'normal', 'slow', 'platforms' and +configuration parameters) as well as 'normal', 'platforms' and 'native-comp' (run respective test jobs based on the produced images). The jobs for stage 'normal' are contained in the file diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in index c6b9b39e8c..ae5a9fe50b 100644 --- a/test/infra/Makefile.in +++ b/test/infra/Makefile.in @@ -72,6 +72,8 @@ define subdir_template @echo ' stage: normal' >>$(FILE) @echo ' extends: [.job-template, .test-template]' >>$(FILE) @echo ' rules:' >>$(FILE) + @echo ' - if: $CI_PIPELINE_SOURCE == "schedule"' >>$(FILE) + @echo ' when: never' >>$(FILE) @echo ' - changes:' >>$(FILE) $(changes) @echo ' - test/$(1)/*.el' >>$(FILE) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 47a8b51964..588ca04f3b 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -71,32 +71,6 @@ default: .job-template: variables: test_name: ${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA} - rules: - - changes: - - "**Makefile.in" - - .gitlab-ci.yml - - aclocal.m4 - - autogen.sh - - configure.ac - - lib/*.{h,c} - - lisp/**.el - - src/*.{h,c} - - test/infra/* - - test/lib-src/*.el - - test/lisp/**.el - - test/misc/*.el - - test/src/*.el - - changes: - # gfilemonitor, kqueue - - src/gfilenotify.c - - src/kqueue.c - # MS Windows - - "**w32*" - # GNUstep - - lisp/term/ns-win.el - - src/ns*.{h,m} - - src/macfont.{h,m} - when: never # These will be cached across builds. cache: key: ${CI_COMMIT_SHA} @@ -127,15 +101,17 @@ default: - if: '$CI_PIPELINE_SOURCE == "web"' when: always - changes: - - "**Makefile.in" - - .gitlab-ci.yml + - "**.in" + - "**.yml" + - GNUmakefile - aclocal.m4 - autogen.sh - configure.ac - lib/*.{h,c} + - lib/malloc/*.{h,c} - lisp/emacs-lisp/*.el - src/*.{h,c} - - test/infra/* + - test/infra/Dockerfile.emba - changes: # gfilemonitor, kqueue - src/gfilenotify.c @@ -152,6 +128,7 @@ default: - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} .test-template: + needs: [] # Do not run fast and normal test jobs when scheduled. rules: - if: '$CI_JOB_STAGE =~ "fast|normal" && $CI_PIPELINE_SOURCE == "schedule"' @@ -162,9 +139,7 @@ default: public: true expire_in: 1 week paths: - - ${test_name}/**/*.log - - ${test_name}/**/core - - ${test_name}/core + - "**.log" when: always .gnustep-template: @@ -172,27 +147,26 @@ default: - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - - "**Makefile.in" - - .gitlab-ci.yml - - configure.ac + - "**.in" + - "**.yml" - src/ns*.{h,m} - src/macfont.{h,m} - lisp/term/ns-win.el - nextstep/** - - test/infra/* + - test/infra/Dockerfile.emba .filenotify-gio-template: rules: - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - - "**Makefile.in" - - .gitlab-ci.yml + - "**.in" + - "**.yml" - lisp/autorevert.el - lisp/filenotify.el - lisp/net/tramp-sh.el - src/gfilenotify.c - - test/infra/* + - test/infra/Dockerfile.emba - test/lisp/autorevert-tests.el - test/lisp/filenotify-tests.el @@ -201,25 +175,23 @@ default: - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - - "**Makefile.in" - - .gitlab-ci.yml + - "**.in" + - "**.yml" - lisp/emacs-lisp/comp.el - lisp/emacs-lisp/comp-cstr.el - src/comp.{h,m} - - test/infra/* + - test/infra/Dockerfile.emba - test/src/comp-resources/*.el - test/src/comp-tests.el timeout: 8 hours stages: - build-images -# - fast - normal - platform-images - platforms - native-comp-images - native-comp - - slow build-image-inotify: stage: build-images @@ -227,15 +199,20 @@ build-image-inotify: variables: target: emacs-inotify -# test-fast-inotify: -# stage: fast -# extends: [.job-template, .test-template] -# variables: -# target: emacs-inotify -# make_params: "-C test check" - include: '/test/infra/test-jobs.yml' +test-all-inotify: + # This tests also file monitor libraries inotify and inotifywatch. + stage: normal + extends: [.job-template, .test-template] + rules: + # Note there's no "changes" section, so this always runs on a schedule. + - if: '$CI_PIPELINE_SOURCE == "web"' + - if: '$CI_PIPELINE_SOURCE == "schedule"' + variables: + target: emacs-inotify + make_params: check-expensive + build-image-filenotify-gio: stage: platform-images extends: [.job-template, .build-template, .filenotify-gio-template] @@ -245,8 +222,8 @@ build-image-filenotify-gio: test-filenotify-gio: # This tests file monitor libraries gfilemonitor and gio. stage: platforms - needs: [build-image-filenotify-gio] extends: [.job-template, .test-template, .filenotify-gio-template] + needs: [build-image-filenotify-gio] variables: target: emacs-filenotify-gio make_params: "-k -C test autorevert-tests.log filenotify-tests.log" @@ -260,8 +237,8 @@ build-image-gnustep: test-gnustep: # This tests the GNUstep build process. stage: platforms - needs: [build-image-gnustep] extends: [.job-template, .gnustep-template] + needs: [build-image-gnustep] variables: target: emacs-gnustep make_params: install @@ -286,27 +263,12 @@ build-native-comp-speed2: test-native-comp-speed0: stage: native-comp - needs: [build-native-comp-speed0] extends: [.job-template, .test-template, .native-comp-template] + needs: [build-native-comp-speed0] variables: target: emacs-native-comp-speed0 make_params: "-C test check SELECTOR='(not (tag :unstable))'" -test-all-inotify: - # This tests also file monitor libraries inotify and inotifywatch. - stage: slow - needs: [build-image-inotify] - extends: [.job-template, .test-template] - rules: - # Note there's no "changes" section, so this always runs on a schedule. - - if: '$CI_PIPELINE_SOURCE == "web"' - - if: '$CI_PIPELINE_SOURCE == "schedule"' - variables: - target: emacs-inotify - make_params: check-expensive - # Two hours. - EMACS_TEST_TIMEOUT: 7200 - # Local Variables: # add-log-current-defun-header-regexp: "^\\([-_.[:alnum:]]+\\)[ \t]*:" # End: diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml index 413dfeba33..93a409723d 100644 --- a/test/infra/test-jobs.yml +++ b/test/infra/test-jobs.yml @@ -3,6 +3,8 @@ test-lib-src-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lib-src/*.{h,c} - test/lib-src/*.el @@ -22,6 +24,8 @@ test-lisp-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/*.el - test/lisp/*.el @@ -41,6 +45,8 @@ test-lisp-calc-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/calc/*.el - test/lisp/calc/*.el @@ -60,6 +66,8 @@ test-lisp-calendar-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/calendar/*.el - test/lisp/calendar/*.el @@ -79,6 +87,8 @@ test-lisp-cedet-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/cedet/*.el - test/lisp/cedet/*.el @@ -98,6 +108,8 @@ test-lisp-cedet-semantic-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/cedet/semantic/*.el - test/lisp/cedet/semantic/*.el @@ -117,6 +129,8 @@ test-lisp-cedet-semantic-bovine-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/cedet/semantic/bovine/*.el - test/lisp/cedet/semantic/bovine/*.el @@ -136,6 +150,8 @@ test-lisp-cedet-srecode-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/cedet/srecode/*.el - test/lisp/cedet/srecode/*.el @@ -155,6 +171,8 @@ test-lisp-emacs-lisp-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/emacs-lisp/*.el - test/lisp/emacs-lisp/*.el @@ -174,6 +192,8 @@ test-lisp-emacs-lisp-eieio-tests-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/emacs-lisp/eieio*.el - test/lisp/emacs-lisp/eieio-tests/*.el @@ -193,6 +213,8 @@ test-lisp-emacs-lisp-faceup-tests-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/emacs-lisp/faceup*.el - test/lisp/emacs-lisp/faceup-tests/*.el @@ -212,6 +234,8 @@ test-lisp-emulation-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/emulation/*.el - test/lisp/emulation/*.el @@ -231,6 +255,8 @@ test-lisp-erc-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/erc/*.el - test/lisp/erc/*.el @@ -250,6 +276,8 @@ test-lisp-eshell-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/eshell/*.el - test/lisp/eshell/*.el @@ -269,6 +297,8 @@ test-lisp-gnus-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/gnus/*.el - test/lisp/gnus/*.el @@ -288,6 +318,8 @@ test-lisp-image-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/image/*.el - test/lisp/image/*.el @@ -307,6 +339,8 @@ test-lisp-international-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/international/*.el - test/lisp/international/*.el @@ -326,6 +360,8 @@ test-lisp-mail-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/mail/*.el - test/lisp/mail/*.el @@ -345,6 +381,8 @@ test-lisp-mh-e-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/mh-e/*.el - test/lisp/mh-e/*.el @@ -364,6 +402,8 @@ test-lisp-net-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/net/*.el - test/lisp/net/*.el @@ -383,6 +423,8 @@ test-lisp-nxml-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/nxml/*.el - test/lisp/nxml/*.el @@ -402,6 +444,8 @@ test-lisp-obsolete-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/obsolete/*.el - test/lisp/obsolete/*.el @@ -421,6 +465,8 @@ test-lisp-org-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/org/*.el - test/lisp/org/*.el @@ -440,6 +486,8 @@ test-lisp-play-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/play/*.el - test/lisp/play/*.el @@ -459,6 +507,8 @@ test-lisp-progmodes-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/progmodes/*.el - test/lisp/progmodes/*.el @@ -478,6 +528,8 @@ test-lisp-so-long-tests-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/so-long*.el - test/lisp/so-long-tests/*.el @@ -497,6 +549,8 @@ test-lisp-term-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/term/*.el - test/lisp/term/*.el @@ -516,6 +570,8 @@ test-lisp-textmodes-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/textmodes/*.el - test/lisp/textmodes/*.el @@ -535,6 +591,8 @@ test-lisp-url-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/url/*.el - test/lisp/url/*.el @@ -554,6 +612,8 @@ test-lisp-vc-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - lisp/vc/*.el - test/lisp/vc/*.el @@ -573,6 +633,8 @@ test-misc-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - admin/*.el - test/misc/*.el @@ -592,6 +654,8 @@ test-src-inotify: stage: normal extends: [.job-template, .test-template] rules: + - if: I_PIPELINE_SOURCE == "schedule" + when: never - changes: - src/*.{h,c} - test/src/*.el commit fdafaf5e416e3a38660aedfb02dc5efd0bbd8f17 Author: Lars Ingebrigtsen Date: Wed Nov 24 12:44:45 2021 +0100 Fix min-width end condition handling * src/xdisp.c (handle_display_prop): Fix check for min-width ends -- they may be consecutive. diff --git a/src/xdisp.c b/src/xdisp.c index 4d3b487805..e8de0634a1 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -5340,8 +5340,7 @@ handle_display_prop (struct it *it) Qdisplay, object, &overlay); /* Handle min-width ends. */ - if (! NILP (it->min_width_property) - && NILP (find_display_property (propval, Qmin_width))) + if (!NILP (it->min_width_property)) display_min_width (it, bufpos, object, Qnil); if (NILP (propval)) commit d30cdbbde40e0084c748c11e8f71a449021452c0 Author: Po Lu Date: Wed Nov 24 11:15:06 2021 +0000 Correct adjustments to frame widths in events * src/haiku_support.cc (EmacsWindow.FrameResized) (EmacsWindow.Zoom): Adjust widths to fit into the correct coordinate system. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 8768635069..d6d7967524 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -664,8 +664,8 @@ class EmacsWindow : public BDirectWindow { struct haiku_resize_event rq; rq.window = this; - rq.px_heightf = newHeight; - rq.px_widthf = newWidth; + rq.px_heightf = newHeight + 1.0f; + rq.px_widthf = newWidth + 1.0f; haiku_write (FRAME_RESIZED, &rq); BDirectWindow::FrameResized (newWidth, newHeight); @@ -755,8 +755,8 @@ class EmacsWindow : public BDirectWindow rq.x = o.x; rq.y = o.y; - rq.width = w; - rq.height = h; + rq.width = w + 1; + rq.height = h + 1; if (fullscreen_p) MakeFullscreen (0); commit 3a8e4f13fa43b3636b584f48cddf92de5dc64e4d Author: Po Lu Date: Wed Nov 24 11:03:58 2021 +0000 Remove unused arguments to EmacsView.AfterResize * src/haiku_support.cc (EmacsView.AfterResize): Remove unused arguments. (BView_resize_to): Stop passing unused arguments. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 5f9fe7e234..8768635069 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -979,7 +979,7 @@ class EmacsView : public BView } void - AfterResize (float newWidth, float newHeight) + AfterResize (void) { if (offscreen_draw_view) { @@ -1657,7 +1657,7 @@ BView_resize_to (void *view, int width, int height) if (!vw->LockLooper ()) gui_abort ("Failed to lock view for resize"); vw->ResizeTo (width, height); - vw->AfterResize (width, height); + vw->AfterResize (); vw->UnlockLooper (); } commit a13b437c81f1f2e54555e7281480ea7e8eee8753 Author: Lars Ingebrigtsen Date: Wed Nov 24 11:55:53 2021 +0100 Add support for the min-width display property * doc/lispref/display.texi (Display Property): Document get-display-property. (Other Display Specs): Document min-width property. * src/dispextern.h (struct it): Add fields for min-width handling. * src/xdisp.c (find_display_property, get_display_property): New helper functions. (display_min_width): Insert stretch glyphs based on the min width. (Fget_display_property): New defun. (handle_display_prop): Handle min-width ends. (handle_single_display_spec): Handle min-width starts. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 6b1c52b485..dc53eeff9b 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -4874,9 +4874,7 @@ window on a minibuffer-less frame. The @code{display} text property (or overlay property) is used to insert images into text, and to control other aspects of how text -displays. The value of the @code{display} property should be a -display specification, or a list or vector containing several display -specifications. Display specifications in the same @code{display} +displays. Display specifications in the same @code{display} property value generally apply in parallel to the text they cover. If several sources (overlays and/or a text property) specify values @@ -4884,6 +4882,28 @@ for the @code{display} property, only one of the values takes effect, following the rules of @code{get-char-property}. @xref{Examining Properties}. + The value of the @code{display} property should be a display +specification, or a list or vector containing several display +specifications. + +@defun get-display-property position prop &optional object properties +This convenience function can be used to get a specific display +property, no matter whether the @code{display} property is a vector, a +list or a simple property. This is like @code{get-text-property} +(@pxref{Examining Properties}), but works on the @code{display} +property only. + +@var{position} is the position in the buffer or string to examine, and +@var{prop} is the @code{display} property to return. The optional +@var{object} argument should be either a string or a buffer, and +defaults to the current buffer. If the optional @var{properties} +argument is non-@code{nil}, it should be a @code{display} property, +and in that case, @var{position} and @var{object} are ignored. (This +can be useful if you've already gotten the @code{display} property +with @code{get-char-property}, for instance (@pxref{Examining +Properties}). +@end defun + @cindex display property, unsafe evaluation @cindex security, and display specifications Some of the display specifications allow inclusion of Lisp forms, @@ -5159,6 +5179,22 @@ text that has the specification. It displays all of these spaces be an integer or float. Characters other than spaces are not affected at all; in particular, this has no effect on tab characters. +@item (min-width (@var{width})) +This display specification adds padding to the end of the text if the +text is shorter than @var{width}. The text is partitioned using the +identity of the parameter, which is why the parameter is a list with +one element. For instance: + +@lisp +(insert (propertize "foo" '(display (min-width (6.0))))) +@end lisp + +This will add padding after @samp{foo} bringing the total width up to +the width of six normal characters. Note that the ``range'' is +identified by the @code{(6.0)} list, compared with @code{eq}. The +width can be either a character width or a pixel specification +(@pxref{Pixel Specification}). + @item (height @var{height}) This display specification makes the text taller or shorter. Here are the possibilities for @var{height}: diff --git a/etc/NEWS b/etc/NEWS index 0bf3d9368b..1cd49c5289 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -668,6 +668,13 @@ Use 'exif-parse-file' and 'exif-field' instead. * Lisp Changes in Emacs 29.1 +** New function 'get-display-property'. +This is like 'get-text-property', but works on the 'display' text +property. + +** New 'min-width' 'display' property. +This allows setting a minimum width for a region. + ** Keymaps and key definitions +++ diff --git a/src/dispextern.h b/src/dispextern.h index a698f6546b..088297157a 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -2746,6 +2746,12 @@ struct it /* For iterating over bidirectional text. */ struct bidi_it bidi_it; bidi_dir_t paragraph_embedding; + + /* For handling the :min-width property. The object is the text + property we're testing the `eq' of (nil if none), and the integer + is the x position of the start of the run of glyphs. */ + Lisp_Object min_width_property; + int min_width_start; }; diff --git a/src/xdisp.c b/src/xdisp.c index 11ea836034..4d3b487805 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -822,6 +822,9 @@ bool help_echo_showing_p; /* Functions to mark elements as needing redisplay. */ enum { REDISPLAY_SOME = 2}; /* Arbitrary choice. */ +static bool calc_pixel_width_or_height (double *, struct it *, Lisp_Object, + struct font *, bool, int *); + void redisplay_other_windows (void) { @@ -5141,6 +5144,149 @@ setup_for_ellipsis (struct it *it, int len) it->ellipsis_p = true; } + +static Lisp_Object +find_display_property (Lisp_Object disp, Lisp_Object prop) +{ + if (NILP (disp)) + return Qnil; + /* We have a vector of display specs. */ + if (VECTORP (disp)) + { + for (ptrdiff_t i = 0; i < ASIZE (disp); i++) + { + Lisp_Object elem = AREF (disp, i); + if (CONSP (elem) + && CONSP (XCDR (elem)) + && EQ (XCAR (elem), prop)) + return XCAR (XCDR (elem)); + } + return Qnil; + } + /* We have a list of display specs. */ + else if (CONSP (disp) + && CONSP (XCAR (disp))) + { + while (!NILP (disp)) + { + Lisp_Object elem = XCAR (disp); + if (CONSP (elem) + && CONSP (XCDR (elem)) + && EQ (XCAR (elem), prop)) + return XCAR (XCDR (elem)); + + /* Check that we have a proper list before going to the next + element. */ + if (CONSP (XCDR (disp))) + disp = XCDR (disp); + else + disp = Qnil; + } + return Qnil; + } + /* A simple display spec. */ + else if (CONSP (disp) + && CONSP (XCDR (disp)) + && EQ (XCAR (disp), prop)) + return XCAR (XCDR (disp)); + else + return Qnil; +} + +static Lisp_Object get_display_property (ptrdiff_t bufpos, Lisp_Object prop, + Lisp_Object object) +{ + return find_display_property (Fget_text_property (make_fixnum (bufpos), + + Qdisplay, object), + prop); +} + +static void +display_min_width (struct it *it, ptrdiff_t bufpos, + Lisp_Object object, Lisp_Object width_spec) +{ + /* We're being called at the end of the `min-width' sequence, + probably. */ + if (!NILP (it->min_width_property) + && !EQ (width_spec, it->min_width_property)) + { + if (!it->glyph_row) + return; + + /* Check that we're really right after the sequence of + characters covered by this `min-width'. */ + if (bufpos > BEGV + && EQ (it->min_width_property, + get_display_property (bufpos - 1, Qmin_width, object))) + { + Lisp_Object w = Qnil; + double width; +#ifdef HAVE_WINDOW_SYSTEM + if (FRAME_WINDOW_P (it->f)) + { + struct font *font = NULL; + struct face *face = FACE_FROM_ID (it->f, it->face_id); + font = face->font ? face->font : FRAME_FONT (it->f); + calc_pixel_width_or_height (&width, it, + XCAR (it->min_width_property), + font, true, NULL); + width -= it->current_x - it->min_width_start; + w = list1 (make_int (width)); + } + else +#endif + { + calc_pixel_width_or_height (&width, it, + XCAR (it->min_width_property), + NULL, true, NULL); + width -= (it->current_x - it->min_width_start) / + FRAME_COLUMN_WIDTH (it->f); + w = make_int (width); + } + + /* Insert the stretch glyph. */ + it->object = list3 (Qspace, QCwidth, w); + produce_stretch_glyph (it); + it->min_width_property = Qnil; + } + } + + /* We're at the start of a `min-width' sequence -- record the + position and the property, so that we can later see if we're at + the end. */ + if (CONSP (width_spec)) + { + if (bufpos == BEGV + || (bufpos > BEGV + && !EQ (width_spec, + get_display_property (bufpos - 1, Qmin_width, object)))) + { + it->min_width_property = width_spec; + it->min_width_start = it->current_x; + } + } +} + +DEFUN ("get-display-property", Fget_display_property, + Sget_display_property, 2, 4, 0, + doc: /* Get the `display' property PROP at POSITION. +If OBJECT, this should be a buffer or string where the property is +fetched from. This defaults to the current buffer. + +If PROPERTIES, use those properties instead of the properties at +POSITION. */) + (Lisp_Object position, Lisp_Object prop, Lisp_Object object, + Lisp_Object properties) +{ + if (NILP (properties)) + properties = Fget_text_property (position, Qdisplay, object); + else + CHECK_LIST (properties); + + return find_display_property (properties, prop); +} + /*********************************************************************** @@ -5187,16 +5333,22 @@ handle_display_prop (struct it *it) if (!it->string_from_display_prop_p) it->area = TEXT_AREA; + if (!STRINGP (it->string)) + object = it->w->contents; + propval = get_char_property_and_overlay (make_fixnum (position->charpos), Qdisplay, object, &overlay); + + /* Handle min-width ends. */ + if (! NILP (it->min_width_property) + && NILP (find_display_property (propval, Qmin_width))) + display_min_width (it, bufpos, object, Qnil); + if (NILP (propval)) return HANDLED_NORMALLY; /* Now OVERLAY is the overlay that gave us this property, or nil if it was a text property. */ - if (!STRINGP (it->string)) - object = it->w->contents; - display_replaced = handle_display_spec (it, propval, object, overlay, position, bufpos, FRAME_WINDOW_P (it->f)); @@ -5250,6 +5402,7 @@ handle_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, && !(CONSP (XCAR (spec)) && EQ (XCAR (XCAR (spec)), Qmargin)) && !EQ (XCAR (spec), Qleft_fringe) && !EQ (XCAR (spec), Qright_fringe) + && !EQ (XCAR (spec), Qmin_width) && !NILP (XCAR (spec))) { for (; CONSP (spec); spec = XCDR (spec)) @@ -5483,6 +5636,17 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, return 0; } + /* Handle `(min-width (WIDTH))'. */ + if (CONSP (spec) + && EQ (XCAR (spec), Qmin_width) + && CONSP (XCDR (spec)) + && CONSP (XCAR (XCDR (spec)))) + { + if (it) + display_min_width (it, bufpos, object, XCAR (XCDR (spec))); + return 0; + } + /* Handle `(slice X Y WIDTH HEIGHT)'. */ if (CONSP (spec) && EQ (XCAR (spec), Qslice)) @@ -7186,6 +7350,7 @@ reseat_1 (struct it *it, struct text_pos pos, bool set_stop_p) } /* This make the information stored in it->cmp_it invalidate. */ it->cmp_it.id = -1; + it->min_width_property = Qnil; } @@ -35121,6 +35286,7 @@ be let-bound around code that needs to disable messages temporarily. */); defsubr (&Smove_point_visually); defsubr (&Sbidi_find_overridden_directionality); defsubr (&Sdisplay__line_is_continued_p); + defsubr (&Sget_display_property); DEFSYM (Qmenu_bar_update_hook, "menu-bar-update-hook"); DEFSYM (Qoverriding_terminal_local_map, "overriding-terminal-local-map"); diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el index cc67aef8e1..ae4aacd9c7 100644 --- a/test/src/xdisp-tests.el +++ b/test/src/xdisp-tests.el @@ -154,4 +154,20 @@ int main () { nil) 138)))) +(ert-deftest test-get-display-property () + (with-temp-buffer + (insert (propertize "foo" 'face 'bold 'display '(height 2.0))) + (should (equal (get-display-property 2 'height) 2.0))) + (with-temp-buffer + (insert (propertize "foo" 'face 'bold 'display '((height 2.0) + (space-width 2.0)))) + (should (equal (get-display-property 2 'height) 2.0)) + (should (equal (get-display-property 2 'space-width) 2.0))) + (with-temp-buffer + (insert (propertize "foo bar" 'face 'bold + 'display '[(height 2.0) + (space-width 20)])) + (should (equal (get-display-property 2 'height) 2.0)) + (should (equal (get-display-property 2 'space-width) 20)))) + ;;; xdisp-tests.el ends here commit 8efee422e1915a000f7220e680e3165407171388 Author: Gregory Heytings Date: Wed Nov 24 08:54:37 2021 +0100 Re-enable the disabledForeground X resource. * doc/emacs/xresources.texi (Lucid Resources): Document the resource. Also document the 'cursor' resource (bug#52052). * lwlib/xlwmenu.c (make_drawing_gcs): Re-enable the use of the disabledForeground resource. The use of this X resource was disabled without reason in commit ef93458b2f8 by overwriting its value with the value of the foreground resource. diff --git a/doc/emacs/xresources.texi b/doc/emacs/xresources.texi index 0e0070829c..a7bd006df4 100644 --- a/doc/emacs/xresources.texi +++ b/doc/emacs/xresources.texi @@ -395,6 +395,8 @@ Background color. Foreground color for a selected item. @item foreground Foreground color. +@item disabledForeground +Foreground color for a disabled menu item. @ifnottex @item horizontalSpacing Horizontal spacing in pixels between items. Default is 3. @@ -409,6 +411,9 @@ elements. Default is 1. @item borderThickness Thickness of the external borders of the menu bars and pop-up menus. Default is 1. +@item cursor +Name of the cursor to use in the menu bars and pop-up menus. Default +is @code{"right_ptr"}. @end ifnottex @item margin Margin of the menu bar, in characters. Default is 1. diff --git a/lwlib/xlwmenu.c b/lwlib/xlwmenu.c index 5f8832bb36..a0a10d13db 100644 --- a/lwlib/xlwmenu.c +++ b/lwlib/xlwmenu.c @@ -1657,7 +1657,6 @@ make_drawing_gcs (XlwMenuWidget mw) #define BRIGHTNESS(color) (((color) & 0xff) + (((color) >> 8) & 0xff) + (((color) >> 16) & 0xff)) /* Allocate color for disabled menu-items. */ - mw->menu.disabled_foreground = mw->menu.foreground; if (BRIGHTNESS(mw->menu.foreground) < BRIGHTNESS(mw->core.background_pixel)) scale = 2.3; else commit 7e3c2b553fede9feeeb755dfeba875fece0c2f63 Author: Alan Third Date: Tue Nov 23 20:56:44 2021 +0000 Allow NS to handle non-text clipboard contents * src/nsselect.m (ns_get_foreign_selection): Handle non-plain text clipboard entries. (ns_string_from_pasteboard): Remove EOL conversion. (syms_of_nsselect): Define QTARGETS. diff --git a/src/nsselect.m b/src/nsselect.m index 5ab3ef77fe..e999835014 100644 --- a/src/nsselect.m +++ b/src/nsselect.m @@ -215,9 +215,74 @@ Updated by Christian Limpach (chris@nice.ch) static Lisp_Object ns_get_foreign_selection (Lisp_Object symbol, Lisp_Object target) { + NSDictionary *typeLookup; id pb; pb = ns_symbol_to_pb (symbol); - return pb != nil ? ns_string_from_pasteboard (pb) : Qnil; + + /* Dictionary for looking up NS types from MIME types, and vice versa. */ + typeLookup + = [NSDictionary + dictionaryWithObjectsAndKeys: + @"text/plain", NSPasteboardTypeURL, +#if NS_USE_NSPasteboardTypeFileURL + @"text/plain", NSPasteboardTypeFileURL, +#else + @"text/plain", NSFilenamesPboardType, +#endif + @"text/html", NSPasteboardTypeHTML, + @"text/plain", NSPasteboardTypeMultipleTextSelection, + @"application/pdf", NSPasteboardTypePDF, + @"image/png", NSPasteboardTypePNG, + @"application/rtf", NSPasteboardTypeRTF, + @"application/rtfd", NSPasteboardTypeRTFD, + @"STRING", NSPasteboardTypeString, + @"text/plain", NSPasteboardTypeTabularText, + @"image/tiff", NSPasteboardTypeTIFF, + nil]; + + if (EQ (target, QTARGETS)) + { + NSMutableArray *types = [NSMutableArray arrayWithCapacity:3]; + + NSString *type; + NSEnumerator *e = [[pb types] objectEnumerator]; + while (type = [e nextObject]) + { + NSString *val = [typeLookup valueForKey:type]; + if (val && ! [types containsObject:val]) + [types addObject:val]; + } + + Lisp_Object v = Fmake_vector (make_fixnum ([types count]+1), Qnil); + ASET (v, 0, QTARGETS); + + for (int i = 0 ; i < [types count] ; i++) + ASET (v, i+1, intern ([[types objectAtIndex:i] UTF8String])); + + return v; + } + else + { + NSData *d; + NSArray *availableTypes; + NSString *result, *t; + + if (!NILP (target)) + availableTypes + = [typeLookup allKeysForObject: + [NSString stringWithLispString:SYMBOL_NAME (target)]]; + else + availableTypes = @[NSPasteboardTypeString]; + + t = [pb availableTypeFromArray:availableTypes]; + + result = [pb stringForType:t]; + if (result) + return [result lispString]; + + d = [pb dataForType:t]; + return make_string ([d bytes], [d length]); + } } @@ -234,8 +299,6 @@ Updated by Christian Limpach (chris@nice.ch) ns_string_from_pasteboard (id pb) { NSString *type, *str; - const char *utfStr; - int length; type = [pb availableTypeFromArray: ns_return_types]; if (type == nil) @@ -260,6 +323,14 @@ Updated by Christian Limpach (chris@nice.ch) } } + /* FIXME: Is the below EOL conversion even needed? I've removed it + for now so we can see if it causes problems. */ + return [str lispString]; + +#if 0 + const char *utfStr; + int length; + /* assume UTF8 */ NS_DURING { @@ -294,6 +365,7 @@ Updated by Christian Limpach (chris@nice.ch) NS_ENDHANDLER return make_string (utfStr, length); +#endif } @@ -491,6 +563,8 @@ Updated by Christian Limpach (chris@nice.ch) DEFSYM (QTEXT, "TEXT"); DEFSYM (QFILE_NAME, "FILE_NAME"); + DEFSYM (QTARGETS, "TARGETS"); + defsubr (&Sns_disown_selection_internal); defsubr (&Sns_get_selection); defsubr (&Sns_own_selection_internal); commit e754973d4ddf6925b0289ce1f2cbbf415310a5da Author: Po Lu Date: Wed Nov 24 09:56:29 2021 +0000 Clear past end of frame on Haiku * src/haiku_support.c (EmacsWindow.FrameResized): Delete size adjustment. * src/haikuterm.c (haiku_clear_frame): Clear one pixel past the end of the frame. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 9fb98f7081..5f9fe7e234 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -664,8 +664,8 @@ class EmacsWindow : public BDirectWindow { struct haiku_resize_event rq; rq.window = this; - rq.px_heightf = newHeight + 1.0f; - rq.px_widthf = newWidth + 1.0f; + rq.px_heightf = newHeight; + rq.px_widthf = newWidth; haiku_write (FRAME_RESIZED, &rq); BDirectWindow::FrameResized (newWidth, newHeight); diff --git a/src/haikuterm.c b/src/haikuterm.c index 3e5b6046f6..97dbe3c8d3 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -218,11 +218,11 @@ haiku_clear_frame (struct frame *f) block_input (); BView_draw_lock (view); BView_StartClip (view); - BView_ClipToRect (view, 0, 0, FRAME_PIXEL_WIDTH (f), - FRAME_PIXEL_HEIGHT (f)); + BView_ClipToRect (view, 0, 0, FRAME_PIXEL_WIDTH (f) + 1, + FRAME_PIXEL_HEIGHT (f) + 1); BView_SetHighColor (view, FRAME_BACKGROUND_PIXEL (f)); - BView_FillRectangle (view, 0, 0, FRAME_PIXEL_WIDTH (f), - FRAME_PIXEL_HEIGHT (f)); + BView_FillRectangle (view, 0, 0, FRAME_PIXEL_WIDTH (f) + 1, + FRAME_PIXEL_HEIGHT (f) + 1); BView_EndClip (view); BView_draw_unlock (view); unblock_input (); commit 7394c0fe3540d96109034495a50e317b1bceb338 Merge: 3219518e5c 3a2eee6f74 Author: Po Lu Date: Wed Nov 24 09:39:58 2021 +0000 Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs commit 3219518e5c64281237bb604e6c2977f655aff238 Author: Po Lu Date: Wed Nov 24 09:38:26 2021 +0000 Fix 1 pixel wide border in frames on Haiku * src/haiku_support.cc (EmacsWindow.FrameResized): Add 1 to pixel widths. * src/haikuterm.c (haiku_read_socket): Use `lrint' to round widths. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 5f9fe7e234..9fb98f7081 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -664,8 +664,8 @@ class EmacsWindow : public BDirectWindow { struct haiku_resize_event rq; rq.window = this; - rq.px_heightf = newHeight; - rq.px_widthf = newWidth; + rq.px_heightf = newHeight + 1.0f; + rq.px_widthf = newWidth + 1.0f; haiku_write (FRAME_RESIZED, &rq); BDirectWindow::FrameResized (newWidth, newHeight); diff --git a/src/haikuterm.c b/src/haikuterm.c index be2b6c2491..3e5b6046f6 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -2626,8 +2626,8 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (!f) continue; - int width = (int) b->px_widthf; - int height = (int) b->px_heightf; + int width = lrint (b->px_widthf); + int height = lrint (b->px_heightf); BView_draw_lock (FRAME_HAIKU_VIEW (f)); BView_resize_to (FRAME_HAIKU_VIEW (f), width, height); commit 3a2eee6f7439866ac51d0d4c7b43f7f9f6f88fe2 Author: Lars Ingebrigtsen Date: Wed Nov 24 08:27:22 2021 +0100 Fix string-glyph-split infloop * lisp/emacs-lisp/subr-x.el (string-glyph-split): Fix infloop when applied to (string-glyph-split "✈️🌍") (bug#52067). diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index b2dae564c2..95254b946e 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -456,7 +456,12 @@ This takes into account combining characters and grapheme clusters." (start 0) comp) (while (< start (length string)) - (if (setq comp (find-composition-internal start nil string nil)) + (if (setq comp (find-composition-internal + start + ;; Don't search backward in the string for the + ;; start of the composition. + (min (length string) (1+ start)) + string nil)) (progn (push (substring string (car comp) (cadr comp)) result) (setq start (cadr comp))) commit d63fc69b192a608f98c15d6014430f28138fd82e Author: Gregory Heytings Date: Wed Nov 24 07:58:11 2021 +0100 Pass options from make to configure through a variable. * GNUmakefile (configure): Use the variable. * INSTALL.REPO: Document the variable (bug#51965). diff --git a/GNUmakefile b/GNUmakefile index 5155487de2..76fd77ba1b 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -104,8 +104,13 @@ configure: Makefile: configure @echo >&2 'There seems to be no Makefile in this directory.' +ifeq ($(configure),default) @echo >&2 'Running ./configure ...' ./configure +else + @echo >&2 'Running ./configure '$(configure)'...' + ./configure $(configure) +endif @echo >&2 'Makefile built.' # 'make bootstrap' in a fresh checkout needn't run 'configure' twice. diff --git a/INSTALL.REPO b/INSTALL.REPO index da56d7611b..182c2e9534 100644 --- a/INSTALL.REPO +++ b/INSTALL.REPO @@ -8,9 +8,15 @@ directory on your local machine: To build the repository code, simply run 'make' in the 'emacs' directory. This should work if your files are freshly checked out -from the repository, and if you have the proper tools installed. If -it doesn't work, or if you have special build requirements, the -following information may be helpful. +from the repository, and if you have the proper tools installed; the +default configuration options will be used. Other configuration +options can be specified by setting a 'configure' variable, for +example: + + $ make configure="--prefix=/opt/emacs CFLAGS='-O0 -g3'" + +If the above doesn't work, or if you have special build requirements, +the following information may be helpful. Building Emacs from the source-code repository requires some tools that are not needed when building from a release. You will need: @@ -58,7 +64,16 @@ To update loaddefs.el (and similar files), do: If either of the above partial procedures fails, try 'make bootstrap'. If CPU time is not an issue, 'make bootstrap' is a more thorough way -to rebuild, avoiding spurious problems. +to rebuild, avoiding spurious problems. 'make bootstrap' rebuilds +Emacs with the same configuration options as the previous build; it +can also be used to rebuild Emacs with other configuration options by +setting a 'configure' variable, for example: + + $ make bootstrap configure="CFLAGS='-O0 -g3'" + +To rebuild Emacs with the default configuration options, you can use: + + $ make bootstrap configure=default Occasionally, there are changes that 'make bootstrap' won't be able to handle. The most thorough cleaning can be achieved by 'git clean -fdx' diff --git a/Makefile.in b/Makefile.in index 3c092fa63d..4b40d8741d 100644 --- a/Makefile.in +++ b/Makefile.in @@ -1145,14 +1145,23 @@ check-info: info .PHONY: bootstrap -# Bootstrapping does the following: +# Without a 'configure' variable, bootstrapping does the following: # * Remove files to start from a bootstrap-clean slate. # * Run autogen.sh. # * Rebuild Makefile, to update the build procedure itself. # * Do the actual build. -bootstrap: bootstrap-clean +# With a 'configure' variable, bootstrapping does the following: +# * Remove files to start from an extraclean slate. +# * Do the actual build, during which the 'configure' variable is +# used (see the Makefile goal in GNUmakefile). +bootstrap: +ifndef configure + $(MAKE) bootstrap-clean cd $(srcdir) && ./autogen.sh autoconf $(MAKE) MAKEFILE_NAME=force-Makefile force-Makefile +else + $(MAKE) extraclean +endif $(MAKE) all .PHONY: ChangeLog change-history change-history-commit change-history-nocommit commit d112c75f53c690e6f13ec3b340dbc384425bb04d Merge: c484b749f2 756b8a5f1b Author: Stefan Kangas Date: Wed Nov 24 07:00:27 2021 +0100 Merge from origin/emacs-28 756b8a5f1b Fix typos in documentation 38fdeaef46 ; * etc/DEBUG: Fix last change. commit c484b749f204522b3e9df643cb371b9f5511f4d2 Author: Po Lu Date: Wed Nov 24 09:49:39 2021 +0800 Fix mouse-wheel-text-scale * lisp/mwheel.el (mouse-wheel-text-scale): Test for alternative events correctly. diff --git a/lisp/mwheel.el b/lisp/mwheel.el index 5d18cf84c2..6a853a3521 100644 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@ -415,8 +415,8 @@ value of ARG, and the command uses it in subsequent scrolls." (cond ((memq button (list mouse-wheel-down-event mouse-wheel-down-alternate-event)) (text-scale-increase 1)) - ((eq button (list mouse-wheel-up-event - mouse-wheel-up-alternate-event)) + ((memq button (list mouse-wheel-up-event + mouse-wheel-up-alternate-event)) (text-scale-decrease 1))) (select-window selected-window)))) commit dc0ed8818bebaf8a6003bb9626d28ea9be070890 Author: Po Lu Date: Wed Nov 24 01:46:33 2021 +0000 Remove extraneous code left over from the ftbe font driver * src/haikuterm.c (syms_of_haikuterm): Remove dead code. diff --git a/src/haikuterm.c b/src/haikuterm.c index da8c92d621..be2b6c2491 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -3620,9 +3620,6 @@ Setting it to any other value is equivalent to `shift'. */); staticpro (&rdb); Fprovide (Qhaiku, Qnil); -#ifdef HAVE_BE_FREETYPE - Fprovide (Qfreetype, Qnil); -#endif #ifdef USE_BE_CAIRO Fprovide (intern_c_string ("cairo"), Qnil); #endif commit f90176b1ca8440adcbcfa61ce0da35d967b9cd6f Author: Po Lu Date: Wed Nov 24 09:09:45 2021 +0800 Use only effective modifiers when handling XI2 button events * src/xterm.c (handle_one_xevent): Use mods.effective when constructing button events. diff --git a/src/xterm.c b/src/xterm.c index dfbbff2302..7e0d58745e 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10149,10 +10149,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, bv.x = lrint (xev->event_x); bv.y = lrint (xev->event_y); bv.window = xev->event; - bv.state = xev->mods.base - | xev->mods.effective - | xev->mods.latched - | xev->mods.locked; + bv.state = xev->mods.effective; bv.time = xev->time; memset (&compose_status, 0, sizeof (compose_status)); commit 88637c341510e92bb6213418628e2ce84332450a Author: Michael Albinus Date: Tue Nov 23 16:25:41 2021 +0100 Adapt artifacts paths in emba testjobs * test/infra/Makefile.in (subdir_template): Adapt artifacts paths. * test/infra/test-jobs.yml: Regenerate. diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in index c091d2a7ba..c6b9b39e8c 100644 --- a/test/infra/Makefile.in +++ b/test/infra/Makefile.in @@ -81,9 +81,7 @@ define subdir_template @echo ' public: true' >>$(FILE) @echo ' expire_in: 1 week' >>$(FILE) @echo ' paths:' >>$(FILE) - @echo ' - $(tn)/test/$(1)/*.log' >>$(FILE) - @echo ' - $(tn)/**/core' >>$(FILE) - @echo ' - $(tn)/core' >>$(FILE) + @echo ' - $(tn)/$(1)/*.log' >>$(FILE) @echo ' when: always' >>$(FILE) @echo ' variables:' >>$(FILE) @echo ' target: emacs-inotify' >>$(FILE) diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml index 7949403553..413dfeba33 100644 --- a/test/infra/test-jobs.yml +++ b/test/infra/test-jobs.yml @@ -12,9 +12,7 @@ test-lib-src-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lib-src/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lib-src/*.log when: always variables: target: emacs-inotify @@ -33,9 +31,7 @@ test-lisp-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/*.log when: always variables: target: emacs-inotify @@ -54,9 +50,7 @@ test-lisp-calc-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/calc/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/calc/*.log when: always variables: target: emacs-inotify @@ -75,9 +69,7 @@ test-lisp-calendar-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/calendar/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/calendar/*.log when: always variables: target: emacs-inotify @@ -96,9 +88,7 @@ test-lisp-cedet-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/cedet/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/cedet/*.log when: always variables: target: emacs-inotify @@ -117,9 +107,7 @@ test-lisp-cedet-semantic-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/cedet/semantic/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/cedet/semantic/*.log when: always variables: target: emacs-inotify @@ -138,9 +126,7 @@ test-lisp-cedet-semantic-bovine-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/cedet/semantic/bovine/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/cedet/semantic/bovine/*.log when: always variables: target: emacs-inotify @@ -159,9 +145,7 @@ test-lisp-cedet-srecode-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/cedet/srecode/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/cedet/srecode/*.log when: always variables: target: emacs-inotify @@ -180,9 +164,7 @@ test-lisp-emacs-lisp-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/emacs-lisp/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/emacs-lisp/*.log when: always variables: target: emacs-inotify @@ -201,9 +183,7 @@ test-lisp-emacs-lisp-eieio-tests-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/emacs-lisp/eieio-tests/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/emacs-lisp/eieio-tests/*.log when: always variables: target: emacs-inotify @@ -222,9 +202,7 @@ test-lisp-emacs-lisp-faceup-tests-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/emacs-lisp/faceup-tests/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/emacs-lisp/faceup-tests/*.log when: always variables: target: emacs-inotify @@ -243,9 +221,7 @@ test-lisp-emulation-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/emulation/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/emulation/*.log when: always variables: target: emacs-inotify @@ -264,9 +240,7 @@ test-lisp-erc-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/erc/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/erc/*.log when: always variables: target: emacs-inotify @@ -285,9 +259,7 @@ test-lisp-eshell-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/eshell/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/eshell/*.log when: always variables: target: emacs-inotify @@ -306,9 +278,7 @@ test-lisp-gnus-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/gnus/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/gnus/*.log when: always variables: target: emacs-inotify @@ -327,9 +297,7 @@ test-lisp-image-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/image/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/image/*.log when: always variables: target: emacs-inotify @@ -348,9 +316,7 @@ test-lisp-international-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/international/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/international/*.log when: always variables: target: emacs-inotify @@ -369,9 +335,7 @@ test-lisp-mail-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/mail/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/mail/*.log when: always variables: target: emacs-inotify @@ -390,9 +354,7 @@ test-lisp-mh-e-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/mh-e/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/mh-e/*.log when: always variables: target: emacs-inotify @@ -411,9 +373,7 @@ test-lisp-net-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/net/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/net/*.log when: always variables: target: emacs-inotify @@ -432,9 +392,7 @@ test-lisp-nxml-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/nxml/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/nxml/*.log when: always variables: target: emacs-inotify @@ -453,9 +411,7 @@ test-lisp-obsolete-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/obsolete/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/obsolete/*.log when: always variables: target: emacs-inotify @@ -474,9 +430,7 @@ test-lisp-org-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/org/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/org/*.log when: always variables: target: emacs-inotify @@ -495,9 +449,7 @@ test-lisp-play-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/play/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/play/*.log when: always variables: target: emacs-inotify @@ -516,9 +468,7 @@ test-lisp-progmodes-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/progmodes/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/progmodes/*.log when: always variables: target: emacs-inotify @@ -537,9 +487,7 @@ test-lisp-so-long-tests-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/so-long-tests/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/so-long-tests/*.log when: always variables: target: emacs-inotify @@ -558,9 +506,7 @@ test-lisp-term-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/term/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/term/*.log when: always variables: target: emacs-inotify @@ -579,9 +525,7 @@ test-lisp-textmodes-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/textmodes/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/textmodes/*.log when: always variables: target: emacs-inotify @@ -600,9 +544,7 @@ test-lisp-url-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/url/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/url/*.log when: always variables: target: emacs-inotify @@ -621,9 +563,7 @@ test-lisp-vc-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/lisp/vc/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/lisp/vc/*.log when: always variables: target: emacs-inotify @@ -642,9 +582,7 @@ test-misc-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/misc/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/misc/*.log when: always variables: target: emacs-inotify @@ -663,9 +601,7 @@ test-src-inotify: public: true expire_in: 1 week paths: - - ${test_name}/test/src/*.log - - ${test_name}/**/core - - ${test_name}/core + - ${test_name}/src/*.log when: always variables: target: emacs-inotify commit 756b8a5f1bd28aeadc804fd2f93ce7e823a1d4a2 Author: Takesi Ayanokoji Date: Tue Nov 23 23:30:23 2021 +0900 Fix typos in documentation * doc/lispref/anti.texi: * doc/misc/efaq.texi: Fix typos. Copyright-paperwork-exempt: yes diff --git a/doc/lispref/anti.texi b/doc/lispref/anti.texi index 118df05c79..45cbff61e0 100644 --- a/doc/lispref/anti.texi +++ b/doc/lispref/anti.texi @@ -135,7 +135,7 @@ the programmers should be trusted to know what they are doing. @item We deleted several features of the @code{pcase} macro, in accordance -with our general plane to remove @code{pcase} from Emacs: +with our general plan to remove @code{pcase} from Emacs: @itemize @minus @item diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index 18342e65b0..cdb6f9b584 100644 --- a/doc/misc/efaq.texi +++ b/doc/misc/efaq.texi @@ -1086,7 +1086,7 @@ Emacs Lisp form at point. @cindex pasting text on text terminals @cindex bracketed paste mode @item -On text terminals that support the ``bracketed paste mode'' EMacs now +On text terminals that support the ``bracketed paste mode'' Emacs now uses that mode by default. This mode allows Emacs to distinguish between pasted text and text typed by the user. @@ -2542,12 +2542,12 @@ load @code{dired-x} by adding the following to your @file{.emacs} file: (require 'dired-x)) @end lisp -With @code{dired-x} loaded, @kbd{M-o} toggles omitting in each dired buffer. +With @code{dired-x} loaded, @kbd{C-x M-o} toggles omitting in each dired buffer. You can make omitting the default for new dired buffers by putting the following in your @file{.emacs}: @lisp -(add-hook 'dired-mode-hook 'dired-omit-toggle) +(add-hook 'dired-mode-hook 'dired-omit-mode) @end lisp If you're tired of seeing backup files whenever you do an @samp{ls} at commit 38fdeaef4654d4d4fac8c73f48058d94f158e711 Author: Eli Zaretskii Date: Tue Nov 23 16:25:48 2021 +0200 ; * etc/DEBUG: Fix last change. diff --git a/etc/DEBUG b/etc/DEBUG index ced6a92d71..a05aeef160 100644 --- a/etc/DEBUG +++ b/etc/DEBUG @@ -591,10 +591,13 @@ If you cannot figure out the cause for the problem using the above, native-compile the problematic file after setting the variable 'comp-libgccjit-reproducer' to a non-nil value. That should produce a file named ELNFILENAME_libgccjit_repro.c, where ELNFILENAME is the -name of the problematic .eln file in the same directory where the .eln -file is produced, or a file repro.c under your ~/.emacs.d/eln-cache -(which one depends on how the native-compilation is invoked). Then -attach that reproducer C file to your bug report. +name of the problematic .eln file, either in the same directory where +the .eln file is produced, or under your ~/.emacs.d/eln-cache (which +one depends on how the native-compilation is invoked). It is also +possible that the reproducer file's name will be something like +subr--trampoline-XXXXXXX_FUNCTION_libgccjit_repro.c, where XXXXXXX is +a long string of hex digits and FUNCTION is some function from the +compiled .el file. Attach that reproducer C file to your bug report. ** Following longjmp call. commit 8b62b20159f8ec3f5c7ea5227f814681741d61b1 Merge: 84d9d47660 bdb489ad5d Author: Eli Zaretskii Date: Tue Nov 23 15:11:14 2021 +0200 Merge from origin/emacs-28 bdb489a ; * etc/DEBUG: Adjust instructions for libgccjit reproducer. b4fb381 ; * src/xdisp.c (produce_stretch_glyph): Avoid compilation wa... commit bdb489ad5dd81c8aef8ada8940f6981034dfaf82 Author: Eli Zaretskii Date: Tue Nov 23 14:44:45 2021 +0200 ; * etc/DEBUG: Adjust instructions for libgccjit reproducer. diff --git a/etc/DEBUG b/etc/DEBUG index 555370588f..ced6a92d71 100644 --- a/etc/DEBUG +++ b/etc/DEBUG @@ -591,9 +591,10 @@ If you cannot figure out the cause for the problem using the above, native-compile the problematic file after setting the variable 'comp-libgccjit-reproducer' to a non-nil value. That should produce a file named ELNFILENAME_libgccjit_repro.c, where ELNFILENAME is the -name of the problematic .eln file, in the same directory where the -.eln file is produced. Then attach that reproducer C file to your bug -report. +name of the problematic .eln file in the same directory where the .eln +file is produced, or a file repro.c under your ~/.emacs.d/eln-cache +(which one depends on how the native-compilation is invoked). Then +attach that reproducer C file to your bug report. ** Following longjmp call. commit b4fb381d8d7e866676650a7283ac6d873838c49f Author: Eli Zaretskii Date: Tue Nov 23 14:37:53 2021 +0200 ; * src/xdisp.c (produce_stretch_glyph): Avoid compilation warning. diff --git a/src/xdisp.c b/src/xdisp.c index b3647f71e4..34add80798 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -29853,7 +29853,7 @@ produce_stretch_glyph (struct it *it) #ifdef HAVE_WINDOW_SYSTEM int ascent = 0; bool zero_height_ok_p = false; - struct face *face; + struct face *face = NULL; /* shut up GCC's -Wmaybe-uninitialized */ if (FRAME_WINDOW_P (it->f)) { commit 84d9d47660be203ba04f807a5a9de27151df7273 Author: Stefan Kangas Date: Tue Nov 23 11:39:21 2021 +0100 Prefer locate-user-emacs-file in gitmerge.el * admin/gitmerge.el (gitmerge-status-file): Prefer 'locate-user-emacs-file' to fiddling with 'user-emacs-directory'. diff --git a/admin/gitmerge.el b/admin/gitmerge.el index 67fca87c11..658ceb77f4 100644 --- a/admin/gitmerge.el +++ b/admin/gitmerge.el @@ -68,8 +68,7 @@ bump Emacs version\\|Auto-commit")) (defvar gitmerge-minimum-missing 10 "Minimum number of missing commits to consider merging in batch mode.") -(defvar gitmerge-status-file (expand-file-name "gitmerge-status" - user-emacs-directory) +(defvar gitmerge-status-file (locate-user-emacs-file "gitmerge-status") "File where missing commits will be saved between sessions.") (defvar gitmerge-ignore-branches-regexp commit 5c4136f56465c6b2c65fb3577603879cdbbe7f97 Author: Po Lu Date: Tue Nov 23 17:57:09 2021 +0800 Fix compilation with XInput 2 but without XKB * src/xterm.c (handle_one_xevent): Remove extraneous conditional. diff --git a/src/xterm.c b/src/xterm.c index bbfd3b0e82..dfbbff2302 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10310,9 +10310,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, char copy_buffer[81]; char *copy_bufptr = copy_buffer; unsigned char *copy_ubufptr; -#ifdef HAVE_XKB int copy_bufsiz = sizeof (copy_buffer); -#endif ptrdiff_t i; int nchars, len; commit 4c5efda8d33e582c53a0d7a1d3dfabecaca038bd Merge: 2955d46c00 d791cd556d Author: Stefan Kangas Date: Tue Nov 23 08:49:49 2021 +0100 Merge from origin/emacs-28 d791cd556d Fix '(space :relative-width N)' display spec w/non-ASCII c... 712898210f * lisp/proced.el (proced-sort-header): Fix event positions... # Conflicts: # lisp/proced.el commit 2955d46c00430b38310d0fae968adea91e2bbc3d Author: Po Lu Date: Tue Nov 23 11:08:45 2021 +0800 Only reset scroll valuators on real enter events * src/xterm.c (handle_one_xevent): Test event detail and mode before resetting scroll valuators. diff --git a/src/xterm.c b/src/xterm.c index 11e7e602c0..bbfd3b0e82 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -9870,7 +9870,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_display_set_last_user_time (dpyinfo, xi_event->time); x_detect_focus_change (dpyinfo, any, event, &inev.ie); - xi_reset_scroll_valuators_for_device_id (dpyinfo, enter->deviceid); + + if (enter->detail != XINotifyInferior + && enter->mode != XINotifyPassiveUngrab + && enter->mode != XINotifyUngrab && any) + xi_reset_scroll_valuators_for_device_id (dpyinfo, enter->deviceid); + f = any; if (f && x_mouse_click_focus_ignore_position) @@ -9895,7 +9900,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_display_set_last_user_time (dpyinfo, xi_event->time); x_detect_focus_change (dpyinfo, any, event, &inev.ie); - xi_reset_scroll_valuators_for_device_id (dpyinfo, leave->deviceid); f = x_top_window_to_frame (dpyinfo, leave->event); if (f) commit da3db6a15d1fa20e862ee7b95aeed84ab86dbb05 Author: Po Lu Date: Tue Nov 23 01:20:15 2021 +0000 Fix delay between tool bar clicks and visual feedback * src/haikuterm.c (haiku_read_socket): Redisplay after tool bar click. diff --git a/src/haikuterm.c b/src/haikuterm.c index 5364ebf823..da8c92d621 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -2843,8 +2843,11 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) tool_bar_p = EQ (window, f->tool_bar_window); if (tool_bar_p) - handle_tool_bar_click - (f, x, y, type == BUTTON_DOWN, inev.modifiers); + { + handle_tool_bar_click + (f, x, y, type == BUTTON_DOWN, inev.modifiers); + redisplay (); + } } if (type == BUTTON_UP) commit 919cb31cf7f2aec2d8134783b0a5bb93a621fcaf Author: Po Lu Date: Tue Nov 23 09:01:33 2021 +0800 Fix XI2 keysym translation * src/xterm.c (handle_one_xevent): Handle XI_KeyPress events that can't be translated into strings. diff --git a/src/xterm.c b/src/xterm.c index 197776ce31..11e7e602c0 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10324,7 +10324,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, memset (&xkey, 0, sizeof xkey); xkey.type = KeyPress; - xkey.serial = 0; + xkey.serial = xev->serial; xkey.send_event = xev->send_event; xkey.display = xev->display; xkey.window = xev->event; @@ -10439,53 +10439,38 @@ handle_one_xevent (struct x_display_info *dpyinfo, emacs_abort (); } else - { #endif + { #ifdef HAVE_XKB int overflow = 0; KeySym sym = keysym; if (dpyinfo->xkb_desc) { - if (!(nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, - state & ~mods_rtrn, copy_bufptr, - copy_bufsiz, &overflow))) - goto XI_OTHER; - } - else -#else - { - block_input (); - char *str = XKeysymToString (keysym); - if (!str) + nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, + state & ~mods_rtrn, copy_bufptr, + copy_bufsiz, &overflow); + if (overflow) { - unblock_input (); - goto XI_OTHER; + copy_bufptr = alloca ((copy_bufsiz += overflow) + * sizeof *copy_bufptr); + overflow = 0; + nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, + state & ~mods_rtrn, copy_bufptr, + copy_bufsiz, &overflow); + + if (overflow) + nbytes = 0; } - nbytes = strlen (str) + 1; - copy_bufptr = alloca (nbytes); - strcpy (copy_bufptr, str); - unblock_input (); } + else #endif -#ifdef HAVE_XKB - if (overflow) { - overflow = 0; - copy_bufptr = alloca (copy_bufsiz + overflow); - keysym = sym; - if (!(nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, - state & ~mods_rtrn, copy_bufptr, - copy_bufsiz + overflow, &overflow))) - goto XI_OTHER; - - if (overflow) - goto XI_OTHER; + nbytes = XLookupString (&xkey, copy_bufptr, + copy_bufsiz, &keysym, + &compose_status); } -#endif -#ifdef HAVE_X_I18N } -#endif /* First deal with keysyms which have defined translations to characters. */ commit 9ceb3070e34ad8a54184fd0deda477bf5ff77000 Author: Stefan Monnier Date: Mon Nov 22 14:23:26 2021 -0500 * lisp/subr.el (event-start, event-end): Handle `(menu-bar)` events * lisp/net/browse-url.el (browse-url-interactive-arg): Simplify accordingly diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 19afb81331..011e43c447 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -737,8 +737,7 @@ position clicked before acting. This function returns a list (URL NEW-WINDOW-FLAG) for use in `interactive'." (let ((event (elt (this-command-keys) 0))) - (when (mouse-event-p event) - (mouse-set-point event))) + (mouse-set-point event)) (list (read-string prompt (or (and transient-mark-mode mark-active ;; rfc2396 Appendix E. (replace-regexp-in-string diff --git a/lisp/subr.el b/lisp/subr.el index 867db47a47..06ea503da6 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -1553,22 +1553,22 @@ nil or (STRING . POSITION)'. `posn-timestamp': The time the event occurred, in milliseconds. For more information, see Info node `(elisp)Click Events'." - (if (consp event) (nth 1 event) - ;; Use `window-point' for the case when the current buffer - ;; is temporarily switched to some other buffer (bug#50256) - (or (posn-at-point (window-point)) - (list (selected-window) (window-point) '(0 . 0) 0)))) + (or (and (consp event) (nth 1 event)) + ;; Use `window-point' for the case when the current buffer + ;; is temporarily switched to some other buffer (bug#50256) + (posn-at-point (window-point)) + (list (selected-window) (window-point) '(0 . 0) 0))) (defun event-end (event) "Return the ending position of EVENT. EVENT should be a click, drag, or key press event. See `event-start' for a description of the value returned." - (if (consp event) (nth (if (consp (nth 2 event)) 2 1) event) - ;; Use `window-point' for the case when the current buffer - ;; is temporarily switched to some other buffer (bug#50256) - (or (posn-at-point (window-point)) - (list (selected-window) (window-point) '(0 . 0) 0)))) + (or (and (consp event) (nth (if (consp (nth 2 event)) 2 1) event)) + ;; Use `window-point' for the case when the current buffer + ;; is temporarily switched to some other buffer (bug#50256) + (posn-at-point (window-point)) + (list (selected-window) (window-point) '(0 . 0) 0))) (defsubst event-click-count (event) "Return the multi-click count of EVENT, a click or drag event. commit 44923722f42c2974c140e385c4c765f60944efe7 Author: Juri Linkov Date: Mon Nov 22 21:05:15 2021 +0200 * lisp/textmodes/flyspell.el: Pop up the menu under cursor from keyboard. * lisp/textmodes/flyspell.el (flyspell-emacs-popup): Use popup-menu-normalize-position with point when no mouse is involved, instead of the incorrect use of mouse-position (bug#52025). diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 258e5fde67..2a9cae29f7 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -2270,17 +2270,8 @@ If OPOINT is non-nil, restore point there after adjusting it for replacement." ;;*---------------------------------------------------------------------*/ (defun flyspell-emacs-popup (event poss word) "The Emacs popup menu." - (if (and (not event) - (display-mouse-p)) - (let* ((mouse-pos (mouse-position)) - (mouse-pos (if (nth 1 mouse-pos) - mouse-pos - (set-mouse-position (car mouse-pos) - (/ (frame-width) 2) 2) - (mouse-position)))) - (setq event (list (list (car (cdr mouse-pos)) - (1+ (cdr (cdr mouse-pos)))) - (car mouse-pos))))) + (unless event + (setq event (popup-menu-normalize-position (point)))) (let* ((corrects (flyspell-sort (car (cdr (cdr poss))) word)) (cor-menu (if (consp corrects) (mapcar (lambda (correct) commit 0601afcf7c6c3498df010cef1511c38f254cbbf8 Author: Stefan Monnier Date: Mon Nov 22 14:06:14 2021 -0500 src/indent.c, src/xdisp.c: Questions about with_echo_area_buffer_unwind_data diff --git a/src/indent.c b/src/indent.c index de6b489561..914dabf1e7 100644 --- a/src/indent.c +++ b/src/indent.c @@ -2051,6 +2051,7 @@ window_column_x (struct window *w, Lisp_Object window, /* Restore window's buffer and point. */ +/* FIXME: Merge with `with_echo_area_buffer_unwind_data`? */ static void restore_window_buffer (Lisp_Object list) { diff --git a/src/xdisp.c b/src/xdisp.c index d965021142..259d057adb 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -10937,6 +10937,7 @@ WINDOW. */) /* The unwind form of with_echo_area_buffer is what we need here to make WINDOW temporarily show our buffer. */ + /* FIXME: Can we move this into the `if (!EQ (buffer, w->contents))`? */ record_unwind_protect (unwind_with_echo_area_buffer, with_echo_area_buffer_unwind_data (w)); commit c3ac8285d42eeb88d7abf9670229884f1bbccaae Author: Michael Albinus Date: Mon Nov 22 19:40:56 2021 +0100 ; Remove "needs" from emba jobs diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in index a6fa81570a..c091d2a7ba 100644 --- a/test/infra/Makefile.in +++ b/test/infra/Makefile.in @@ -70,7 +70,6 @@ define subdir_template @echo >>$(FILE) @echo 'test-$(subst /,-,$(1))-inotify:' >>$(FILE) @echo ' stage: normal' >>$(FILE) - @echo ' needs: [build-image-inotify]' >>$(FILE) @echo ' extends: [.job-template, .test-template]' >>$(FILE) @echo ' rules:' >>$(FILE) @echo ' - changes:' >>$(FILE) diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml index 059ab4f0e0..7949403553 100644 --- a/test/infra/test-jobs.yml +++ b/test/infra/test-jobs.yml @@ -1,7 +1,6 @@ test-lib-src-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -23,7 +22,6 @@ test-lib-src-inotify: test-lisp-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -45,7 +43,6 @@ test-lisp-inotify: test-lisp-calc-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -67,7 +64,6 @@ test-lisp-calc-inotify: test-lisp-calendar-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -89,7 +85,6 @@ test-lisp-calendar-inotify: test-lisp-cedet-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -111,7 +106,6 @@ test-lisp-cedet-inotify: test-lisp-cedet-semantic-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -133,7 +127,6 @@ test-lisp-cedet-semantic-inotify: test-lisp-cedet-semantic-bovine-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -155,7 +148,6 @@ test-lisp-cedet-semantic-bovine-inotify: test-lisp-cedet-srecode-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -177,7 +169,6 @@ test-lisp-cedet-srecode-inotify: test-lisp-emacs-lisp-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -199,7 +190,6 @@ test-lisp-emacs-lisp-inotify: test-lisp-emacs-lisp-eieio-tests-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -221,7 +211,6 @@ test-lisp-emacs-lisp-eieio-tests-inotify: test-lisp-emacs-lisp-faceup-tests-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -243,7 +232,6 @@ test-lisp-emacs-lisp-faceup-tests-inotify: test-lisp-emulation-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -265,7 +253,6 @@ test-lisp-emulation-inotify: test-lisp-erc-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -287,7 +274,6 @@ test-lisp-erc-inotify: test-lisp-eshell-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -309,7 +295,6 @@ test-lisp-eshell-inotify: test-lisp-gnus-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -331,7 +316,6 @@ test-lisp-gnus-inotify: test-lisp-image-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -353,7 +337,6 @@ test-lisp-image-inotify: test-lisp-international-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -375,7 +358,6 @@ test-lisp-international-inotify: test-lisp-mail-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -397,7 +379,6 @@ test-lisp-mail-inotify: test-lisp-mh-e-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -419,7 +400,6 @@ test-lisp-mh-e-inotify: test-lisp-net-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -441,7 +421,6 @@ test-lisp-net-inotify: test-lisp-nxml-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -463,7 +442,6 @@ test-lisp-nxml-inotify: test-lisp-obsolete-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -485,7 +463,6 @@ test-lisp-obsolete-inotify: test-lisp-org-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -507,7 +484,6 @@ test-lisp-org-inotify: test-lisp-play-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -529,7 +505,6 @@ test-lisp-play-inotify: test-lisp-progmodes-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -551,7 +526,6 @@ test-lisp-progmodes-inotify: test-lisp-so-long-tests-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -573,7 +547,6 @@ test-lisp-so-long-tests-inotify: test-lisp-term-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -595,7 +568,6 @@ test-lisp-term-inotify: test-lisp-textmodes-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -617,7 +589,6 @@ test-lisp-textmodes-inotify: test-lisp-url-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -639,7 +610,6 @@ test-lisp-url-inotify: test-lisp-vc-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -661,7 +631,6 @@ test-lisp-vc-inotify: test-misc-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: @@ -683,7 +652,6 @@ test-misc-inotify: test-src-inotify: stage: normal - needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: commit eef6626b55e59d4a76e8666108cc68a578fac793 Author: Juri Linkov Date: Mon Nov 22 20:15:28 2021 +0200 * lisp/tab-bar.el: 'C-x t RET' creates a new tab for non-existent tab name. * lisp/tab-bar.el (tab-bar-switch-to-tab): Create a new tab and rename it to NAME when can't find the tab with the given NAME (bug#51935). diff --git a/etc/NEWS b/etc/NEWS index 09f17d6553..0bf3d9368b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -181,6 +181,11 @@ For example, a 'display-buffer-alist' entry of will make the body of the chosen window 40 columns wide. For the height use 'window-height' in combination with 'body-lines'. +** Tab Bars and Tab Lines + +--- +*** 'C-x t RET' creates a new tab when the provided tab name doesn't exist. + ** Better detection of text suspiciously reordered on display. The function 'bidi-find-overridden-directionality' has been extended to detect reordering effects produced by embeddings and isolates diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index d331f29194..656cb878e3 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -1196,7 +1196,9 @@ Interactively, ARG is the prefix numeric argument and defaults to 1." Default values are tab names sorted by recency, so you can use \ \\\\[next-history-element] to get the name of the most recently visited tab, the second -most recent, and so on." +most recent, and so on. +When the tab with that NAME doesn't exist, create a new tab +and rename it to NAME." (interactive (let* ((recent-tabs (mapcar (lambda (tab) (alist-get 'name tab)) @@ -1204,7 +1206,11 @@ most recent, and so on." (list (completing-read (format-prompt "Switch to tab by name" (car recent-tabs)) recent-tabs nil nil nil nil recent-tabs)))) - (tab-bar-select-tab (1+ (or (tab-bar--tab-index-by-name name) 0)))) + (let ((tab-index (tab-bar--tab-index-by-name name))) + (if tab-index + (tab-bar-select-tab (1+ tab-index)) + (tab-bar-new-tab) + (tab-bar-rename-tab name)))) (defalias 'tab-bar-select-tab-by-name 'tab-bar-switch-to-tab) commit d096e12f447c1c67fe6fb6baa44212781d27ef53 Author: Mattias Engdegård Date: Mon Nov 22 19:07:32 2021 +0100 Simplify `gnu` compilation-mode regexp * lisp/progmodes/compile.el (compilation-error-regexp-alist-alist): Remove the pattern ostensibly added for Ruby, because at closer inspection it could never have matched anything. This lessens the performance impact of the pattern added for GCC's -fanalyzer, now slightly tweaked. diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index c0e16ce351..2d4070c389 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -346,15 +346,10 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) ;; PROGRAM:SOURCE-FILE-NAME:LINENO: MESSAGE ;; which is used for non-interactive programs other than ;; compilers (e.g. the "jade:" entry in compilation.txt). - (? (| (regexp "[[:alpha:]][-[:alnum:].]+: ?") - ;; FIXME: This pattern was added for handling messages - ;; from Ruby, but it is unclear whether it is actually - ;; used since the gcc-include rule above seems to cover - ;; it. - (regexp "[ \t]+\\(?:in \\|from\\)") + (? (| (: alpha (+ (in ?. ?- alnum)) ":" (? " ")) ;; Skip indentation generated by tools like GCC's ;; -fanalyzer. - (: (+ space) "|"))) + (: (+ (in " \t")) "|"))) ;; File name group. (group-n 1 commit d791cd556d622accb935e4dd230023c485d1e07a Author: Eli Zaretskii Date: Mon Nov 22 20:00:48 2021 +0200 Fix '(space :relative-width N)' display spec w/non-ASCII chars * src/xdisp.c (produce_stretch_glyph): Use the correct face for non-ASCII characters. Support :relative-width display spec on Lisp strings, not just on buffer text. diff --git a/src/xdisp.c b/src/xdisp.c index 0316408d92..b3647f71e4 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -29810,7 +29810,7 @@ append_stretch_glyph (struct it *it, Lisp_Object object, #endif /* HAVE_WINDOW_SYSTEM */ /* Produce a stretch glyph for iterator IT. IT->object is the value - of the glyph property displayed. The value must be a list + of the display property. The value must be a list of the form `(space KEYWORD VALUE ...)' with the following KEYWORD/VALUE pairs being recognized: @@ -29820,7 +29820,7 @@ append_stretch_glyph (struct it *it, Lisp_Object object, 2. `:relative-width FACTOR' specifies that the width of the stretch should be computed from the width of the first character having the - `glyph' property, and should be FACTOR times that width. + `display' property, and should be FACTOR times that width. 3. `:align-to HPOS' specifies that the space should be wide enough to reach HPOS, a value in canonical character units. @@ -29832,7 +29832,7 @@ append_stretch_glyph (struct it *it, Lisp_Object object, 5. `:relative-height FACTOR' specifies that the height of the stretch should be FACTOR times the height of the characters having - the glyph property. + the display property. Either none or exactly one of 4 or 5 must be present. @@ -29853,10 +29853,11 @@ produce_stretch_glyph (struct it *it) #ifdef HAVE_WINDOW_SYSTEM int ascent = 0; bool zero_height_ok_p = false; + struct face *face; if (FRAME_WINDOW_P (it->f)) { - struct face *face = FACE_FROM_ID (it->f, it->face_id); + face = FACE_FROM_ID (it->f, it->face_id); font = face->font ? face->font : FRAME_FONT (it->f); prepare_face_for_display (it->f, face); } @@ -29877,14 +29878,27 @@ produce_stretch_glyph (struct it *it) else if (prop = Fplist_get (plist, QCrelative_width), NUMVAL (prop) > 0) { /* Relative width `:relative-width FACTOR' specified and valid. - Compute the width of the characters having the `glyph' + Compute the width of the characters having this `display' property. */ struct it it2; - unsigned char *p = BYTE_POS_ADDR (IT_BYTEPOS (*it)); + Lisp_Object object = it->stack[it->sp - 1].string; + unsigned char *p = (STRINGP (object) + ? SDATA (object) + IT_STRING_BYTEPOS (*it) + : BYTE_POS_ADDR (IT_BYTEPOS (*it))); + bool multibyte_p = + STRINGP (object) ? STRING_MULTIBYTE (object) : it->multibyte_p; it2 = *it; - if (it->multibyte_p) - it2.c = it2.char_to_display = string_char_and_length (p, &it2.len); + if (multibyte_p) + { + it2.c = it2.char_to_display = string_char_and_length (p, &it2.len); +#ifdef HAVE_WINDOW_SYSTEM + if (FRAME_WINDOW_P (it->f) && ! ASCII_CHAR_P (it2.c)) + it2.face_id = FACE_FOR_CHAR (it->f, face, it2.c, + IT_CHARPOS (*it), + STRINGP (object)? object : Qnil); +#endif + } else { it2.c = it2.char_to_display = *p, it2.len = 1; commit 6de588ad244172466bd1948d27f770a624ff9965 Author: Juri Linkov Date: Mon Nov 22 19:57:59 2021 +0200 * lisp/tab-bar.el (tab-bar-history-old-minibuffer-depth): Remove variable. (tab-bar--history-pre-change, tab-bar--history-change): Use minibuffer-depth instead of this variable (bug#51370). diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 4bb6391cd9..d331f29194 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -1818,16 +1818,11 @@ Interactively, prompt for GROUP-NAME." (defvar tab-bar-history-done-command nil "Command handled by `window-configuration-change-hook'.") -(defvar tab-bar-history-old-minibuffer-depth 0 - "Minibuffer depth before the current command.") - (defun tab-bar--history-pre-change () ;; Reset before the command could set it (setq tab-bar-history-omit nil) (setq tab-bar-history-pre-command this-command) - (setq tab-bar-history-old-minibuffer-depth (minibuffer-depth)) - ;; Store window-configuration before possibly entering the minibuffer. - (when (zerop tab-bar-history-old-minibuffer-depth) + (when (zerop (minibuffer-depth)) (setq tab-bar-history-old `((wc . ,(current-window-configuration)) (wc-point . ,(point-marker)))))) @@ -1837,15 +1832,13 @@ Interactively, prompt for GROUP-NAME." ;; Don't register changes performed by the same command ;; repeated in sequence, such as incremental window resizing. (not (eq tab-bar-history-done-command tab-bar-history-pre-command)) - ;; Store window-configuration before possibly entering - ;; the minibuffer. - (zerop tab-bar-history-old-minibuffer-depth)) + (zerop (minibuffer-depth))) (puthash (selected-frame) (seq-take (cons tab-bar-history-old (gethash (selected-frame) tab-bar-history-back)) tab-bar-history-limit) - tab-bar-history-back)) - (setq tab-bar-history-old nil) + tab-bar-history-back) + (setq tab-bar-history-old nil)) (setq tab-bar-history-done-command tab-bar-history-pre-command)) (defun tab-bar-history-back () commit 712898210fdc4d7d5efc1636c68f9eac1632c9f8 Author: Juri Linkov Date: Mon Nov 22 19:39:28 2021 +0200 * lisp/proced.el (proced-sort-header): Fix event positions (bug#1779). The logic was copied from 'tabulated-list-col-sort'. diff --git a/lisp/proced.el b/lisp/proced.el index fec2a29c84..3b754c24c5 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -1330,11 +1330,12 @@ It is converted to the corresponding attribute key. This command updates the variable `proced-sort'. Prefix ARG controls sort order, see `proced-sort-interactive'." (interactive (list last-input-event (or last-prefix-arg 'no-arg))) - (let ((start (event-start event)) - col key) + (let* ((start (event-start event)) + (obj (posn-object start)) + col key) (save-selected-window (select-window (posn-window start)) - (setq col (+ (1- (car (posn-actual-col-row start))) + (setq col (+ (if obj (cdr obj) (posn-point start)) (window-hscroll))) (when (and (<= 0 col) (< col (length proced-header-line))) (setq key (get-text-property col 'proced-key proced-header-line)) commit d737bfe911fc46f520fece46dfc930561272ab8d Author: Michael Albinus Date: Mon Nov 22 16:47:23 2021 +0100 ; Fix error in artifacts paths of emba jobs diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in index 36c27024af..a6fa81570a 100644 --- a/test/infra/Makefile.in +++ b/test/infra/Makefile.in @@ -82,8 +82,9 @@ define subdir_template @echo ' public: true' >>$(FILE) @echo ' expire_in: 1 week' >>$(FILE) @echo ' paths:' >>$(FILE) - @echo ' - test/$(1)/*.log' >>$(FILE) - @echo ' - **core' >>$(FILE) + @echo ' - $(tn)/test/$(1)/*.log' >>$(FILE) + @echo ' - $(tn)/**/core' >>$(FILE) + @echo ' - $(tn)/core' >>$(FILE) @echo ' when: always' >>$(FILE) @echo ' variables:' >>$(FILE) @echo ' target: emacs-inotify' >>$(FILE) diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml index 92eac04f59..059ab4f0e0 100644 --- a/test/infra/test-jobs.yml +++ b/test/infra/test-jobs.yml @@ -13,8 +13,9 @@ test-lib-src-inotify: public: true expire_in: 1 week paths: - - test/lib-src/*.log - - **core + - ${test_name}/test/lib-src/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -34,8 +35,9 @@ test-lisp-inotify: public: true expire_in: 1 week paths: - - test/lisp/*.log - - **core + - ${test_name}/test/lisp/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -55,8 +57,9 @@ test-lisp-calc-inotify: public: true expire_in: 1 week paths: - - test/lisp/calc/*.log - - **core + - ${test_name}/test/lisp/calc/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -76,8 +79,9 @@ test-lisp-calendar-inotify: public: true expire_in: 1 week paths: - - test/lisp/calendar/*.log - - **core + - ${test_name}/test/lisp/calendar/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -97,8 +101,9 @@ test-lisp-cedet-inotify: public: true expire_in: 1 week paths: - - test/lisp/cedet/*.log - - **core + - ${test_name}/test/lisp/cedet/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -118,8 +123,9 @@ test-lisp-cedet-semantic-inotify: public: true expire_in: 1 week paths: - - test/lisp/cedet/semantic/*.log - - **core + - ${test_name}/test/lisp/cedet/semantic/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -139,8 +145,9 @@ test-lisp-cedet-semantic-bovine-inotify: public: true expire_in: 1 week paths: - - test/lisp/cedet/semantic/bovine/*.log - - **core + - ${test_name}/test/lisp/cedet/semantic/bovine/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -160,8 +167,9 @@ test-lisp-cedet-srecode-inotify: public: true expire_in: 1 week paths: - - test/lisp/cedet/srecode/*.log - - **core + - ${test_name}/test/lisp/cedet/srecode/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -181,8 +189,9 @@ test-lisp-emacs-lisp-inotify: public: true expire_in: 1 week paths: - - test/lisp/emacs-lisp/*.log - - **core + - ${test_name}/test/lisp/emacs-lisp/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -202,8 +211,9 @@ test-lisp-emacs-lisp-eieio-tests-inotify: public: true expire_in: 1 week paths: - - test/lisp/emacs-lisp/eieio-tests/*.log - - **core + - ${test_name}/test/lisp/emacs-lisp/eieio-tests/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -223,8 +233,9 @@ test-lisp-emacs-lisp-faceup-tests-inotify: public: true expire_in: 1 week paths: - - test/lisp/emacs-lisp/faceup-tests/*.log - - **core + - ${test_name}/test/lisp/emacs-lisp/faceup-tests/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -244,8 +255,9 @@ test-lisp-emulation-inotify: public: true expire_in: 1 week paths: - - test/lisp/emulation/*.log - - **core + - ${test_name}/test/lisp/emulation/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -265,8 +277,9 @@ test-lisp-erc-inotify: public: true expire_in: 1 week paths: - - test/lisp/erc/*.log - - **core + - ${test_name}/test/lisp/erc/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -286,8 +299,9 @@ test-lisp-eshell-inotify: public: true expire_in: 1 week paths: - - test/lisp/eshell/*.log - - **core + - ${test_name}/test/lisp/eshell/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -307,8 +321,9 @@ test-lisp-gnus-inotify: public: true expire_in: 1 week paths: - - test/lisp/gnus/*.log - - **core + - ${test_name}/test/lisp/gnus/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -328,8 +343,9 @@ test-lisp-image-inotify: public: true expire_in: 1 week paths: - - test/lisp/image/*.log - - **core + - ${test_name}/test/lisp/image/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -349,8 +365,9 @@ test-lisp-international-inotify: public: true expire_in: 1 week paths: - - test/lisp/international/*.log - - **core + - ${test_name}/test/lisp/international/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -370,8 +387,9 @@ test-lisp-mail-inotify: public: true expire_in: 1 week paths: - - test/lisp/mail/*.log - - **core + - ${test_name}/test/lisp/mail/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -391,8 +409,9 @@ test-lisp-mh-e-inotify: public: true expire_in: 1 week paths: - - test/lisp/mh-e/*.log - - **core + - ${test_name}/test/lisp/mh-e/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -412,8 +431,9 @@ test-lisp-net-inotify: public: true expire_in: 1 week paths: - - test/lisp/net/*.log - - **core + - ${test_name}/test/lisp/net/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -433,8 +453,9 @@ test-lisp-nxml-inotify: public: true expire_in: 1 week paths: - - test/lisp/nxml/*.log - - **core + - ${test_name}/test/lisp/nxml/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -454,8 +475,9 @@ test-lisp-obsolete-inotify: public: true expire_in: 1 week paths: - - test/lisp/obsolete/*.log - - **core + - ${test_name}/test/lisp/obsolete/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -475,8 +497,9 @@ test-lisp-org-inotify: public: true expire_in: 1 week paths: - - test/lisp/org/*.log - - **core + - ${test_name}/test/lisp/org/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -496,8 +519,9 @@ test-lisp-play-inotify: public: true expire_in: 1 week paths: - - test/lisp/play/*.log - - **core + - ${test_name}/test/lisp/play/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -517,8 +541,9 @@ test-lisp-progmodes-inotify: public: true expire_in: 1 week paths: - - test/lisp/progmodes/*.log - - **core + - ${test_name}/test/lisp/progmodes/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -538,8 +563,9 @@ test-lisp-so-long-tests-inotify: public: true expire_in: 1 week paths: - - test/lisp/so-long-tests/*.log - - **core + - ${test_name}/test/lisp/so-long-tests/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -559,8 +585,9 @@ test-lisp-term-inotify: public: true expire_in: 1 week paths: - - test/lisp/term/*.log - - **core + - ${test_name}/test/lisp/term/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -580,8 +607,9 @@ test-lisp-textmodes-inotify: public: true expire_in: 1 week paths: - - test/lisp/textmodes/*.log - - **core + - ${test_name}/test/lisp/textmodes/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -601,8 +629,9 @@ test-lisp-url-inotify: public: true expire_in: 1 week paths: - - test/lisp/url/*.log - - **core + - ${test_name}/test/lisp/url/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -622,8 +651,9 @@ test-lisp-vc-inotify: public: true expire_in: 1 week paths: - - test/lisp/vc/*.log - - **core + - ${test_name}/test/lisp/vc/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -643,8 +673,9 @@ test-misc-inotify: public: true expire_in: 1 week paths: - - test/misc/*.log - - **core + - ${test_name}/test/misc/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify @@ -664,8 +695,9 @@ test-src-inotify: public: true expire_in: 1 week paths: - - test/src/*.log - - **core + - ${test_name}/test/src/*.log + - ${test_name}/**/core + - ${test_name}/core when: always variables: target: emacs-inotify commit 196196c739b0ea5db0d9ad5e753f9e38fba11593 Author: Michael Albinus Date: Mon Nov 22 16:33:16 2021 +0100 Adapt emba jobs * admin/notes/emba (Emacs jobset): Precise. * test/infra/Makefile.in (tn): New variable. (subdir_template): Use it. Handle eieio-tests, faceup-tests and so-long-tests. Rearrange .PHONY entry. Add needs and artifacts to emba job. * test/infra/gitlab-ci.yml (test-filenotify-gio): Move up. * test/infra/test-jobs.yml: Regenerate. diff --git a/admin/notes/emba b/admin/notes/emba index 4e500bc92c..a30e570fd4 100644 --- a/admin/notes/emba +++ b/admin/notes/emba @@ -28,7 +28,8 @@ The messages contain a URL to the log file of the failed job, like * Emacs jobset The Emacs jobset is defined in the Emacs source tree, file -'.gitlab-ci.yml'. It could be adapted for every Emacs branch, see +'.gitlab-ci.yml'. All related files are located in directory +'test/infra'. They could be adapted for every Emacs branch, see . A jobset on Gitlab is called pipeline. Emacs pipelines run through @@ -37,6 +38,11 @@ the stages 'build-images', 'platform-images' and 'native-comp-images' configuration parameters) as well as 'normal', 'slow', 'platforms' and 'native-comp' (run respective test jobs based on the produced images). +The jobs for stage 'normal' are contained in the file +'test/infra/test-jobs.yml'. This file is generated by calling 'make +-C test generate-test-jobs' in the Emacs source tree, and the +resulting file shall be pushed to the Emacs git repository afterwards. + Every job runs in a Debian docker container. It uses the local clone of the Emacs git repository to perform a bootstrap and test of Emacs. This could happen for several jobs with changed configuration, compile diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in index e91aea404d..36c27024af 100644 --- a/test/infra/Makefile.in +++ b/test/infra/Makefile.in @@ -1,4 +1,4 @@ -### test/infra/Makefile. Generated from Makefile.in by configure. +### @configure_input@ # Copyright (C) 2021 Free Software Foundation, Inc. @@ -33,6 +33,7 @@ top_builddir = @top_builddir@ SUBDIRS ?= $(shell make -s -C .. subdirs) SUBDIR_TARGETS = FILE = test-jobs.yml +tn = $$$${test_name} define subdir_template $(eval target = check-$(subst /,-,$(1))) @@ -41,41 +42,59 @@ define subdir_template $(eval ifeq ($(findstring src, $(1)), src) define changes - @echo " - $(1)/*.{h,c}" >>$(FILE) - @echo " - test/$(1)/*.el" >>$(FILE) + @echo ' - $(1)/*.{h,c}' >>$(FILE) + endef + else ifeq ($(findstring eieio, $(1)), eieio) + define changes + @echo ' - lisp/emacs-lisp/eieio*.el' >>$(FILE) + endef + else ifeq ($(findstring faceup, $(1)), faceup) + define changes + @echo ' - lisp/emacs-lisp/faceup*.el' >>$(FILE) + endef + else ifeq ($(findstring so-long, $(1)), so-long) + define changes + @echo ' - lisp/so-long*.el' >>$(FILE) endef else ifeq ($(findstring misc, $(1)), misc) define changes - @echo " - admin/*.el" >>$(FILE) - @echo " - test/$(1)/*.el" >>$(FILE) + @echo ' - admin/*.el' >>$(FILE) endef else define changes - @echo " - $(1)/*.el" >>$(FILE) - @echo " - test/$(1)/*.el" >>$(FILE) + @echo ' - $(1)/*.el' >>$(FILE) endef endif) - .PHONY: $(target) - $(target): - @echo "test-$(subst /,-,$(1))-inotify:" >>$(FILE) - @echo " stage: normal" >>$(FILE) - @echo " extends: [.job-template, .test-template]" >>$(FILE) - @echo " rules:" >>$(FILE) - @echo " - changes:" >>$(FILE) - $(changes) - @echo " variables:" >>$(FILE) - @echo " target: emacs-inotify" >>$(FILE) - @echo " make_params: \"-C test $(target)\"" >>$(FILE) @echo >>$(FILE) + @echo 'test-$(subst /,-,$(1))-inotify:' >>$(FILE) + @echo ' stage: normal' >>$(FILE) + @echo ' needs: [build-image-inotify]' >>$(FILE) + @echo ' extends: [.job-template, .test-template]' >>$(FILE) + @echo ' rules:' >>$(FILE) + @echo ' - changes:' >>$(FILE) + $(changes) + @echo ' - test/$(1)/*.el' >>$(FILE) + @echo ' - test/$(1)/*resources/**' >>$(FILE) + @echo ' artifacts:' >>$(FILE) + @echo ' name: $(tn)' >>$(FILE) + @echo ' public: true' >>$(FILE) + @echo ' expire_in: 1 week' >>$(FILE) + @echo ' paths:' >>$(FILE) + @echo ' - test/$(1)/*.log' >>$(FILE) + @echo ' - **core' >>$(FILE) + @echo ' when: always' >>$(FILE) + @echo ' variables:' >>$(FILE) + @echo ' target: emacs-inotify' >>$(FILE) + @echo ' make_params: "-C test $(target)"' >>$(FILE) endef $(foreach subdir, $(SUBDIRS), $(eval $(call subdir_template,$(subdir)))) all: generate-test-jobs -.PHONY: generate-test-jobs $(FILE) +.PHONY: generate-test-jobs $(FILE) $(SUBDIR_TARGETS) generate-test-jobs: clean $(FILE) $(SUBDIR_TARGETS) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index a0e2c283cd..47a8b51964 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -236,32 +236,12 @@ build-image-inotify: include: '/test/infra/test-jobs.yml' -# test-lisp-inotify: -# stage: normal -# extends: [.job-template, .test-template] -# variables: -# target: emacs-inotify -# make_params: "-C test check-lisp" - -# test-lisp-net-inotify: -# stage: normal -# extends: [.job-template, .test-template] -# variables: -# target: emacs-inotify -# make_params: "-C test check-lisp-net" - build-image-filenotify-gio: stage: platform-images extends: [.job-template, .build-template, .filenotify-gio-template] variables: target: emacs-filenotify-gio -build-image-gnustep: - stage: platform-images - extends: [.job-template, .build-template, .gnustep-template] - variables: - target: emacs-gnustep - test-filenotify-gio: # This tests file monitor libraries gfilemonitor and gio. stage: platforms @@ -271,6 +251,12 @@ test-filenotify-gio: target: emacs-filenotify-gio make_params: "-k -C test autorevert-tests.log filenotify-tests.log" +build-image-gnustep: + stage: platform-images + extends: [.job-template, .build-template, .gnustep-template] + variables: + target: emacs-gnustep + test-gnustep: # This tests the GNUstep build process. stage: platforms diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml index 9fb15081bd..92eac04f59 100644 --- a/test/infra/test-jobs.yml +++ b/test/infra/test-jobs.yml @@ -1,362 +1,672 @@ + test-lib-src-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lib-src/*.{h,c} - test/lib-src/*.el + - test/lib-src/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lib-src/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lib-src" test-lisp-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/*.el - test/lisp/*.el + - test/lisp/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp" test-lisp-calc-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/calc/*.el - test/lisp/calc/*.el + - test/lisp/calc/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/calc/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-calc" test-lisp-calendar-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/calendar/*.el - test/lisp/calendar/*.el + - test/lisp/calendar/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/calendar/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-calendar" test-lisp-cedet-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/cedet/*.el - test/lisp/cedet/*.el + - test/lisp/cedet/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/cedet/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-cedet" test-lisp-cedet-semantic-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/cedet/semantic/*.el - test/lisp/cedet/semantic/*.el + - test/lisp/cedet/semantic/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/cedet/semantic/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-cedet-semantic" test-lisp-cedet-semantic-bovine-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/cedet/semantic/bovine/*.el - test/lisp/cedet/semantic/bovine/*.el + - test/lisp/cedet/semantic/bovine/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/cedet/semantic/bovine/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-cedet-semantic-bovine" test-lisp-cedet-srecode-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/cedet/srecode/*.el - test/lisp/cedet/srecode/*.el + - test/lisp/cedet/srecode/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/cedet/srecode/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-cedet-srecode" test-lisp-emacs-lisp-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/emacs-lisp/*.el - test/lisp/emacs-lisp/*.el + - test/lisp/emacs-lisp/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/emacs-lisp/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-emacs-lisp" test-lisp-emacs-lisp-eieio-tests-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - - lisp/emacs-lisp/eieio-tests/*.el + - lisp/emacs-lisp/eieio*.el - test/lisp/emacs-lisp/eieio-tests/*.el + - test/lisp/emacs-lisp/eieio-tests/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/emacs-lisp/eieio-tests/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-emacs-lisp-eieio-tests" test-lisp-emacs-lisp-faceup-tests-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - - lisp/emacs-lisp/faceup-tests/*.el + - lisp/emacs-lisp/faceup*.el - test/lisp/emacs-lisp/faceup-tests/*.el + - test/lisp/emacs-lisp/faceup-tests/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/emacs-lisp/faceup-tests/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-emacs-lisp-faceup-tests" test-lisp-emulation-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/emulation/*.el - test/lisp/emulation/*.el + - test/lisp/emulation/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/emulation/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-emulation" test-lisp-erc-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/erc/*.el - test/lisp/erc/*.el + - test/lisp/erc/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/erc/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-erc" test-lisp-eshell-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/eshell/*.el - test/lisp/eshell/*.el + - test/lisp/eshell/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/eshell/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-eshell" test-lisp-gnus-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/gnus/*.el - test/lisp/gnus/*.el + - test/lisp/gnus/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/gnus/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-gnus" test-lisp-image-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/image/*.el - test/lisp/image/*.el + - test/lisp/image/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/image/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-image" test-lisp-international-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/international/*.el - test/lisp/international/*.el + - test/lisp/international/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/international/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-international" -test-lisp-legacy-inotify: - stage: normal - extends: [.job-template, .test-template] - rules: - - changes: - - lisp/legacy/*.el - - test/lisp/legacy/*.el - variables: - target: emacs-inotify - make_params: "-C test check-lisp-legacy" - test-lisp-mail-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/mail/*.el - test/lisp/mail/*.el + - test/lisp/mail/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/mail/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-mail" test-lisp-mh-e-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/mh-e/*.el - test/lisp/mh-e/*.el + - test/lisp/mh-e/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/mh-e/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-mh-e" test-lisp-net-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/net/*.el - test/lisp/net/*.el + - test/lisp/net/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/net/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-net" test-lisp-nxml-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/nxml/*.el - test/lisp/nxml/*.el + - test/lisp/nxml/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/nxml/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-nxml" test-lisp-obsolete-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/obsolete/*.el - test/lisp/obsolete/*.el + - test/lisp/obsolete/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/obsolete/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-obsolete" test-lisp-org-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/org/*.el - test/lisp/org/*.el + - test/lisp/org/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/org/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-org" test-lisp-play-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/play/*.el - test/lisp/play/*.el + - test/lisp/play/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/play/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-play" test-lisp-progmodes-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/progmodes/*.el - test/lisp/progmodes/*.el + - test/lisp/progmodes/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/progmodes/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-progmodes" test-lisp-so-long-tests-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - - lisp/so-long-tests/*.el + - lisp/so-long*.el - test/lisp/so-long-tests/*.el + - test/lisp/so-long-tests/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/so-long-tests/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-so-long-tests" test-lisp-term-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/term/*.el - test/lisp/term/*.el + - test/lisp/term/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/term/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-term" test-lisp-textmodes-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/textmodes/*.el - test/lisp/textmodes/*.el + - test/lisp/textmodes/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/textmodes/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-textmodes" test-lisp-url-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/url/*.el - test/lisp/url/*.el + - test/lisp/url/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/url/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-url" test-lisp-vc-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - lisp/vc/*.el - test/lisp/vc/*.el + - test/lisp/vc/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/lisp/vc/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-lisp-vc" test-misc-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - admin/*.el - test/misc/*.el + - test/misc/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/misc/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-misc" test-src-inotify: stage: normal + needs: [build-image-inotify] extends: [.job-template, .test-template] rules: - changes: - src/*.{h,c} - test/src/*.el + - test/src/*resources/** + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - test/src/*.log + - **core + when: always variables: target: emacs-inotify make_params: "-C test check-src" commit 55f84a12ec1451788cbabad983f19e065be1d43e Author: Stefan Kangas Date: Mon Nov 22 16:27:55 2021 +0100 ; Improve recent NEWS entry * etc/NEWS: Improve recently added entry on substitution of literal key sequences. Thanks to Eli Zaretskii . diff --git a/etc/NEWS b/etc/NEWS index 47b5578dee..09f17d6553 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -721,8 +721,8 @@ vectors and strings. +++ ** New substitution in docstrings and 'substitute-command-keys'. -Use "\\`KEYSEQ'" to insert a literal key sequence "KEYSEQ" -(e.g. "C-k") in a docstring or when calling 'substitute-command-keys', +Use \\`KEYSEQ' to insert a literal key sequence "KEYSEQ" (for example +\\`C-k') in a docstring or when calling 'substitute-command-keys', which will use the same face as a command substitution. This should be used only when a key sequence has no corresponding command, for example when it is read directly with 'read-key-sequence'. It must be commit a59e35d79fae989d1047b23ddabc6f2c5bbe0097 Author: Stefan Kangas Date: Mon Nov 22 16:11:45 2021 +0100 ; Further minor simplification of rx form in bytecomp.el * lisp/emacs-lisp/bytecomp.el (byte-compile--wide-docstring-p): Simplify even more. Thanks to Mattias Engdegård . diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 5dc03eac92..566a3fdf99 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1672,12 +1672,12 @@ URLs." ;; known at compile time. So instead, we assume that these ;; substitutions are of some length N. (replace-regexp-in-string - (rx "\\" (seq "[" (* (not "]")) "]")) + (rx "\\[" (* (not "]")) "]") (make-string byte-compile--wide-docstring-substitution-len ?x) ;; For literal key sequence substitutions (e.g. "\\`C-h'"), just ;; remove the markup as `substitute-command-keys' would. (replace-regexp-in-string - (rx "\\" (seq "`" (group (* (not "'"))) "'")) + (rx "\\`" (group (* (not "'"))) "'") "\\1" docstring))))) commit a5fbc21bc6c695623f8ae8c2df635e9d6220c483 Author: Eli Zaretskii Date: Mon Nov 22 17:05:40 2021 +0200 Improve recently installed documentation * doc/lispref/display.texi (Size of Displayed Text): Move to description of 'buffer-text-pixel-size' to preserve previous text; mention the importance of WINDOW. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 2341883129..6b1c52b485 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -2140,21 +2140,6 @@ height of all of these lines, if present, in the return value. whole and does not care about the size of individual lines. The following function does. -@defun buffer-text-pixel-size &optional buffer-or-name window from to x-limit y-limit -This is much like @code{window-text-pixel-size}, but can be used when -the buffer isn't shown in a window. (@code{window-text-pixel-size} is -faster when it is, so this function shouldn't be used in that case.) - -@var{buffer-or-name} must specify a live buffer or the name of a live -buffer and defaults to the current buffer. @var{window} must be a -live window and defaults to the selected one. The return value is a -cons of the maximum pixel-width of any text line and the pixel-height -of all the text lines of the buffer specified by @var{buffer-or-name}. - -The optional arguments @var{x-limit} and @var{y-limit} have the same -meaning as with @code{window-text-pixel-size}. -@end defun - @defun window-lines-pixel-dimensions &optional window first last body inverse left This function calculates the pixel dimensions of each line displayed in the specified @var{window}. It does so by walking @var{window}'s @@ -2216,6 +2201,23 @@ though when this function is run from an idle timer with a delay of zero seconds. @end defun +@defun buffer-text-pixel-size &optional buffer-or-name window from to x-limit y-limit +This is much like @code{window-text-pixel-size}, but can be used when +the buffer isn't shown in a window. (@code{window-text-pixel-size} is +faster when it is, so this function shouldn't be used in that case.) + +@var{buffer-or-name} must specify a live buffer or the name of a live +buffer and defaults to the current buffer. @var{window} must be a +live window and defaults to the selected one; the function will +compute the text dimensions as if @var{buffer} is displayed in +@var{window}. The return value is a cons of the maximum pixel-width +of any text line and the pixel-height of all the text lines of the +buffer specified by @var{buffer-or-name}. + +The optional arguments @var{x-limit} and @var{y-limit} have the same +meaning as with @code{window-text-pixel-size}. +@end defun + @defun string-pixel-width string This is a convenience function that uses @code{window-text-pixel-size} to compute the width of @var{string} (in pixels). commit 698e044a253e9d0e4ec2c74b0b9648f139f2192b Author: Robert Pluim Date: Mon Nov 22 14:20:45 2021 +0100 ; * etc/NEWS: Fix some typos and improve some entries. diff --git a/etc/NEWS b/etc/NEWS index 626b67d03a..47b5578dee 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -105,8 +105,6 @@ the previous definition to be discarded, which was probably not intended when this occurs in batch mode. To remedy the error, rename tests so that they all have unique names. -** Emacs now supports Unicode Standard version 14.0. - ** Emoji +++ @@ -436,7 +434,7 @@ This works like 'image-transform-fit-to-window'. *** New user option 'image-auto-resize-max-scale-percent'. The new 'fit-window' option will never scale an image more than this -much (in percent). It is nil by default. +much (in percent). It is nil by default, which means no limit. ** Image-Dired @@ -549,7 +547,7 @@ WebKit widget. +++ *** New minor mode 'xwidget-webkit-isearch-mode'. -This mode acts similarly to incremental search, and allows to search +This mode acts similarly to incremental search, and allows searching the contents of a WebKit widget. In xwidget-webkit mode, it is bound to 'C-s' and 'C-r'. @@ -722,7 +720,7 @@ This is like 'kbd', but only returns vectors instead of a mix of vectors and strings. +++ -** New substitution in docstrings and 'substitute-command-keys'. Use +** New substitution in docstrings and 'substitute-command-keys'. Use "\\`KEYSEQ'" to insert a literal key sequence "KEYSEQ" (e.g. "C-k") in a docstring or when calling 'substitute-command-keys', which will use the same face as a command substitution. This should commit 487ddf466a58c5f558e44b4ab3b5912219445d89 Author: Stefan Kangas Date: Mon Nov 22 12:12:25 2021 +0100 ; Fix typo * lisp/emacs-lisp/bytecomp.el (byte-compile--wide-docstring-p): Fix typo. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index e1c7ab4904..5dc03eac92 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1677,7 +1677,7 @@ URLs." ;; For literal key sequence substitutions (e.g. "\\`C-h'"), just ;; remove the markup as `substitute-command-keys' would. (replace-regexp-in-string - (rx "\\" (seq "`" (group (* (not "]"))) "'")) + (rx "\\" (seq "`" (group (* (not "'"))) "'")) "\\1" docstring))))) commit 3db3d5a3981dad1ac42a5729c285b9adaba10f05 Author: Po Lu Date: Mon Nov 22 11:13:03 2021 +0000 Fix compiler warning in image.c * src/image.c (webp_load): Initialize `mask_img' to NULL. diff --git a/src/image.c b/src/image.c index 734ccdac31..f2597f529d 100644 --- a/src/image.c +++ b/src/image.c @@ -9059,7 +9059,7 @@ webp_load (struct frame *f, struct image *img) } /* Create the x image and pixmap. */ - Emacs_Pix_Container ximg, mask_img; + Emacs_Pix_Container ximg, mask_img = NULL; if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, false)) goto webp_error2; commit d1a2e78b8cab54c0d6d0f3c208b24f59545ffbb3 Author: Stefan Kangas Date: Mon Nov 22 11:55:24 2021 +0100 ; Very minor simplification in bytecomp.el * lisp/emacs-lisp/bytecomp.el (byte-compile--wide-docstring-p): Very minor simplification of 'rx' form. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index bd74c79d71..e1c7ab4904 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1672,7 +1672,7 @@ URLs." ;; known at compile time. So instead, we assume that these ;; substitutions are of some length N. (replace-regexp-in-string - (rx "\\" (or (seq "[" (* (not "]")) "]"))) + (rx "\\" (seq "[" (* (not "]")) "]")) (make-string byte-compile--wide-docstring-substitution-len ?x) ;; For literal key sequence substitutions (e.g. "\\`C-h'"), just ;; remove the markup as `substitute-command-keys' would. commit 4a3ba8528bc8b8f083251cbebe46e5978e9ec816 Author: Stefan Kangas Date: Mon Nov 22 11:45:44 2021 +0100 Use substitute-command-keys for literal key sequences * lisp/abbrev.el (expand-region-abbrevs): * lisp/calc/calc-graph.el (calc-graph-show-dumb): * lisp/calc/calc-help.el (calc-help-for-help): * lisp/calc/calc-mode.el (calc-auto-why): * lisp/calc/calc.el (calc-do): * lisp/calculator.el (calculator-mode): * lisp/dired-aux.el (dired-create-files) (dired-do-create-files-regexp, dired-create-files-non-directory): * lisp/dired-x.el (dired-virtual): * lisp/dired.el (dired-mark-region, dired-unmark-all-files): * lisp/emacs-lisp/map-ynp.el (map-y-or-n-p): * lisp/emacs-lisp/re-builder.el (reb-enter-subexp-mode): * lisp/epa-ks.el (epa-ks--display-keys): * lisp/erc/erc.el (erc-toggle-debug-irc-protocol): * lisp/files.el (save-some-buffers): * lisp/gnus/gnus-dired.el (gnus-dired-find-file-mailcap) (gnus-dired-print): * lisp/gnus/gnus-group.el (gnus-keep-same-level): * lisp/gnus/gnus-score.el (gnus-score-find-trace): * lisp/gnus/gnus.el (to-list): * lisp/gnus/message.el (message--send-mail-maybe-partially): * lisp/mail/supercite.el (sc-set-variable): * lisp/minibuffer.el (minibuffer-inactive-mode): * lisp/progmodes/etags.el (select-tags-table): * lisp/progmodes/idlw-shell.el (idlwave-shell-mode) (idlwave-shell-char-mode-loop): * lisp/replace.el (query-replace-help): * lisp/simple.el (set-variable): * lisp/subr.el (read-char-from-minibuffer): * lisp/textmodes/ispell.el (ispell-help, ispell-message): * lisp/textmodes/reftex-global.el (reftex-find-duplicate-labels): * lisp/textmodes/reftex-vars.el (reftex-toc-include-file-boundaries) (reftex-toc-include-labels, reftex-toc-include-index-entries) (reftex-toc-include-context, reftex-toc-follow-mode) (reftex-index-include-context, reftex-index-follow-mode) (reftex-enable-partial-scans) (reftex-auto-update-selection-buffers) (reftex-highlight-selection): * lisp/time.el (display-time-update): * lisp/vc/ediff-help.el (ediff-help-for-quick-help): * lisp/vc/ediff-init.el (ediff-keep-variants): * lisp/vc/ediff-ptch.el (ediff-fixup-patch-map) (ediff-patch-file-internal): * lisp/windmove.el (windmove-delete-default-keybindings): Use 'substitute-command-keys' for literal key sequences. * lisp/userlock.el (userlock--fontify-key): Remove function. (ask-user-about-lock, ask-user-about-lock-help) (ask-user-about-supersession-threat) (ask-user-about-supersession-help): Use 'substitute-command-keys' for literal key sequences. * lisp/ibuffer.el (ibuffer-unmark-all): Use 'substitute-command-keys' for command. diff --git a/lisp/abbrev.el b/lisp/abbrev.el index d3daf637cc..386aff1627 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -403,7 +403,7 @@ argument." (defun expand-region-abbrevs (start end &optional noquery) "For abbrev occurrence in the region, offer to expand it. -The user is asked to type `y' or `n' for each occurrence. +The user is asked to type \\`y' or \\`n' for each occurrence. A prefix argument means don't query; expand all abbrevs." (interactive "r\nP") (save-excursion diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el index 7891e35c40..b6ee124a72 100644 --- a/lisp/calc/calc-graph.el +++ b/lisp/calc/calc-graph.el @@ -969,7 +969,8 @@ This \"dumb\" driver will be present in Gnuplot 3.0." (define-key calc-dumb-map "\C-c\C-c" 'exit-recursive-edit))) (use-local-map calc-dumb-map) (setq truncate-lines t) - (message "Type `q' or `C-c C-c' to return to Calc") + (message (substitute-command-keys + "Type \\`q' or \\`C-c C-c' to return to Calc")) (recursive-edit) (bury-buffer "*Gnuplot Trail*"))) diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el index 8481d0b5e9..2633d64fe4 100644 --- a/lisp/calc/calc-help.el +++ b/lisp/calc/calc-help.el @@ -50,25 +50,25 @@ (beep)))) (defun calc-help-for-help (arg) - "You have typed `h', the Calc help character. Type a Help option: + "You have typed \\`h', the Calc help character. Type a Help option: -B calc-describe-bindings. Display a table of all key bindings. -H calc-full-help. Display all `?' key messages at once. +\\`B' calc-describe-bindings. Display a table of all key bindings. +\\`H' calc-full-help. Display all \\`?' key messages at once. -I calc-info. Read the Calc manual using the Info system. -T calc-tutorial. Read the Calc tutorial using the Info system. -S calc-info-summary. Read the Calc summary using the Info system. +\\`I' calc-info. Read the Calc manual using the Info system. +\\`T' calc-tutorial. Read the Calc tutorial using the Info system. +\\`S' calc-info-summary. Read the Calc summary using the Info system. -C calc-describe-key-briefly. Look up the command name for a given key. -K calc-describe-key. Look up a key's documentation in the manual. -F calc-describe-function. Look up a function's documentation in the manual. -V calc-describe-variable. Look up a variable's documentation in the manual. +\\`C' calc-describe-key-briefly. Look up the command name for a given key. +\\`K' calc-describe-key. Look up a key's documentation in the manual. +\\`F' calc-describe-function. Look up a function's documentation in the manual. +\\`V' calc-describe-variable. Look up a variable's documentation in the manual. -N calc-view-news. Display Calc history of changes. +\\`N' calc-view-news. Display Calc history of changes. -C-c Describe conditions for copying Calc. -C-d Describe how you can get a new copy of Calc or report a bug. -C-w Describe how there is no warranty for Calc." +\\`C-c' Describe conditions for copying Calc. +\\`C-d' Describe how you can get a new copy of Calc or report a bug. +\\`C-w' Describe how there is no warranty for Calc." (interactive "P") (if calc-dispatch-help (let (key) diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el index c8394e8c2f..1c4438e7f7 100644 --- a/lisp/calc/calc-misc.el +++ b/lisp/calc/calc-misc.el @@ -216,26 +216,28 @@ Calc user interface as before (either C-x * C or C-x * K; initially C-x * C)." (defun calc-help () (interactive) (let ((msgs - '("Press `h' for complete help; press `?' repeatedly for a summary" - "Letter keys: Negate; Precision; Yank; Why; Xtended cmd; Quit" - "Letter keys: SHIFT + Undo, reDo; Inverse, Hyperbolic, Option" - "Letter keys: SHIFT + sQrt; Sin, Cos, Tan; Exp, Ln, logB" - "Letter keys: SHIFT + Floor, Round; Abs, conJ, arG; Pi" - "Letter keys: SHIFT + Num-eval; More-recn; eXec-kbd-macro; Keep-args" - "Other keys: +, -, *, /, ^, \\ (int div), : (frac div)" - "Other keys: & (1/x), | (concat), % (modulo), ! (factorial)" - "Other keys: \\=' (alg-entry), = (eval), \\=` (edit); M-RET (last-args)" - "Other keys: SPC/RET (enter/dup), LFD (over); < > (scroll horiz)" - "Other keys: DEL (drop), M-DEL (drop-above); { } (scroll vert)" - "Other keys: TAB (swap/roll-dn), M-TAB (roll-up)" - "Other keys: [ , ; ] (vector), ( , ) (complex), ( ; ) (polar)" - "Prefix keys: Algebra, Binary/business, Convert, Display" - "Prefix keys: Functions, Graphics, Help, J (select)" - "Prefix keys: Kombinatorics/statistics, Modes, Store/recall" - "Prefix keys: Trail/time, Units/statistics, Vector/matrix" - "Prefix keys: Z (user), SHIFT + Z (define)" - "Prefix keys: prefix + ? gives further help for that prefix" - " Calc by Dave Gillespie, daveg@synaptics.com"))) + ;; FIXME: Change these to `substitute-command-keys' syntax. + (mapcar #'substitute-command-keys + '("Press \\`h' for complete help; press \\`?' repeatedly for a summary" + "Letter keys: Negate; Precision; Yank; Why; Xtended cmd; Quit" + "Letter keys: SHIFT + Undo, reDo; Inverse, Hyperbolic, Option" + "Letter keys: SHIFT + sQrt; Sin, Cos, Tan; Exp, Ln, logB" + "Letter keys: SHIFT + Floor, Round; Abs, conJ, arG; Pi" + "Letter keys: SHIFT + Num-eval; More-recn; eXec-kbd-macro; Keep-args" + "Other keys: +, -, *, /, ^, \\ (int div), : (frac div)" + "Other keys: & (1/x), | (concat), % (modulo), ! (factorial)" + "Other keys: \\=' (alg-entry), = (eval), \\=` (edit); M-RET (last-args)" + "Other keys: \\`SPC'/\\`RET' (enter/dup), LFD (over); < > (scroll horiz)" + "Other keys: \\`DEL' (drop), \\`M-DEL' (drop-above); { } (scroll vert)" + "Other keys: \\`TAB' (swap/roll-dn), \\`M-TAB' (roll-up)" + "Other keys: [ , ; ] (vector), ( , ) (complex), ( ; ) (polar)" + "Prefix keys: Algebra, Binary/business, Convert, Display" + "Prefix keys: Functions, Graphics, Help, J (select)" + "Prefix keys: Kombinatorics/statistics, Modes, Store/recall" + "Prefix keys: Trail/time, Units/statistics, Vector/matrix" + "Prefix keys: Z (user), SHIFT + Z (define)" + "Prefix keys: prefix + ? gives further help for that prefix" + " Calc by Dave Gillespie, daveg@synaptics.com")))) (if calc-full-help-flag msgs (if (or calc-inverse-flag calc-hyperbolic-flag) diff --git a/lisp/calc/calc-mode.el b/lisp/calc/calc-mode.el index 68c8b90ac3..211b8e661f 100644 --- a/lisp/calc/calc-mode.el +++ b/lisp/calc/calc-mode.el @@ -109,11 +109,14 @@ (setq n (and (not (eq calc-auto-why t)) (if calc-auto-why t 1)))) (calc-change-mode 'calc-auto-why n nil) (cond ((null n) - (message "User must press `w' to explain unsimplified results")) + (message (substitute-command-keys + "User must press \\`w' to explain unsimplified results"))) ((eq n t) - (message "Automatically doing `w' to explain unsimplified results")) + (message (substitute-command-keys + "Automatically doing \\`w' to explain unsimplified results"))) (t - (message "Automatically doing `w' only for unusual messages"))))) + (message (substitute-command-keys + "Automatically doing \\`w' only for unusual messages")))))) (defun calc-group-digits (n) (interactive "P") diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index bd4ec4ff2f..9774ddff40 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -1621,7 +1621,8 @@ See calc-keypad for details." (stringp (nth 1 err)) (string-match "max-specpdl-size\\|max-lisp-eval-depth" (nth 1 err))) - (error "Computation got stuck or ran too long. Type `M' to increase the limit") + (error (substitute-command-keys + "Computation got stuck or ran too long. Type \\`M' to increase the limit")) (setq calc-aborted-prefix nil) (signal (car err) (cdr err))))) (when calc-aborted-prefix diff --git a/lisp/calculator.el b/lisp/calculator.el index 6bcea2d885..0c255c0cf9 100644 --- a/lisp/calculator.el +++ b/lisp/calculator.el @@ -593,15 +593,15 @@ except when using a non-decimal radix mode for input (in this case `e' will be the hexadecimal digit). Here are the editing keys: -* `RET' `=' evaluate the current expression -* `C-insert' copy the whole current expression to the `kill-ring' -* `C-return' evaluate, save result the `kill-ring' and exit -* `insert' paste a number if the one was copied (normally) -* `delete' `C-d' clear last argument or whole expression (hit twice) -* `backspace' delete a digit or a previous expression element -* `h' `?' pop-up a quick reference help -* `ESC' `q' exit (`ESC' can be used if `calculator-bind-escape' is - non-nil, otherwise use three consecutive `ESC's) +* \\`RET' \\`=' evaluate the current expression +* \\`C-' copy the whole current expression to the `kill-ring' +* \\`C-' evaluate, save result the `kill-ring' and exit +* \\`' paste a number if the one was copied (normally) +* \\`' \\`C-d' clear last argument or whole expression (hit twice) +* \\`' delete a digit or a previous expression element +* \\`h' \\`?' pop-up a quick reference help +* \\`ESC' \\`q' exit (\\`ESC' can be used if `calculator-bind-escape' is + non-nil, otherwise use three consecutive \\`ESC's) These operators are pre-defined: * `+' `-' `*' `/' the common binary operators @@ -623,10 +623,10 @@ argument. hex/oct/bin modes can be set for input and for display separately. Another toggle-able mode is for using degrees instead of radians for trigonometric functions. -The keys to switch modes are (both `H' and `X' are for hex): -* `D' switch to all-decimal mode, or toggle degrees/radians -* `B' `O' `H' `X' binary/octal/hexadecimal modes for input & display -* `i' `o' followed by one of `D' `B' `O' `H' `X' (case +The keys to switch modes are (both \\`H' and \\`X' are for hex): +* \\`D' switch to all-decimal mode, or toggle degrees/radians +* \\`B' \\`O' \\`H' \\`X' binary/octal/hexadecimal modes for input & display +* \\`i' \\`o' followed by one of \\`D' \\`B' \\`O' \\`H' \\`X' (case insensitive) sets only the input or display radix mode The prompt indicates the current modes: * \"==\": decimal mode (using radians); @@ -649,17 +649,17 @@ collected data. It is possible to navigate in this list, and if the value shown is the current one on the list, an indication is displayed as \"[N]\" if this is the last number and there are N numbers, or \"[M/N]\" if the M-th value is shown. -* `SPC' evaluate the current value as usual, but also adds +* \\`SPC' evaluate the current value as usual, but also adds the result to the list of saved values -* `l' `v' computes total / average of saved values -* `up' `C-p' browse to the previous value in the list -* `down' `C-n' browse to the next value in the list -* `delete' `C-d' remove current value from the list (if it is on it) -* `C-delete' `C-c' delete the whole list +* \\`l' \\`v' computes total / average of saved values +* \\`' \\`C-p' browse to the previous value in the list +* \\`' \\`C-n' browse to the next value in the list +* \\`' \\`C-d' remove current value from the list (if it is on it) +* \\`C-' \\`C-c' delete the whole list Registers are variable-like place-holders for values: -* `s' followed by a character attach the current value to that character -* `g' followed by a character fetches the attached value +* \\`s' followed by a character attach the current value to that character +* \\`g' followed by a character fetches the attached value There are many variables that can be used to customize the calculator. Some interesting customization variables are: diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 92409db33e..588551a641 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1989,11 +1989,12 @@ or with the current marker character if MARKER-CHAR is t." (let* ((overwrite (file-exists-p to)) (dired-overwrite-confirmed ; for dired-handle-overwrite (and overwrite - (let ((help-form (format-message "\ -Type SPC or `y' to overwrite file `%s', -DEL or `n' to skip to next, -ESC or `q' to not overwrite any of the remaining files, -`!' to overwrite all remaining files with no more questions." to))) + (let ((help-form (format-message + (substitute-command-keys "\ +Type \\`SPC' or \\`y' to overwrite file `%s', +\\`DEL' or \\`n' to skip to next, +\\`ESC' or \\`q' to not overwrite any of the remaining files, +\\`!' to overwrite all remaining files with no more questions.") to))) (dired-query 'overwrite-query "Overwrite `%s'?" to)))) ;; must determine if FROM is marked before file-creator @@ -2486,11 +2487,12 @@ Also see `dired-do-revert-buffer'." ;; Optional arg MARKER-CHAR as in dired-create-files. (let* ((fn-list (dired-get-marked-files nil arg)) (operation-prompt (concat operation " `%s' to `%s'?")) - (rename-regexp-help-form (format-message "\ -Type SPC or `y' to %s one match, DEL or `n' to skip to next, -`!' to %s all remaining matches with no more questions." - (downcase operation) - (downcase operation))) + (rename-regexp-help-form (format-message + (substitute-command-keys "\ +Type \\`SPC' or \\`y' to %s one match, \\`DEL' or \\`n' to skip to next, +\\`!' to %s all remaining matches with no more questions.") + (downcase operation) + (downcase operation))) (regexp-name-constructor ;; Function to construct new filename using REGEXP and NEWNAME: (if whole-name ; easy (but rare) case @@ -2611,11 +2613,12 @@ See function `dired-do-rename-regexp' for more info." (let ((to (concat (file-name-directory from) (funcall basename-constructor (file-name-nondirectory from))))) - (and (let ((help-form (format-message "\ -Type SPC or `y' to %s one file, DEL or `n' to skip to next, -`!' to %s all remaining matches with no more questions." - (downcase operation) - (downcase operation)))) + (and (let ((help-form (format-message + (substitute-command-keys "\ +Type \\`SPC' or \\`y' to %s one file, \\`DEL' or \\`n' to skip to next, +\\`!' to %s all remaining matches with no more questions.") + (downcase operation) + (downcase operation)))) (dired-query 'rename-non-directory-query (concat operation " `%s' to `%s'") (dired-make-relative from) diff --git a/lisp/dired-x.el b/lisp/dired-x.el index fc626aa76b..de21dcf7a6 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -596,7 +596,7 @@ If you have saved a Dired buffer in a file you can use \\[dired-virtual] to resume it in a later session. Type \\\\[revert-buffer] \ -in the Virtual Dired buffer and answer `y' to convert +in the Virtual Dired buffer and answer \\`y' to convert the virtual to a real Dired buffer again. You don't have to do this, though: you can relist single subdirs using \\[dired-do-redisplay]." diff --git a/lisp/dired.el b/lisp/dired.el index a0fa917891..9280c080a4 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -345,11 +345,11 @@ When `file', the region marking is based on the file name. This means don't mark the file if the end of the region is before the file name displayed on the Dired line, so the file name is visually outside the region. This behavior is consistent with -marking files without the region using the key `m' that advances +marking files without the region using the key \\`m' that advances point to the next line after marking the file. Thus the number of keys used to mark files is the same as the number of keys -used to select the region, e.g. `M-2 m' marks 2 files, and -`C-SPC M-2 n m' marks 2 files, and `M-2 S-down m' marks 2 files. +used to select the region, for example \\`M-2 m' marks 2 files, and +\\`C-SPC M-2 n m' marks 2 files, and \\`M-2 S- m' marks 2 files. When `line', the region marking is based on Dired lines, so include the file into marking if the end of the region @@ -4102,9 +4102,9 @@ Type \\[help-command] at that time for help." (inhibit-read-only t) case-fold-search dired-unmark-all-files-query (string (format "\n%c" mark)) - (help-form "\ -Type SPC or `y' to unmark one file, DEL or `n' to skip to next, -`!' to unmark all remaining files with no more questions.")) + (help-form (substitute-command-keys "\ +Type \\`SPC' or \\`y' to unmark one file, \\`DEL' or \\`n' to skip to next, +\\`!' to unmark all remaining files with no more questions."))) (goto-char (point-min)) (while (if (eq mark ?\r) (re-search-forward dired-re-mark nil t) diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index b95f11eab6..2f2f96ca0d 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -215,12 +215,12 @@ The function's value is the number of actions taken." (action (or (nth 2 help) "act on"))) (concat (format-message - "\ -Type SPC or `y' to %s the current %s; -DEL or `n' to skip the current %s; -RET or `q' to skip the current and all remaining %s; -C-g to quit (cancel the whole command); -! to %s all remaining %s;\n" + (substitute-command-keys "\ +Type \\`SPC' or \\`y' to %s the current %s; +\\`DEL' or \\`n' to skip the current %s; +\\`RET' or \\`q' to skip the current and all remaining %s; +\\`C-g' to quit (cancel the whole command); +\\`!' to %s all remaining %s;\n") action object object objects action objects) (mapconcat (lambda (elt) (format "%s to %s;\n" diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index aec438ed99..5516b2a81f 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -448,7 +448,8 @@ provided in the Commentary section of this library." (setq reb-subexp-mode t) (reb-update-modestring) (use-local-map reb-subexp-mode-map) - (message "`0'-`9' to display subexpressions `q' to quit subexp mode")) + (message (substitute-command-keys + "\\`0'-\\`9' to display subexpressions \\`q' to quit subexp mode"))) (defun reb-show-subexp (subexp &optional pause) "Visually show limit of subexpression SUBEXP of recent search. diff --git a/lisp/epa-ks.el b/lisp/epa-ks.el index 35caa1a93c..5dd6ad34d7 100644 --- a/lisp/epa-ks.el +++ b/lisp/epa-ks.el @@ -210,7 +210,8 @@ KEYS is a list of `epa-ks-key' structures, as parsed by (with-current-buffer buf (setq tabulated-list-entries entries) (tabulated-list-print t t)) - (message "Press `f' to mark a key, `x' to fetch all marked keys.")))) + (message (substitute-command-keys + "Press \\`f' to mark a key, \\`x' to fetch all marked keys."))))) (defun epa-ks--restart-search () (when epa-ks-last-query diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index c5a4fbe5a0..df6c3c09d9 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -2405,7 +2405,8 @@ If ARG is non-nil, show the *erc-protocol* buffer." (concat "This buffer displays all IRC protocol " "traffic exchanged with servers.")) (erc-make-notice "Kill it to disable logging.") - (erc-make-notice "Press `t' to toggle.")))) + (erc-make-notice (substitute-command-keys + "Press \\`t' to toggle."))))) (insert (string-join msg "\r\n"))) (use-local-map (make-sparse-keymap)) (local-set-key (kbd "t") 'erc-toggle-debug-irc-protocol)) diff --git a/lisp/files.el b/lisp/files.el index 1979f1bbe3..f72723ab7d 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -5806,13 +5806,13 @@ of the directory that was default during command invocation." (defun save-some-buffers (&optional arg pred) "Save some modified file-visiting buffers. Asks user about each one. -You can answer `y' or SPC to save, `n' or DEL not to save, `C-r' +You can answer \\`y' or \\`SPC' to save, \\`n' or \\`DEL' not to save, \\`C-r' to look at the buffer in question with `view-buffer' before -deciding, `d' to view the differences using -`diff-buffer-with-file', `!' to save the buffer and all remaining -buffers without any further querying, `.' to save only the -current buffer and skip the remaining ones and `q' or RET to exit -the function without saving any more buffers. `C-h' displays a +deciding, \\`d' to view the differences using +`diff-buffer-with-file', \\`!' to save the buffer and all remaining +buffers without any further querying, \\`.' to save only the +current buffer and skip the remaining ones and \\`q' or \\`RET' to exit +the function without saving any more buffers. \\`C-h' displays a help message describing these options. This command first saves any buffers where `buffer-save-without-query' is diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el index 1d16e00700..00769a5da6 100644 --- a/lisp/gnus/gnus-dired.el +++ b/lisp/gnus/gnus-dired.el @@ -204,7 +204,8 @@ If ARG is non-nil, open it in a new buffer." (find-file file-name))) (if (file-symlink-p file-name) (error "File is a symlink to a nonexistent target") - (error "File no longer exists; type `g' to update Dired buffer")))) + (error (substitute-command-keys + "File no longer exists; type \\`g' to update Dired buffer"))))) (defun gnus-dired-print (&optional file-name print-to) "In dired, print FILE-NAME according to the mailcap file. @@ -244,9 +245,10 @@ of the file to save in." (error "MIME print only implemented via Gnus"))) (ps-despool print-to)))) ((file-symlink-p file-name) - (error "File is a symlink to a nonexistent target")) - (t - (error "File no longer exists; type `g' to update Dired buffer")))) + (error "File is a symlink to a nonexistent target")) + (t + (error (substitute-command-keys + "File no longer exists; type \\`g' to update Dired buffer"))))) (provide 'gnus-dired) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index f0b0ca5879..2ec001faee 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -62,7 +62,7 @@ (defcustom gnus-keep-same-level nil "Non-nil means that the newsgroup after this one will be on the same level. -When you type, for instance, `n' after reading the last article in the +When you type, for instance, \\`n' after reading the last article in the current newsgroup, you will go to the next newsgroup. If this variable is nil, the next newsgroup will be the next from the group buffer. diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index 2ca2580295..d031047804 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -2562,16 +2562,17 @@ score in `gnus-newsgroup-scored' by SCORE." (or (caddr s) gnus-score-interactive-default-score)) trace)))) - (insert - "\n\nQuick help: + (insert + (substitute-command-keys + "\n\nQuick help: -Type `e' to edit score file corresponding to the score rule on current line, -`f' to format (pretty print) the score file and edit it, -`t' toggle to truncate long lines in this buffer, -`q' to quit, `k' to kill score trace buffer. +Type \\`e' to edit score file corresponding to the score rule on current line, +\\`f' to format (pretty print) the score file and edit it, +\\`t' toggle to truncate long lines in this buffer, +\\`q' to quit, \\`k' to kill score trace buffer. The first sexp on each line is the score rule, followed by the file name of -the score file and its full name, including the directory.") +the score file and its full name, including the directory.")) (goto-char (point-min)) (gnus-configure-windows 'score-trace))) (set-buffer gnus-summary-buffer) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 4519d65aa8..56934dfa15 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -1467,11 +1467,11 @@ address was listed in gnus-group-split Addresses (see below).") :variable-group gnus-group-parameter :parameter-type '(gnus-email-address :tag "To List") :parameter-document "\ -This address will be used when doing a `a' in the group. +This address will be used when doing a \\`a' in the group. It is totally ignored when doing a followup--except that if it is present in a news group, you'll get mail group semantics when doing -`f'. +\\`f'. The gnus-group-split mail splitting mechanism will behave as if this address was listed in gnus-group-split Addresses (see below).") diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 4a0ea59586..562bc64f6f 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -4763,23 +4763,25 @@ Valid types are `send', `return', `exit', `kill' and `postpone'." t "\ The message size, " - (/ (buffer-size) 1000) "KB, is too large. + (/ (buffer-size) 1000) + (substitute-command-keys "KB, is too large. Some mail gateways (MTA's) bounce large messages. To avoid the -problem, answer `y', and the message will be split into several -smaller pieces, the size of each is about " +problem, answer \\`y', and the message will be split into several +smaller pieces, the size of each is about ") (/ message-send-mail-partially-limit 1000) - "KB except the last + (substitute-command-keys + "KB except the last one. However, some mail readers (MUA's) can't read split messages, i.e., -mails in message/partially format. Answer `n', and the message +mails in message/partially format. Answer \\`n', and the message will be sent in one piece. The size limit is controlled by `message-send-mail-partially-limit'. If you always want Gnus to send messages in one piece, set `message-send-mail-partially-limit' to nil. -"))) +")))) (progn (message "Sending via mail...") (if message-send-mail-real-function diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index 233127b011..b461197abe 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -1257,7 +1257,9 @@ Otherwise, toggle lock status." "Unmark all buffers with mark MARK." (interactive "cRemove marks (RET means all):") (if (= (ibuffer-count-marked-lines t) 0) - (message "No buffers marked; use `m' to mark a buffer") + (message (substitute-command-keys + "No buffers marked; use \\\ +\\[ibuffer-mark-forward] to mark a buffer")) (let ((fn (lambda (_buf mk) (unless (eq mk ?\s) (ibuffer-set-mark-1 ?\s)) t))) diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el index f393ac773f..b3080ac416 100644 --- a/lisp/mail/supercite.el +++ b/lisp/mail/supercite.el @@ -1767,7 +1767,7 @@ is determined non-interactively. The value is queried for in the minibuffer exactly the same way that `set-variable' does it. You can see the current value of the variable when the minibuffer is -querying you by typing `C-h'. Note that the format is changed +querying you by typing \\`C-h'. Note that the format is changed slightly from that used by `set-variable' -- the current value is printed just after the variable's name instead of at the bottom of the help window." diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 0fea057d1c..c2a6b01fc8 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2734,7 +2734,7 @@ not active.") This is only used when the minibuffer area has no active minibuffer. Note that the minibuffer may change to this mode more often than -you might expect. For instance, typing `M-x' may change the +you might expect. For instance, typing \\`M-x' may change the buffer to this mode, then to a different mode, and then back again to this mode upon exit. Code running from `minibuffer-inactive-mode-hook' has to be prepared to run diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index d833612cd9..d7dbaa0650 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -1992,7 +1992,8 @@ see the doc of that variable if you want to add names to the list." (setq set-list (delete (car set-list) set-list))) (goto-char (point-min)) (insert-before-markers - "Type `t' to select a tags table or set of tags tables:\n\n") + (substitute-command-keys + "Type \\`t' to select a tags table or set of tags tables:\n\n")) (if desired-point (goto-char desired-point)) (set-window-start (selected-window) 1 t)) diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el index 5a31ad3508..ded3a9c463 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -817,7 +817,7 @@ IDL has currently stepped.") Command history, searching of previous commands, command line editing are available via the comint-mode key bindings, by default - mostly on the key `C-c'. Command history is also available with + mostly on the key \\`C-c'. Command history is also available with the arrow keys UP and DOWN. 2. Completion @@ -1327,7 +1327,7 @@ See also the variable `idlwave-shell-input-mode-spells'." Characters are sent one by one, without newlines. The loop is blocking and intercepts all input events to Emacs. You can use this command to interact with the IDL command GET_KBRD. -The loop can be aborted by typing `C-g'. The loop also exits automatically +The loop can be aborted by typing \\[keyboard-quit]. The loop also exits automatically when the IDL prompt gets displayed again after the current IDL command." (interactive) @@ -1342,7 +1342,8 @@ when the IDL prompt gets displayed again after the current IDL command." (funcall errf "No IDL program seems to be waiting for input")) ;; OK, start the loop - (message "Character mode on: Sending single chars (`C-g' to exit)") + (message (substitute-command-keys + "Character mode on: Sending single chars (\\[keyboard-quit] to exit)")) (message (catch 'exit (while t diff --git a/lisp/replace.el b/lisp/replace.el index 5287be2c52..0e81b15a09 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -2402,20 +2402,20 @@ To be added to `context-menu-functions'." ;; It would be nice to use \\[...], but there is no reasonable way ;; to make that display both SPC and Y. (defconst query-replace-help - "Type Space or `y' to replace one match, Delete or `n' to skip to next, -RET or `q' to exit, Period to replace one match and exit, -Comma to replace but not move point immediately, -C-r to enter recursive edit (\\[exit-recursive-edit] to get out again), -C-w to delete match and recursive edit, -C-l to clear the screen, redisplay, and offer same replacement again, -! to replace all remaining matches in this buffer with no more questions, -^ to move point back to previous match, -u to undo previous replacement, -U to undo all replacements, -E to edit the replacement string. -In multi-buffer replacements type `Y' to replace all remaining + "Type \\`SPC' or \\`y' to replace one match, Delete or \\`n' to skip to next, +\\`RET' or \\`q' to exit, Period to replace one match and exit, +\\`,' to replace but not move point immediately, +\\`C-r' to enter recursive edit (\\[exit-recursive-edit] to get out again), +\\`C-w' to delete match and recursive edit, +\\`C-l' to clear the screen, redisplay, and offer same replacement again, +\\`!' to replace all remaining matches in this buffer with no more questions, +\\`^' to move point back to previous match, +\\`u' to undo previous replacement, +\\`U' to undo all replacements, +\\`E' to edit the replacement string. +In multi-buffer replacements type \\`Y' to replace all remaining matches in all remaining buffers with no more questions, -`N' to skip to the next buffer without replacing remaining matches +\\`N' to skip to the next buffer without replacing remaining matches in the current buffer." "Help message while in `query-replace'.") diff --git a/lisp/simple.el b/lisp/simple.el index 58283e7b7f..84928caa31 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -8912,7 +8912,7 @@ With a prefix argument, set VARIABLE to VALUE buffer-locally. When called interactively, the user is prompted for VARIABLE and then VALUE. The current value of VARIABLE will be put in the -minibuffer history so that it can be accessed with `M-n', which +minibuffer history so that it can be accessed with \\`M-n', which makes it easier to edit it." (interactive (let* ((default-var (variable-at-point)) diff --git a/lisp/subr.el b/lisp/subr.el index 7ba764880e..867db47a47 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -3120,7 +3120,7 @@ Optional argument CHARS, if non-nil, should be a list of characters; the function will ignore any input that is not one of CHARS. Optional argument HISTORY, if non-nil, should be a symbol that specifies the history list variable to use for navigating in input -history using `M-p' and `M-n', with `RET' to select a character from +history using \\`M-p' and \\`M-n', with \\`RET' to select a character from history. If you bind the variable `help-form' to a non-nil value while calling this function, then pressing `help-char' diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index 0a3a49d868..4087f7e5f2 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -2398,24 +2398,24 @@ Global `ispell-quit' set to start location to continue spell session." Selections are: -DIGIT: Replace the word with a digit offered in the *Choices* buffer. -SPC: Accept word this time. -`i': Accept word and insert into private dictionary. -`a': Accept word for this session. -`A': Accept word and place in `buffer-local dictionary'. -`r': Replace word with typed-in value. Rechecked. -`R': Replace word with typed-in value. Query-replaced in buffer. Rechecked. -`?': Show these commands. -`x': Exit spelling buffer. Move cursor to original point. -`X': Exit spelling buffer. Leaves cursor at the current point, and permits +\\`0'..\\`9' Replace the word with a digit offered in the *Choices* buffer. +\\`SPC' Accept word this time. +\\`i' Accept word and insert into private dictionary. +\\`a' Accept word for this session. +\\`A' Accept word and place in `buffer-local dictionary'. +\\`r' Replace word with typed-in value. Rechecked. +\\`R' Replace word with typed-in value. Query-replaced in buffer. Rechecked. +\\`?' Show these commands. +\\`x' Exit spelling buffer. Move cursor to original point. +\\`X' Exit spelling buffer. Leaves cursor at the current point, and permits the aborted check to be completed later. -`q': Quit spelling session (Kills ispell process). -`l': Look up typed-in replacement in alternate dictionary. Wildcards okay. -`u': Like `i', but the word is lower-cased first. -`m': Place typed-in value in personal dictionary, then recheck current word. -`C-l': Redraw screen. -`C-r': Recursive edit. -`C-z': Suspend Emacs or iconify frame." +\\`q' Quit spelling session (Kills ispell process). +\\`l' Look up typed-in replacement in alternate dictionary. Wildcards okay. +\\`u' Like \\`i', but the word is lower-cased first. +\\`m' Place typed-in value in personal dictionary, then recheck current word. +\\`C-l' Redraw screen. +\\`C-r' Recursive edit. +\\`C-z' Suspend Emacs or iconify frame." (if (equal ispell-help-in-bufferp 'electric) (progn @@ -2428,26 +2428,28 @@ SPC: Accept word this time. ;;(if (< (window-height) 15) ;; (enlarge-window ;; (- 15 (ispell-adjusted-window-height)))) - (princ "Selections are: - -DIGIT: Replace the word with a digit offered in the *Choices* buffer. -SPC: Accept word this time. -`i': Accept word and insert into private dictionary. -`a': Accept word for this session. -`A': Accept word and place in `buffer-local dictionary'. -`r': Replace word with typed-in value. Rechecked. -`R': Replace word with typed-in value. Query-replaced in buffer. Rechecked. -`?': Show these commands. -`x': Exit spelling buffer. Move cursor to original point. -`X': Exit spelling buffer. Leaves cursor at the current point, and permits - the aborted check to be completed later. -`q': Quit spelling session (Kills ispell process). -`l': Look up typed-in replacement in alternate dictionary. Wildcards okay. -`u': Like `i', but the word is lower-cased first. -`m': Place typed-in value in personal dictionary, then recheck current word. -`C-l': Redraw screen. -`C-r': Recursive edit. -`C-z': Suspend Emacs or iconify frame.") + (princ + (substitute-command-keys + "Selections are: + +\\`0'..\\`9' Replace the word with a digit offered in the *Choices* buffer. +\\`SPC' Accept word this time. +\\`i' Accept word and insert into private dictionary. +\\`a' Accept word for this session. +\\`A' Accept word and place in `buffer-local dictionary'. +\\`r' Replace word with typed-in value. Rechecked. +\\`R' Replace word with typed-in value. Query-replaced in buffer. Rechecked. +\\`?' Show these commands. +\\`x' Exit spelling buffer. Move cursor to original point. +\\`X' Exit spelling buffer. Leaves cursor at the current point, and permits + the aborted check to be completed later. +\\`q' Quit spelling session (Kills ispell process). +\\`l' Look up typed-in replacement in alternate dictionary. Wildcards okay. +\\`u' Like \\`i', but the word is lower-cased first. +\\`m' Place typed-in value in personal dictionary, then recheck current word. +\\`C-l' Redraw screen. +\\`C-r' Recursive edit. +\\`C-z' Suspend Emacs or iconify frame.")) nil))) @@ -3883,8 +3885,8 @@ Don't check spelling of message headers except the Subject field. Don't check included messages. To abort spell checking of a message region and send the message anyway, -use the `x' command. (Any subsequent regions will be checked.) -The `X' command aborts sending the message so that you can edit the buffer. +use the \\`x' command. (Any subsequent regions will be checked.) +The \\`X' command aborts sending the message so that you can edit the buffer. To spell-check whenever a message is sent, include the appropriate lines in your init file: diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el index b90c21339c..f787f5f3e5 100644 --- a/lisp/textmodes/reftex-global.el +++ b/lisp/textmodes/reftex-global.el @@ -148,8 +148,10 @@ No active TAGS table is required." (erase-buffer) (insert " MULTIPLE LABELS IN CURRENT DOCUMENT:\n") (insert - " Move point to label and type `r' to run a query-replace on the label\n" - " and its references. Type `q' to exit this buffer.\n\n") + (substitute-command-keys + " Move point to label and type \\`r' to run a query-replace on the label\n") + (substitute-command-keys + " and its references. Type \\`q' to exit this buffer.\n\n")) (insert " LABEL FILE\n") (insert " -------------------------------------------------------------\n") (use-local-map (make-sparse-keymap)) diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el index d57a767855..eedc067b86 100644 --- a/lisp/textmodes/reftex-vars.el +++ b/lisp/textmodes/reftex-vars.el @@ -392,19 +392,19 @@ that the *toc* window fills half the frame." (defcustom reftex-toc-include-file-boundaries nil "Non-nil means, include file boundaries in *toc* buffer. -This flag can be toggled from within the *toc* buffer with the `F' key." +This flag can be toggled from within the *toc* buffer with the \\`F' key." :group 'reftex-table-of-contents-browser :type 'boolean) (defcustom reftex-toc-include-labels nil "Non-nil means, include labels in *toc* buffer. -This flag can be toggled from within the *toc* buffer with the `l' key." +This flag can be toggled from within the *toc* buffer with the \\`l' key." :group 'reftex-table-of-contents-browser :type 'boolean) (defcustom reftex-toc-include-index-entries nil "Non-nil means, include index entries in *toc* buffer. -This flag can be toggled from within the *toc* buffer with the `i' key." +This flag can be toggled from within the *toc* buffer with the \\`i' key." :group 'reftex-table-of-contents-browser :type 'boolean) @@ -422,14 +422,14 @@ changed." (defcustom reftex-toc-include-context nil "Non-nil means, include context with labels in the *toc* buffer. Context will only be shown when labels are visible as well. -This flag can be toggled from within the *toc* buffer with the `c' key." +This flag can be toggled from within the *toc* buffer with the \\`c' key." :group 'reftex-table-of-contents-browser :type 'boolean) (defcustom reftex-toc-follow-mode nil "Non-nil means, point in *toc* buffer will cause other window to follow. The other window will show the corresponding part of the document. -This flag can be toggled from within the *toc* buffer with the `f' key." +This flag can be toggled from within the *toc* buffer with the \\`f' key." :group 'reftex-table-of-contents-browser :type 'boolean) @@ -1627,14 +1627,14 @@ to that section." (defcustom reftex-index-include-context nil "Non-nil means, display the index definition context in the index buffer. -This flag may also be toggled from the index buffer with the `c' key." +This flag may also be toggled from the index buffer with the \\`c' key." :group 'reftex-index-support :type 'boolean) (defcustom reftex-index-follow-mode nil "Non-nil means, point in *Index* buffer will cause other window to follow. The other window will show the corresponding part of the document. -This flag can be toggled from within the *Index* buffer with the `f' key." +This flag can be toggled from within the *Index* buffer with the \\`f' key." :group 'reftex-table-of-contents-browser :type 'boolean) @@ -1863,10 +1863,11 @@ of the regular expressions in this list, that file is not parsed by RefTeX." (defcustom reftex-enable-partial-scans nil "Non-nil means, re-parse only 1 file when asked to re-parse. Re-parsing is normally requested with a \\[universal-argument] prefix to many RefTeX commands, -or with the `r' key in menus. When this option is t in a multifile document, +or with the \\`r' key in menus. When this option is t in a multifile document, we will only parse the current buffer, or the file associated with the label or section heading near point in a menu. Requesting re-parsing of an entire -multifile document then requires a \\[universal-argument] \\[universal-argument] prefix or the capital `R' key +multifile document then requires a \\[universal-argument] \ +\\[universal-argument] prefix or the capital \\`R' key in menus." :group 'reftex-optimizations-for-large-documents :type 'boolean) @@ -1912,7 +1913,7 @@ when new labels in its category are added. See the variable When a new label is defined with `reftex-label', all selection buffers associated with that label category are emptied, in order to force an update upon next use. When nil, the buffers are left alone and have to be -updated by hand, with the `g' key from the label selection process. +updated by hand, with the \\`g' key from the label selection process. The value of this variable will only have any effect when `reftex-use-multiple-selection-buffers' is non-nil." :group 'reftex-optimizations-for-large-documents @@ -1964,7 +1965,7 @@ instead or as well. The variable may have one of these values: both Both cursor and mouse trigger highlighting. Changing this variable requires rebuilding the selection and *toc* buffers -to become effective (keys `g' or `r')." +to become effective (keys \\`g' or \\`r')." :group 'reftex-fontification-configurations :type '(choice (const :tag "Never" nil) diff --git a/lisp/time.el b/lisp/time.el index 8496adec22..4f302caa67 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -343,7 +343,7 @@ Switches from the 1 to 5 to 15 minute load average, and then back to 1." "Update the `display-time' info for the mode line. However, don't redisplay right now. -This is used for things like Rmail `g' that want to force an +This is used for things like Rmail \\`g' that want to force an update which can wait for the next redisplay." (let* ((now (current-time)) (time (current-time-string now)) diff --git a/lisp/userlock.el b/lisp/userlock.el index 348ccc6f8e..9a2d45a846 100644 --- a/lisp/userlock.el +++ b/lisp/userlock.el @@ -39,10 +39,6 @@ (define-error 'file-locked "File is locked" 'file-error) -(defun userlock--fontify-key (key) - "Add the `help-key-binding' face to string KEY." - (propertize key 'face 'help-key-binding)) - ;;;###autoload (defun ask-user-about-lock (file opponent) "Ask user what to do when he wants to edit FILE but it is locked by OPPONENT. @@ -68,12 +64,9 @@ in any way you like." (match-string 0 opponent))) opponent)) (while (null answer) - (message "%s locked by %s: (%s, %s, %s, %s)? " - short-file short-opponent - (userlock--fontify-key "s") - (userlock--fontify-key "q") - (userlock--fontify-key "p") - (userlock--fontify-key "?")) + (message (substitute-command-keys + "%s locked by %s: (\\`s', \\`q', \\`p', \\`?'? ") + short-file short-opponent) (if noninteractive (error "Cannot resolve lock conflict in batch mode")) (let ((tem (let ((inhibit-quit t) (cursor-in-echo-area t)) @@ -88,12 +81,9 @@ in any way you like." (?? . help)))) (cond ((null answer) (beep) - (message "Please type %s, %s, or %s; or %s for help" - (userlock--fontify-key "q") - (userlock--fontify-key "s") - (userlock--fontify-key "p") - ;; FIXME: Why do we use "?" here and "C-h" below? - (userlock--fontify-key "?")) + ;; FIXME: Why do we use "?" here and "C-h" below? + (message (substitute-command-keys + "Please type \\`q', \\`s', or \\`p'; or \\`?' for help")) (sit-for 3)) ((eq (cdr answer) 'help) (ask-user-about-lock-help) @@ -106,17 +96,14 @@ in any way you like." (with-output-to-temp-buffer "*Help*" (with-current-buffer standard-output (insert - (format + (substitute-command-keys "It has been detected that you want to modify a file that someone else has already started modifying in Emacs. -You can <%s>teal the file; the other user becomes the +You can <\\`s'>teal the file; the other user becomes the intruder if (s)he ever unmodifies the file and then changes it again. -You can <%s>roceed; you edit at your own (and the other user's) risk. -You can <%s>uit; don't modify this file." - (userlock--fontify-key "s") - (userlock--fontify-key "p") - (userlock--fontify-key "q"))) +You can <\\`p'>roceed; you edit at your own (and the other user's) risk. +You can <\\`q'>uit; don't modify this file.")) (help-mode)))) (define-error 'file-supersession nil 'file-error) @@ -169,14 +156,11 @@ The buffer in question is current when this function is called." (discard-input) (save-window-excursion (let ((prompt - (format "%s changed on disk; \ -really edit the buffer? (%s, %s, %s or %s) " - (file-name-nondirectory filename) - (userlock--fontify-key "y") - (userlock--fontify-key "n") - (userlock--fontify-key "r") - ;; FIXME: Why do we use "C-h" here and "?" above? - (userlock--fontify-key "C-h"))) + ;; FIXME: Why do we use "C-h" here and "?" above? + (format (substitute-command-keys + "%s changed on disk; \ +really edit the buffer? (\\`y', \\`n', \\`r' or \\`C-h') ") + (file-name-nondirectory filename))) (choices '(?y ?n ?r ?? ?\C-h)) answer) (when noninteractive @@ -205,22 +189,18 @@ really edit the buffer? (%s, %s, %s or %s) " (with-output-to-temp-buffer "*Help*" (with-current-buffer standard-output (insert - (format + (substitute-command-keys "You want to modify a buffer whose disk file has changed since you last read it in or saved it with this buffer. -If you say %s to go ahead and modify this buffer, +If you say \\`y' to go ahead and modify this buffer, you risk ruining the work of whoever rewrote the file. -If you say %s to revert, the contents of the buffer are refreshed +If you say \\`r' to revert, the contents of the buffer are refreshed from the file on disk. -If you say %s, the change you started to make will be aborted. - -Usually, you should type %s to get the latest version of the -file, then make the change again." - (userlock--fontify-key "y") - (userlock--fontify-key "r") - (userlock--fontify-key "n") - (userlock--fontify-key "r"))) +If you say \\`n', the change you started to make will be aborted. + +Usually, you should type \\`r' to get the latest version of the +file, then make the change again.")) (help-mode)))) ;;;###autoload diff --git a/lisp/vc/ediff-help.el b/lisp/vc/ediff-help.el index 0450cd7f23..48e1f15f05 100644 --- a/lisp/vc/ediff-help.el +++ b/lisp/vc/ediff-help.el @@ -227,7 +227,9 @@ the value of this variable and the variables `ediff-help-message-*' in ((string= cmd "s") (re-search-forward "^['`‘]s['’]")) ((string= cmd "+") (re-search-forward "^['`‘]\\+['’]")) ((string= cmd "=") (re-search-forward "^['`‘]=['’]")) - (t (user-error "Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer"))) + (t (user-error (substitute-command-keys + "Undocumented command! Type \\`G' in Ediff Control \ +Panel to drop a note to the Ediff maintainer")))) ) ; let case-fold-search )) diff --git a/lisp/vc/ediff-init.el b/lisp/vc/ediff-init.el index eaccb7a98c..4b352bd34f 100644 --- a/lisp/vc/ediff-init.el +++ b/lisp/vc/ediff-init.el @@ -615,8 +615,8 @@ Actually, Ediff restores the scope of visibility that existed at startup.") (defcustom ediff-keep-variants t "Nil means prompt to remove unmodified buffers A/B/C at session end. -Supplying a prefix argument to the quit command `q' temporarily reverses the -meaning of this variable." +Supplying a prefix argument to the quit command \\`q' temporarily +reverses the meaning of this variable." :type 'boolean :group 'ediff) diff --git a/lisp/vc/ediff-ptch.el b/lisp/vc/ediff-ptch.el index 7622cf4c19..a03c6a5ed7 100644 --- a/lisp/vc/ediff-ptch.el +++ b/lisp/vc/ediff-ptch.el @@ -415,7 +415,9 @@ other files, enter `/dev/null'. (with-output-to-temp-buffer ediff-msg-buffer (ediff-with-current-buffer standard-output (fundamental-mode)) - (princ (format-message " + (with-current-buffer standard-output + (insert (format-message + (substitute-command-keys " Ediff has inferred that %s %s @@ -423,10 +425,10 @@ are two possible targets for applying the patch. Both files seem to be plausible alternatives. Please advise: - Type `y' to use %s as the target; - Type `n' to use %s as the target. -" - file1 file2 file1 file2))) + Type \\`y' to use %s as the target; + Type \\`n' to use %s as the target. +") + file1 file2 file1 file2)))) (setcar session-file-object (if (y-or-n-p (format "Use %s ? " file1)) (progn @@ -823,7 +825,8 @@ you can still examine the changes via M-x ediff-files" ediff-patch-diagnostics patch-diagnostics)) (bury-buffer patch-diagnostics) - (message "Type `P', if you need to see patch diagnostics") + (message (substitute-command-keys + "Type \\`P', if you need to see patch diagnostics")) ctl-buf)) (defun ediff-multi-patch-internal (patch-buf &optional startup-hooks) diff --git a/lisp/windmove.el b/lisp/windmove.el index 658e59af19..8904f5cbf7 100644 --- a/lisp/windmove.el +++ b/lisp/windmove.el @@ -700,7 +700,7 @@ where PREFIX is a prefix key and MODIFIERS is either a list of modifiers or a single modifier. If PREFIX is `none', no prefix is used. If MODIFIERS is `none', the keybindings are directly bound to the arrow keys. -Default value of PREFIX is `C-x' and MODIFIERS is `shift'." +Default value of PREFIX is \\`C-x' and MODIFIERS is `shift'." (interactive) (unless prefix (setq prefix '(?\C-x))) (when (eq prefix 'none) (setq prefix nil)) commit e91f71676c19127dd90efabfc0da36483aa53a82 Author: Stefan Kangas Date: Mon Nov 22 08:08:11 2021 +0100 Avoid false positives about wide docstrings for key sequences * lisp/emacs-lisp/bytecomp.el (byte-compile--wide-docstring-p): Ignore literal key sequence substitutions. * test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el: New file. * test/lisp/emacs-lisp/bytecomp-tests.el ("warn-wide-docstring-ignore-substitutions.el"): New test. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 3338c38317..bd74c79d71 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1674,7 +1674,12 @@ URLs." (replace-regexp-in-string (rx "\\" (or (seq "[" (* (not "]")) "]"))) (make-string byte-compile--wide-docstring-substitution-len ?x) - docstring)))) + ;; For literal key sequence substitutions (e.g. "\\`C-h'"), just + ;; remove the markup as `substitute-command-keys' would. + (replace-regexp-in-string + (rx "\\" (seq "`" (group (* (not "]"))) "'")) + "\\1" + docstring))))) (defcustom byte-compile-docstring-max-column 80 "Recommended maximum width of doc string lines. diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el new file mode 100644 index 0000000000..37cfe463bf --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el @@ -0,0 +1,17 @@ +;;; -*- lexical-binding: t -*- +(defalias 'foo #'ignore + "None of this should be considered too wide. + +; this should be treated as 60 characters - no warning +\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window] + +; 64 * 'x' does not warn +\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x' + +; keymaps are just ignored +\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + +\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map} + +bar baz foo bar baz foo bar baz foo bar baz foo bar baz foo bar +") diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index dbc0aa3db4..816f14a18d 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -955,6 +955,10 @@ byte-compiled. Run with dynamic binding." "warn-wide-docstring-ignore-override.el" "defvar .foo-bar. docstring wider than .* characters" 'reverse) +(bytecomp--define-warning-file-test + "warn-wide-docstring-ignore-substitutions.el" + "defvar .foo-bar. docstring wider than .* characters" 'reverse) + (bytecomp--define-warning-file-test "warn-wide-docstring-ignore.el" "defvar .foo-bar. docstring wider than .* characters" 'reverse) commit 61c254cafc9caa3b52553fa0e7cca8a5086c5cea Author: martin rudalics Date: Mon Nov 22 12:02:35 2021 +0100 Add new function buffer-text-pixel-size * doc/lispref/display.texi (Size of Displayed Text): Document it. * lisp/emacs-lisp/subr-x.el (string-pixel-width): Use buffer-text-pixel-size (bug#51995). * src/xdisp.c (window_text_pixel_size): Factor out from Fwindow_text_pixel_size. (Fbuffer_text_pixel_size): New function. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index b948aff024..2341883129 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -2140,6 +2140,21 @@ height of all of these lines, if present, in the return value. whole and does not care about the size of individual lines. The following function does. +@defun buffer-text-pixel-size &optional buffer-or-name window from to x-limit y-limit +This is much like @code{window-text-pixel-size}, but can be used when +the buffer isn't shown in a window. (@code{window-text-pixel-size} is +faster when it is, so this function shouldn't be used in that case.) + +@var{buffer-or-name} must specify a live buffer or the name of a live +buffer and defaults to the current buffer. @var{window} must be a +live window and defaults to the selected one. The return value is a +cons of the maximum pixel-width of any text line and the pixel-height +of all the text lines of the buffer specified by @var{buffer-or-name}. + +The optional arguments @var{x-limit} and @var{y-limit} have the same +meaning as with @code{window-text-pixel-size}. +@end defun + @defun window-lines-pixel-dimensions &optional window first last body inverse left This function calculates the pixel dimensions of each line displayed in the specified @var{window}. It does so by walking @var{window}'s diff --git a/etc/NEWS b/etc/NEWS index b3693c82b4..626b67d03a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -75,6 +75,11 @@ time. * Changes in Emacs 29.1 ++++ +** New function 'buffer-text-pixel-size'. +This is similar to 'window-text-pixel-size', but can be used when the +buffer isn't displayed. + +++ ** New X resource: "borderThickness". This controls the thickness of the external borders of the menu bars diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index f336799040..b2dae564c2 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -446,8 +446,7 @@ is inserted before adjusting the number of empty lines." "Return the width of STRING in pixels." (with-temp-buffer (insert string) - (car (window-text-pixel-size - (current-buffer) (point-min) (point))))) + (car (buffer-text-pixel-size nil nil t)))) ;;;###autoload (defun string-glyph-split (string) diff --git a/src/xdisp.c b/src/xdisp.c index 8d34b7c4c3..d965021142 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -10626,77 +10626,21 @@ in_display_vector_p (struct it *it) && it->dpvec + it->current.dpvec_index != it->dpend); } -DEFUN ("window-text-pixel-size", Fwindow_text_pixel_size, Swindow_text_pixel_size, 0, 6, 0, - doc: /* Return the size of the text of WINDOW's buffer in pixels. -WINDOW can be any live window and defaults to the selected one. The -return value is a cons of the maximum pixel-width of any text line -and the pixel-height of all the text lines in the accessible portion -of buffer text. -WINDOW can also be a buffer, in which case the selected window is used, -and the function behaves as if that window was displaying this buffer. - -This function exists to allow Lisp programs to adjust the dimensions -of WINDOW to the buffer text it needs to display. - -The optional argument FROM, if non-nil, specifies the first text -position to consider, and defaults to the minimum accessible position -of the buffer. If FROM is t, it stands for the minimum accessible -position that starts a non-empty line. TO, if non-nil, specifies the -last text position and defaults to the maximum accessible position of -the buffer. If TO is t, it stands for the maximum accessible position -that ends a non-empty line. - -The optional argument X-LIMIT, if non-nil, specifies the maximum X -coordinate beyond which the text should be ignored. It is therefore -also the maximum width that the function can return. X-LIMIT nil or -omitted means to use the pixel-width of WINDOW's body. This default -means text of truncated lines wider than the window will be ignored; -specify a large value for X-LIMIT if lines are truncated and you need -to account for the truncated text. Use nil for X-LIMIT if you want to -know how high WINDOW should become in order to fit all of its buffer's -text with the width of WINDOW unaltered. Use the maximum width WINDOW -may assume if you intend to change WINDOW's width. Since calculating -the width of long lines can take some time, it's always a good idea to -make this argument as small as possible; in particular, if the buffer -contains long lines that shall be truncated anyway. - -The optional argument Y-LIMIT, if non-nil, specifies the maximum Y -coordinate beyond which the text is to be ignored; it is therefore -also the maximum height that the function can return (excluding the -height of the mode- or header-line, if any). Y-LIMIT nil or omitted -means consider all of the accessible portion of buffer text up to the -position specified by TO. Since calculating the text height of a -large buffer can take some time, it makes sense to specify this -argument if the size of the buffer is large or unknown. - -Optional argument MODE-LINES nil or omitted means do not include the -height of the mode-, tab- or header-line of WINDOW in the return value. -If it is the symbol `mode-line', 'tab-line' or `header-line', include -only the height of that line, if present, in the return value. If t, -include the height of any of these, if present, in the return value. */) - (Lisp_Object window, Lisp_Object from, Lisp_Object to, Lisp_Object x_limit, - Lisp_Object y_limit, Lisp_Object mode_lines) +/* This is like Fwindow_text_pixel_size but assumes that WINDOW's buffer + is the current buffer. Fbuffer_text_pixel_size calls it after it has + set WINDOW's buffer to the buffer specified by its BUFFER_OR_NAME + argument. */ +static Lisp_Object +window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to, Lisp_Object x_limit, + Lisp_Object y_limit, Lisp_Object mode_lines) { - struct window *w = BUFFERP (window) ? XWINDOW (selected_window) - : decode_live_window (window); - Lisp_Object buffer = BUFFERP (window) ? window : w->contents; - struct buffer *b; + struct window *w = decode_live_window (window); struct it it; - struct buffer *old_b = NULL; ptrdiff_t start, end, bpos; struct text_pos startp; void *itdata = NULL; int c, max_x = 0, max_y = 0, x = 0, y = 0; - CHECK_BUFFER (buffer); - b = XBUFFER (buffer); - - if (b != current_buffer) - { - old_b = current_buffer; - set_buffer_internal (b); - } - if (NILP (from)) { start = BEGV; @@ -10755,8 +10699,10 @@ include the height of any of these, if present, in the return value. */) else end = clip_to_bounds (start, fix_position (to), ZV); - if (!NILP (x_limit) && RANGED_FIXNUMP (0, x_limit, INT_MAX)) + if (RANGED_FIXNUMP (0, x_limit, INT_MAX)) max_x = XFIXNUM (x_limit); + else if (!NILP (x_limit)) + max_x = INT_MAX; if (NILP (y_limit)) max_y = INT_MAX; @@ -10889,12 +10835,128 @@ include the height of any of these, if present, in the return value. */) bidi_unshelve_cache (itdata, false); + return Fcons (make_fixnum (x - start_x), make_fixnum (y)); +} + +DEFUN ("window-text-pixel-size", Fwindow_text_pixel_size, Swindow_text_pixel_size, 0, 6, 0, + doc: /* Return the size of the text of WINDOW's buffer in pixels. +WINDOW must be a live window and defaults to the selected one. The +return value is a cons of the maximum pixel-width of any text line +and the pixel-height of all the text lines in the accessible portion +of buffer text. + +This function exists to allow Lisp programs to adjust the dimensions +of WINDOW to the buffer text it needs to display. + +The optional argument FROM, if non-nil, specifies the first text +position to consider, and defaults to the minimum accessible position +of the buffer. If FROM is t, it stands for the minimum accessible +position that starts a non-empty line. TO, if non-nil, specifies the +last text position and defaults to the maximum accessible position of +the buffer. If TO is t, it stands for the maximum accessible position +that ends a non-empty line. + +The optional argument X-LIMIT, if non-nil, specifies the maximum X +coordinate beyond which the text should be ignored. It is therefore +also the maximum width that the function can return. X-LIMIT nil or +omitted means to use the pixel-width of WINDOW's body. This default +means text of truncated lines wider than the window will be ignored; +specify a non-nil value for X-LIMIT if lines are truncated and you need +to account for the truncated text. + +Use nil for X-LIMIT if you want to know how high WINDOW should become in +order to fit all of its buffer's text with the width of WINDOW +unaltered. Use the maximum width WINDOW may assume if you intend to +change WINDOW's width. Use t for the maximum possible value. Since +calculating the width of long lines can take some time, it's always a +good idea to make this argument as small as possible; in particular, if +the buffer contains long lines that shall be truncated anyway. + +The optional argument Y-LIMIT, if non-nil, specifies the maximum Y +coordinate beyond which the text is to be ignored; it is therefore +also the maximum height that the function can return (excluding the +height of the mode- or header-line, if any). Y-LIMIT nil or omitted +means consider all of the accessible portion of buffer text up to the +position specified by TO. Since calculating the text height of a +large buffer can take some time, it makes sense to specify this +argument if the size of the buffer is large or unknown. + +Optional argument MODE-LINES nil or omitted means do not include the +height of the mode-, tab- or header-line of WINDOW in the return value. +If it is the symbol `mode-line', 'tab-line' or `header-line', include +only the height of that line, if present, in the return value. If t, +include the height of any of these, if present, in the return value. */) + (Lisp_Object window, Lisp_Object from, Lisp_Object to, Lisp_Object x_limit, + Lisp_Object y_limit, Lisp_Object mode_lines) +{ + struct window *w = decode_live_window (window); + struct buffer *b = XBUFFER (w->contents); + struct buffer *old_b = NULL; + Lisp_Object value; + + if (b != current_buffer) + { + old_b = current_buffer; + set_buffer_internal_1 (b); + } + + value = window_text_pixel_size (window, from, to, x_limit, y_limit, mode_lines); + if (old_b) - set_buffer_internal (old_b); + set_buffer_internal_1 (old_b); + + return value; +} + +DEFUN ("buffer-text-pixel-size", Fbuffer_text_pixel_size, Sbuffer_text_pixel_size, 0, 4, 0, + doc: /* Return size of whole text of BUFFER-OR-NAME in WINDOW. +BUFFER-OR-NAME must specify a live buffer or the name of a live buffer +and defaults to the current buffer. WINDOW must be a live window and +defaults to the selected one. The return value is a cons of the maximum +pixel-width of any text line and the pixel-height of all the text lines +of the buffer specified by BUFFER-OR-NAME. + +The optional arguments X-LIMIT and Y-LIMIT have the same meaning as with +`window-text-pixel-size'. + +Do not use this function if the buffer specified by BUFFER-OR-NAME is +already displayed in WINDOW. `window-text-pixel-size' is cheaper in +that case because it does not have to temporarily show that buffer in +WINDOW. */) + (Lisp_Object buffer_or_name, Lisp_Object window, Lisp_Object x_limit, + Lisp_Object y_limit) +{ + struct window *w = decode_live_window (window); + struct buffer *b = (NILP (buffer_or_name) + ? current_buffer + : XBUFFER (Fget_buffer (buffer_or_name))); + Lisp_Object buffer, value; + ptrdiff_t count = SPECPDL_INDEX (); - return Fcons (make_fixnum (x - start_x), make_fixnum (y)); + XSETBUFFER (buffer, b); + + /* The unwind form of with_echo_area_buffer is what we need here to + make WINDOW temporarily show our buffer. */ + record_unwind_protect (unwind_with_echo_area_buffer, + with_echo_area_buffer_unwind_data (w)); + + set_buffer_internal_1 (b); + + if (!EQ (buffer, w->contents)) + { + wset_buffer (w, buffer); + set_marker_both (w->pointm, buffer, BEG, BEG_BYTE); + set_marker_both (w->old_pointm, buffer, BEG, BEG_BYTE); + } + + value = window_text_pixel_size (window, Qnil, Qnil, x_limit, y_limit, Qnil); + + unbind_to (count, Qnil); + + return value; } + DEFUN ("display--line-is-continued-p", Fdisplay__line_is_continued_p, Sdisplay__line_is_continued_p, 0, 0, 0, doc: /* Return non-nil if the current screen line is continued on display. */) @@ -35040,6 +35102,7 @@ be let-bound around code that needs to disable messages temporarily. */); defsubr (&Sinvisible_p); defsubr (&Scurrent_bidi_paragraph_direction); defsubr (&Swindow_text_pixel_size); + defsubr (&Sbuffer_text_pixel_size); defsubr (&Smove_point_visually); defsubr (&Sbidi_find_overridden_directionality); defsubr (&Sdisplay__line_is_continued_p); commit c7699b97022f5bdc3848d474485e0da5f2673595 Author: Po Lu Date: Mon Nov 22 07:10:57 2021 +0000 Fix mouse movement event generation on Haiku * src/haikuterm.c (haiku_mouse_position): Set timestamp. (haiku_read_socket): Set last_mouse_movement_time. * src/haikuterm.h (struct haiku_display_info): Add field `last_mouse_movement_time'. diff --git a/src/haikuterm.c b/src/haikuterm.c index bc956f066a..5364ebf823 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -2386,9 +2386,10 @@ haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, enum scroll_bar_part *part, Lisp_Object *x, Lisp_Object *y, Time *timestamp) { - block_input (); if (!fp) return; + + block_input (); Lisp_Object frame, tail; struct frame *f1 = NULL; FOR_EACH_FRAME (tail, frame) @@ -2428,6 +2429,7 @@ haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, *bar_window = Qnil; *part = scroll_bar_above_handle; *fp = f1; + *timestamp = x_display_list->last_mouse_movement_time; XSETINT (*x, sx); XSETINT (*y, sy); } @@ -2578,6 +2580,7 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) static void *buf = NULL; ssize_t b_size; struct unhandled_event *unhandled_events = NULL; + int button_or_motion_p; if (!buf) buf = xmalloc (200); @@ -2597,6 +2600,8 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) inev.arg = Qnil; inev2.arg = Qnil; + button_or_motion_p = 0; + haiku_read (&type, buf, b_size); switch (type) @@ -2721,6 +2726,9 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) Lisp_Object frame; XSETFRAME (frame, f); + x_display_list->last_mouse_movement_time = time (NULL); + button_or_motion_p = 1; + if (b->just_exited_p) { Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f); @@ -2748,9 +2756,9 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) previous_help_echo_string = help_echo_string; help_echo_string = Qnil; - if (f != dpyinfo->last_mouse_glyph_frame || - b->x < r.x || b->x >= r.x + r.width - 1 || b->y < r.y || - b->y >= r.y + r.height - 1) + if (f != dpyinfo->last_mouse_glyph_frame + || b->x < r.x || b->x >= r.x + r.width + || b->y < r.y || b->y >= r.y + r.height) { f->mouse_moved = true; dpyinfo->last_mouse_scroll_bar = NULL; @@ -2805,6 +2813,8 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) inev.modifiers = haiku_modifiers_to_emacs (b->modifiers); x_display_list->last_mouse_glyph_frame = 0; + x_display_list->last_mouse_movement_time = time (NULL); + button_or_motion_p = 1; /* Is this in the tab-bar? */ if (WINDOWP (f->tab_bar_window) @@ -2858,6 +2868,8 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) inev.arg = tab_bar_arg; inev.code = b->btn_no; + f->mouse_moved = false; + XSETINT (inev.x, b->x); XSETINT (inev.y, b->y); @@ -3183,15 +3195,19 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (inev.kind != NO_EVENT) { if (inev.kind != HELP_EVENT) - inev.timestamp = time (NULL); + inev.timestamp = (button_or_motion_p + ? x_display_list->last_mouse_movement_time + : time (NULL)); kbd_buffer_store_event_hold (&inev, hold_quit); ++message_count; } if (inev2.kind != NO_EVENT) { - if (inev.kind != HELP_EVENT) - inev.timestamp = time (NULL); + if (inev2.kind != HELP_EVENT) + inev2.timestamp = (button_or_motion_p + ? x_display_list->last_mouse_movement_time + : time (NULL)); kbd_buffer_store_event_hold (&inev2, hold_quit); ++message_count; } diff --git a/src/haikuterm.h b/src/haikuterm.h index af55f68c67..7ed7485ef5 100644 --- a/src/haikuterm.h +++ b/src/haikuterm.h @@ -30,6 +30,7 @@ along with GNU Emacs. If not, see . */ #include "character.h" #include "dispextern.h" #include "font.h" +#include "systime.h" #define C_FRAME struct frame * #define C_FONT struct font * @@ -107,6 +108,8 @@ struct haiku_display_info haiku display; double resx, resy; + + Time last_mouse_movement_time; }; struct haiku_output commit 9d8a2832e857fa82d401709ee4b56682ccb5b7d4 Author: Po Lu Date: Mon Nov 22 06:33:22 2021 +0000 Don't set button event modifiers twice on Haiku * src/haikuterm.c (haiku_read_socket): Simplify. diff --git a/src/haikuterm.c b/src/haikuterm.c index 61920dbece..bc956f066a 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -2858,9 +2858,6 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) inev.arg = tab_bar_arg; inev.code = b->btn_no; - inev.modifiers |= type == BUTTON_UP ? - up_modifier : down_modifier; - XSETINT (inev.x, b->x); XSETINT (inev.y, b->y); commit 8aea4721d9fadfaaabfea7843df71b62e3fb94a7 Author: Po Lu Date: Mon Nov 22 14:06:18 2021 +0800 Move XI2 event filtering to a more appropriate location * src/xterm.c (handle_one_xevent): Filter all key press events even if no frame is found. diff --git a/src/xterm.c b/src/xterm.c index 4e7ecd840e..197776ce31 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10312,6 +10312,36 @@ handle_one_xevent (struct x_display_info *dpyinfo, ptrdiff_t i; int nchars, len; +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) + /* Dispatch XI_KeyPress events when in menu. */ + if (popup_activated ()) + goto XI_OTHER; +#endif + +#ifdef HAVE_X_I18N + XKeyPressedEvent xkey; + + memset (&xkey, 0, sizeof xkey); + + xkey.type = KeyPress; + xkey.serial = 0; + xkey.send_event = xev->send_event; + xkey.display = xev->display; + xkey.window = xev->event; + xkey.root = xev->root; + xkey.subwindow = xev->child; + xkey.time = xev->time; + xkey.state = xev->mods.effective; + xkey.keycode = xev->detail; + xkey.same_screen = True; + + if (x_filter_event (dpyinfo, (XEvent *) &xkey)) + { + *finish = X_EVENT_DROP; + goto XI_OTHER; + } +#endif + #ifdef HAVE_XKB if (dpyinfo->xkb_desc) { @@ -10341,12 +10371,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_display_set_last_user_time (dpyinfo, xev->time); ignore_next_mouse_click_timeout = 0; -#if defined (USE_X_TOOLKIT) || defined (USE_GTK) - /* Dispatch XI_KeyPress events when in menu. */ - if (popup_activated ()) - goto XI_OTHER; -#endif - f = x_any_window_to_frame (dpyinfo, xev->event); /* If mouse-highlight is an integer, input clears out @@ -10385,25 +10409,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, inev.ie.timestamp = xev->time; #ifdef HAVE_X_I18N - XKeyPressedEvent xkey; - - memset (&xkey, 0, sizeof xkey); - - xkey.type = KeyPress; - xkey.serial = 0; - xkey.send_event = xev->send_event; - xkey.display = xev->display; - xkey.window = xev->event; - xkey.root = xev->root; - xkey.subwindow = xev->child; - xkey.time = xev->time; - xkey.state = state; - xkey.keycode = keycode; - xkey.same_screen = True; - - if (x_filter_event (dpyinfo, (XEvent *) &xkey)) - goto xi_done_keysym; - if (FRAME_XIC (f)) { Status status_return; commit 1aef1a6673bc29784effe10d2e01e62b49c0112c Author: Stefan Kangas Date: Mon Nov 22 06:44:10 2021 +0100 Add new format for literal key sequences to substitute-command-keys * lisp/help.el (substitute-command-keys): Add new format "\\`f'" for literal key sequences. (Bug#50804) * doc/lispref/help.texi (Keys in Documentation): Document the above new substitution. * test/lisp/help-tests.el (help-tests-substitute-command-keys/literal-key-sequence): (help-tests-substitute-command-keys/literal-key-sequence-errors): New tests. (help-tests-substitute-key-bindings/face-help-key-binding): Extend test. diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi index a788852de7..1a9eb30fde 100644 --- a/doc/lispref/help.texi +++ b/doc/lispref/help.texi @@ -333,6 +333,13 @@ stands for no text itself. It is used only for a side effect: it specifies @var{mapvar}'s value as the keymap for any following @samp{\[@var{command}]} sequences in this documentation string. +@item \`@var{KEYSEQ}' +stands for a key sequence @var{KEYSEQ}, which will use the same face +as a command substitution. This should be used only when a key +sequence has no corresponding command, for example when it is read +directly with @code{read-key-sequence}. It must be a valid key +sequence according to @code{key-valid-p}. + @item ` (grave accent) stands for a left quote. This generates a left single quotation mark, an apostrophe, or a grave diff --git a/etc/NEWS b/etc/NEWS index 6fa5de0116..b3693c82b4 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -716,6 +716,15 @@ syntax. This is like 'kbd', but only returns vectors instead of a mix of vectors and strings. ++++ +** New substitution in docstrings and 'substitute-command-keys'. Use +Use "\\`KEYSEQ'" to insert a literal key sequence "KEYSEQ" +(e.g. "C-k") in a docstring or when calling 'substitute-command-keys', +which will use the same face as a command substitution. This should +be used only when a key sequence has no corresponding command, for +example when it is read directly with 'read-key-sequence'. It must be +a valid key sequence according to 'key-valid-p'. + +++ ** New function 'file-name-split'. This returns a list of all the components of a file name. diff --git a/lisp/help.el b/lisp/help.el index bc3d4773da..9122d96271 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1078,6 +1078,9 @@ Each substring of the form \\\\=[COMMAND] is replaced by either a keystroke sequence that invokes COMMAND, or \"M-x COMMAND\" if COMMAND is not on any keys. Keybindings will use the face `help-key-binding'. +Each substring of the form \\\\=`KEYBINDING' will be replaced by +KEYBINDING and use the `help-key-binding' face. + Each substring of the form \\\\={MAPVAR} is replaced by a summary of the value of MAPVAR as a keymap. This summary is similar to the one produced by ‘describe-bindings’. The summary ends in two newlines @@ -1130,6 +1133,23 @@ Otherwise, return a new string." (delete-char 2) (ignore-errors (forward-char 1))) + ((and (= (following-char) ?`) + (save-excursion + (prog1 (search-forward "'" nil t) + (setq end-point (- (point) 2))))) + (goto-char orig-point) + (delete-char 2) + (goto-char (1- end-point)) + (delete-char 1) + ;; (backward-char 1) + (let ((k (buffer-substring-no-properties orig-point (point)))) + (cond ((= (length k) 0) + (error "Empty key sequence in substitution")) + ((not (key-valid-p k)) + (error "Invalid key sequence in substitution: `%s'" k)))) + (add-text-properties orig-point (point) + '( face help-key-binding + font-lock-face help-key-binding))) ;; 1C. \[foo] is replaced with the keybinding. ((and (= (following-char) ?\[) (save-excursion diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el index 982750f479..281d97ee92 100644 --- a/test/lisp/help-tests.el +++ b/test/lisp/help-tests.el @@ -88,6 +88,25 @@ (test "\\[emacs-version]\\[next-line]" "M-x emacs-versionC-n") (test-re "\\[emacs-version]`foo'" "M-x emacs-version[`'‘]foo['’]"))) +(ert-deftest help-tests-substitute-command-keys/literal-key-sequence () + "Literal replacement." + (with-substitute-command-keys-test + (test "\\`C-m'" "C-m") + (test "\\`C-m'\\`C-j'" "C-mC-j") + (test "foo\\`C-m'bar\\`C-j'baz" "fooC-mbarC-jbaz"))) + +(ert-deftest help-tests-substitute-command-keys/literal-key-sequence-errors () + (should-error (substitute-command-keys "\\`'")) + (should-error (substitute-command-keys "\\`c-c'")) + (should-error (substitute-command-keys "\\`'"))) + +(ert-deftest help-tests-substitute-key-bindings/face-help-key-binding () + (should (eq (get-text-property 0 'face (substitute-command-keys "\\[next-line]")) + 'help-key-binding)) + (should (eq (get-text-property 0 'face (substitute-command-keys "\\`f'")) + 'help-key-binding))) + + (ert-deftest help-tests-substitute-command-keys/keymaps () (with-substitute-command-keys-test (test-re "\\{minibuffer-local-must-match-map}" commit 5fcff0d2cbe33faef8bbb753a5f02fb26b1d7e5c Author: Po Lu Date: Mon Nov 22 13:24:59 2021 +0800 Use more precise test for emulated wheel events in XI2 * src/xterm.c (handle_one_xevent): Ignore button events that have XIPointerEmulated set. diff --git a/src/xterm.c b/src/xterm.c index 9d052c412b..4e7ecd840e 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10128,11 +10128,15 @@ handle_one_xevent (struct x_display_info *dpyinfo, bool tool_bar_p = false; struct xi_device_t *device; +#ifdef XIPointerEmulated /* Ignore emulated scroll events when XI2 native scroll events are present. */ - if (dpyinfo->xi2_version >= 1 && xev->detail >= 4 - && xev->detail <= 8) + if (dpyinfo->xi2_version >= 1 + && xev->detail >= 4 + && xev->detail <= 8 + && xev->flags & XIPointerEmulated) goto XI_OTHER; +#endif device = xi_device_from_id (dpyinfo, xev->deviceid); commit 9324efac480df3cd78af112da2b12a0d2bd18e02 Author: Po Lu Date: Mon Nov 22 10:42:46 2021 +0800 Make `xwidget-display-event' a special event as well * doc/lispref/commands.texi (Xwidget Events): Document that `xwidget-display-event' is a special event, and that it should be handled through callbacks. * etc/NEWS: Update NEWS entry. * lisp/xwidget.el (xwidget-webkit-new-session) (xwidget-webkit-import-widget): Attach display callback. (xwidget-webkit-display-event): Call display callback instead. (xwidget-webkit-display-callback): New function. * src/keyboard.c (make_lispy_event): Store source information for XWIDGET_DISPLAY_EVENT correctly. * src/xwidget.c (store_xwidget_display_event): Store source of the display request. (webkit_ready_to_show): Store source if available. (webkit_create_cb_1): Store source if available. (kill_xwidget): Remove dead widget from internal_xwidget_list. diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index 5fd7b55a60..c12a97cc7d 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -1950,9 +1950,15 @@ internally by @code{xwidget-webkit-execute-script}. @end table @cindex @code{xwidget-display-event} event -@item (xwidget-display-event @var{xwidget}) +@item (xwidget-display-event @var{xwidget} @var{source}) This event is sent whenever an xwidget requests that another xwidget -be displayed. @var{xwidget} is the xwidget that should be displayed. +be displayed. @var{xwidget} is the xwidget that should be displayed, +and @var{source} is the xwidget that asked to display @var{xwidget}. + +It is also a special event which should be handled through callbacks. +You can add such a callback by setting the @code{display-callback} of +@var{source}'s property list, which should be a function that accepts +@var{xwidget} and @var{source} as arguments. @var{xwidget}'s buffer will be set to a temporary buffer. When displaying the widget, care should be taken to replace the buffer with diff --git a/etc/NEWS b/etc/NEWS index bfea4da8b9..6fa5de0116 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -927,8 +927,8 @@ commits to the load. +++ *** New event type 'xwidget-display-event'. These events are sent whenever an xwidget requests that Emacs display -another xwidget. The only argument to this event is the xwidget that -should be displayed. +another xwidget. The only arguments to this event are the xwidget +that should be displayed, and the xwidget that asked to display it. +++ *** New function 'xwidget-webkit-set-cookie-storage-file'. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 160da67cb2..cf4396fec2 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -818,6 +818,7 @@ For example, use this to display an anchor." (xwidget-webkit-set-cookie-storage-file xw (expand-file-name xwidget-webkit-cookie-file))) (xwidget-put xw 'callback callback) + (xwidget-put xw 'display-callback #'xwidget-webkit-display-callback) (xwidget-webkit-mode) (xwidget-webkit-goto-uri (xwidget-webkit-last-session) url))) @@ -840,16 +841,26 @@ Return the buffer." (put-text-property (point-min) (point-max) 'display (list 'xwidget :xwidget xwidget))) (xwidget-put xwidget 'callback callback) + (xwidget-put xwidget 'display-callback + #'xwidget-webkit-display-callback) (set-xwidget-buffer xwidget buffer) (xwidget-webkit-mode)) buffer)) (defun xwidget-webkit-display-event (event) - "Import the xwidget inside EVENT and display it." + "Trigger display callback for EVENT." (interactive "e") - (display-buffer (xwidget-webkit-import-widget (nth 1 event)))) + (let ((xwidget (cadr event)) + (source (caddr event))) + (when (xwidget-get source 'display-callback) + (funcall (xwidget-get source 'display-callback) + xwidget source)))) -(global-set-key [xwidget-display-event] 'xwidget-webkit-display-event) +(defun xwidget-webkit-display-callback (xwidget _source) + "Import XWIDGET and display it." + (display-buffer (xwidget-webkit-import-widget xwidget))) + +(define-key special-event-map [xwidget-display-event] 'xwidget-webkit-display-event) (defun xwidget-webkit-goto-url (url) "Goto URL with xwidget webkit." diff --git a/src/keyboard.c b/src/keyboard.c index 982854c41e..c98175aea0 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -6141,7 +6141,7 @@ make_lispy_event (struct input_event *event) return Fcons (Qxwidget_event, event->arg); case XWIDGET_DISPLAY_EVENT: - return list2 (Qxwidget_display_event, event->arg); + return Fcons (Qxwidget_display_event, event->arg); #endif #ifdef USE_FILE_NOTIFY diff --git a/src/xwidget.c b/src/xwidget.c index d88270dbe9..5da2aa1743 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -1316,16 +1316,18 @@ store_xwidget_js_callback_event (struct xwidget *xw, #ifdef USE_GTK static void -store_xwidget_display_event (struct xwidget *xw) +store_xwidget_display_event (struct xwidget *xw, + struct xwidget *src) { struct input_event evt; - Lisp_Object val; + Lisp_Object val, src_val; XSETXWIDGET (val, xw); + XSETXWIDGET (src_val, src); EVENT_INIT (evt); evt.kind = XWIDGET_DISPLAY_EVENT; evt.frame_or_window = Qnil; - evt.arg = val; + evt.arg = list2 (val, src_val); kbd_buffer_store_event (&evt); } @@ -1335,6 +1337,9 @@ webkit_ready_to_show (WebKitWebView *new_view, { Lisp_Object tem; struct xwidget *xw; + struct xwidget *src; + + src = find_xwidget_for_offscreen_window (GDK_WINDOW (user_data)); for (tem = internal_xwidget_list; CONSP (tem); tem = XCDR (tem)) { @@ -1344,14 +1349,21 @@ webkit_ready_to_show (WebKitWebView *new_view, if (EQ (xw->type, Qwebkit) && WEBKIT_WEB_VIEW (xw->widget_osr) == new_view) - store_xwidget_display_event (xw); + { + /* The source widget was destroyed before we had a + chance to display the new widget. */ + if (!src) + kill_xwidget (xw); + else + store_xwidget_display_event (xw, src); + } } } } static GtkWidget * webkit_create_cb_1 (WebKitWebView *webview, - struct xwidget_view *xv) + struct xwidget *xv) { Lisp_Object related; Lisp_Object xwidget; @@ -1369,7 +1381,8 @@ webkit_create_cb_1 (WebKitWebView *webview, widget = XXWIDGET (xwidget)->widget_osr; g_signal_connect (G_OBJECT (widget), "ready-to-show", - G_CALLBACK (webkit_ready_to_show), NULL); + G_CALLBACK (webkit_ready_to_show), + gtk_widget_get_window (xv->widgetwindow_osr)); return widget; } @@ -1591,7 +1604,7 @@ webkit_decide_policy_cb (WebKitWebView *webView, newview = WEBKIT_WEB_VIEW (XXWIDGET (new_xwidget)->widget_osr); webkit_web_view_load_request (newview, request); - store_xwidget_display_event (XXWIDGET (new_xwidget)); + store_xwidget_display_event (XXWIDGET (new_xwidget), xw); return TRUE; } case WEBKIT_POLICY_DECISION_TYPE_NAVIGATION_ACTION: @@ -3106,6 +3119,11 @@ kill_frame_xwidget_views (struct frame *f) static void kill_xwidget (struct xwidget *xw) { + Lisp_Object val; + XSETXWIDGET (val, xw); + + internal_xwidget_list = Fdelq (val, internal_xwidget_list); + Vxwidget_list = Fcopy_sequence (internal_xwidget_list); #ifdef USE_GTK xw->buffer = Qnil; @@ -3145,8 +3163,6 @@ kill_buffer_xwidgets (Lisp_Object buffer) for (tail = Fget_buffer_xwidgets (buffer); CONSP (tail); tail = XCDR (tail)) { xwidget = XCAR (tail); - internal_xwidget_list = Fdelq (xwidget, internal_xwidget_list); - Vxwidget_list = Fcopy_sequence (internal_xwidget_list); { CHECK_LIVE_XWIDGET (xwidget); struct xwidget *xw = XXWIDGET (xwidget); commit 536e7bf03b2ef8451fdd6b8d62db08f2bc7ebec9 Author: Glenn Morris Date: Sun Nov 21 18:29:24 2021 -0800 Fix recent compile-tests addition * test/lisp/progmodes/compile-tests.el (compile-test-error-regexps): Bump number of expected errors. ; Surely running the tests before committing would have flagged this? diff --git a/test/lisp/progmodes/compile-tests.el b/test/lisp/progmodes/compile-tests.el index c714b9ecfe..c87a4453cb 100644 --- a/test/lisp/progmodes/compile-tests.el +++ b/test/lisp/progmodes/compile-tests.el @@ -492,7 +492,7 @@ The test data is in `compile-tests--test-regexps-data'." (compilation-num-warnings-found 0) (compilation-num-infos-found 0)) (mapc #'compile--test-error-line compile-tests--test-regexps-data) - (should (eq compilation-num-errors-found 96)) + (should (eq compilation-num-errors-found 97)) (should (eq compilation-num-warnings-found 35)) (should (eq compilation-num-infos-found 28))))) commit 4eb228bfac3cd384bc8b21cd0c46fc89b339b0ed Author: Po Lu Date: Mon Nov 22 09:40:47 2021 +0800 Also filter XI_KeyRelease events * src/xterm.c (handle_one_xevent): Also filter XI_KeyRelease events through the X input method. diff --git a/src/xterm.c b/src/xterm.c index 7c2276f2e6..9d052c412b 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10649,6 +10649,25 @@ handle_one_xevent (struct x_display_info *dpyinfo, } case XI_KeyRelease: x_display_set_last_user_time (dpyinfo, xev->time); +#ifdef HAVE_X_I18N + XKeyPressedEvent xkey; + + memset (&xkey, 0, sizeof xkey); + + xkey.type = KeyRelease; + xkey.serial = 0; + xkey.send_event = xev->send_event; + xkey.display = xev->display; + xkey.window = xev->event; + xkey.root = xev->root; + xkey.subwindow = xev->child; + xkey.time = xev->time; + xkey.state = xev->mods.effective; + xkey.keycode = xev->detail; + xkey.same_screen = True; + + x_filter_event (dpyinfo, (XEvent *) &xkey); +#endif goto XI_OTHER; case XI_PropertyEvent: case XI_HierarchyChanged: commit a4ac6090986262f5a01c858a35bdcfb1787ded45 Author: Po Lu Date: Mon Nov 22 09:34:39 2021 +0800 Use only effective modifiers for XI2 key press events * src/xterm.c (handle_one_xevent): Use only effective modifiers in XI_KeyPress events. diff --git a/src/xterm.c b/src/xterm.c index f5459afd4f..7c2276f2e6 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10292,10 +10292,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, } case XI_KeyPress: { - int state = xev->mods.base - | xev->mods.effective - | xev->mods.latched - | xev->mods.locked; + int state = xev->mods.effective; Lisp_Object c; #ifdef HAVE_XKB unsigned int mods_rtrn; commit bb2a989e002c954e67e3112d7bdb2f2891d387bd Author: Po Lu Date: Mon Nov 22 00:24:26 2021 +0000 Remove variable that no longer exists from manual * doc/emacs/haiku.texi: Remove nonexistent variable. diff --git a/doc/emacs/haiku.texi b/doc/emacs/haiku.texi index 551599dfa8..a41804b233 100644 --- a/doc/emacs/haiku.texi +++ b/doc/emacs/haiku.texi @@ -106,14 +106,6 @@ defaults to @code{t}. If GDB cannot be used on your system, please attach the report generated by the system debugger when reporting a bug. -@table @code -@vindex haiku-use-system-debugger -@item haiku-use-system-debugger -When non-nil, Emacs will ask the system to launch the system debugger -whenever it experiences a fatal error. This behaviour is standard -among Haiku applications. -@end table - @node Haiku Fonts @section Font and font backend selection on Haiku @cindex font backend selection (Haiku) commit 73754bc54c0d9d390ae76ab0ccf18f63db16bc1f Author: Stefan Kangas Date: Sun Nov 21 21:05:47 2021 +0100 Adapt isearch help screen for variable-pitch-mode * lisp/isearch.el (isearch-help-for-help-internal): Adapt for 'variable-pitch-mode', now that 'make-help-screen' uses that. diff --git a/lisp/isearch.el b/lisp/isearch.el index dea9662477..9dc8525417 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -488,9 +488,9 @@ and doesn't remove full-buffer highlighting after a search." "You have typed %THIS-KEY%, the help character. Type a Help option: \(Type \\\\[help-quit] to exit the Help command.) -\\[isearch-describe-bindings] Display all Isearch key bindings. -\\[isearch-describe-key] KEYS Display full documentation of Isearch key sequence. -\\[isearch-describe-mode] Display documentation of Isearch mode. + \\[isearch-describe-bindings] Display all Isearch key bindings. + \\[isearch-describe-key] Display full documentation of Isearch key sequence. + \\[isearch-describe-mode] Display documentation of Isearch mode. You can't type here other help keys available in the global help map, but outside of this help window when you type them in Isearch mode, commit 74386abc0ff14affe2a9564c681d9e53cfe418e2 Author: Omar Polo Date: Mon Nov 15 21:49:23 2021 +0000 ; Simplify rcirc authentication querying functions diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 6030db9dae..b4e9031e0d 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -654,30 +654,15 @@ See `rcirc-connect' for more details on these variables.") (defun rcirc-get-server-method (server) "Return authentication method for SERVER." - (catch 'method - (dolist (i rcirc-authinfo) - (let ((server-i (car i)) - (method (cadr i))) - (when (string-match server-i server) - (throw 'method method)))))) + (cadr (assoc server rcirc-authinfo #'string-match))) (defun rcirc-get-server-password (server) "Return password for SERVER." - (catch 'pass - (dolist (i rcirc-authinfo) - (let ((server-i (car i)) - (args (cdddr i))) - (when (string-match server-i server) - (throw 'pass (car args))))))) + (cadddr (assoc server rcirc-authinfo #'string-match))) (defun rcirc-get-server-cert (server) "Return a list of key and certificate for SERVER." - (catch 'cert - (dolist (i rcirc-authinfo) - (let ((server-i (car i)) - (args (cddr i))) - (when (string-match server-i server) - (throw 'cert args)))))) + (cddr (assoc server rcirc-authinfo #'string-match))) ;;;###autoload (defun rcirc-connect (server &optional port nick user-name commit b79cb838a477ee5a5c3660e81264991ff833a82f Author: Omar Polo Date: Mon Nov 15 17:40:58 2021 +0000 implement certfp authentication to rcirc * lisp/net/rcirc.el (rcirc-connect): Use the provided client certs * doc/misc/rcirc.texi (Configuration): Document the change diff --git a/doc/misc/rcirc.texi b/doc/misc/rcirc.texi index 696983dc77..58ca045e78 100644 --- a/doc/misc/rcirc.texi +++ b/doc/misc/rcirc.texi @@ -633,6 +633,13 @@ Use this symbol if you want to use @acronym{SASL} authentication. The necessary arguments are the nickname you want to use this for, and the password to use. +@item certfp +@cindex certfp authentication +Use this symbol if you want to use CertFP authentication. The +necessary arguments are the path to the client certificate key and +password. The CertFP authentication requires a @acronym{TLS} +connection. + @end table @end table diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 5c92c60eda..6030db9dae 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -262,6 +262,7 @@ The ARGUMENTS for each METHOD symbol are: `bitlbee': NICK PASSWORD `quakenet': ACCOUNT PASSWORD `sasl': NICK PASSWORD + `certfp': KEY CERT Examples: ((\"Libera.Chat\" nickserv \"bob\" \"p455w0rd\") @@ -291,7 +292,11 @@ Examples: (list :tag "SASL" (const sasl) (string :tag "Nick") - (string :tag "Password"))))) + (string :tag "Password")) + (list :tag "CertFP" + (const certfp) + (string :tag "Key") + (string :tag "Certificate"))))) (defcustom rcirc-auto-authenticate-flag t "Non-nil means automatically send authentication string to server. @@ -547,6 +552,9 @@ If ARG is non-nil, instead prompt for connection parameters." (password (plist-get (cdr c) :password)) (encryption (plist-get (cdr c) :encryption)) (server-alias (plist-get (cdr c) :server-alias)) + (client-cert (when (eq (rcirc-get-server-method (car c)) + 'certfp) + (rcirc-get-server-cert (car c)))) contact) (when-let (((not password)) (auth (auth-source-search :host server @@ -563,7 +571,7 @@ If ARG is non-nil, instead prompt for connection parameters." (condition-case nil (let ((process (rcirc-connect server port nick user-name full-name channels password encryption - server-alias))) + client-cert server-alias))) (when rcirc-display-server-buffer (pop-to-buffer-same-window (process-buffer process)))) (quit (message "Quit connecting to %s" @@ -662,13 +670,22 @@ See `rcirc-connect' for more details on these variables.") (when (string-match server-i server) (throw 'pass (car args))))))) +(defun rcirc-get-server-cert (server) + "Return a list of key and certificate for SERVER." + (catch 'cert + (dolist (i rcirc-authinfo) + (let ((server-i (car i)) + (args (cddr i))) + (when (string-match server-i server) + (throw 'cert args)))))) + ;;;###autoload (defun rcirc-connect (server &optional port nick user-name full-name startup-channels password encryption - server-alias) + certfp server-alias) "Connect to SERVER. The arguments PORT, NICK, USER-NAME, FULL-NAME, PASSWORD, -ENCRYPTION, SERVER-ALIAS are interpreted as in +ENCRYPTION, CERTFP, SERVER-ALIAS are interpreted as in `rcirc-server-alist'. STARTUP-CHANNELS is a list of channels that are joined after authentication." (save-excursion @@ -695,6 +712,7 @@ that are joined after authentication." (setq process (open-network-stream (or server-alias server) nil server port-number :type (or encryption 'plain) + :client-certificate certfp :nowait t)) (set-process-coding-system process 'raw-text 'raw-text) (with-current-buffer (get-buffer-create (rcirc-generate-new-buffer-name process nil)) commit 1bc4fd6f52eaba61a452152642a0ed85d07702c4 Author: Omar Polo Date: Mon Nov 15 17:33:51 2021 +0000 Move the sasl section after the bitlbee text diff --git a/doc/misc/rcirc.texi b/doc/misc/rcirc.texi index a4ca54a8b0..696983dc77 100644 --- a/doc/misc/rcirc.texi +++ b/doc/misc/rcirc.texi @@ -609,12 +609,6 @@ Use this symbol if you need to identify yourself in the Bitlbee channel as follows: @code{identify secret}. The necessary arguments are the nickname you want to use this for, and the password to use. -@item sasl -@cindex sasl authentication -Use this symbol if you want to use @acronym{SASL} authentication. The -necessary arguments are the nickname you want to use this for, and the -password to use. - @cindex gateway to other IM services @cindex instant messaging, other services @cindex Jabber @@ -633,6 +627,12 @@ the other instant messaging services, and Bitlbee will log you in. All @code{rcirc} needs to know, is the login to your Bitlbee account. Don't confuse the Bitlbee account with all the other accounts. +@item sasl +@cindex sasl authentication +Use this symbol if you want to use @acronym{SASL} authentication. The +necessary arguments are the nickname you want to use this for, and the +password to use. + @end table @end table commit 08ccce2257d81ae4e8a579c374f6a8e886992385 Author: Philip Kaludercic Date: Tue Nov 16 00:05:11 2021 +0100 Improve error parsing for GCC -fanalyzer output * compile.el (compilation-error-regexp-alist-alist): Adjust gnu rule * compile-tests.el (compile-tests--test-regexps-data): Add testcase diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 14da588020..c0e16ce351 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -351,7 +351,10 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) ;; from Ruby, but it is unclear whether it is actually ;; used since the gcc-include rule above seems to cover ;; it. - (regexp "[ \t]+\\(?:in \\|from\\)"))) + (regexp "[ \t]+\\(?:in \\|from\\)") + ;; Skip indentation generated by tools like GCC's + ;; -fanalyzer. + (: (+ space) "|"))) ;; File name group. (group-n 1 diff --git a/test/lisp/progmodes/compile-tests.el b/test/lisp/progmodes/compile-tests.el index 2a3bb3dafa..c714b9ecfe 100644 --- a/test/lisp/progmodes/compile-tests.el +++ b/test/lisp/progmodes/compile-tests.el @@ -230,6 +230,7 @@ (gnu "foo.c:8:23:information: message" 1 23 8 "foo.c") (gnu "foo.c:8.23-45: Informational: message" 1 (23 . 45) (8 . nil) "foo.c") (gnu "foo.c:8-23: message" 1 nil (8 . 23) "foo.c") + (gnu " |foo.c:8: message" 1 nil 8 "foo.c") ;; The next one is not in the GNU standards AFAICS. ;; Here we seem to interpret it as LINE1-LINE2.COL2. (gnu "foo.c:8-45.3: message" 1 (nil . 3) (8 . 45) "foo.c") commit b7db7eb2c7b8ac1bddf4afa9ccf9b30ebeb0224e Author: Eli Zaretskii Date: Sun Nov 21 19:07:10 2021 +0200 Fix positioning of pop-up menus when there are window-margins * src/menu.c (x_popup_menu_1): Calculate X and Y correctly for clicks in the text area. (Bug#51782) diff --git a/src/menu.c b/src/menu.c index ab01e1bfad..96d1c5208a 100644 --- a/src/menu.c +++ b/src/menu.c @@ -1113,7 +1113,7 @@ into menu items. */) Lisp_Object x_popup_menu_1 (Lisp_Object position, Lisp_Object menu) { - Lisp_Object keymap, tem, tem2; + Lisp_Object keymap, tem, tem2 = Qnil; int xpos = 0, ypos = 0; Lisp_Object title; const char *error_name = NULL; @@ -1252,8 +1252,21 @@ x_popup_menu_1 (Lisp_Object position, Lisp_Object menu) CHECK_LIVE_WINDOW (window); f = XFRAME (WINDOW_FRAME (win)); - xpos = WINDOW_LEFT_EDGE_X (win); - ypos = WINDOW_TOP_EDGE_Y (win); + if (FIXNUMP (tem2)) + { + /* Clicks in the text area, where TEM2 is a buffer + position, are relative to the top-left edge of the text + area, see keyboard.c:make_lispy_position. */ + xpos = window_box_left (win, TEXT_AREA); + ypos = (WINDOW_TOP_EDGE_Y (win) + + WINDOW_TAB_LINE_HEIGHT (win) + + WINDOW_HEADER_LINE_HEIGHT (win)); + } + else + { + xpos = WINDOW_LEFT_EDGE_X (win); + ypos = WINDOW_TOP_EDGE_Y (win); + } } else /* ??? Not really clean; should be CHECK_WINDOW_OR_FRAME, commit 85f193b6133387b0901ea89d7ff9f665a5f33d26 Author: Robert Pluim Date: Sun Nov 21 16:20:20 2021 +0100 Add :version tags to new mwheel defcustoms * lisp/mwheel.el (mouse-wheel-down-alternate-event): (mouse-wheel-up-alternate-event): Add :version tag. diff --git a/lisp/mwheel.el b/lisp/mwheel.el index cd84a10999..5d18cf84c2 100644 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@ -69,6 +69,7 @@ "Alternative wheel down event to consider." :group 'mouse :type 'symbol + :version "29.1" :set 'mouse-wheel-change-button) (defcustom mouse-wheel-up-event @@ -86,6 +87,7 @@ "Alternative wheel up event to consider." :group 'mouse :type 'symbol + :version "29.1" :set 'mouse-wheel-change-button) (defcustom mouse-wheel-click-event 'mouse-2 commit 7c52c86a84466665fa661bf4ff9cb7a1d9501324 Author: Robert Pluim Date: Sun Nov 21 16:00:11 2021 +0100 ; Fix a few haiku typos * lisp/net/browse-url.el (browse-url-webpositive-program): Correct :version tag. * src/frame.c (Fframep): Fix quoting of "haiku". diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index f85f5f6149..19afb81331 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -371,7 +371,7 @@ Defaults to the value of `browse-url-epiphany-arguments' at the time (defcustom browse-url-webpositive-program "WebPositive" "The name by which to invoke WebPositive." :type 'string - :version "28.1") + :version "29.1") ;; GNOME means of invoking either Mozilla or Netscape. (defvar browse-url-gnome-moz-program "gnome-moz-remote") diff --git a/src/frame.c b/src/frame.c index a21dd0d927..33e9606e41 100644 --- a/src/frame.c +++ b/src/frame.c @@ -226,7 +226,7 @@ Value is: `w32' for an Emacs frame that is a window on MS-Windows display, `ns' for an Emacs frame on a GNUstep or Macintosh Cocoa display, `pc' for a direct-write MS-DOS frame. - `haiku` for an Emacs frame running in Haiku. + `haiku' for an Emacs frame running in Haiku. See also `frame-live-p'. */) (Lisp_Object object) { commit 2716146e6cb0926162378de45ee7448d8c88aa64 Author: Eli Zaretskii Date: Sun Nov 21 16:57:12 2021 +0200 Minor cleanup in w32inevt.c * src/w32inevt.c (w32_console_mouse_position, mouse_moved_to) (do_mouse_event): Use 'get_frame' to obtain the frame pointer. diff --git a/src/w32inevt.c b/src/w32inevt.c index 894bc3ab08..4cc01d31c9 100644 --- a/src/w32inevt.c +++ b/src/w32inevt.c @@ -420,7 +420,7 @@ w32_console_mouse_position (struct frame **f, *f = get_frame (); *bar_window = Qnil; *part = scroll_bar_above_handle; - SELECTED_FRAME ()->mouse_moved = 0; + (*f)->mouse_moved = 0; XSETINT (*x, movement_pos.X); XSETINT (*y, movement_pos.Y); @@ -436,7 +436,8 @@ mouse_moved_to (int x, int y) /* If we're in the same place, ignore it. */ if (x != movement_pos.X || y != movement_pos.Y) { - SELECTED_FRAME ()->mouse_moved = 1; + struct frame *f = get_frame (); + f->mouse_moved = 1; movement_pos.X = x; movement_pos.Y = y; movement_time = GetTickCount (); @@ -471,13 +472,13 @@ do_mouse_event (MOUSE_EVENT_RECORD *event, int i; /* Mouse didn't move unless MOUSE_MOVED says it did. */ - SELECTED_FRAME ()->mouse_moved = 0; + struct frame *f = get_frame (); + f->mouse_moved = 0; switch (flags) { case MOUSE_MOVED: { - struct frame *f = get_frame (); Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f); int mx = event->dwMousePosition.X, my = event->dwMousePosition.Y; @@ -536,7 +537,6 @@ do_mouse_event (MOUSE_EVENT_RECORD *event, case MOUSE_WHEELED: case MOUSE_HWHEELED: { - struct frame *f = get_frame (); /* Mouse positions in console wheel events are reported to ReadConsoleInput relative to the display's top-left corner(!), not relative to the origin of the console screen @@ -588,8 +588,8 @@ do_mouse_event (MOUSE_EVENT_RECORD *event, int x = event->dwMousePosition.X; int y = event->dwMousePosition.Y; - struct frame *f = get_frame (); - emacs_ev->arg = tty_handle_tab_bar_click (f, x, y, (button_state & mask) != 0, + emacs_ev->arg = tty_handle_tab_bar_click (f, x, y, + (button_state & mask) != 0, emacs_ev); emacs_ev->modifiers |= ((button_state & mask) commit 1e0e77bd449dd50501ee7047362a1e66f45c6d46 Author: Stefan Kangas Date: Sun Nov 21 14:44:41 2021 +0100 Use variable-pitch-mode in 'C-h C-h' * lisp/faces.el (help-key-binding): Inherit 'fixed-pitch'. * lisp/help-macro.el (make-help-screen): Use 'variable-pitch-mode'. This was discussed in https://lists.gnu.org/r/emacs-devel/2021-11/msg01378.html diff --git a/lisp/faces.el b/lisp/faces.el index b2498cda88..a07f8c652e 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2883,13 +2883,17 @@ Note: Other faces cannot inherit from the cursor face." ;; making the characters wider, which then would cause unpleasant ;; horizontal shifts of the cursor during C-n/C-p movement ;; through a line with this face. - :box (:line-width (-1 . -1) :color "grey80")) + :box (:line-width (-1 . -1) :color "grey80") + :inherit fixed-pitch) (((class color) (min-colors 88) (background dark)) :background "grey19" :foreground "LightBlue" - :box (:line-width (-1 . -1) :color "grey35")) - (((class color grayscale) (background light)) :background "grey90") - (((class color grayscale) (background dark)) :background "grey25") - (t :background "grey90")) + :box (:line-width (-1 . -1) :color "grey35") + :inherit fixed-pitch) + (((class color grayscale) (background light)) :background "grey90" + :inherit fixed-pitch) + (((class color grayscale) (background dark)) :background "grey25" + :inherit fixed-pitch) + (t :background "grey90" :inherit fixed-pitch)) "Face for keybindings in *Help* buffers. This face is added by `substitute-command-keys', which see. diff --git a/lisp/help-macro.el b/lisp/help-macro.el index 1fa9d82afd..588efee66b 100644 --- a/lisp/help-macro.el +++ b/lisp/help-macro.el @@ -140,6 +140,7 @@ and then returns." (insert (substitute-command-keys help-screen))) (let ((minor-mode-map-alist new-minor-mode-map-alist)) (help-mode) + (variable-pitch-mode) (setq new-minor-mode-map-alist minor-mode-map-alist)) (goto-char (point-min)) (while (or (memq char (append help-event-list commit 75d294cd4abb4d4062a1bfcd914229d0f9e142dd Author: Michael Albinus Date: Sun Nov 21 14:39:29 2021 +0100 Reorganize emba control files Using dynamic job generation in GitLab does not work sufficiently. So we generate the jobs in the Emacs sources. * configure.ac (SUBDIR_MAKEFILES): Add test/infra/Makefile. * test/Makefile.in (subdirs, generate-test-jobs): New targets. * test/infra/Makefile.in: * test/infra/test-jobs.yml: New files. * test/infra/default-gitlab-ci.yml: * test/infra/test-jobs-generator.sh: Remove. * test/infra/gitlab-ci.yml: Insert contents of default-gitlab-ci.yml. (stages): Remove generator and trigger. Add normal. (test-jobs-generator, test-jobs-pipeline): Remove jobs. (top): Include test-jobs.yml. diff --git a/configure.ac b/configure.ac index 90a487f7ac..9cf192d4ba 100644 --- a/configure.ac +++ b/configure.ac @@ -6309,6 +6309,13 @@ if test -f "$srcdir/$opt_makefile.in"; then dnl ", [], [opt_makefile='$opt_makefile']" and it should work. AC_CONFIG_FILES([test/Makefile]) fi +opt_makefile=test/infra/Makefile +if test -f "$srcdir/$opt_makefile.in"; then + SUBDIR_MAKEFILES="$SUBDIR_MAKEFILES $opt_makefile" + dnl Again, it's best not to use a variable. Though you can add + dnl ", [], [opt_makefile='$opt_makefile']" and it should work. + AC_CONFIG_FILES([test/infra/Makefile]) +fi dnl The admin/ directory used to be excluded from tarfiles. diff --git a/test/Makefile.in b/test/Makefile.in index 39d7b1d4e4..51696d7faa 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -371,7 +371,13 @@ check-declare: $(emacs) -l check-declare \ --eval '(check-declare-directory "$(srcdir)")' -.PHONY: subdir-targets +.PHONY: subdirs subdir-targets generate-test-jobs + +subdirs: + @echo $(SUBDIRS) subdir-targets: @echo $(SUBDIR_TARGETS) + +generate-test-jobs: + @$(MAKE) -C infra generate-test-jobs SUBDIRS="$(SUBDIRS)" diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in new file mode 100644 index 0000000000..e91aea404d --- /dev/null +++ b/test/infra/Makefile.in @@ -0,0 +1,86 @@ +### test/infra/Makefile. Generated from Makefile.in by configure. + +# Copyright (C) 2021 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: + +## Generate the test-jobs.yml file for emba. + +### Code: + +SHELL = @SHELL@ + +top_builddir = @top_builddir@ + +-include ${top_builddir}/src/verbose.mk + +## Get the tests for only a specific directory. +SUBDIRS ?= $(shell make -s -C .. subdirs) +SUBDIR_TARGETS = +FILE = test-jobs.yml + +define subdir_template + $(eval target = check-$(subst /,-,$(1))) + SUBDIR_TARGETS += $(target) + + $(eval + ifeq ($(findstring src, $(1)), src) + define changes + @echo " - $(1)/*.{h,c}" >>$(FILE) + @echo " - test/$(1)/*.el" >>$(FILE) + endef + else ifeq ($(findstring misc, $(1)), misc) + define changes + @echo " - admin/*.el" >>$(FILE) + @echo " - test/$(1)/*.el" >>$(FILE) + endef + else + define changes + @echo " - $(1)/*.el" >>$(FILE) + @echo " - test/$(1)/*.el" >>$(FILE) + endef + endif) + + .PHONY: $(target) + + $(target): + @echo "test-$(subst /,-,$(1))-inotify:" >>$(FILE) + @echo " stage: normal" >>$(FILE) + @echo " extends: [.job-template, .test-template]" >>$(FILE) + @echo " rules:" >>$(FILE) + @echo " - changes:" >>$(FILE) + $(changes) + @echo " variables:" >>$(FILE) + @echo " target: emacs-inotify" >>$(FILE) + @echo " make_params: \"-C test $(target)\"" >>$(FILE) + @echo >>$(FILE) +endef + +$(foreach subdir, $(SUBDIRS), $(eval $(call subdir_template,$(subdir)))) + +all: generate-test-jobs + +.PHONY: generate-test-jobs $(FILE) + +generate-test-jobs: clean $(FILE) $(SUBDIR_TARGETS) + +$(FILE): + $(AM_V_GEN) + +clean: + @rm -f $(FILE) diff --git a/test/infra/default-gitlab-ci.yml b/test/infra/default-gitlab-ci.yml deleted file mode 100644 index f6fadee27f..0000000000 --- a/test/infra/default-gitlab-ci.yml +++ /dev/null @@ -1,216 +0,0 @@ -# Copyright (C) 2017-2021 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 . - -# GNU Emacs support for the GitLab protocol for CI. - -# The presence of this file does not imply any FSF/GNU endorsement of -# any particular service that uses that protocol. Also, it is intended for -# evaluation purposes, thus possibly temporary. - -# Maintainer: Ted Zlatanov -# URL: https://emba.gnu.org/emacs/emacs - -# Never run merge request pipelines, they usually duplicate push pipelines -# see https://docs.gitlab.com/ee/ci/yaml/README.html#common-if-clauses-for-rules - -# Rules: always run tags and branches named master*, emacs*, feature*, fix* -# Test that it triggers by pushing a tag: `git tag mytag; git push origin mytag` -# Test that it triggers by pushing to: feature/emba, feature1, master, master-2, fix/emba, emacs-299, fix-2 -# Test that it doesn't trigger by pushing to: scratch-2, scratch/emba, oldbranch, dev -workflow: - rules: - - if: '$CI_PIPELINE_SOURCE == "merge_request_event"' - when: never - - if: '$CI_COMMIT_TAG' - when: always - - if: '$CI_COMMIT_BRANCH !~ /^(master|emacs|feature|fix)/' - when: never - - when: always - -variables: - GIT_STRATEGY: fetch - EMACS_EMBA_CI: 1 - # Three hours, see below. - EMACS_TEST_TIMEOUT: 10800 - EMACS_TEST_VERBOSE: 1 - # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled - # DOCKER_HOST: tcp://docker:2376 - # DOCKER_TLS_CERTDIR: "/certs" - # Put the configuration for each run in a separate directory to - # avoid conflicts. - DOCKER_CONFIG: "/.docker-config-${CI_COMMIT_SHA}" - DOCKER_BUILDKIT: 1 - # We don't use ${CI_COMMIT_SHA} to be able to do one bootstrap - # across multiple builds. - BUILD_TAG: ${CI_COMMIT_REF_SLUG} - # Disable if you don't need it, it can be a security risk. - CI_DEBUG_TRACE: "true" - -default: - image: docker:19.03.12 - timeout: 3 hours - before_script: - - docker info - - echo "docker registry is ${CI_REGISTRY}" - - docker login -u ${CI_REGISTRY_USER} -p ${CI_REGISTRY_PASSWORD} ${CI_REGISTRY} - -.job-template: - variables: - test_name: ${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA} - rules: - - changes: - - "**Makefile.in" - - .gitlab-ci.yml - - aclocal.m4 - - autogen.sh - - configure.ac - - lib/*.{h,c} - - lisp/**.el - - src/*.{h,c} - - test/infra/* - - test/lib-src/*.el - - test/lisp/**.el - - test/misc/*.el - - test/src/*.el - - changes: - # gfilemonitor, kqueue - - src/gfilenotify.c - - src/kqueue.c - # MS Windows - - "**w32*" - # GNUstep - - lisp/term/ns-win.el - - src/ns*.{h,m} - - src/macfont.{h,m} - when: never - # These will be cached across builds. - cache: - key: ${CI_COMMIT_SHA} - paths: [] - policy: pull-push - # These will be saved for followup builds. - artifacts: - expire_in: 24 hrs - paths: [] - # Using the variables for each job. - script: - - docker pull ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} - # TODO: with make -j4 several of the tests were failing, for - # example shadowfile-tests, but passed without it. - - 'export PWD=$(pwd)' - - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} -e EMACS_TEST_TIMEOUT=${EMACS_TEST_TIMEOUT} -e EMACS_TEST_VERBOSE=${EMACS_TEST_VERBOSE} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' - after_script: - # - docker ps -a - # - printenv - # - test -n "$(docker ps -aq -f name=${test_name})" && ( docker export ${test_name} | tar -tvf - ) - - test -n "$(docker ps -aq -f name=${test_name})" && docker cp ${test_name}:checkout/test ${test_name} - - test -n "$(docker ps -aq -f name=${test_name})" && docker rm ${test_name} - # - ls -alR ${test_name} - -.build-template: - needs: [] - rules: - - if: '$CI_PIPELINE_SOURCE == "web"' - when: always - - changes: - - "**Makefile.in" - - .gitlab-ci.yml - - aclocal.m4 - - autogen.sh - - configure.ac - - lib/*.{h,c} - - lisp/emacs-lisp/*.el - - src/*.{h,c} - - test/infra/* - - changes: - # gfilemonitor, kqueue - - src/gfilenotify.c - - src/kqueue.c - # MS Windows - - "**w32*" - # GNUstep - - lisp/term/ns-win.el - - src/ns*.{h,m} - - src/macfont.{h,m} - when: never - script: - - docker build --pull --target ${target} -t ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} -f test/infra/Dockerfile.emba . - - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} - -.test-template: - # Do not run fast and normal test jobs when scheduled. - rules: - - if: '$CI_JOB_STAGE =~ "fast|normal" && $CI_PIPELINE_SOURCE == "schedule"' - when: never - - when: always - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/**/*.log - - ${test_name}/**/core - - ${test_name}/core - when: always - -.gnustep-template: - rules: - - if: '$CI_PIPELINE_SOURCE == "web"' - - if: '$CI_PIPELINE_SOURCE == "schedule"' - changes: - - "**Makefile.in" - - .gitlab-ci.yml - - configure.ac - - src/ns*.{h,m} - - src/macfont.{h,m} - - lisp/term/ns-win.el - - nextstep/** - - test/infra/* - -.filenotify-gio-template: - rules: - - if: '$CI_PIPELINE_SOURCE == "web"' - - if: '$CI_PIPELINE_SOURCE == "schedule"' - changes: - - "**Makefile.in" - - .gitlab-ci.yml - - lisp/autorevert.el - - lisp/filenotify.el - - lisp/net/tramp-sh.el - - src/gfilenotify.c - - test/infra/* - - test/lisp/autorevert-tests.el - - test/lisp/filenotify-tests.el - -.native-comp-template: - rules: - - if: '$CI_PIPELINE_SOURCE == "web"' - - if: '$CI_PIPELINE_SOURCE == "schedule"' - changes: - - "**Makefile.in" - - .gitlab-ci.yml - - lisp/emacs-lisp/comp.el - - lisp/emacs-lisp/comp-cstr.el - - src/comp.{h,m} - - test/infra/* - - test/src/comp-resources/*.el - - test/src/comp-tests.el - timeout: 8 hours - -# Local Variables: -# add-log-current-defun-header-regexp: "^\\([-_.[:alnum:]]+\\)[ \t]*:" -# End: diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index ebfe996513..a0e2c283cd 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -24,15 +24,197 @@ # Maintainer: Ted Zlatanov # URL: https://emba.gnu.org/emacs/emacs -# Include defaults. -include: '/test/infra/default-gitlab-ci.yml' +# Never run merge request pipelines, they usually duplicate push pipelines +# see https://docs.gitlab.com/ee/ci/yaml/README.html#common-if-clauses-for-rules + +# Rules: always run tags and branches named master*, emacs*, feature*, fix* +# Test that it triggers by pushing a tag: `git tag mytag; git push origin mytag` +# Test that it triggers by pushing to: feature/emba, feature1, master, master-2, fix/emba, emacs-299, fix-2 +# Test that it doesn't trigger by pushing to: scratch-2, scratch/emba, oldbranch, dev +workflow: + rules: + - if: '$CI_PIPELINE_SOURCE == "merge_request_event"' + when: never + - if: '$CI_COMMIT_TAG' + when: always + - if: '$CI_COMMIT_BRANCH !~ /^(master|emacs|feature|fix)/' + when: never + - when: always + +variables: + GIT_STRATEGY: fetch + EMACS_EMBA_CI: 1 + # Three hours, see below. + EMACS_TEST_TIMEOUT: 10800 + EMACS_TEST_VERBOSE: 1 + # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled + # DOCKER_HOST: tcp://docker:2376 + # DOCKER_TLS_CERTDIR: "/certs" + # Put the configuration for each run in a separate directory to + # avoid conflicts. + DOCKER_CONFIG: "/.docker-config-${CI_COMMIT_SHA}" + DOCKER_BUILDKIT: 1 + # We don't use ${CI_COMMIT_SHA} to be able to do one bootstrap + # across multiple builds. + BUILD_TAG: ${CI_COMMIT_REF_SLUG} + # Disable if you don't need it, it can be a security risk. + # CI_DEBUG_TRACE: "true" + +default: + image: docker:19.03.12 + timeout: 3 hours + before_script: + - docker info + - echo "docker registry is ${CI_REGISTRY}" + - docker login -u ${CI_REGISTRY_USER} -p ${CI_REGISTRY_PASSWORD} ${CI_REGISTRY} + +.job-template: + variables: + test_name: ${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA} + rules: + - changes: + - "**Makefile.in" + - .gitlab-ci.yml + - aclocal.m4 + - autogen.sh + - configure.ac + - lib/*.{h,c} + - lisp/**.el + - src/*.{h,c} + - test/infra/* + - test/lib-src/*.el + - test/lisp/**.el + - test/misc/*.el + - test/src/*.el + - changes: + # gfilemonitor, kqueue + - src/gfilenotify.c + - src/kqueue.c + # MS Windows + - "**w32*" + # GNUstep + - lisp/term/ns-win.el + - src/ns*.{h,m} + - src/macfont.{h,m} + when: never + # These will be cached across builds. + cache: + key: ${CI_COMMIT_SHA} + paths: [] + policy: pull-push + # These will be saved for followup builds. + artifacts: + expire_in: 24 hrs + paths: [] + # Using the variables for each job. + script: + - docker pull ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} + # TODO: with make -j4 several of the tests were failing, for + # example shadowfile-tests, but passed without it. + - 'export PWD=$(pwd)' + - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} -e EMACS_TEST_TIMEOUT=${EMACS_TEST_TIMEOUT} -e EMACS_TEST_VERBOSE=${EMACS_TEST_VERBOSE} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' + after_script: + # - docker ps -a + # - printenv + # - test -n "$(docker ps -aq -f name=${test_name})" && ( docker export ${test_name} | tar -tvf - ) + - test -n "$(docker ps -aq -f name=${test_name})" && docker cp ${test_name}:checkout/test ${test_name} + - test -n "$(docker ps -aq -f name=${test_name})" && docker rm ${test_name} + # - ls -alR ${test_name} + +.build-template: + needs: [] + rules: + - if: '$CI_PIPELINE_SOURCE == "web"' + when: always + - changes: + - "**Makefile.in" + - .gitlab-ci.yml + - aclocal.m4 + - autogen.sh + - configure.ac + - lib/*.{h,c} + - lisp/emacs-lisp/*.el + - src/*.{h,c} + - test/infra/* + - changes: + # gfilemonitor, kqueue + - src/gfilenotify.c + - src/kqueue.c + # MS Windows + - "**w32*" + # GNUstep + - lisp/term/ns-win.el + - src/ns*.{h,m} + - src/macfont.{h,m} + when: never + script: + - docker build --pull --target ${target} -t ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} -f test/infra/Dockerfile.emba . + - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} + +.test-template: + # Do not run fast and normal test jobs when scheduled. + rules: + - if: '$CI_JOB_STAGE =~ "fast|normal" && $CI_PIPELINE_SOURCE == "schedule"' + when: never + - when: always + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - ${test_name}/**/*.log + - ${test_name}/**/core + - ${test_name}/core + when: always + +.gnustep-template: + rules: + - if: '$CI_PIPELINE_SOURCE == "web"' + - if: '$CI_PIPELINE_SOURCE == "schedule"' + changes: + - "**Makefile.in" + - .gitlab-ci.yml + - configure.ac + - src/ns*.{h,m} + - src/macfont.{h,m} + - lisp/term/ns-win.el + - nextstep/** + - test/infra/* + +.filenotify-gio-template: + rules: + - if: '$CI_PIPELINE_SOURCE == "web"' + - if: '$CI_PIPELINE_SOURCE == "schedule"' + changes: + - "**Makefile.in" + - .gitlab-ci.yml + - lisp/autorevert.el + - lisp/filenotify.el + - lisp/net/tramp-sh.el + - src/gfilenotify.c + - test/infra/* + - test/lisp/autorevert-tests.el + - test/lisp/filenotify-tests.el + +.native-comp-template: + rules: + - if: '$CI_PIPELINE_SOURCE == "web"' + - if: '$CI_PIPELINE_SOURCE == "schedule"' + changes: + - "**Makefile.in" + - .gitlab-ci.yml + - lisp/emacs-lisp/comp.el + - lisp/emacs-lisp/comp-cstr.el + - src/comp.{h,m} + - test/infra/* + - test/src/comp-resources/*.el + - test/src/comp-tests.el + timeout: 8 hours stages: - build-images - - generator - - trigger # - fast -# - normal + - normal - platform-images - platforms - native-comp-images @@ -52,21 +234,7 @@ build-image-inotify: # target: emacs-inotify # make_params: "-C test check" -test-jobs-generator: - stage: generator - script: - - test/infra/test-jobs-generator.sh > test-jobs.yml - artifacts: - paths: - - test-jobs.yml - -test-jobs-pipeline: - stage: trigger - trigger: - include: - - artifact: test-jobs.yml - job: test-jobs-generator - strategy: depend +include: '/test/infra/test-jobs.yml' # test-lisp-inotify: # stage: normal diff --git a/test/infra/test-jobs-generator.sh b/test/infra/test-jobs-generator.sh deleted file mode 100755 index c40570cbc3..0000000000 --- a/test/infra/test-jobs-generator.sh +++ /dev/null @@ -1,75 +0,0 @@ -#!/bin/sh - -# Copyright (C) 2021 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 . - -# GNU Emacs support for the gitlab-ci.yml template generation. - -# The presence of this file does not imply any FSF/GNU endorsement of -# any particular service that uses that protocol. Also, it is intended for -# evaluation purposes, thus possibly temporary. - -# Maintainer: Michael Albinus -# URL: https://emba.gnu.org/emacs/emacs - -cd test -SUBDIRS=\ -$(find lib-src lisp misc src -type d \ - ! \( -path "*resources*" -o -path "*auto-save-list" \) -print | sort -) - -for subdir in $SUBDIRS; do - target=check-$(echo $subdir | tr '/' '-') - - case $target in - check*-src) - changes=" - - $subdir/*.{h,c} - - test/$subdir/*.el" - ;; - check-misc) - changes=" - - admin/*.el - - test/$subdir/*.el" - ;; - *) - changes=" - - $subdir/*.el - - test/$subdir/*.el" - ;; - esac - - cat < Date: Sun Nov 21 13:14:06 2021 +0000 Fix double and triple click in Haiku. * src/haikuterm.c (haiku_read_socket): Record timestamp in events. diff --git a/src/haikuterm.c b/src/haikuterm.c index 67c202d97a..61920dbece 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -3185,12 +3185,16 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (inev.kind != NO_EVENT) { + if (inev.kind != HELP_EVENT) + inev.timestamp = time (NULL); kbd_buffer_store_event_hold (&inev, hold_quit); ++message_count; } if (inev2.kind != NO_EVENT) { + if (inev.kind != HELP_EVENT) + inev.timestamp = time (NULL); kbd_buffer_store_event_hold (&inev2, hold_quit); ++message_count; } commit f1ee5c67027b22884835edc0910bbabe4aa62d6c Author: Po Lu Date: Sun Nov 21 21:07:58 2021 +0800 Report time in XInput 2 button events * src/xterm.c (handle_one_xevent): Report time in XI button events. diff --git a/src/xterm.c b/src/xterm.c index ee8e03f80b..f5459afd4f 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10145,6 +10145,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, | xev->mods.effective | xev->mods.latched | xev->mods.locked; + bv.time = xev->time; memset (&compose_status, 0, sizeof (compose_status)); dpyinfo->last_mouse_glyph_frame = NULL; commit e22c37aa8763b4e8ab5919d87fb14bc9ed175724 Author: Po Lu Date: Sun Nov 21 12:43:53 2021 +0000 Fix horizontal wheel events on Haiku * src/haikuterm.c (haiku_read_socket): Fix modifier calculation for horizontal wheel events. diff --git a/src/haikuterm.c b/src/haikuterm.c index 6304d9bcd3..67c202d97a 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -3025,7 +3025,10 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) make_float (py)); XSETFRAME (inev.frame_or_window, f); - inev.modifiers |= signbit (py) ? up_modifier : down_modifier; + inev.modifiers |= (signbit (inev.kind == HORIZ_WHEEL_EVENT + ? px : py) + ? up_modifier + : down_modifier); py = 0.0f; px = 0.0f; } commit 1de6a86553c15905066a93e5b761e1825f23015a Merge: 539ee617d4 0dd3883def Author: Stefan Kangas Date: Sun Nov 21 11:18:23 2021 +0100 Merge from origin/emacs-28 0dd3883def Update to Org 9.5-72-gc5d6656 e3d5337970 Fix mouse handling with several TTY frames on MS-Windows 7e437af413 Fix temacs invocation from outside of the 'src' directory 0fbfd4253e ; Avoid byte-compilation warnings in edmacro.el c22c988b1f Fix mouse events on tab bar or tool bar when 'track-mouse'... 354c834fba Fix `browse-url-interactive-arg' for certain kinds of events # Conflicts: # lisp/mouse.el commit 539ee617d42220e53218c4fc11f8901c79789a8c Author: Lars Ingebrigtsen Date: Sun Nov 21 11:04:35 2021 +0100 Fill the Emacs version on the splash page * lisp/startup.el (fancy-startup-tail): (normal-mouse-startup-screen): (normal-no-mouse-startup-screen): Fill the Emacs version data, since it's usually longer than a single line, anyway. diff --git a/lisp/startup.el b/lisp/startup.el index d4fa59925f..e1106419f1 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -1838,11 +1838,14 @@ a face or button specification." :face 'variable-pitch "To quit a partially entered command, type " :face 'default "Control-g" :face 'variable-pitch ".\n") - (fancy-splash-insert :face '(variable-pitch font-lock-builtin-face) - "\nThis is " - (emacs-version) - "\n" - :face '(variable-pitch (:height 0.8)) + (save-restriction + (narrow-to-region (point) (point)) + (fancy-splash-insert :face '(variable-pitch font-lock-builtin-face) + "\nThis is " + (emacs-version) + "\n") + (fill-region (point-min) (point-max))) + (fancy-splash-insert :face '(variable-pitch (:height 0.8)) emacs-copyright "\n") (when auto-save-list-file-prefix @@ -2121,8 +2124,11 @@ To quit a partially entered command, type Control-g.\n") 'follow-link t) (insert "\tChange initialization settings including this screen\n") - (insert "\n" (emacs-version) - "\n" emacs-copyright)) + (save-restriction + (narrow-to-region (point) (point)) + (insert "\n" (emacs-version) "\n") + (fill-region (point-min) (point-max))) + (insert emacs-copyright)) (defun normal-no-mouse-startup-screen () "Show a splash screen suitable for displays without mouse support." @@ -2202,7 +2208,11 @@ If you have no Meta key, you may instead type ESC followed by the character.)")) (startup--get-buffer-create-scratch))) 'follow-link t) (insert "\n") - (insert "\n" (emacs-version) "\n" emacs-copyright "\n") + (save-restriction + (narrow-to-region (point) (point)) + (insert "\n" (emacs-version) "\n") + (fill-region (point-min) (point-max))) + (insert emacs-copyright "\n") (insert (substitute-command-keys " GNU Emacs comes with ABSOLUTELY NO WARRANTY; type \\[describe-no-warranty] for ")) commit f094120360b4cfbb104496c0b3e21b26f88547a6 Author: Po Lu Date: Sun Nov 21 17:38:41 2021 +0800 Implement `pick_embedded_child' for offscreen xwidgets * src/xwidget.c (pick_embedded_child): New function. (Fmake_xwidget): Connect `pick-embedded-child' signal to offscreen window. diff --git a/src/xwidget.c b/src/xwidget.c index b0ff142bc7..d88270dbe9 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -64,6 +64,7 @@ static gboolean webkit_script_dialog_cb (WebKitWebView *, WebKitScriptDialog *, static void record_osr_embedder (struct xwidget_view *); static void from_embedder (GdkWindow *, double, double, gpointer, gpointer, gpointer); static void to_embedder (GdkWindow *, double, double, gpointer, gpointer, gpointer); +static GdkWindow *pick_embedded_child (GdkWindow *, double, double, gpointer); #endif static struct xwidget * @@ -243,6 +244,8 @@ fails. */) "from-embedder", G_CALLBACK (from_embedder), NULL); g_signal_connect (G_OBJECT (gtk_widget_get_window (xw->widgetwindow_osr)), "to-embedder", G_CALLBACK (to_embedder), NULL); + g_signal_connect (G_OBJECT (gtk_widget_get_window (xw->widgetwindow_osr)), + "pick-embedded-child", G_CALLBACK (pick_embedded_child), NULL); /* Store some xwidget data in the gtk widgets for convenient retrieval in the event handlers. */ @@ -510,6 +513,32 @@ xwidget_from_id (uint32_t id) } #ifdef USE_GTK +static GdkWindow * +pick_embedded_child (GdkWindow *window, double x, double y, + gpointer user_data) +{ + GtkWidget *widget; + GtkWidget *child; + GdkEvent event; + int xout, yout; + + event.any.window = window; + event.any.type = GDK_NOTHING; + + widget = gtk_get_event_widget (&event); + + if (!widget) + return NULL; + + child = find_widget_at_pos (widget, lrint (x), lrint (y), + &xout, &yout); + + if (!child) + return NULL; + + return gtk_widget_get_window (child); +} + static void record_osr_embedder (struct xwidget_view *view) { commit 1f08f2258beb16d20851f2d4cb85b94840b45ed4 Author: Stefan Kangas Date: Sun Nov 21 10:10:07 2021 +0100 Revert "* admin/gitmerge.el (gitmerge-mode-map): Convert to defvar-keymap." This reverts commit 4c467e4aff12e65fa4fa62d7f4bdcbf4a2bcd92c. diff --git a/admin/gitmerge.el b/admin/gitmerge.el index 5aae6b40a0..67fca87c11 100644 --- a/admin/gitmerge.el +++ b/admin/gitmerge.el @@ -96,13 +96,16 @@ If nil, the function `gitmerge-default-branch' guesses.") (defvar gitmerge-log-regexp "^\\([A-Z ]\\)\\s-*\\([0-9a-f]+\\) \\(.+?\\): \\(.*\\)$") -(defvar-keymap gitmerge-mode-map - :doc "Keymap for gitmerge major mode." - "l" #'gitmerge-show-log - "d" #'gitmerge-show-diff - "f" #'gitmerge-show-files - "s" #'gitmerge-toggle-skip - "m" #'gitmerge-start-merge) +(defvar gitmerge-mode-map + (let ((map (make-keymap))) + (define-key map [(l)] 'gitmerge-show-log) + (define-key map [(d)] 'gitmerge-show-diff) + (define-key map [(f)] 'gitmerge-show-files) + (define-key map [(s)] 'gitmerge-toggle-skip) + (define-key map [(m)] 'gitmerge-start-merge) + map) + "Keymap for gitmerge major mode.") + (defvar gitmerge-mode-font-lock-keywords `((,gitmerge-log-regexp commit 867c57029c4d71b9378d34dfbdd975dca8a104f4 Author: dickmao Date: Sun Nov 21 09:18:57 2021 +0100 Fix icalendar time zone parsing * lisp/calendar/icalendar.el (icalendar--decode-isodatetime): Parse time zones more correctly. * test/lisp/calendar/icalendar-tests.el (icalendar-tests--decode-isodatetime): Fix tests so that they work in other time zones than Europe/Berlin (bug#51959). diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index 2d31101e50..7a483d4062 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -644,13 +644,13 @@ FIXME: multiple comma-separated values should be allowed!" ;; seconds present (setq second (read (substring isodatetimestring 13 15)))) ;; FIXME: Support subseconds. - (when (and (> (length isodatetimestring) 15) - ;; UTC specifier present - (char-equal ?Z (aref isodatetimestring 15))) - (setq source-zone t - ;; decode to local time unless result-zone is explicitly given, - ;; i.e. do not decode to UTC, i.e. do not (setq result-zone t) - )) + (when (> (length isodatetimestring) 15) + (cl-case (aref isodatetimestring 15) + (?Z + (setq source-zone t)) + ((?- ?+) + (setq source-zone + (concat "UTC" (substring isodatetimestring 15)))))) ;; shift if necessary (if day-shift (let ((mdy (calendar-gregorian-from-absolute diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index 10b684aacb..1551922028 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -1635,26 +1635,30 @@ SUMMARY:NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30 (ert-deftest icalendar-tests--decode-isodatetime () "Test `icalendar--decode-isodatetime'." - (should (equal (icalendar-test--format "20040917T050910-0200") - "2004-09-17T03:09:10+0000")) - (should (equal (icalendar-test--format "20040917T050910") + (should (equal (icalendar-test--format "20040917T050910-02:00") "2004-09-17T03:09:10+0000")) + (let ((orig (icalendar-test--format "20040917T050910"))) + (unwind-protect + (progn + (set-time-zone-rule "UTC-02:00") + (should (equal (icalendar-test--format "20040917T050910") + "2004-09-17T03:09:10+0000")) + (should (equal (icalendar-test--format "20040917T0509") + "2004-09-17T03:09:00+0000")) + (should (equal (icalendar-test--format "20040917") + "2004-09-16T22:00:00+0000")) + (should (equal (icalendar-test--format "20040917T050910" 1) + "2004-09-18T03:09:10+0000")) + (should (equal (icalendar-test--format "20040917T050910" 30) + "2004-10-17T03:09:10+0000"))) + (set-time-zone-rule 'wall) ;; (set-time-zone-rule nil) is broken + (should (equal orig (icalendar-test--format "20040917T050910"))))) (should (equal (icalendar-test--format "20040917T050910Z") "2004-09-17T05:09:10+0000")) - (should (equal (icalendar-test--format "20040917T0509") - "2004-09-17T03:09:00+0000")) - (should (equal (icalendar-test--format "20040917") - "2004-09-16T22:00:00+0000")) - (should (equal (icalendar-test--format "20040917T050910" 1) - "2004-09-18T03:09:10+0000")) - (should (equal (icalendar-test--format "20040917T050910" 30) - "2004-10-17T03:09:10+0000")) - (should (equal (icalendar-test--format "20040917T050910" -1) - "2004-09-16T03:09:10+0000")) - + (should (equal (icalendar-test--format "20040917T050910" -1 0) + "2004-09-16T05:09:10+0000")) (should (equal (icalendar-test--format "20040917T050910" nil -3600) "2004-09-17T06:09:10+0000"))) - (provide 'icalendar-tests) ;;; icalendar-tests.el ends here commit 2a4a32eddbee7bd8759cf5f64be5d948a68b2caa Author: Po Lu Date: Sun Nov 21 08:05:13 2021 +0000 Fix documentation string of x_coalesce_scroll_events * src/xterm.c (x_coalesce_scroll_events): Update doc string to reflect that this option is now supported under Haiku. diff --git a/src/xterm.c b/src/xterm.c index b78cfa7053..ee8e03f80b 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -15155,6 +15155,6 @@ always uses gtk_window_move and ignores the value of this variable. */); doc: /* Non-nil means send a wheel event only for scrolling at least one screen line. Otherwise, a wheel event will be sent every time the mouse wheel is moved. This option is only effective when Emacs is built with XInput -2. */); +2 or with Haiku windowing support. */); x_coalesce_scroll_events = true; } commit f2730520ce3159704801e7cd459e2971c191c5a3 Author: Eli Zaretskii Date: Sun Nov 21 09:52:43 2021 +0200 Improve the fix for bug#51864 * src/xfaces.c (face_at_buffer_position): Call FACE_FROM_ID_OR_NULL just once. (face_at_string_position): Make sure we have a usable base face. diff --git a/src/xfaces.c b/src/xfaces.c index fec6b2654b..174a1ca47c 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -4841,7 +4841,7 @@ lookup_named_face (struct window *w, struct frame *f, /* Return the display face-id of the basic face whose canonical face-id is FACE_ID. The return value will usually simply be FACE_ID, unless that - basic face has bee remapped via Vface_remapping_alist. This function is + basic face has been remapped via Vface_remapping_alist. This function is conservative: if something goes wrong, it will simply return FACE_ID rather than signal an error. Window W, if non-NULL, is used to filter face specifications for remapping. */ @@ -6372,20 +6372,16 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos, int face_id; if (base_face_id >= 0) - { - face_id = base_face_id; - /* Make sure the base face ID is usable: if someone freed the - cached faces since we've looked up the base face, we need - to look it up again. */ - if (!FACE_FROM_ID_OR_NULL (f, face_id)) - face_id = lookup_basic_face (w, f, DEFAULT_FACE_ID); - } + face_id = base_face_id; else if (NILP (Vface_remapping_alist)) face_id = DEFAULT_FACE_ID; else face_id = lookup_basic_face (w, f, DEFAULT_FACE_ID); default_face = FACE_FROM_ID_OR_NULL (f, face_id); + /* Make sure the default face ID is usable: if someone freed the + cached faces since we've looked up these faces, we need to look + them up again. */ if (!default_face) default_face = FACE_FROM_ID (f, lookup_basic_face (w, f, DEFAULT_FACE_ID)); @@ -6573,7 +6569,9 @@ face_at_string_position (struct window *w, Lisp_Object string, else *endptr = -1; - base_face = FACE_FROM_ID (f, base_face_id); + base_face = FACE_FROM_ID_OR_NULL (f, base_face_id); + if (!base_face) + base_face = FACE_FROM_ID (f, lookup_basic_face (w, f, DEFAULT_FACE_ID)); /* Optimize the default case that there is no face property. */ if (NILP (prop) commit f0507192826070ca0070c0c5ce4ac80c8b32313d Author: Po Lu Date: Sun Nov 21 05:37:50 2021 +0000 Improve Haiku documentation * doc/emacs/haiku.texi: Remove duplicate text and extraneous pxref. diff --git a/doc/emacs/haiku.texi b/doc/emacs/haiku.texi index a2dc6e14d0..551599dfa8 100644 --- a/doc/emacs/haiku.texi +++ b/doc/emacs/haiku.texi @@ -56,9 +56,6 @@ the system, and those known to Emacs. The variables that allow for that are described below. @cindex modifier key customization (Haiku) -You can customize which Emacs modifiers the various system modifier -keys correspond to through the following variables: - @table @code @vindex haiku-meta-keysym @item haiku-meta-keysym @@ -126,8 +123,7 @@ several different font backends. You can specify font backends by specifying @kbd{-xrm Emacs.fontBackend:BACKEND} on the command line used to invoke Emacs, where @kbd{BACKEND} is one of the backends specified below, or on a per-frame basis by changing the -@code{font-backend} frame parameter. (@pxref{Parameter Access,,, -elisp, The Emacs Lisp Reference Manual}). +@code{font-backend} frame parameter. Two of these backends, @code{ftcr} and @code{ftcrhb} are identical to their counterparts on the X Window System. There is also a commit 890fd7760c5f709feb5a0533ebe89a6fec5709a8 Author: Po Lu Date: Sun Nov 21 13:32:03 2021 +0800 Add a user command to stop page loading in xwidget-webkit * lisp/xwidget.el: Add `xwidget-webkit-stop' to menu. (xwidget-webkit-stop): New command. (xwidget-webkit-tool-bar-map): New tool bar item. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 5b465dad3d..160da67cb2 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -59,6 +59,7 @@ (declare-function xwidget-webkit-estimated-load-progress "xwidget.c" (xwidget)) (declare-function xwidget-webkit-set-cookie-storage-file "xwidget.c" (xwidget file)) (declare-function xwidget-live-p "xwidget.c" (xwidget)) +(declare-function xwidget-webkit-stop-loading "xwidget.c" (xwidget)) (defgroup xwidget nil "Displaying native widgets in Emacs buffers." @@ -256,11 +257,17 @@ for the actual events that will be sent." :help "Save the browser's selection in the kill ring"] ["Incremental Search" xwidget-webkit-isearch-mode :active (not xwidget-webkit-isearch-mode) - :help "Perform incremental search inside the WebKit widget"])) + :help "Perform incremental search inside the WebKit widget"] + ["Stop Loading" xwidget-webkit-stop + :active xwidget-webkit--loading-p])) (defvar xwidget-webkit-tool-bar-map (let ((map (make-sparse-keymap))) (prog1 map + (tool-bar-local-item-from-menu 'xwidget-webkit-stop + "cancel" + map + xwidget-webkit-mode-map) (tool-bar-local-item-from-menu 'xwidget-webkit-back "left-arrow" map @@ -561,6 +568,10 @@ The latter might be nil." (let ((size (xwidget-size-request xw))) (xwidget-resize xw (car size) (cadr size)))) +(defun xwidget-webkit-stop () + "Stop trying to load the current page." + (interactive) + (xwidget-webkit-stop-loading (xwidget-webkit-current-session))) (defvar xwidget-webkit-activeelement-js" function findactiveelement(doc){ commit a81fbf83672d275ae693b7cb7c00cb52155f4d7b Author: Po Lu Date: Sun Nov 21 03:48:27 2021 +0000 Fix compiler warnings * src/haikuterm.c (haiku_read_socket): Fix compiler warnings intoduced by last change. diff --git a/src/haikuterm.c b/src/haikuterm.c index 6b3c5dbe48..6304d9bcd3 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -3005,14 +3005,16 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (signbit (py) != signbit (b->delta_y)) py = 0; - px += b->delta_x * pow (FRAME_PIXEL_HEIGHT (f), 2.0 / 3.0); - py += b->delta_y * pow (FRAME_PIXEL_HEIGHT (f), 2.0 / 3.0); + px += (b->delta_x + * powf (FRAME_PIXEL_HEIGHT (f), 2.0f / 3.0f)); + py += (b->delta_y + * powf (FRAME_PIXEL_HEIGHT (f), 2.0f / 3.0f)); if (fabsf (py) >= FRAME_LINE_HEIGHT (f) || fabsf (px) >= FRAME_COLUMN_WIDTH (f) || !x_coalesce_scroll_events) { - inev.kind = (fabsf (px) > fabs (py) + inev.kind = (fabsf (px) > fabsf (py) ? HORIZ_WHEEL_EVENT : WHEEL_EVENT); inev.code = 0; commit 677859b7af143e3bb2f8f15bb47ff7b7773dc955 Author: Po Lu Date: Sun Nov 21 03:40:36 2021 +0000 Add pixel delta support for wheel events on Haiku * src/haiku_support.cc (EmacsWindow.MessageReceived): Stop adjusting scroll deltas. * src/haikuterm.c (haiku_read_socket): Handle pixel deltas correctly. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 99d4ee7914..5f9fe7e234 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -631,8 +631,8 @@ class EmacsWindow : public BDirectWindow if (msg->FindFloat ("be:wheel_delta_x", &dx) == B_OK && msg->FindFloat ("be:wheel_delta_y", &dy) == B_OK) { - rq.delta_x = dx * 10; - rq.delta_y = dy * 10; + rq.delta_x = dx; + rq.delta_y = dy; haiku_write (WHEEL_MOVE_EVENT, &rq); }; diff --git a/src/haikuterm.c b/src/haikuterm.c index 05fbd1021b..6b3c5dbe48 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -3005,34 +3005,26 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (signbit (py) != signbit (b->delta_y)) py = 0; - px += b->delta_x; - py += b->delta_y; + px += b->delta_x * pow (FRAME_PIXEL_HEIGHT (f), 2.0 / 3.0); + py += b->delta_y * pow (FRAME_PIXEL_HEIGHT (f), 2.0 / 3.0); - if (fabsf (py) >= FRAME_LINE_HEIGHT (f)) + if (fabsf (py) >= FRAME_LINE_HEIGHT (f) + || fabsf (px) >= FRAME_COLUMN_WIDTH (f) + || !x_coalesce_scroll_events) { - inev.kind = WHEEL_EVENT; + inev.kind = (fabsf (px) > fabs (py) + ? HORIZ_WHEEL_EVENT + : WHEEL_EVENT); inev.code = 0; XSETINT (inev.x, x); XSETINT (inev.y, y); - XSETINT (inev.arg, lrint (fabsf (py) / FRAME_LINE_HEIGHT (f))); + inev.arg = list3 (Qnil, make_float (px), + make_float (py)); XSETFRAME (inev.frame_or_window, f); inev.modifiers |= signbit (py) ? up_modifier : down_modifier; py = 0.0f; - } - - if (fabsf (px) >= FRAME_COLUMN_WIDTH (f)) - { - inev2.kind = HORIZ_WHEEL_EVENT; - inev2.code = 0; - - XSETINT (inev2.x, x); - XSETINT (inev2.y, y); - XSETINT (inev2.arg, lrint (fabsf (px) / FRAME_COLUMN_WIDTH (f))); - XSETFRAME (inev2.frame_or_window, f); - - inev2.modifiers |= signbit (px) ? up_modifier : down_modifier; px = 0.0f; } @@ -3548,6 +3540,10 @@ syms_of_haikuterm (void) doc: /* SKIP: real doc in xterm.c. */); Vx_toolkit_scroll_bars = Qt; + DEFVAR_BOOL ("x-coalesce-scroll-events", x_coalesce_scroll_events, + doc: /* SKIP: real doc in xterm.c. */); + x_coalesce_scroll_events = true; + DEFVAR_BOOL ("haiku-debug-on-fatal-error", haiku_debug_on_fatal_error, doc: /* If non-nil, Emacs will launch the system debugger upon a fatal error. */); haiku_debug_on_fatal_error = 1; commit b6570602cca3fffd8adcd05dadb1d64d2b1442bd Author: Po Lu Date: Sun Nov 21 11:14:14 2021 +0800 Attach download-started signals to correct WebKit context * src/xwidget.c (Fmake_xwidget): Use correct context. diff --git a/src/xwidget.c b/src/xwidget.c index 35e359458b..b0ff142bc7 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -197,6 +197,10 @@ fails. */) xw->widget_osr = webkit_web_view_new_with_context (ctx); g_object_unref (ctx); + g_signal_connect (G_OBJECT (ctx), + "download-started", + G_CALLBACK (webkit_download_cb), xw); + webkit_web_view_load_uri (WEBKIT_WEB_VIEW (xw->widget_osr), "about:blank"); /* webkitgtk uses GSubprocess which sets sigaction causing @@ -252,10 +256,6 @@ fails. */) "load-changed", G_CALLBACK (webkit_view_load_changed_cb), xw); - g_signal_connect (G_OBJECT (webkit_context), - "download-started", - G_CALLBACK (webkit_download_cb), xw); - g_signal_connect (G_OBJECT (xw->widget_osr), "decide-policy", G_CALLBACK commit 39f3604e229ff349742dab0d6a5c7b4500530c07 Author: Po Lu Date: Sun Nov 21 11:04:29 2021 +0800 Allow handling smooth scroll events in xwidgets * src/xterm.c (handle_one_xevent): Pass through XI2 motion events to xwidgets. * src/xterm.c (xwidget_button): Don't handle legacy scroll events on XInput 2. (xwidget_motion_notify, xwidget_scroll): New functions. diff --git a/src/xterm.c b/src/xterm.c index 6a35b11d05..b78cfa7053 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -9927,6 +9927,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_display_set_last_user_time (dpyinfo, xi_event->time); +#ifdef HAVE_XWIDGETS + struct xwidget_view *xv = xwidget_view_from_window (xev->event); + double xv_total_x = 0.0; + double xv_total_y = 0.0; +#endif + for (int i = 0; i < states->mask_len * 8; i++) { if (XIMaskIsSet (states->mask, i)) @@ -9939,6 +9945,18 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (delta != DBL_MAX) { +#ifdef HAVE_XWIDGETS + if (xv) + { + if (val->horizontal) + xv_total_x += delta; + else + xv_total_y += -delta; + + found_valuator = true; + continue; + } +#endif if (!f) { f = x_any_window_to_frame (dpyinfo, xev->event); @@ -9999,6 +10017,20 @@ handle_one_xevent (struct x_display_info *dpyinfo, inev.ie.kind = NO_EVENT; } +#ifdef HAVE_XWIDGETS + if (xv) + { + if (found_valuator) + xwidget_scroll (xv, xev->event_x, xev->event_y, + xv_total_x, xv_total_y, xev->mods.effective, + xev->time); + else + xwidget_motion_notify (xv, xev->event_x, xev->event_y, + xev->mods.effective, xev->time); + + goto XI_OTHER; + } +#endif if (found_valuator) goto XI_OTHER; diff --git a/src/xwidget.c b/src/xwidget.c index 1ab953d3c8..35e359458b 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -40,10 +40,15 @@ along with GNU Emacs. If not, see . */ #include #include #include +#ifdef HAVE_XINPUT2 +#include +#endif #elif defined NS_IMPL_COCOA #include "nsxwidget.h" #endif +#include + static Lisp_Object id_to_xwidget_map; static Lisp_Object internal_xwidget_view_list; static Lisp_Object internal_xwidget_list; @@ -912,7 +917,12 @@ xwidget_button (struct xwidget_view *view, if (button < 4 || button > 8) xwidget_button_1 (view, down_p, x, y, button, modifier_state, time); +#ifndef HAVE_XINPUT2 else +#else + else if (!FRAME_DISPLAY_INFO (view->frame)->supports_xi2 + || FRAME_DISPLAY_INFO (view->frame)->xi2_version < 1) +#endif { GdkEvent *xg_event = gdk_event_new (GDK_SCROLL); struct xwidget *model = XXWIDGET (view->model); @@ -955,6 +965,93 @@ xwidget_button (struct xwidget_view *view, } } +#ifdef HAVE_XINPUT2 +void +xwidget_motion_notify (struct xwidget_view *view, + double x, double y, uint state, Time time) +{ + GdkEvent *xg_event; + GtkWidget *target; + struct xwidget *model = XXWIDGET (view->model); + int target_x, target_y; + + if (NILP (model->buffer)) + return; + + record_osr_embedder (view); + + target = find_widget_at_pos (model->widgetwindow_osr, + lrint (x), lrint (y), + &target_x, &target_y); + + if (!target) + { + target_x = lrint (x); + target_y = lrint (y); + target = model->widget_osr; + } + + xg_event = gdk_event_new (GDK_MOTION_NOTIFY); + xg_event->any.window = gtk_widget_get_window (target); + xg_event->motion.x = target_x; + xg_event->motion.y = target_y; + xg_event->motion.x_root = lrint (x); + xg_event->motion.y_root = lrint (y); + xg_event->motion.time = time; + xg_event->motion.state = state; + xg_event->motion.device = find_suitable_pointer (view->frame); + + g_object_ref (xg_event->any.window); + + gtk_main_do_event (xg_event); + gdk_event_free (xg_event); +} + +void +xwidget_scroll (struct xwidget_view *view, double x, double y, + double dx, double dy, uint state, Time time) +{ + GdkEvent *xg_event; + GtkWidget *target; + struct xwidget *model = XXWIDGET (view->model); + int target_x, target_y; + + if (NILP (model->buffer)) + return; + + record_osr_embedder (view); + + target = find_widget_at_pos (model->widgetwindow_osr, + lrint (x), lrint (y), + &target_x, &target_y); + + if (!target) + { + target_x = lrint (x); + target_y = lrint (y); + target = model->widget_osr; + } + + xg_event = gdk_event_new (GDK_SCROLL); + xg_event->any.window = gtk_widget_get_window (target); + xg_event->scroll.direction = GDK_SCROLL_SMOOTH; + xg_event->scroll.x = target_x; + xg_event->scroll.y = target_y; + xg_event->scroll.x_root = lrint (x); + xg_event->scroll.y_root = lrint (y); + xg_event->scroll.time = time; + xg_event->scroll.state = state; + xg_event->scroll.delta_x = dx; + xg_event->scroll.delta_y = dy; + xg_event->scroll.device = find_suitable_pointer (view->frame); + + g_object_ref (xg_event->any.window); + + gtk_main_do_event (xg_event); + gdk_event_free (xg_event); +} +#endif + void xwidget_motion_or_crossing (struct xwidget_view *view, const XEvent *event) { @@ -1705,6 +1802,22 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) clip_bottom - clip_top, 0, CopyFromParent, CopyFromParent, CopyFromParent, CWEventMask, &a); +#ifdef HAVE_XINPUT2 + XIEventMask mask; + ptrdiff_t l = XIMaskLen (XI_LASTEVENT); + unsigned char *m; + + if (FRAME_DISPLAY_INFO (s->f)->supports_xi2) + { + mask.mask = m = alloca (l); + memset (m, 0, l); + mask.mask_len = l; + mask.deviceid = XIAllMasterDevices; + + XISetMask (m, XI_Motion); + XISelectEvents (xv->dpy, xv->wdesc, &mask, 1); + } +#endif XLowerWindow (xv->dpy, xv->wdesc); XDefineCursor (xv->dpy, xv->wdesc, xv->cursor); xv->cr_surface = cairo_xlib_surface_create (xv->dpy, diff --git a/src/xwidget.h b/src/xwidget.h index 78fe865dd8..f2d497c092 100644 --- a/src/xwidget.h +++ b/src/xwidget.h @@ -195,6 +195,12 @@ extern void xwidget_button (struct xwidget_view *, bool, int, int, int, int, Time); extern void xwidget_motion_or_crossing (struct xwidget_view *, const XEvent *); +#ifdef HAVE_XINPUT2 +extern void xwidget_motion_notify (struct xwidget_view *, double, + double, uint, Time); +extern void xwidget_scroll (struct xwidget_view *, double, double, + double, double, uint, Time); +#endif #endif #else INLINE_HEADER_BEGIN commit f16bb8693f0122cea447edc243885428a4b8d370 Author: Po Lu Date: Sun Nov 21 09:32:46 2021 +0800 Select device notification events correctly * src/xfns.c (setup_xi_event_mask): Select PropertyEvent, HierarchyChanged and DeviceChanged for all devices. diff --git a/src/xfns.c b/src/xfns.c index a142f5518c..5eff9f5b0f 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -2938,6 +2938,13 @@ setup_xi_event_mask (struct frame *f) XISetMask (m, XI_Leave); XISetMask (m, XI_FocusIn); XISetMask (m, XI_FocusOut); + XISelectEvents (FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), + &mask, 1); + + memset (m, 0, l); + mask.deviceid = XIAllDevices; + XISetMask (m, XI_PropertyEvent); XISetMask (m, XI_HierarchyChanged); XISetMask (m, XI_DeviceChanged); commit b60c2a5d853b0c6478d7182920c39cb2ec96bdc7 Author: Po Lu Date: Sun Nov 21 09:22:31 2021 +0800 Add XInput 2 input method support * src/xterm.c (handle_one_xevent): Let input methods filter events first before trying to handle an XI2 key press event. diff --git a/src/xterm.c b/src/xterm.c index 9e5aed996a..6a35b11d05 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10350,6 +10350,104 @@ handle_one_xevent (struct x_display_info *dpyinfo, = x_x_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), state); inev.ie.timestamp = xev->time; +#ifdef HAVE_X_I18N + XKeyPressedEvent xkey; + + memset (&xkey, 0, sizeof xkey); + + xkey.type = KeyPress; + xkey.serial = 0; + xkey.send_event = xev->send_event; + xkey.display = xev->display; + xkey.window = xev->event; + xkey.root = xev->root; + xkey.subwindow = xev->child; + xkey.time = xev->time; + xkey.state = state; + xkey.keycode = keycode; + xkey.same_screen = True; + + if (x_filter_event (dpyinfo, (XEvent *) &xkey)) + goto xi_done_keysym; + + if (FRAME_XIC (f)) + { + Status status_return; + nbytes = XmbLookupString (FRAME_XIC (f), + &xkey, (char *) copy_bufptr, + copy_bufsiz, &keysym, + &status_return); + + if (status_return == XBufferOverflow) + { + copy_bufsiz = nbytes + 1; + copy_bufptr = alloca (copy_bufsiz); + nbytes = XmbLookupString (FRAME_XIC (f), + &xkey, (char *) copy_bufptr, + copy_bufsiz, &keysym, + &status_return); + } + + if (status_return == XLookupNone) + goto xi_done_keysym; + else if (status_return == XLookupChars) + { + keysym = NoSymbol; + state = 0; + } + else if (status_return != XLookupKeySym + && status_return != XLookupBoth) + emacs_abort (); + } + else + { +#endif +#ifdef HAVE_XKB + int overflow = 0; + KeySym sym = keysym; + + if (dpyinfo->xkb_desc) + { + if (!(nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, + state & ~mods_rtrn, copy_bufptr, + copy_bufsiz, &overflow))) + goto XI_OTHER; + } + else +#else + { + block_input (); + char *str = XKeysymToString (keysym); + if (!str) + { + unblock_input (); + goto XI_OTHER; + } + nbytes = strlen (str) + 1; + copy_bufptr = alloca (nbytes); + strcpy (copy_bufptr, str); + unblock_input (); + } +#endif +#ifdef HAVE_XKB + if (overflow) + { + overflow = 0; + copy_bufptr = alloca (copy_bufsiz + overflow); + keysym = sym; + if (!(nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, + state & ~mods_rtrn, copy_bufptr, + copy_bufsiz + overflow, &overflow))) + goto XI_OTHER; + + if (overflow) + goto XI_OTHER; + } +#endif +#ifdef HAVE_X_I18N + } +#endif + /* First deal with keysyms which have defined translations to characters. */ if (keysym >= 32 && keysym < 128) @@ -10466,49 +10564,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto xi_done_keysym; } -#ifdef HAVE_XKB - int overflow = 0; - KeySym sym = keysym; - - if (dpyinfo->xkb_desc) - { - if (!(nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, - state & ~mods_rtrn, copy_bufptr, - copy_bufsiz, &overflow))) - goto XI_OTHER; - } - else -#else - { - block_input (); - char *str = XKeysymToString (keysym); - if (!str) - { - unblock_input (); - goto XI_OTHER; - } - nbytes = strlen (str) + 1; - copy_bufptr = alloca (nbytes); - strcpy (copy_bufptr, str); - unblock_input (); - } -#endif -#ifdef HAVE_XKB - if (overflow) - { - overflow = 0; - copy_bufptr = alloca (copy_bufsiz + overflow); - keysym = sym; - if (!(nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, - state & ~mods_rtrn, copy_bufptr, - copy_bufsiz + overflow, &overflow))) - goto XI_OTHER; - - if (overflow) - goto XI_OTHER; - } -#endif - for (i = 0, nchars = 0; i < nbytes; i++) { if (ASCII_CHAR_P (copy_bufptr[i])) @@ -10574,6 +10629,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto XI_OTHER; } xi_done_keysym: +#ifdef HAVE_X_I18N + if (FRAME_XIC (f) && (FRAME_XIC_STYLE (f) & XIMStatusArea)) + xic_set_statusarea (f); +#endif if (must_free_data) XFreeEventData (dpyinfo->display, &event->xcookie); goto done_keysym; commit 64fc94b11e361940c3c7e36f5701ec7ca26b87f4 Author: Michael Albinus Date: Sat Nov 20 21:50:20 2021 +0100 * test/infra/test-jobs-generator.sh: Generate also stages entry. diff --git a/test/infra/test-jobs-generator.sh b/test/infra/test-jobs-generator.sh index 0636d8c8c2..c40570cbc3 100755 --- a/test/infra/test-jobs-generator.sh +++ b/test/infra/test-jobs-generator.sh @@ -56,6 +56,9 @@ for subdir in $SUBDIRS; do include: - local: '/test/infra/default-gitlab-ci.yml' +stages: + - test + EOF cat < Date: Sat Nov 20 20:05:52 2021 +0100 Revert last change on emba files diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index d53133d8ac..ebfe996513 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -32,7 +32,7 @@ stages: - generator - trigger # - fast - - normal +# - normal - platform-images - platforms - native-comp-images diff --git a/test/infra/test-jobs-generator.sh b/test/infra/test-jobs-generator.sh index 67205b383b..0636d8c8c2 100755 --- a/test/infra/test-jobs-generator.sh +++ b/test/infra/test-jobs-generator.sh @@ -60,7 +60,7 @@ EOF cat < Date: Sat Nov 20 13:12:18 2021 -0500 Update to Org 9.5-72-gc5d6656 diff --git a/lisp/org/org-goto.el b/lisp/org/org-goto.el index 0a3470f545..352bf9f2e5 100644 --- a/lisp/org/org-goto.el +++ b/lisp/org/org-goto.el @@ -203,40 +203,39 @@ When nil, you can use these keybindings to navigate the buffer: "Let the user select a location in current buffer. This function uses a recursive edit. It returns the selected position or nil." - (org-no-popups - (let ((isearch-mode-map org-goto-local-auto-isearch-map) - (isearch-hide-immediately nil) - (isearch-search-fun-function - (lambda () #'org-goto--local-search-headings)) - (help (or help org-goto-help))) - (save-excursion - (save-window-excursion - (delete-other-windows) - (and (get-buffer "*org-goto*") (kill-buffer "*org-goto*")) - (pop-to-buffer-same-window - (condition-case nil - (make-indirect-buffer (current-buffer) "*org-goto*" t) - (error (make-indirect-buffer (current-buffer) "*org-goto*" t)))) - (let (temp-buffer-show-function temp-buffer-show-hook) - (with-output-to-temp-buffer "*Org Help*" - (princ (format help (if org-goto-auto-isearch - " Just type for auto-isearch." - " n/p/f/b/u to navigate, q to quit."))))) - (org-fit-window-to-buffer (get-buffer-window "*Org Help*")) - (org-overview) - (setq buffer-read-only t) - (if (and (boundp 'org-goto-start-pos) - (integer-or-marker-p org-goto-start-pos)) - (progn (goto-char org-goto-start-pos) - (when (org-invisible-p) - (org-show-set-visibility 'lineage))) - (goto-char (point-min))) - (let (org-special-ctrl-a/e) (org-beginning-of-line)) - (message "Select location and press RET") - (use-local-map org-goto-map) - (recursive-edit))) - (kill-buffer "*org-goto*") - (cons org-goto-selected-point org-goto-exit-command)))) + (let ((isearch-mode-map org-goto-local-auto-isearch-map) + (isearch-hide-immediately nil) + (isearch-search-fun-function + (lambda () #'org-goto--local-search-headings)) + (help (or help org-goto-help))) + (save-excursion + (save-window-excursion + (delete-other-windows) + (and (get-buffer "*org-goto*") (kill-buffer "*org-goto*")) + (pop-to-buffer-same-window + (condition-case nil + (make-indirect-buffer (current-buffer) "*org-goto*" t) + (error (make-indirect-buffer (current-buffer) "*org-goto*" t)))) + (let (temp-buffer-show-function temp-buffer-show-hook) + (with-output-to-temp-buffer "*Org Help*" + (princ (format help (if org-goto-auto-isearch + " Just type for auto-isearch." + " n/p/f/b/u to navigate, q to quit."))))) + (org-fit-window-to-buffer (get-buffer-window "*Org Help*")) + (org-overview) + (setq buffer-read-only t) + (if (and (boundp 'org-goto-start-pos) + (integer-or-marker-p org-goto-start-pos)) + (progn (goto-char org-goto-start-pos) + (when (org-invisible-p) + (org-show-set-visibility 'lineage))) + (goto-char (point-min))) + (let (org-special-ctrl-a/e) (org-beginning-of-line)) + (message "Select location and press RET") + (use-local-map org-goto-map) + (recursive-edit))) + (kill-buffer "*org-goto*") + (cons org-goto-selected-point org-goto-exit-command))) ;;;###autoload (defun org-goto (&optional alternative-interface) diff --git a/lisp/org/org-version.el b/lisp/org/org-version.el index 6427f30072..77b1cf4e5f 100644 --- a/lisp/org/org-version.el +++ b/lisp/org/org-version.el @@ -11,7 +11,7 @@ Inserted by installing Org mode or when a release is made." (defun org-git-version () "The Git version of Org mode. Inserted by installing Org or when a release is made." - (let ((org-git-version "release_9.5-68-g77e2ec")) + (let ((org-git-version "release_9.5-72-gc5d6656")) org-git-version)) (provide 'org-version) diff --git a/lisp/org/ox-icalendar.el b/lisp/org/ox-icalendar.el index 9170059156..081a28317f 100644 --- a/lisp/org/ox-icalendar.el +++ b/lisp/org/ox-icalendar.el @@ -280,6 +280,7 @@ re-read the iCalendar file.") (footnote-definition . ignore) (footnote-reference . ignore) (headline . org-icalendar-entry) + (inner-template . org-icalendar-inner-template) (inlinetask . ignore) (planning . ignore) (section . ignore) @@ -805,6 +806,11 @@ END:VALARM\n" ;;;; Template +(defun org-icalendar-inner-template (contents _) + "Return document body string after iCalendar conversion. +CONTENTS is the transcoded contents string." + contents) + (defun org-icalendar-template (contents info) "Return complete document string after iCalendar conversion. CONTENTS is the transcoded contents string. INFO is a plist used commit e3d5337970585d1e47a4942048edf8261ad5b781 Author: Eli Zaretskii Date: Sat Nov 20 20:08:06 2021 +0200 Fix mouse handling with several TTY frames on MS-Windows * src/w32inevt.c (do_mouse_event): Reset the 'mouse_moved' flag of the selected frame. Without that, this flag might remain set on a TTY frame that is not displayed. diff --git a/src/w32inevt.c b/src/w32inevt.c index 9a69b32bcb..894bc3ab08 100644 --- a/src/w32inevt.c +++ b/src/w32inevt.c @@ -470,6 +470,9 @@ do_mouse_event (MOUSE_EVENT_RECORD *event, DWORD but_change, mask, flags = event->dwEventFlags; int i; + /* Mouse didn't move unless MOUSE_MOVED says it did. */ + SELECTED_FRAME ()->mouse_moved = 0; + switch (flags) { case MOUSE_MOVED: commit 7e437af41319330ddade02d9784cf78c8e6674d8 Author: Eli Zaretskii Date: Sat Nov 20 18:17:59 2021 +0200 Fix temacs invocation from outside of the 'src' directory * src/emacs.c (main) [HAVE_NATIVE_COMP]: Recompute the value of native-comp-eln-load-path if about to load loadup in uninitialized Emacs. (Bug#51999) diff --git a/src/emacs.c b/src/emacs.c index 866e43fda9..41c92a4615 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2284,6 +2284,17 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem /* Unless next switch is -nl, load "loadup.el" first thing. */ if (! no_loadup) Vtop_level = list2 (Qload, build_string ("loadup.el")); + +#ifdef HAVE_NATIVE_COMP + /* If we are going to load stuff in a non-initialized Emacs, + update the value of native-comp-eln-load-path, so that the + *.eln files will be found if they are there. */ + if (!NILP (Vtop_level) && !temacs) + Vnative_comp_eln_load_path = + Fcons (Fexpand_file_name (XCAR (Vnative_comp_eln_load_path), + Vinvocation_directory), + Qnil); +#endif } /* Set up for profiling. This is known to work on FreeBSD, commit 85a078e7853d708e599f97a3de06aed3a1c090ea Author: Po Lu Date: Sat Nov 20 21:30:08 2021 +0800 Add support for the Haiku operating system and its window system * .gitignore: Add binaries specific to Haiku. * Makefie.in (HAVE_BE_APP): New variable. (install-arch-dep): Install Emacs and Emacs.pdmp when using Haiku. * configure.ac: Detect and configure for Haiku and various related configurations. (be-app, be-freetype, be-cairo): New options. (HAVE_BE_APP, HAIKU_OBJ, HAIKU_CXX_OBJ) (HAIKU_LIBS, HAIKU_CFLAGS): New variables. (HAIKU, HAVE_TINY_SPEED_T): New define. (emacs_config_features): Add BE_APP. * doc/emacs/Makefile.in (EMACSSOURCES): Add Haiku appendix. * doc/emacs/emacs.texi: Add Haiku appendix to menus and include it. * doc/emacs/haiku.texi: New Haiku appendix. * doc/lispref/display.texi (Defining Faces, Window Systems): Explain meaning of `haiku' as a window system identifier. (haiku-use-system-tooltips): Explain meaning of system tooltips on Haiku. * doc/lispref/frames.texi (Multiple Terminals): Explain meaning of haiku as a display type. (Frame Layout): Clarify section for Haiku frames. (Size Parameters): Explain limitations of fullwidth and fullheight on Haiku. (Management Parameters): Explain limitations of inhibiting double buffering on builds with Cairo, and the inability of frames with no-accept-focus to receive keyboard input on Haiku. (Font and Color Parameters): Explain the different font backends available on Haiku. (Raising and Lowering): Explain that lowering and restacking frames doesn't work on Haiku. (Child Frames): Explain oddities of child frame visibility on Haiku. * doc/lispref/os.texi (System Environment): Explain meaning of haiku. * etc/MACHINES: Add appropriate notices for Haiku. * etc/NEWS: Document changes. * etc/PROBLEMS: Document font spacing bug on Haiku. * lib-src/Makefile.in: Build be-resources binary on Haiku. (CXX, CXXFLAGS, NON_CXX_FLAGS, ALL_CXXFLAGS) (HAVE_BE_APP, HAIKU_LIBS, HAIKU_CFLAGS): New variables. (DONT_INSTALL): Add be-resources binary if on Haiku. (be-resources): New target. * lib-src/be_resources: Add helper binary for setting resources on the Emacs application. * lib-src/emacsclient.c (decode_options): Set alt_display to "be" on Haiku. * lisp/cus-edit.el (custom-button, custom-button-mouse) (custom-button-unraised, custom-button-pressed): Update face definitions for Haiku. * lisp/cus-start.el: Add haiku-debug-on-fatal-error and haiku-use-system-tooltips. * lisp/faces.el (face-valid-attribute-values): Clarify attribute comment for Haiku. (tool-bar): Add appropriate toolbar color for Haiku. * lisp/frame.el (haiku-frame-geometry) (haiku-mouse-absolute-pixel-position) (haiku-set-mouse-absolute-pixel-position) (haiku-frame-edges) (haiku-frame-list-z-order): New function declarations. (frame-geometry, frame-edges) (mouse-absolute-pixel-position) (set-mouse-absolute-pixel-position) (frame-list-z-order): Call appropriate window system functions on Haiku. (display-mouse-p, display-graphic-p) (display-images-p, display-pixel-height) (display-pixel-width, display-mm-height) (display-mm-width, display-backing-store) (display-save-under, display-planes) (display-color-cells, display-visual-class): Update type tests for Haiku. * lisp/international/mule-cmds.el (set-coding-system-map): Also prevent set-terminal-coding-system from appearing in the menu bar on Haiku. * lisp/loadup.el: Load Haiku-specific files when built with Haiku, and don't rename newly built Emacs on Haiku as BFS doesn't support hard links. * lisp/menu-bar.el (menu-bar-open): Add for Haiku. * lisp/mwheel.el (mouse-wheel-down-event): Expect wheel-up on Haiku. (mouse-wheel-up-event): Expect wheel-down on Haiku. (mouse-wheel-left-event): Expect wheel-left on Haiku. (mouse-wheel-right-event): Expect wheel-right on Haiku. * lisp/net/browse-url.el (browse-url--browser-defcustom-type): Add option for WebPositive. (browse-url-webpositive-program): New variable. (browse-url-default-program): Search for WebPositive. (browse-url-webpositive): New function. * lisp/net/eww.el (eww-form-submit, eww-form-file) (eww-form-checkbox, eww-form-select): Define faces appropriately for Haiku. * lisp/term/haiku-win.el: New file. * lisp/tooltip.el (menu-or-popup-active-p): New function declaration. (tooltip-show-help): Don't use tooltips on Haiku when a menu is active. * lisp/version.el (haiku-get-version-string): New function declaration. (emacs-version): Add Haiku version string if appropriate. * src/Makefile.in: Also produce binary named "Emacs" with Haiku resources set. (CXX, HAIKU_OBJ, HAIKU_CXX_OBJ, HAIKU_LIBS) (HAIKU_CFLAGS, HAVE_BE_APP, NON_CXX_FLAGS) (ALL_CXX_FLAGS): New variables. (.SUFFIXES): Add .cc. (.cc.o): New target. (base_obj): Add Haiku C objects. (doc_obj, obj): Split objects that should scanned for documentation into doc_obj. (SOME_MACHINE_OBJECTS): Add appropriate Haiku C objects. (all): Depend on Emacs and Emacs.pdmp on Haiku. (LIBES): Add Haiku libraries. (gl-stamp) ($(etc)/DOC): Scan doc_obj instead of obj (temacs$(EXEEXT): Use C++ linker on Haiku. (ctagsfiles3): New variable. (TAGS): Scan C++ files. * src/alloc.c (garbage_collect): Mark Haiku display. * src/dispextern.h (HAVE_NATIVE_TRANSFORMS): Also enable on Haiku. (struct image): Add fields for Haiku transforms. (RGB_PIXEL_COLOR): Define to unsigned long on Haiku as well. (sit_for): Also check USABLE_SIGPOLL. (init_display_interactive): Set initial window system to Haiku on Haiku builds. * src/emacs.c (main): Define Haiku syms and init haiku clipboard. (shut_down_emacs): Quit BApplication on Haiku and trigger debug on aborts if haiku_debug_on_fatal_error. (Vsystem_type): Update docstring. * src/fileio.c (next-read-file-uses-dialog-p): Enable on Haiku. * src/filelock.c (WTMP_FILE): Only define if BOOT_TIME is also defined. * src/floatfns.c (double_integer_scale): Work around Haiku libroot brain damage. * src/font.c (syms_of_font): Define appropriate font driver symbols for Haiku builds with various options. * src/font.h: Also enable ftcrfont on Haiku builds with Cairo. (font_data_structures_may_be_ill_formed): Also enable on Haiku builds that have Cairo. * src/frame.c (Fframep): Update doc-string for Haiku builds and return haiku if appropriate. (syms_of_frame): New symbol `haiku'. * src/frame.h (struct frame): Add output data for Haiku. (FRAME_HAIKU_P): New macro. (FRAME_WINDOW_P): Test for Haiku frames as well. * src/ftcrfont.c (RED_FROM_ULONG, GREEN_FROM_ULONG) (BLUE_FROM_ULONG): New macros. (ftcrfont_draw): Add haiku specific code for Haiku builds with Cairo. * src/ftfont.c (ftfont_open): Set face. (ftfont_has_char, ftfont_text_extents): Work around crash. (syms_of_ftfont): New symbol `mono'. * src/ftfont.h (struct font_info): Enable Cairo-specific fields for Cairo builds on Haiku. * src/haiku_draw_support.cc: * src/haiku_font_support.cc: * src/haiku_io.c: * src/haiku_select.cc: * src/haiku_support.cc: * src/haiku_support.h: * src/haikufns.c: * src/haikufont.c: * src/haikugui.h: * src/haikuimage.c: * src/haikumenu.c: * src/haikuselect.c: * src/haikuselect.h: * src/haikuterm.c: * src/haikuterm.h: Add new files for Haiku windowing support. * src/haiku.c: Add new files for Haiku operating system support. * src/image.c: Implement image transforms and native XPM support on Haiku. (GET_PIXEL, PUT_PIXEL, NO_PIXMAP) (PIX_MASK_RETAIN, PIX_MASK_DRAW) (RGB_TO_ULONG, RED_FROM_ULONG, GREEN_FROM_ULONG) (BLUE_FROM_ULONG, RED16_FROM_ULONG, GREEN16_FROM_ULONG) (BLUE16_FROM_ULONG): Define to appropriate values on Haiku. (image_create_bitmap_from_data): Add Haiku support. (image_create_bitmap_from_file): Add TODO on Haiku. (free_bitmap_record): Free bitmap on Haiku. (image_size_in_bytes): Implement for Haiku bitmaps. (image_set_transform): Implement on Haiku. (image_create_x_image_and_pixmap_1): Implement on Haiku, 24-bit or 1-bit only. (image_destroy_x_image, image_get_x_image): Use correct img and pixmap values on Haiku. (lookup_rgb_color): Use correct macro on Haiku. (image_to_emacs_colors): Implement on Haiku. (image_disable_image): Disable on Haiku. (image_can_use_native_api): Test for translator presence on Haiku. (native_image_load): Use translator on Haiku. (imagemagick_load_image): Add Haiku-specific quirks. (Fimage_transforms_p): Allow rotate90 on Haiku. (image_types): Enable native XPM support on Haiku. (syms_of_image): Enable XPM images on Haiku. * src/keyboard.c (kbd_buffer_get_event) (handle_async_input, handle_input_available_signal) (handle_user_signal, Fset_input_interrupt_mode) (init_keyboard): Check for USABLE_SIGPOLL along with USABLE_SIGIO. * src/lisp.h (pD): Work around broken Haiku headers. (HAVE_EXT_MENU_BAR): Define on Haiku. (handle_input_available_signal): Enable if we just have SIGPOLL as well. * src/menu.c (have_boxes): Return true on Haiku. (single_menu_item): Enable toolkit menus on Haiku. (find_and_call_menu_selection): Also enable on Haiku. * src/process.c (keyboard_bit_set): Enable with only usable SIGPOLL. (wait_reading_process_output): Test for SIGPOLL as well as SIGIO availability. * src/sound.c (sound_perror, vox_open) (vox_configure, vox_close): Enable for usable SIGPOLL as well. * src/sysdep.c (sys_subshell): Enable for usable SIGPOLL. (reset_sigio): Make conditional on F_SETOWN. (request_sigio, unrequest_sigio) (emacs_sigaction_init): Also handle SIGPOLLs. (init_sys_modes): Disable TCXONC usage on Haiku, as it doesn't have any ttys other than pseudo ttys, which don't support C-s/C-q flow control, and causes compiler warnings. (speeds): Disable high speeds if HAVE_TINY_SPEED_T. * src/termhooks.h (enum output_method): Add output_haiku. (struct terminal): Add Haiku display info. (TERMINAL_FONT_CACHE): Enable for Haiku. * src/terminal.c (Fterminal_live_p): Return `haiku' if appropriate. * src/verbose.mk.in (AM_V_CXX, AM_V_CXXLD): New logging variables. * src/xdisp.c (redisplay_internal) (note_mouse_highlight): Return on Haiku if a popup is activated. (display_menu_bar): Return on Haiku if frame is a Haiku frame. * src/xfaces.c (GCGraphicsExposures): Enable correctly on Haiku. (x_create_gc): Enable dummy GC code on Haiku. * src/xfns.c (x-server-version, x-file-dialog): Add Haiku specifics to doc strings. * src/xterm.c (syms_of_xterm): Add Haiku information to doc string. diff --git a/.gitignore b/.gitignore index ea1662c9b8..f1abb2ab68 100644 --- a/.gitignore +++ b/.gitignore @@ -182,6 +182,7 @@ ID # Executables. *.exe a.out +lib-src/be-resources lib-src/blessmail lib-src/ctags lib-src/ebrowse @@ -203,6 +204,7 @@ nextstep/GNUstep/Emacs.base/Resources/Info-gnustep.plist src/bootstrap-emacs src/emacs src/emacs-[0-9]* +src/Emacs src/temacs src/dmpstruct.h src/*.pdmp diff --git a/Makefile.in b/Makefile.in index ccb5d93f2f..3c092fa63d 100644 --- a/Makefile.in +++ b/Makefile.in @@ -102,6 +102,8 @@ HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@ USE_STARTUP_NOTIFICATION = @USE_STARTUP_NOTIFICATION@ +HAVE_BE_APP = @HAVE_BE_APP@ + # ==================== Where To Install Things ==================== # Location to install Emacs.app under GNUstep / macOS. @@ -521,7 +523,13 @@ install-arch-dep: src install-arch-indep install-etcdoc install-$(NTDIR) $(MAKE) -C lib-src install ifeq (${ns_self_contained},no) ${INSTALL_PROGRAM} $(INSTALL_STRIP) src/emacs${EXEEXT} "$(DESTDIR)${bindir}/$(EMACSFULL)" +ifeq (${HAVE_BE_APP},yes) + ${INSTALL_PROGRAM} $(INSTALL_STRIP) src/Emacs "$(DESTDIR)${prefix}/apps/Emacs" +endif ifeq (${DUMPING},pdumper) +ifeq (${HAVE_BE_APP},yes) + ${INSTALL_DATA} src/Emacs.pdmp "$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}"/Emacs.pdmp +endif ${INSTALL_DATA} src/emacs.pdmp "$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}"/emacs-${EMACS_PDMP} endif -chmod 755 "$(DESTDIR)${bindir}/$(EMACSFULL)" diff --git a/configure.ac b/configure.ac index 82661c975e..90a487f7ac 100644 --- a/configure.ac +++ b/configure.ac @@ -511,6 +511,12 @@ otherwise for the first of 'inotify', 'kqueue' or 'gfile' that is usable.]) OPTION_DEFAULT_OFF([xwidgets], [enable use of xwidgets in Emacs buffers (requires gtk3 or macOS Cocoa)]) +OPTION_DEFAULT_OFF([be-app], + [enable use of Haiku's Application Kit as a window system]) + +OPTION_DEFAULT_OFF([be-cairo], + [enable use of cairo under Haiku's Application Kit]) + ## Makefile.in needs the cache file name. AC_SUBST(cache_file) @@ -787,6 +793,10 @@ case "${canonical}" in LDFLAGS="-N2M $LDFLAGS" ;; + *-haiku ) + opsys=haiku + ;; + ## Intel 386 machines where we don't care about the manufacturer. i[3456]86-*-* ) case "${canonical}" in @@ -908,7 +918,9 @@ if test "$ac_test_CFLAGS" != set; then if test $emacs_cv_prog_cc_g3 != yes; then CFLAGS=$emacs_save_CFLAGS fi - if test $opsys = mingw32; then + # Haiku also needs -gdwarf-2 because its GDB is too old + # to understand newer formats. + if test $opsys = mingw32 || test $opsys = haiku; then CFLAGS="$CFLAGS -gdwarf-2" fi fi @@ -1575,6 +1587,8 @@ case "$opsys" in ## Motif needs -lgen. unixware) LIBS_SYSTEM="-lsocket -lnsl -lelf -lgen" ;; + + haiku) LIBS_SYSTEM="-lnetwork" ;; esac AC_SUBST(LIBS_SYSTEM) @@ -2080,6 +2094,22 @@ if test "${HAVE_NS}" = yes; then fi fi +HAVE_BE_APP=no +if test "${opsys}" = "haiku" && test "${with_be_app}" = "yes"; then + dnl Only GCC is supported. Clang might work, but it's + dnl not reliable, so don't check for it here. + AC_PROG_CXX([gcc g++]) + CXXFLAGS="$CXXFLAGS $emacs_g3_CFLAGS" + AC_LANG_PUSH([C++]) + AC_CHECK_HEADER([app/Application.h], [HAVE_BE_APP=yes], + [AC_MSG_ERROR([The Application Kit headers required for building +with the Application Kit were not found or cannot be compiled. Either fix this, or +re-configure with the option '--without-be-app'.])]) + AC_LANG_POP([C++]) +fi + +AC_SUBST(HAVE_BE_APP) + HAVE_W32=no W32_OBJ= W32_LIBS= @@ -2201,6 +2231,39 @@ if test "${HAVE_W32}" = "yes"; then with_xft=no fi +HAIKU_OBJ= +HAIKU_CXX_OBJ= +HAIKU_LIBS= +HAIKU_CFLAGS= + +if test "$opsys" = "haiku"; then + HAIKU_OBJ="$HAIKU_OBJ haiku.o" +fi + +if test "${HAVE_BE_APP}" = "yes"; then + AC_DEFINE([HAVE_HAIKU], 1, + [Define if Emacs will be built with Haiku windowing support]) +fi + +if test "${HAVE_BE_APP}" = "yes"; then + window_system=haiku + with_xft=no + HAIKU_OBJ="$HAIKU_OBJ haikufns.o haikuterm.o haikumenu.o haikufont.o haikuselect.o haiku_io.o" + HAIKU_CXX_OBJ="haiku_support.o haiku_font_support.o haiku_draw_support.o haiku_select.o" + HAIKU_LIBS="-lbe -lgame -ltranslation -ltracker" # -lgame is needed for set_mouse_position. + + if test "${with_native_image_api}" = yes; then + AC_DEFINE(HAVE_NATIVE_IMAGE_API, 1, [Define to use native OS APIs for images.]) + NATIVE_IMAGE_API="yes (haiku)" + HAIKU_OBJ="$HAIKU_OBJ haikuimage.o" + fi +fi + +AC_SUBST(HAIKU_LIBS) +AC_SUBST(HAIKU_OBJ) +AC_SUBST(HAIKU_CXX_OBJ) +AC_SUBST(HAIKU_CFLAGS) + ## $window_system is now set to the window system we will ## ultimately use. @@ -2240,6 +2303,9 @@ dnl use the toolkit if we have gtk, or X11R5 or newer. w32 ) term_header=w32term.h ;; + haiku ) + term_header=haikuterm.h + ;; esac if test "$window_system" = none && test "X$with_x" != "Xno"; then @@ -2571,7 +2637,8 @@ fi ### Use -lrsvg-2 if available, unless '--with-rsvg=no' is specified. HAVE_RSVG=no -if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${opsys}" = "mingw32"; then +if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" \ + || test "${opsys}" = "mingw32" || test "${HAVE_BE_APP}" = "yes"; then if test "${with_rsvg}" != "no"; then RSVG_REQUIRED=2.14.0 RSVG_MODULE="librsvg-2.0 >= $RSVG_REQUIRED" @@ -2595,7 +2662,8 @@ fi HAVE_WEBP=no if test "${with_webp}" != "no"; then if test "${HAVE_X11}" = "yes" || test "${opsys}" = "mingw32" \ - || test "${HAVE_W32}" = "yes" || test "${HAVE_NS}" = "yes"; then + || test "${HAVE_W32}" = "yes" || test "${HAVE_NS}" = "yes" \ + || test "${HAVE_BE_APP}" = "yes"; then WEBP_REQUIRED=0.6.0 WEBP_MODULE="libwebp >= $WEBP_REQUIRED" @@ -2614,7 +2682,8 @@ if test "${with_webp}" != "no"; then fi HAVE_IMAGEMAGICK=no -if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${HAVE_W32}" = "yes"; then +if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${HAVE_W32}" = "yes" || \ + test "${HAVE_BE_APP}" = "yes"; then if test "${with_imagemagick}" != "no"; then if test -n "$BREW"; then # Homebrew doesn't link ImageMagick 6 by default, so make sure @@ -3264,6 +3333,9 @@ if test "${with_toolkit_scroll_bars}" != "no"; then elif test "${HAVE_W32}" = "yes"; then AC_DEFINE(USE_TOOLKIT_SCROLL_BARS) USE_TOOLKIT_SCROLL_BARS=yes + elif test "${HAVE_BE_APP}" = "yes"; then + AC_DEFINE(USE_TOOLKIT_SCROLL_BARS) + USE_TOOLKIT_SCROLL_BARS=yes fi fi @@ -3353,6 +3425,22 @@ if test "${HAVE_X11}" = "yes"; then fi fi fi +if test "${HAVE_BE_APP}" = "yes"; then + if test "${with_be_cairo}" != "no"; then + CAIRO_REQUIRED=1.8.0 + CAIRO_MODULE="cairo >= $CAIRO_REQUIRED" + EMACS_CHECK_MODULES(CAIRO, $CAIRO_MODULE) + if test $HAVE_CAIRO = yes; then + AC_DEFINE(USE_BE_CAIRO, 1, [Define to 1 if using cairo on Haiku.]) + CFLAGS="$CFLAGS $CAIRO_CFLAGS" + LIBS="$LIBS $CAIRO_LIBS" + AC_SUBST(CAIRO_CFLAGS) + AC_SUBST(CAIRO_LIBS) + else + AC_MSG_WARN([cairo requested but not found.]) + fi + fi +fi ### Start of font-backend (under any platform) section. # (nothing here yet -- this is a placeholder) @@ -3502,6 +3590,58 @@ if test "${HAVE_X11}" = "yes" && test "${HAVE_FREETYPE}" = "yes" \ fi fi +### Start of font-backend (under Haiku) selectionn. +if test "${HAVE_BE_APP}" = "yes"; then + if test $HAVE_CAIRO = "yes"; then + EMACS_CHECK_MODULES([FREETYPE], [freetype2 >= 2.5.0]) + test "$HAVE_FREETYPE" = "no" && AC_MSG_ERROR(cairo on Haiku requires libfreetype) + EMACS_CHECK_MODULES([FONTCONFIG], [fontconfig >= 2.2.0]) + test "$HAVE_FONTCONFIG" = "no" && AC_MSG_ERROR(cairo on Haiku requires libfontconfig) + fi + + HAVE_LIBOTF=no + + if test "${HAVE_FREETYPE}" = "yes"; then + AC_DEFINE(HAVE_FREETYPE, 1, + [Define to 1 if using the freetype and fontconfig libraries.]) + OLD_CFLAGS=$CFLAGS + OLD_LIBS=$LIBS + CFLAGS="$CFLAGS $FREETYPE_CFLAGS" + LIBS="$FREETYPE_LIBS $LIBS" + AC_CHECK_FUNCS(FT_Face_GetCharVariantIndex) + CFLAGS=$OLD_CFLAGS + LIBS=$OLD_LIBS + if test "${with_libotf}" != "no"; then + EMACS_CHECK_MODULES([LIBOTF], [libotf]) + if test "$HAVE_LIBOTF" = "yes"; then + AC_DEFINE(HAVE_LIBOTF, 1, [Define to 1 if using libotf.]) + AC_CHECK_LIB(otf, OTF_get_variation_glyphs, + HAVE_OTF_GET_VARIATION_GLYPHS=yes, + HAVE_OTF_GET_VARIATION_GLYPHS=no) + if test "${HAVE_OTF_GET_VARIATION_GLYPHS}" = "yes"; then + AC_DEFINE(HAVE_OTF_GET_VARIATION_GLYPHS, 1, + [Define to 1 if libotf has OTF_get_variation_glyphs.]) + fi + if ! $PKG_CONFIG --atleast-version=0.9.16 libotf; then + AC_DEFINE(HAVE_OTF_KANNADA_BUG, 1, +[Define to 1 if libotf is affected by https://debbugs.gnu.org/28110.]) + fi + fi + fi + dnl FIXME should there be an error if HAVE_FREETYPE != yes? + dnl Does the new font backend require it, or can it work without it? + fi +fi + +if test "${HAVE_BE_APP}" = "yes" && test "${HAVE_FREETYPE}" = "yes"; then + if test "${with_harfbuzz}" != "no"; then + EMACS_CHECK_MODULES([HARFBUZZ], [harfbuzz >= $harfbuzz_required_ver]) + if test "$HAVE_HARFBUZZ" = "yes"; then + AC_DEFINE(HAVE_HARFBUZZ, 1, [Define to 1 if using HarfBuzz.]) + fi + fi +fi + ### End of font-backend section. AC_SUBST(FREETYPE_CFLAGS) @@ -3623,7 +3763,7 @@ AC_SUBST(LIBXPM) HAVE_JPEG=no LIBJPEG= if test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \ - || test "${HAVE_NS}" = "yes"; then + || test "${HAVE_NS}" = "yes" || test "${HAVE_BE_APP}" = "yes"; then if test "${with_jpeg}" != "no"; then AC_CACHE_CHECK([for jpeglib 6b or later], [emacs_cv_jpeglib], @@ -3941,7 +4081,7 @@ if test "${with_png}" != no; then if test "$opsys" = mingw32; then AC_CHECK_HEADER([png.h], [HAVE_PNG=yes]) elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \ - || test "${HAVE_NS}" = "yes"; then + || test "${HAVE_NS}" = "yes" || test "${HAVE_BE_APP}" = "yes"; then EMACS_CHECK_MODULES([PNG], [libpng >= 1.0.0]) if test $HAVE_PNG = yes; then LIBPNG=$PNG_LIBS @@ -4016,7 +4156,7 @@ if test "${opsys}" = "mingw32"; then AC_DEFINE(HAVE_TIFF, 1, [Define to 1 if you have the tiff library (-ltiff).]) fi elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \ - || test "${HAVE_NS}" = "yes"; then + || test "${HAVE_NS}" = "yes" || test "${HAVE_BE_APP}" = "yes"; then if test "${with_tiff}" != "no"; then AC_CHECK_HEADER(tiffio.h, [tifflibs="-lz -lm" @@ -4045,7 +4185,8 @@ if test "${opsys}" = "mingw32"; then AC_DEFINE(HAVE_GIF, 1, [Define to 1 if you have a gif (or ungif) library.]) fi elif test "${HAVE_X11}" = "yes" && test "${with_gif}" != "no" \ - || test "${HAVE_W32}" = "yes" || test "${HAVE_NS}" = "yes"; then + || test "${HAVE_W32}" = "yes" || test "${HAVE_NS}" = "yes" \ + || test "${HAVE_BE_APP}" = "yes"; then AC_CHECK_HEADER(gif_lib.h, # EGifPutExtensionLast only exists from version libungif-4.1.0b1. # Earlier versions can crash Emacs, but version 5.0 removes EGifPutExtensionLast. @@ -4482,6 +4623,13 @@ case $with_unexec,$canonical in [AC_MSG_ERROR([Non-ELF systems are not supported on this platform.])]);; esac +if test "$with_unexec" = yes && test "$opsys" = "haiku"; then + dnl A serious attempt was actually made to port unexec to Haiku. + dnl Something in libstdc++ seems to prevent it from working. + AC_MSG_ERROR([Haiku is not supported by the legacy unexec dumper. +Please use the portable dumper instead.]) +fi + # Dump loading AC_CHECK_FUNCS([posix_madvise]) @@ -4835,7 +4983,7 @@ CFLAGS="$OLDCFLAGS" LIBS="$OLDLIBS"]) if test "${emacs_cv_links_glib}" = "yes"; then AC_DEFINE(HAVE_GLIB, 1, [Define to 1 if GLib is linked in.]) - if test "$HAVE_NS" = no;then + if test "$HAVE_NS" = no ; then XGSELOBJ=xgselect.o fi fi @@ -5090,7 +5238,7 @@ dnl It would have Emacs fork off a separate process dnl to read the input and send it to the true Emacs process dnl through a pipe. case $opsys in - darwin | gnu-linux | gnu-kfreebsd ) + darwin | gnu-linux | gnu-kfreebsd) AC_DEFINE(INTERRUPT_INPUT, 1, [Define to read input using SIGIO.]) ;; esac @@ -5186,6 +5334,14 @@ case $opsys in AC_DEFINE(PTY_OPEN, [fd = open (pty_name, O_RDWR | O_NONBLOCK)]) AC_DEFINE(PTY_TTY_NAME_SPRINTF, [{ char *ptsname (int), *ptyname; int grantpt_result; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); grantpt_result = grantpt (fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (grantpt_result == -1) fatal("could not grant slave pty"); if (unlockpt(fd) == -1) fatal("could not unlock slave pty"); if (!(ptyname = ptsname(fd))) fatal ("could not enable slave pty"); snprintf (pty_name, PTY_NAME_SIZE, "%s", ptyname); }]) ;; + + haiku*) + AC_DEFINE(FIRST_PTY_LETTER, ['s']) + AC_DEFINE(PTY_NAME_SPRINTF, []) + dnl on Haiku pty names aren't distinctive, thus the use of posix_openpt + AC_DEFINE(PTY_OPEN, [fd = posix_openpt (O_RDWR | O_NONBLOCK)]) + AC_DEFINE(PTY_TTY_NAME_SPRINTF, [{ char *ptyname; int grantpt_result; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); grantpt_result = grantpt (fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (grantpt_result == -1) fatal("could not grant slave pty"); if (unlockpt(fd) == -1) fatal("could not unlock slave pty"); if (!(ptyname = ptsname(fd))) fatal ("could not enable slave pty"); snprintf (pty_name, PTY_NAME_SIZE, "%s", ptyname); }]) + ;; esac @@ -5407,8 +5563,25 @@ case $opsys in AC_DEFINE(USG, []) AC_DEFINE(USG5_4, []) ;; + + haiku) + AC_DEFINE(HAIKU, [], [Define if the system is Haiku.]) + ;; esac +AC_SYS_POSIX_TERMIOS +if test $ac_cv_sys_posix_termios = yes; then + AC_CHECK_SIZEOF([speed_t], [], [#include ]) + dnl on Haiku, and possibly other platforms, speed_t is defined to + dnl unsigned char, even when speeds greater than 200 baud are + dnl defined. + + if test ${ac_cv_sizeof_speed_t} -lt 2; then + AC_DEFINE([HAVE_TINY_SPEED_T], [1], + [Define to 1 if speed_t has some sort of nonsensically tiny size.]) + fi +fi + AC_CACHE_CHECK([for usable FIONREAD], [emacs_cv_usable_FIONREAD], [case $opsys in aix4-2 | nacl) @@ -5451,6 +5624,22 @@ if test $emacs_cv_usable_FIONREAD = yes; then AC_DEFINE([USABLE_SIGIO], [1], [Define to 1 if SIGIO is usable.]) fi fi + + if test $emacs_broken_SIGIO = no && test $emacs_cv_usable_SIGIO = no; then + AC_CACHE_CHECK([for usable SIGPOLL], [emacs_cv_usable_SIGPOLL], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([[#include + #include + ]], + [[int foo = SIGPOLL | F_SETFL;]])], + [emacs_cv_usable_SIGPOLL=yes], + [emacs_cv_usable_SIGPOLL=no])], + [emacs_cv_usable_SIGPOLL=yes], + [emacs_cv_usable_SIGPOLL=no]) + if test $emacs_cv_usable_SIGPOLL = yes; then + AC_DEFINE([USABLE_SIGPOLL], [1], [Define to 1 if SIGPOLL is usable but SIGIO is not.]) + fi + fi fi case $opsys in @@ -5563,6 +5752,17 @@ if test "${HAVE_X_WINDOWS}" = "yes" ; then FONT_OBJ="$FONT_OBJ ftfont.o" fi fi + +if test "${HAVE_BE_APP}" = "yes" ; then + if test "${HAVE_FREETYPE}" = "yes" || \ + test "${HAVE_CAIRO}" = "yes"; then + FONT_OBJ="$FONT_OBJ ftfont.o" + fi + if test "${HAVE_CAIRO}" = "yes"; then + FONT_OBJ="$FONT_OBJ ftcrfont.o" + fi +fi + if test "${HAVE_HARFBUZZ}" = "yes" ; then FONT_OBJ="$FONT_OBJ hbfont.o" fi @@ -5951,7 +6151,7 @@ Configured for '${canonical}'. #### Please respect alphabetical ordering when making additions. optsep= emacs_config_features= -for opt in ACL CAIRO DBUS FREETYPE GCONF GIF GLIB GMP GNUTLS GPM GSETTINGS \ +for opt in ACL BE_APP CAIRO DBUS FREETYPE GCONF GIF GLIB GMP GNUTLS GPM GSETTINGS \ HARFBUZZ IMAGEMAGICK JPEG JSON LCMS2 LIBOTF LIBSELINUX LIBSYSTEMD LIBXML2 \ M17N_FLT MODULES NATIVE_COMP NOTIFY NS OLDXMENU PDUMPER PNG RSVG SECCOMP \ SOUND THREADS TIFF TOOLKIT_SCROLL_BARS \ diff --git a/doc/emacs/Makefile.in b/doc/emacs/Makefile.in index 69d39efa8b..dde3ae83c1 100644 --- a/doc/emacs/Makefile.in +++ b/doc/emacs/Makefile.in @@ -140,6 +140,7 @@ EMACSSOURCES= \ ${srcdir}/xresources.texi \ ${srcdir}/anti.texi \ ${srcdir}/macos.texi \ + $(srcdir)/haiku.texi \ ${srcdir}/msdos.texi \ ${srcdir}/gnu.texi \ ${srcdir}/glossary.texi \ diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi index 83847fb8f1..ce92435ae7 100644 --- a/doc/emacs/emacs.texi +++ b/doc/emacs/emacs.texi @@ -221,6 +221,7 @@ Appendices * X Resources:: X resources for customizing Emacs. * Antinews:: Information about Emacs version 27. * Mac OS / GNUstep:: Using Emacs under macOS and GNUstep. +* Haiku:: Using Emacs on Haiku. * Microsoft Windows:: Using Emacs on Microsoft Windows and MS-DOS. * Manifesto:: What's GNU? Gnu's Not Unix! @@ -1249,6 +1250,11 @@ Emacs and macOS / GNUstep * Mac / GNUstep Events:: How window system events are handled. * GNUstep Support:: Details on status of GNUstep support. +Emacs and Haiku + +* Haiku Basics:: Basic Emacs usage and installation under Haiku. +* Haiku Fonts:: The various options for displaying fonts on Haiku. + Emacs and Microsoft Windows/MS-DOS * Windows Startup:: How to start Emacs on Windows. @@ -1618,6 +1624,7 @@ Lisp programming. @include anti.texi @include macos.texi +@include haiku.texi @c Includes msdos-xtra. @include msdos.texi @include gnu.texi diff --git a/doc/emacs/haiku.texi b/doc/emacs/haiku.texi new file mode 100644 index 0000000000..a2dc6e14d0 --- /dev/null +++ b/doc/emacs/haiku.texi @@ -0,0 +1,136 @@ +@c This is part of the Emacs manual. +@c Copyright (C) 2021 Free Software Foundation, Inc. +@c See file emacs.texi for copying conditions. +@node Haiku +@appendix Emacs and Haiku +@cindex Haiku + + Haiku is a Unix-like operating system that originated as a +re-implementation of the operating system BeOS. + + This section describes the peculiarities of using Emacs built with +the Application Kit, the windowing system native to Haiku. The +oddities described here do not apply to using Emacs on Haiku built +without windowing support, or built with X11. + +@menu +* Haiku Basics:: Basic Emacs usage and installation under Haiku. +* Haiku Fonts:: The various options for displaying fonts on Haiku. +@end menu + +@node Haiku Basics +@section Installation and usage peculiarities under Haiku +@cindex haiku application +@cindex haiku installation + + Emacs installs two separate executables under Haiku; it is up to the +user to decide which one suits him best: A regular executable, with +the lowercase name @code{emacs}, and a binary containing +Haiku-specific application metadata, with the name @code{Emacs}. + +@cindex launching Emacs from the tracker +@cindex tty Emacs in haiku + If you are launching Emacs from the Tracker, or want to make the +Tracker open files using Emacs, you should use the binary named +@code{Emacs}; ff you are going to use Emacs in the terminal, or wish +to launch separate instances of Emacs, or do not care for the +aforementioned system integration features, use the binary named +@code{emacs} instead. + +@cindex modifier keys and system keymap (Haiku) +@cindex haiku keymap + On Haiku, unusual modifier keys such as the Hyper key are +unsupported. By default, the super key corresponds with the option +key defined by the operating system, the meta key with the command +key, the control key with the system control key, and the shift key +with the system shift key. On a standard PC keyboard, Haiku should +map these keys to positions familiar to those using a GNU system, but +this may require some adjustment to your system's configuration to +work. + + It is impossible to type accented characters using the system super +key map. + + You can customize the correspondence between modifier keys known to +the system, and those known to Emacs. The variables that allow for +that are described below. + +@cindex modifier key customization (Haiku) +You can customize which Emacs modifiers the various system modifier +keys correspond to through the following variables: + +@table @code +@vindex haiku-meta-keysym +@item haiku-meta-keysym +The system modifier key that will be treated as the Meta key by Emacs. +It defaults to @code{command}. + +@vindex haiku-control-keysym +@item haiku-control-keysym +The system modifier key that will be treated as the Control key by +Emacs. It defaults to @code{control}. + +@vindex haiku-super-keysym +@item haiku-super-keysym +The system modifier key that will be treated as the Super key by +Emacs. It defaults to @code{option}. + +@vindex haiku-shift-keysym +@item haiku-shift-keysym +The system modifier key that will be treated as the Shift key by +Emacs. It defaults to @code{shift}. +@end table + +The value of each variable can be one of the symbols @code{command}, +@code{control}, @code{option}, @code{shift}, or @code{nil}. +@code{nil} or any other value will cause the default value to be used +instead. + +@cindex tooltips (haiku) +@cindex haiku tooltips +@vindex haiku-use-system-tooltips + On Haiku, Emacs defaults to using the system tooltip mechanism. +This usually leads to more responsive tooltips, but the tooltips will +not be able to display text properties or faces. If you need those +features, customize the variable @code{haiku-use-system-tooltips} to +the nil value, and Emacs will use its own implementation of tooltips. + + Both system tooltips and Emacs's own tooltips cannot display above +the menu bar, so help text in the menu bar will display in the echo +area instead. + +@subsection What to do when Emacs crashes +@cindex crashes, Haiku +@cindex haiku debugger +@vindex haiku-debug-on-fatal-error + If the variable @code{haiku-debug-on-fatal-error} is non-nil, Emacs +will launch the system debugger when a fatal signal is received. It +defaults to @code{t}. If GDB cannot be used on your system, please +attach the report generated by the system debugger when reporting a +bug. + +@table @code +@vindex haiku-use-system-debugger +@item haiku-use-system-debugger +When non-nil, Emacs will ask the system to launch the system debugger +whenever it experiences a fatal error. This behaviour is standard +among Haiku applications. +@end table + +@node Haiku Fonts +@section Font and font backend selection on Haiku +@cindex font backend selection (Haiku) + + Emacs, when built with Haiku windowing support, can be built with +several different font backends. You can specify font backends by +specifying @kbd{-xrm Emacs.fontBackend:BACKEND} on the command line +used to invoke Emacs, where @kbd{BACKEND} is one of the backends +specified below, or on a per-frame basis by changing the +@code{font-backend} frame parameter. (@pxref{Parameter Access,,, +elisp, The Emacs Lisp Reference Manual}). + + Two of these backends, @code{ftcr} and @code{ftcrhb} are identical +to their counterparts on the X Window System. There is also a +Haiku-specific backend named @code{haiku}, that uses the App Server to +draw fonts, but does not at present support display of color font and +emoji. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index c093901ea1..b948aff024 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -2767,8 +2767,9 @@ apply to. Here are the possible values of @var{characteristic}: @item type The kind of window system the terminal uses---either @code{graphic} (any graphics-capable display), @code{x}, @code{pc} (for the MS-DOS -console), @code{w32} (for MS Windows 9X/NT/2K/XP), or @code{tty} (a -non-graphics-capable display). @xref{Window Systems, window-system}. +console), @code{w32} (for MS Windows 9X/NT/2K/XP), @code{haiku} (for +Haiku), or @code{tty} (a non-graphics-capable display). +@xref{Window Systems, window-system}. @item class What kinds of colors the terminal supports---either @code{color}, @@ -8274,6 +8275,8 @@ Emacs is displaying the frame using the Nextstep interface (used on GNUstep and macOS). @item pc Emacs is displaying the frame using MS-DOS direct screen writes. +@item haiku +Emacs is displaying the frame using the Application Kit on Haiku. @item nil Emacs is displaying the frame on a character-based terminal. @end table @@ -8320,6 +8323,7 @@ area. On text-mode (a.k.a.@: ``TTY'') frames, tooltips are always displayed in the echo area. @end defun +@cindex system tooltips @vindex x-gtk-use-system-tooltips When Emacs is built with GTK+ support, it by default displays tooltips using GTK+ functions, and the appearance of the tooltips is then diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index 31ad82b7ad..923ff19997 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -214,7 +214,8 @@ The terminal and keyboard coding systems used on the terminal. @item The kind of display associated with the terminal. This is the symbol returned by the function @code{terminal-live-p} (i.e., @code{x}, -@code{t}, @code{w32}, @code{ns}, or @code{pc}). @xref{Frames}. +@code{t}, @code{w32}, @code{ns}, @code{pc}, or @code{haiku}). +@xref{Frames}. @item A list of terminal parameters. @xref{Terminal Parameters}. @@ -680,7 +681,7 @@ indicate that position for the various builds: @itemize @w{} @item (1) non-toolkit and terminal frames -@item (2) Lucid, Motif and MS-Windows frames +@item (2) Lucid, Motif, MS-Windows, and Haiku frames @item (3) GTK+ and NS frames @end itemize @@ -1729,7 +1730,9 @@ fit will be clipped by the window manager. @item fullscreen This parameter specifies whether to maximize the frame's width, height or both. Its value can be @code{fullwidth}, @code{fullheight}, -@code{fullboth}, or @code{maximized}. A @dfn{fullwidth} frame is as +@code{fullboth}, or @code{maximized}.@footnote{On Haiku, setting +@code{fullscreen} to @code{fullwidth} or @code{fullheight} has no +effect.} A @dfn{fullwidth} frame is as wide as possible, a @dfn{fullheight} frame is as tall as possible, and a @dfn{fullboth} frame is both as wide and as tall as possible. A @dfn{maximized} frame is like a ``fullboth'' frame, except that it usually @@ -2191,7 +2194,10 @@ either via @code{focus-follows-mouse} (@pxref{Input Focus}) or @code{mouse-autoselect-window} (@pxref{Mouse Window Auto-selection}). This may have the unwanted side-effect that a user cannot scroll a non-selected frame with the mouse. Some window managers may not honor -this parameter. +this parameter. On Haiku, it also has the side-effect that the window +will not be able to receive any keyboard input from the user, not even +if the user switches to the frame using the key combination +@kbd{Alt-@key{TAB}}. @vindex undecorated@r{, a frame parameter} @item undecorated @@ -2352,7 +2358,10 @@ driver for OTF and TTF fonts with text shaping by the Uniscribe engine), and @code{harfbuzz} (font driver for OTF and TTF fonts with HarfBuzz text shaping) (@pxref{Windows Fonts,,, emacs, The GNU Emacs Manual}). The @code{harfbuzz} driver is similarly recommended. On -other systems, there is only one available font backend, so it does +Haiku, there can be several font drivers (@pxref{Haiku Fonts,,, emacs, +The GNU Emacs Manual}). + +On other systems, there is only one available font backend, so it does not make sense to modify this frame parameter. @vindex background-mode@r{, a frame parameter} @@ -3141,8 +3150,10 @@ raises @var{frame} above all other child frames of its parent. @deffn Command lower-frame &optional frame This function lowers frame @var{frame} (default, the selected frame) below all other frames belonging to the same or a higher z-group as -@var{frame}. If @var{frame} is a child frame (@pxref{Child Frames}), -this lowers @var{frame} below all other child frames of its parent. +@var{frame}.@footnote{Lowering frames is not supported on Haiku, due +to limitations imposed by the system.} If @var{frame} is a child +frame (@pxref{Child Frames}), this lowers @var{frame} below all other +child frames of its parent. @end deffn @defun frame-restack frame1 frame2 &optional above @@ -3152,7 +3163,8 @@ that if both frames are visible and their display areas overlap, third argument @var{above} is non-@code{nil}, this function restacks @var{frame1} above @var{frame2}. This means that if both frames are visible and their display areas overlap, @var{frame1} will (partially) -obscure @var{frame2}. +obscure @var{frame2}.@footnote{Restacking frames is not supported on +Haiku, due to limitations imposed by the system.} Technically, this function may be thought of as an atomic action performed in two steps: The first step removes @var{frame1}'s @@ -3247,12 +3259,16 @@ parent frame's window-system window. @cindex reparent frame @cindex nest frame - The @code{parent-frame} parameter can be changed at any time. Setting -it to another frame @dfn{reparents} the child frame. Setting it to -another child frame makes the frame a @dfn{nested} child frame. Setting -it to @code{nil} restores the frame's status as a top-level frame---a -frame whose window-system window is a child of its display's root -window. + The @code{parent-frame} parameter can be changed at any time. +Setting it to another frame @dfn{reparents} the child frame. Setting +it to another child frame makes the frame a @dfn{nested} child frame. +Setting it to @code{nil} restores the frame's status as a top-level +frame---a frame whose window-system window is a child of its display's +root window.@footnote{On Haiku, child frames are only visible when a +parent frame is active, owing to a limitation of the Haiku windowing +system. Owing to the same limitation, child frames are only +guaranteed to appear above their top-level parent; that is to say, the +top-most frame in the hierarchy, which does not have a parent frame.} Since child frames can be arbitrarily nested, a frame can be both a child and a parent frame. Also, the relative roles of child and parent diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index 1fbd66458a..fb0f25fa3d 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -947,6 +947,9 @@ actually Linux is just the kernel, not the whole system.) @item gnu/kfreebsd A GNU (glibc-based) system with a FreeBSD kernel. +@item haiku +The Haiku operating system, a derivative of the Be Operating System. + @item hpux Hewlett-Packard HPUX operating system. diff --git a/etc/MACHINES b/etc/MACHINES index d8d0b86fb4..d883f1abd6 100644 --- a/etc/MACHINES +++ b/etc/MACHINES @@ -103,6 +103,34 @@ the list at the end of this file. ./configure CC='gcc -m64' # GCC ./configure CC='cc -m64' # Oracle Developer Studio +** Haiku + + On 32-bit Haiku it is required that the newer GCC 8 be used, instead + of the legacy GCC 2 used by default. This can be achieved by + invoking configure inside a shell launched by the 'setarch' program + invoked as 'setarch x86'. + + When building with packages discovered through pkg-config, such as + libpng, on a GCC 2/GCC 8 hybrid system, simply evaluating 'setarch + x86' is insufficient to ensure that all required libraries are found + at their correct locations. To avoid this problem, set the + environment variable 'PKG_CONFIG_PATH' to the GCC 8 pkg-config + directory at '/system/develop/lib/x86/pkgconfig/' before configuring + Emacs. + + If GCC complains about not being able to resolve symbols such as + "BHandler::LockLooper", you are almost certainly experiencing this + problem. + + Haiku running on non-x86 systems has not been tested. It is + anticipated that Haiku running on big-endian systems will experience + problems when Emacs is built with Haiku windowing support, but there + doesn't seem to be any reliable way to get Haiku running on a + big-endian system at present. + + The earliest release of Haiku that will successfully compile Emacs + is R1/Beta2. For windowing support, R1/Beta3 or later is required. + * Obsolete platforms diff --git a/etc/NEWS b/etc/NEWS index 3cceac5584..bfea4da8b9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -24,6 +24,27 @@ applies, and please also update docstrings as needed. * Installation Changes in Emacs 29.1 +** Emacs has been ported to the Haiku operating system. +The configuration process should automatically detect and build for +Haiku. There is also an optional window-system port to Haiku, which +can be enabled by configuring Emacs with the option '--with-be-app', +which will require the Haiku Application Kit development headers and a +C++ compiler to be present on your system. If Emacs is not built with +the option '--with-be-app', the resulting Emacs will only run in +text-mode terminals. + ++++ +*** Cairo drawing support has been enabled for Haiku builds. +To enable Cairo support, ensure that the Cairo and FreeType +development files are present on your system, and configure Emacs with +'--with-be-cairo'. + +--- +*** Double buffering is now enabled on the Haiku operating system. +Unlike X, there is no compile-time option to enable or disable +double-buffering. If you wish to disable double-buffering, change the +frame parameter `inhibit-double-buffering' instead. + ** Emacs now installs the ".pdmp" file using a unique fingerprint in the name. The file is typically installed using a file name akin to "...dir/libexec/emacs/29.1/x86_64-pc-linux-gnu/emacs-.pdmp". diff --git a/etc/PROBLEMS b/etc/PROBLEMS index f506881a4b..acff3be7da 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -1022,6 +1022,15 @@ modern fonts are used, such as Noto Emoji or Ebrima. The solution is to switch to a configuration that uses HarfBuzz as its shaping engine, where these problems don't exist. +** On Haiku, some proportionally-spaced fonts display with artifacting. + +This is a Haiku bug: https://dev.haiku-os.org/ticket/17229, which can +be remedied by using a different font that does not exhibit this +problem, or by configuring Emacs '--with-be-cairo'. + +So far, Bitstream Charter and Noto Sans have been known to exhibit +this problem, while Noto Sans Display is known to not do so. + * Internationalization problems ** M-{ does not work on a Spanish PC keyboard. @@ -1105,6 +1114,13 @@ In your ~/.Xresources file, then run And restart Emacs. +** On Haiku, BeCJK doesn't work properly with Emacs + +Some popular Haiku input methods such BeCJK are known to behave badly +when interacting with Emacs, in ways such as stealing input focus and +displaying popup windows that don't disappear. If you are affected, +you should use an Emacs input method instead. + * X runtime problems ** X keyboard problems diff --git a/lib-src/Makefile.in b/lib-src/Makefile.in index e6cda73367..d062e78366 100644 --- a/lib-src/Makefile.in +++ b/lib-src/Makefile.in @@ -27,7 +27,9 @@ EMACSOPT = -batch --no-site-file --no-site-lisp # ==================== Things 'configure' will edit ==================== CC=@CC@ +CXX=@CXX@ CFLAGS=@CFLAGS@ +CXXFLAGS=@CXXFLAGS@ CPPFLAGS = @CPPFLAGS@ LDFLAGS = @LDFLAGS@ @@ -130,6 +132,11 @@ MKDIR_P = @MKDIR_P@ # ========================== Lists of Files =========================== +## Haiku build-time support +HAVE_BE_APP=@HAVE_BE_APP@ +HAIKU_LIBS=@HAIKU_LIBS@ +HAIKU_CFLAGS=@HAIKU_CFLAGS@ + # emacsclientw.exe for MinGW, empty otherwise CLIENTW = @CLIENTW@ @@ -143,7 +150,11 @@ UTILITIES = hexl${EXEEXT} \ $(if $(with_mailutils), , movemail${EXEEXT}) \ $(and $(use_gamedir), update-game-score${EXEEXT}) +ifeq ($(HAVE_BE_APP),yes) +DONT_INSTALL= make-docfile${EXEEXT} make-fingerprint${EXEEXT} be-resources +else DONT_INSTALL= make-docfile${EXEEXT} make-fingerprint${EXEEXT} +endif # Like UTILITIES, but they're not system-dependent, and should not be # deleted by the distclean target. @@ -230,6 +241,10 @@ WINDRES = @WINDRES@ ## Some systems define this to request special libraries. LIBS_SYSTEM = @LIBS_SYSTEM@ +# Flags that could be in WARN_CFLAGS, but are invalid for C++. +NON_CXX_CFLAGS = -Wmissing-prototypes -Wnested-externs -Wold-style-definition \ + -Wstrict-prototypes -Wno-override-init + BASE_CFLAGS = $(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) \ $(WARN_CFLAGS) $(WERROR_CFLAGS) \ -I. -I../src -I../lib \ @@ -238,6 +253,9 @@ BASE_CFLAGS = $(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) \ ALL_CFLAGS = ${BASE_CFLAGS} ${PROFILING_CFLAGS} ${LDFLAGS} ${CPPFLAGS} ${CFLAGS} CPP_CFLAGS = ${BASE_CFLAGS} ${PROFILING_CFLAGS} ${CPPFLAGS} ${CFLAGS} +ALL_CXXFLAGS = $(filter-out ${NON_CXX_CFLAGS},${BASE_CFLAGS}) \ + ${PROFILING_CFLAGS} ${LDFLAGS} ${CPPFLAGS} ${CFLAGS} ${CXXFLAGS} ${HAIKU_CFLAGS} + # Configuration files for .o files to depend on. config_h = ../src/config.h $(srcdir)/../src/conf_post.h @@ -407,6 +425,9 @@ emacsclientw${EXEEXT}: ${srcdir}/emacsclient.c $(NTLIB) $(CLIENTRES) $(config_h) $(LOADLIBES) \ $(LIB_WSOCK32) $(LIB_EACCESS) $(LIBS_ECLIENT) -o $@ +be-resources: ${srcdir}/be_resources.cc ${config_h} + $(AM_V_CXXLD)$(CXX) ${ALL_CXXFLAGS} ${HAIKU_LIBS} $< -o $@ + NTINC = ${srcdir}/../nt/inc NTDEPS = $(NTINC)/ms-w32.h $(NTINC)/sys/stat.h $(NTINC)/inttypes.h \ $(NTINC)/stdint.h $(NTINC)/pwd.h $(NTINC)/sys/time.h $(NTINC)/stdbool.h \ diff --git a/lib-src/be_resources.cc b/lib-src/be_resources.cc new file mode 100644 index 0000000000..e6a14f037b --- /dev/null +++ b/lib-src/be_resources.cc @@ -0,0 +1,144 @@ +/* Haiku window system support + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include +#include +#include + +#include +#include +#include +#include +#include +#include +#include + +using namespace std; + +static void +be_perror (status_t code, char *arg) +{ + if (code != B_OK) + { + switch (code) + { + case B_BAD_VALUE: + fprintf (stderr, "%s: Bad value\n", arg); + break; + case B_ENTRY_NOT_FOUND: + fprintf (stderr, "%s: Not found\n", arg); + break; + case B_PERMISSION_DENIED: + fprintf (stderr, "%s: Permission denied\n", arg); + break; + case B_NO_MEMORY: + fprintf (stderr, "%s: No memory\n", arg); + break; + case B_LINK_LIMIT: + fprintf (stderr, "%s: Link limit reached\n", arg); + break; + case B_BUSY: + fprintf (stderr, "%s: Busy\n", arg); + break; + case B_NO_MORE_FDS: + fprintf (stderr, "%s: No more file descriptors\n", arg); + break; + case B_FILE_ERROR: + fprintf (stderr, "%s: File error\n", arg); + break; + default: + fprintf (stderr, "%s: Unknown error\n", arg); + } + } + else + { + abort (); + } +} + +int +main (int argc, char **argv) +{ + BApplication app ("application/x-vnd.GNU-emacs-resource-helper"); + BFile file; + BBitmap *icon; + BAppFileInfo info; + status_t code; + struct version_info vinfo; + char *v = strdup (PACKAGE_VERSION); + + if (argc != 3) + { + printf ("be-resources ICON FILE: make FILE appropriate for Emacs.\n"); + return EXIT_FAILURE; + } + + code = file.SetTo (argv[2], B_READ_WRITE); + if (code != B_OK) + { + be_perror (code, argv[2]); + return EXIT_FAILURE; + } + code = info.SetTo (&file); + if (code != B_OK) + { + be_perror (code, argv[2]); + return EXIT_FAILURE; + } + code = info.SetAppFlags (B_EXCLUSIVE_LAUNCH | B_ARGV_ONLY); + if (code != B_OK) + { + be_perror (code, argv[2]); + return EXIT_FAILURE; + } + + icon = BTranslationUtils::GetBitmapFile (argv[1], NULL); + + if (!icon) + { + be_perror (B_ERROR, argv[1]); + return EXIT_FAILURE; + } + + info.SetIcon (icon, B_MINI_ICON); + info.SetIcon (icon, B_LARGE_ICON); + info.SetSignature ("application/x-vnd.GNU-emacs"); + + v = strtok (v, "."); + vinfo.major = atoi (v); + + v = strtok (NULL, "."); + vinfo.middle = atoi (v); + + v = strtok (NULL, "."); + vinfo.minor = v ? atoi (v) : 0; + + vinfo.variety = 0; + vinfo.internal = 0; + + strncpy ((char *) &vinfo.short_info, PACKAGE_VERSION, + sizeof vinfo.short_info - 1); + strncpy ((char *) &vinfo.long_info, PACKAGE_STRING, + sizeof vinfo.long_info - 1); + + info.SetVersionInfo (&vinfo, B_APP_VERSION_KIND); + + return EXIT_SUCCESS; +} diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c index 0e800dd7e8..c55b29830d 100644 --- a/lib-src/emacsclient.c +++ b/lib-src/emacsclient.c @@ -603,6 +603,8 @@ decode_options (int argc, char **argv) alt_display = "ns"; #elif defined (HAVE_NTGUI) alt_display = "w32"; +#elif defined (HAVE_HAIKU) + alt_display = "be"; #endif display = egetenv ("DISPLAY"); diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 6c353b0d9e..b7c53a4dfe 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -2176,7 +2176,7 @@ and `face'." ;;; The `custom' Widget. (defface custom-button - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) "Face for custom buffer buttons if `custom-raised-buttons' is non-nil." @@ -2184,7 +2184,7 @@ and `face'." :group 'custom-faces) (defface custom-button-mouse - '((((type x w32 ns) (class color)) + '((((type x w32 ns haiku) (class color)) :box (:line-width 2 :style released-button) :background "grey90" :foreground "black") (t @@ -2209,7 +2209,7 @@ and `face'." (if custom-raised-buttons 'custom-button-mouse 'highlight)) (defface custom-button-pressed - '((((type x w32 ns) (class color)) + '((((type x w32 ns haiku) (class color)) :box (:line-width 2 :style pressed-button) :background "lightgrey" :foreground "black") (t :inverse-video t)) diff --git a/lisp/cus-start.el b/lisp/cus-start.el index a46107a678..68019c038e 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -829,7 +829,11 @@ since it could result in memory overflow and make Emacs crash." ;; xselect.c (x-select-enable-clipboard-manager killing boolean "24.1") ;; xsettings.c - (font-use-system-font font-selection boolean "23.2"))) + (font-use-system-font font-selection boolean "23.2") + ;; haikuterm.c + (haiku-debug-on-fatal-error debug boolean "29.1") + ;; haikufns.c + (haiku-use-system-tooltips tooltip boolean "29.1"))) (setq ;; If we did not specify any standard value expression above, ;; use the current value as the standard value. standard (if (setq prop (memq :standard rest)) @@ -846,6 +850,8 @@ since it could result in memory overflow and make Emacs crash." (eq system-type 'windows-nt)) ((string-match "\\`ns-" (symbol-name symbol)) (featurep 'ns)) + ((string-match "\\`haiku-" (symbol-name symbol)) + (featurep 'haiku)) ((string-match "\\`x-.*gtk" (symbol-name symbol)) (featurep 'gtk)) ((string-match "clipboard-manager" (symbol-name symbol)) diff --git a/lisp/faces.el b/lisp/faces.el index 9ec20c4298..b2498cda88 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1172,7 +1172,7 @@ an integer value." (:height 'integerp) (:stipple - (and (memq (window-system frame) '(x ns)) ; No stipple on w32 + (and (memq (window-system frame) '(x ns)) ; No stipple on w32 or haiku (mapcar #'list (apply #'nconc (mapcar (lambda (dir) @@ -2822,7 +2822,7 @@ Note: Other faces cannot inherit from the cursor face." '((default :box (:line-width 1 :style released-button) :foreground "black") - (((type x w32 ns) (class color)) + (((type x w32 ns haiku) (class color)) :background "grey75") (((type x) (class mono)) :background "grey")) diff --git a/lisp/frame.el b/lisp/frame.el index 2c73737a54..1319759e74 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -1633,6 +1633,7 @@ live frame and defaults to the selected one." (declare-function x-frame-geometry "xfns.c" (&optional frame)) (declare-function w32-frame-geometry "w32fns.c" (&optional frame)) (declare-function ns-frame-geometry "nsfns.m" (&optional frame)) +(declare-function haiku-frame-geometry "haikufns.c" (&optional frame)) (defun frame-geometry (&optional frame) "Return geometric attributes of FRAME. @@ -1682,6 +1683,8 @@ and width values are in pixels. (w32-frame-geometry frame)) ((eq frame-type 'ns) (ns-frame-geometry frame)) + ((eq frame-type 'haiku) + (haiku-frame-geometry frame)) (t (list '(outer-position 0 . 0) @@ -1806,6 +1809,7 @@ of frames like calls to map a frame or change its visibility." (declare-function x-frame-edges "xfns.c" (&optional frame type)) (declare-function w32-frame-edges "w32fns.c" (&optional frame type)) (declare-function ns-frame-edges "nsfns.m" (&optional frame type)) +(declare-function haiku-frame-edges "haikufns.c" (&optional frame type)) (defun frame-edges (&optional frame type) "Return coordinates of FRAME's edges. @@ -1829,12 +1833,15 @@ FRAME." (w32-frame-edges frame type)) ((eq frame-type 'ns) (ns-frame-edges frame type)) + ((eq frame-type 'haiku) + (haiku-frame-edges frame type)) (t (list 0 0 (frame-width frame) (frame-height frame)))))) (declare-function w32-mouse-absolute-pixel-position "w32fns.c") (declare-function x-mouse-absolute-pixel-position "xfns.c") (declare-function ns-mouse-absolute-pixel-position "nsfns.m") +(declare-function haiku-mouse-absolute-pixel-position "haikufns.c") (defun mouse-absolute-pixel-position () "Return absolute position of mouse cursor in pixels. @@ -1849,12 +1856,15 @@ position (0, 0) of the selected frame's terminal." (w32-mouse-absolute-pixel-position)) ((eq frame-type 'ns) (ns-mouse-absolute-pixel-position)) + ((eq frame-type 'haiku) + (haiku-mouse-absolute-pixel-position)) (t (cons 0 0))))) (declare-function ns-set-mouse-absolute-pixel-position "nsfns.m" (x y)) (declare-function w32-set-mouse-absolute-pixel-position "w32fns.c" (x y)) (declare-function x-set-mouse-absolute-pixel-position "xfns.c" (x y)) +(declare-function haiku-set-mouse-absolute-pixel-position "haikufns.c" (x y)) (defun set-mouse-absolute-pixel-position (x y) "Move mouse pointer to absolute pixel position (X, Y). @@ -1867,7 +1877,9 @@ position (0, 0) of the selected frame's terminal." ((eq frame-type 'x) (x-set-mouse-absolute-pixel-position x y)) ((eq frame-type 'w32) - (w32-set-mouse-absolute-pixel-position x y))))) + (w32-set-mouse-absolute-pixel-position x y)) + ((eq frame-type 'haiku) + (haiku-set-mouse-absolute-pixel-position x y))))) (defun frame-monitor-attributes (&optional frame) "Return the attributes of the physical monitor dominating FRAME. @@ -1960,6 +1972,7 @@ workarea attribute." (declare-function x-frame-list-z-order "xfns.c" (&optional display)) (declare-function w32-frame-list-z-order "w32fns.c" (&optional display)) (declare-function ns-frame-list-z-order "nsfns.m" (&optional display)) +(declare-function haiku-frame-list-z-order "haikufns.c" (&optional display)) (defun frame-list-z-order (&optional display) "Return list of Emacs' frames, in Z (stacking) order. @@ -1979,7 +1992,9 @@ Return nil if DISPLAY contains no Emacs frame." ((eq frame-type 'w32) (w32-frame-list-z-order display)) ((eq frame-type 'ns) - (ns-frame-list-z-order display))))) + (ns-frame-list-z-order display)) + ((eq frame-type 'haiku) + (haiku-frame-list-z-order display))))) (declare-function x-frame-restack "xfns.c" (frame1 frame2 &optional above)) (declare-function w32-frame-restack "w32fns.c" (frame1 frame2 &optional above)) @@ -2060,8 +2075,8 @@ frame's display)." ((eq frame-type 'w32) (with-no-warnings (> w32-num-mouse-buttons 0))) - ((memq frame-type '(x ns)) - t) ;; We assume X and NeXTstep *always* have a pointing device + ((memq frame-type '(x ns haiku)) + t) ;; We assume X, NeXTstep and Haiku *always* have a pointing device (t (or (and (featurep 'xt-mouse) xterm-mouse-mode) @@ -2086,7 +2101,7 @@ frames and several different fonts at once. This is true for displays that use a window system such as X, and false for text-only terminals. DISPLAY can be a display name, a frame, or nil (meaning the selected frame's display)." - (not (null (memq (framep-on-display display) '(x w32 ns))))) + (not (null (memq (framep-on-display display) '(x w32 ns haiku))))) (defun display-images-p (&optional display) "Return non-nil if DISPLAY can display images. @@ -2137,7 +2152,7 @@ DISPLAY should be either a frame or a display name (a string). If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-screens display)) (t 1)))) @@ -2157,7 +2172,7 @@ with DISPLAY. To get information for each physical monitor, use `display-monitor-attributes-list'." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-pixel-height display)) (t (frame-height (if (framep display) display (selected-frame))))))) @@ -2177,7 +2192,7 @@ with DISPLAY. To get information for each physical monitor, use `display-monitor-attributes-list'." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-pixel-width display)) (t (frame-width (if (framep display) display (selected-frame))))))) @@ -2215,7 +2230,7 @@ For graphical terminals, note that on \"multi-monitor\" setups this refers to the height in millimeters for all physical monitors associated with DISPLAY. To get information for each physical monitor, use `display-monitor-attributes-list'." - (and (memq (framep-on-display display) '(x w32 ns)) + (and (memq (framep-on-display display) '(x w32 ns haiku)) (or (cddr (assoc (or display (frame-parameter nil 'display)) display-mm-dimensions-alist)) (cddr (assoc t display-mm-dimensions-alist)) @@ -2236,7 +2251,7 @@ For graphical terminals, note that on \"multi-monitor\" setups this refers to the width in millimeters for all physical monitors associated with DISPLAY. To get information for each physical monitor, use `display-monitor-attributes-list'." - (and (memq (framep-on-display display) '(x w32 ns)) + (and (memq (framep-on-display display) '(x w32 ns haiku)) (or (cadr (assoc (or display (frame-parameter nil 'display)) display-mm-dimensions-alist)) (cadr (assoc t display-mm-dimensions-alist)) @@ -2254,7 +2269,7 @@ DISPLAY can be a display name or a frame. If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-backing-store display)) (t 'not-useful)))) @@ -2267,7 +2282,7 @@ DISPLAY can be a display name or a frame. If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-save-under display)) (t 'not-useful)))) @@ -2280,7 +2295,7 @@ DISPLAY can be a display name or a frame. If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-planes display)) ((eq frame-type 'pc) 4) @@ -2295,7 +2310,7 @@ DISPLAY can be a display name or a frame. If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-color-cells display)) ((eq frame-type 'pc) 16) @@ -2312,7 +2327,7 @@ DISPLAY can be a display name or a frame. If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-visual-class display)) ((and (memq frame-type '(pc t)) (tty-display-color-p display)) diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 089decb83c..b922f192a9 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -88,7 +88,7 @@ (bindings--define-key map [separator-3] menu-bar-separator) (bindings--define-key map [set-terminal-coding-system] '(menu-item "For Terminal" set-terminal-coding-system - :enable (null (memq initial-window-system '(x w32 ns))) + :enable (null (memq initial-window-system '(x w32 ns haiku))) :help "How to encode terminal output")) (bindings--define-key map [set-keyboard-coding-system] '(menu-item "For Keyboard" set-keyboard-coding-system diff --git a/lisp/loadup.el b/lisp/loadup.el index 15a71ef244..ed1570e778 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -303,6 +303,11 @@ (load "term/common-win") (load "term/x-win"))) +(if (featurep 'haiku) + (progn + (load "term/common-win") + (load "term/haiku-win"))) + (if (or (eq system-type 'windows-nt) (featurep 'w32)) (progn @@ -558,6 +563,7 @@ lost after dumping"))) (delete-file output))))) ;; Recompute NAME now, so that it isn't set when we dump. (if (not (or (eq system-type 'ms-dos) + (eq system-type 'haiku) ;; BFS doesn't support hard links ;; Don't bother adding another name if we're just ;; building bootstrap-emacs. (member dump-mode '("pbootstrap" "bootstrap")))) diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index 94e75efeeb..274f594f69 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -2540,6 +2540,7 @@ See `menu-bar-mode' for more information." (declare-function x-menu-bar-open "term/x-win" (&optional frame)) (declare-function w32-menu-bar-open "term/w32-win" (&optional frame)) +(declare-function haiku-menu-bar-open "haikumenu.c" (&optional frame)) (defun lookup-key-ignore-too-long (map key) "Call `lookup-key' and convert numeric values to nil." @@ -2665,9 +2666,10 @@ first TTY menu-bar menu to be dropped down. Interactively, this is the numeric argument to the command. This function decides which method to use to access the menu depending on FRAME's terminal device. On X displays, it calls -`x-menu-bar-open'; on Windows, `w32-menu-bar-open'; otherwise it -calls either `popup-menu' or `tmm-menubar' depending on whether -`tty-menu-open-use-tmm' is nil or not. +`x-menu-bar-open'; on Windows, `w32-menu-bar-open'; on Haiku, +`haiku-menu-bar-open'; otherwise it calls either `popup-menu' +or `tmm-menubar' depending on whether `tty-menu-open-use-tmm' +is nil or not. If FRAME is nil or not given, use the selected frame." (interactive @@ -2676,6 +2678,7 @@ If FRAME is nil or not given, use the selected frame." (cond ((eq type 'x) (x-menu-bar-open frame)) ((eq type 'w32) (w32-menu-bar-open frame)) + ((eq type 'haiku) (haiku-menu-bar-open frame)) ((and (null tty-menu-open-use-tmm) (not (zerop (or (frame-parameter nil 'menu-bar-lines) 0)))) ;; Make sure the menu bar is up to date. One situation where diff --git a/lisp/mwheel.el b/lisp/mwheel.el index 3d0b8f07cb..cd84a10999 100644 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@ -55,7 +55,8 @@ (mouse-wheel-mode 1))) (defcustom mouse-wheel-down-event - (if (or (featurep 'w32-win) (featurep 'ns-win)) + (if (or (featurep 'w32-win) (featurep 'ns-win) + (featurep 'haiku-win)) 'wheel-up 'mouse-4) "Event used for scrolling down." @@ -71,7 +72,8 @@ :set 'mouse-wheel-change-button) (defcustom mouse-wheel-up-event - (if (or (featurep 'w32-win) (featurep 'ns-win)) + (if (or (featurep 'w32-win) (featurep 'ns-win) + (featurep 'haiku-win)) 'wheel-down 'mouse-5) "Event used for scrolling up." @@ -235,7 +237,8 @@ Also see `mouse-wheel-tilt-scroll'." "Function that does the job of scrolling right.") (defvar mouse-wheel-left-event - (if (or (featurep 'w32-win) (featurep 'ns-win)) + (if (or (featurep 'w32-win) (featurep 'ns-win) + (featurep 'haiku-win)) 'wheel-left 'mouse-6) "Event used for scrolling left.") @@ -245,7 +248,8 @@ Also see `mouse-wheel-tilt-scroll'." "Alternative wheel left event to consider.") (defvar mouse-wheel-right-event - (if (or (featurep 'w32-win) (featurep 'ns-win)) + (if (or (featurep 'w32-win) (featurep 'ns-win) + (featurep 'haiku-win)) 'wheel-right 'mouse-7) "Event used for scrolling right.") diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 3af37e412d..687bf6c884 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -39,6 +39,7 @@ ;; browse-url-chrome Chrome 47.0.2526.111 ;; browse-url-chromium Chromium 3.0 ;; browse-url-epiphany Epiphany Don't know +;; browse-url-webpositive WebPositive 1.2-alpha (Haiku R1/beta3) ;; browse-url-w3 w3 0 ;; browse-url-text-* Any text browser 0 ;; browse-url-generic arbitrary @@ -156,6 +157,7 @@ (function-item :tag "Google Chrome" :value browse-url-chrome) (function-item :tag "Chromium" :value browse-url-chromium) (function-item :tag "Epiphany" :value browse-url-epiphany) + (function-item :tag "WebPositive" :value browse-url-webpositive) (function-item :tag "Text browser in an xterm window" :value browse-url-text-xterm) (function-item :tag "Text browser in an Emacs window" @@ -366,6 +368,11 @@ Defaults to the value of `browse-url-epiphany-arguments' at the time `browse-url' is loaded." :type '(repeat (string :tag "Argument"))) +(defcustom browse-url-webpositive-program "WebPositive" + "The name by which to invoke WebPositive." + :type 'string + :version "28.1") + ;; GNOME means of invoking either Mozilla or Netscape. (defvar browse-url-gnome-moz-program "gnome-moz-remote") @@ -1050,6 +1057,7 @@ instead of `browse-url-new-window-flag'." ((executable-find browse-url-kde-program) 'browse-url-kde) ;;; ((executable-find browse-url-netscape-program) 'browse-url-netscape) ((executable-find browse-url-chrome-program) 'browse-url-chrome) + ((executable-find browse-url-webpositive-program) 'browse-url-webpositive) ((executable-find browse-url-xterm-program) 'browse-url-text-xterm) ((locate-library "w3") 'browse-url-w3) (t @@ -1376,6 +1384,18 @@ used instead of `browse-url-new-window-flag'." (defvar url-handler-regexp) +;;;###autoload +(defun browse-url-webpositive (url &optional _new-window) + "Ask the WebPositive WWW browser to load URL. +Default to the URL around or before point. +The optional argument NEW-WINDOW is not used." + (interactive (browse-url-interactive-arg "URL: ")) + (setq url (browse-url-encode-url url)) + (let* ((process-environment (browse-url-process-environment))) + (start-process (concat "WebPositive " url) nil "WebPositive" url))) + +(function-put 'browse-url-webpositive 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-emacs (url &optional same-window) "Ask Emacs to load URL into a buffer and show it in another window. diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 031a73143e..e86d21f889 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -239,7 +239,7 @@ parameter, and should return the (possibly) transformed URL." :version "29.1") (defface eww-form-submit - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "#808080" :foreground "black")) "Face for eww buffer buttons." @@ -247,7 +247,7 @@ parameter, and should return the (possibly) transformed URL." :group 'eww) (defface eww-form-file - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "#808080" :foreground "black")) "Face for eww buffer buttons." @@ -255,7 +255,7 @@ parameter, and should return the (possibly) transformed URL." :group 'eww) (defface eww-form-checkbox - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) "Face for eww buffer buttons." @@ -263,7 +263,7 @@ parameter, and should return the (possibly) transformed URL." :group 'eww) (defface eww-form-select - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) "Face for eww buffer buttons." diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el new file mode 100644 index 0000000000..36af10d2c7 --- /dev/null +++ b/lisp/term/haiku-win.el @@ -0,0 +1,134 @@ +;;; haiku-win.el --- set up windowing on Haiku -*- lexical-binding: t -*- + +;; Copyright (C) 2021 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: + +;; Support for using Haiku's BeOS derived windowing system. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(unless (featurep 'haiku) + (error "%s: Loading haiku-win without having Haiku" + invocation-name)) + +;; Documentation-purposes only: actually loaded in loadup.el. +(require 'frame) +(require 'mouse) +(require 'scroll-bar) +(require 'menu-bar) +(require 'fontset) +(require 'dnd) + +(add-to-list 'display-format-alist '(".*" . haiku-win)) + +;;;; Command line argument handling. + +(defvar x-invocation-args) +(defvar x-command-line-resources) + +(defvar haiku-initialized) + +(declare-function x-open-connection "haikufns.c") +(declare-function x-handle-args "common-win") +(declare-function haiku-selection-data "haikuselect.c") +(declare-function haiku-selection-put "haikuselect.c") +(declare-function haiku-put-resource "haikufns.c") + +(defun haiku--handle-x-command-line-resources (command-line-resources) + "Handle command line X resources specified with the option `-xrm'. +The resources should be a list of strings in COMMAND-LINE-RESOURCES." + (dolist (s command-line-resources) + (let ((components (split-string s ":"))) + (when (car components) + (haiku-put-resource (car components) + (string-trim-left + (mapconcat #'identity (cdr components) ":"))))))) + +(cl-defmethod window-system-initialization (&context (window-system haiku) + &optional display) + "Set up the window system. WINDOW-SYSTEM must be HAIKU. +DISPLAY may be set to the name of a display that will be initialized." + (cl-assert (not haiku-initialized)) + + (create-default-fontset) + (when x-command-line-resources + (haiku--handle-x-command-line-resources + (split-string x-command-line-resources "\n"))) + (x-open-connection (or display "be") x-command-line-resources t) + (setq haiku-initialized t)) + +(cl-defmethod frame-creation-function (params &context (window-system haiku)) + (x-create-frame-with-faces params)) + +(cl-defmethod handle-args-function (args &context (window-system haiku)) + (x-handle-args args)) + +(defun haiku--selection-type-to-mime (type) + "Convert symbolic selection type TYPE to its MIME equivalent. +If TYPE is nil, return \"text/plain\"." + (cond + ((memq type '(TEXT COMPOUND_TEXT STRING UTF8_STRING)) "text/plain") + ((stringp type) type) + (t "text/plain"))) + +(cl-defmethod gui-backend-get-selection (type data-type + &context (window-system haiku)) + (haiku-selection-data type (haiku--selection-type-to-mime data-type))) + +(cl-defmethod gui-backend-set-selection (type value + &context (window-system haiku)) + (haiku-selection-put type "text/plain" value)) + +(cl-defmethod gui-backend-selection-exists-p (selection + &context (window-system haiku)) + (haiku-selection-data selection "text/plain")) + +(cl-defmethod gui-backend-selection-owner-p (_ + &context (window-system haiku)) + t) + +(declare-function haiku-read-file-name "haikufns.c") + +(defun x-file-dialog (prompt dir default_filename mustmatch only_dir_p) + "SKIP: real doc in xfns.c." + (if (eq (framep-on-display (selected-frame)) 'haiku) + (haiku-read-file-name prompt (selected-frame) + (or dir (and default_filename + (file-name-directory default_filename))) + mustmatch only_dir_p + (file-name-nondirectory default_filename)) + (error "x-file-dialog on a tty frame"))) + +(defun haiku-dnd-handle-drag-n-drop-event (event) + "Handle specified drag-n-drop EVENT." + (interactive "e") + (let* ((string (caddr event)) + (window (posn-window (event-start event)))) + (with-selected-window window + (raise-frame) + (dnd-handle-one-url window 'private (concat "file:" string))))) + +(define-key special-event-map [drag-n-drop] + 'haiku-dnd-handle-drag-n-drop-event) + +(provide 'haiku-win) +(provide 'term/haiku-win) + +;;; haiku-win.el ends here diff --git a/lisp/tooltip.el b/lisp/tooltip.el index 23b67ee2ca..6cc482d012 100644 --- a/lisp/tooltip.el +++ b/lisp/tooltip.el @@ -368,10 +368,15 @@ It is also called if Tooltip mode is on, for text-only displays." ((equal-including-properties tooltip-help-message (current-message)) (message nil))))) +(declare-function menu-or-popup-active-p "xmenu.c" ()) + (defun tooltip-show-help (msg) "Function installed as `show-help-function'. MSG is either a help string to display, or nil to cancel the display." - (if (display-graphic-p) + (if (and (display-graphic-p) + (or (not (eq window-system 'haiku)) ;; On Haiku, there isn't a reliable way to show tooltips + ;; above menus. + (not (menu-or-popup-active-p)))) (let ((previous-help tooltip-help-message)) (setq tooltip-help-message msg) (cond ((null msg) diff --git a/lisp/version.el b/lisp/version.el index 3a3093fdd4..5d0a1ae37d 100644 --- a/lisp/version.el +++ b/lisp/version.el @@ -53,6 +53,8 @@ developing Emacs.") (defvar ns-version-string) (defvar cairo-version-string) +(declare-function haiku-get-version-string "haikufns.c") + (defun emacs-version (&optional here) "Return string describing the version of Emacs that is running. If optional argument HERE is non-nil, insert string at point. @@ -71,6 +73,8 @@ to the system configuration; look at `system-configuration' instead." ((featurep 'x-toolkit) ", X toolkit") ((featurep 'ns) (format ", NS %s" ns-version-string)) + ((featurep 'haiku) + (format ", Haiku %s" (haiku-get-version-string))) (t "")) (if (featurep 'cairo) (format ", cairo version %s" cairo-version-string) diff --git a/src/Makefile.in b/src/Makefile.in index 0aaaf91d39..d276df2247 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -34,6 +34,7 @@ top_builddir = @top_builddir@ abs_top_srcdir=@abs_top_srcdir@ VPATH = $(srcdir) CC = @CC@ +CXX = @CXX@ CFLAGS = @CFLAGS@ CPPFLAGS = @CPPFLAGS@ LDFLAGS = @LDFLAGS@ @@ -346,10 +347,17 @@ BUILD_DETAILS = @BUILD_DETAILS@ UNEXEC_OBJ = @UNEXEC_OBJ@ +HAIKU_OBJ = @HAIKU_OBJ@ +HAIKU_CXX_OBJ = @HAIKU_CXX_OBJ@ +HAIKU_LIBS = @HAIKU_LIBS@ +HAIKU_CFLAGS = @HAIKU_CFLAGS@ + DUMPING=@DUMPING@ CHECK_STRUCTS = @CHECK_STRUCTS@ HAVE_PDUMPER = @HAVE_PDUMPER@ +HAVE_BE_APP = @HAVE_BE_APP@ + ## ARM Macs require that all code have a valid signature. Since pdump ## invalidates the signature, we must re-sign to fix it. DO_CODESIGN=$(patsubst aarch64-apple-darwin%,yes,@configuration@) @@ -367,6 +375,9 @@ endif # Flags that might be in WARN_CFLAGS but are not valid for Objective C. NON_OBJC_CFLAGS = -Wignored-attributes -Wignored-qualifiers -Wopenmp-simd +# Ditto, but for C++. +NON_CXX_CFLAGS = -Wmissing-prototypes -Wnested-externs -Wold-style-definition \ + -Wstrict-prototypes -Wno-override-init # -Demacs makes some files produce the correct version for use in Emacs. # MYCPPFLAGS is for by-hand Emacs-specific overrides, e.g., @@ -382,17 +393,21 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \ $(HARFBUZZ_CFLAGS) $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) \ $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \ - $(WERROR_CFLAGS) + $(WERROR_CFLAGS) $(HAIKU_CFLAGS) ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS) ALL_OBJC_CFLAGS = $(EMACS_CFLAGS) \ $(filter-out $(NON_OBJC_CFLAGS),$(WARN_CFLAGS)) $(CFLAGS) \ $(GNU_OBJC_CFLAGS) +ALL_CXX_CFLAGS = $(EMACS_CFLAGS) \ + $(filter-out $(NON_CXX_CFLAGS),$(WARN_CFLAGS)) $(CXXFLAGS) -.SUFFIXES: .m +.SUFFIXES: .m .cc .c.o: $(AM_V_CC)$(CC) -c $(CPPFLAGS) $(ALL_CFLAGS) $(PROFILING_CFLAGS) $< .m.o: $(AM_V_CC)$(CC) -c $(CPPFLAGS) $(ALL_OBJC_CFLAGS) $(PROFILING_CFLAGS) $< +.cc.o: + $(AM_V_CXX)$(CXX) -c $(CPPFLAGS) $(ALL_CXX_CFLAGS) $(PROFILING_CFLAGS) $< ## lastfile must follow all files whose initialized data areas should ## be dumped as pure by dump-emacs. @@ -414,8 +429,10 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ thread.o systhread.o \ $(if $(HYBRID_MALLOC),sheap.o) \ $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ - $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ) -obj = $(base_obj) $(NS_OBJC_OBJ) + $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ) \ + $(HAIKU_OBJ) +doc_obj = $(base_obj) $(NS_OBJC_OBJ) +obj = $(doc_obj) $(HAIKU_CXX_OBJ) ## Object files used on some machine or other. ## These go in the DOC file on all machines in case they are needed. @@ -429,7 +446,8 @@ SOME_MACHINE_OBJECTS = dosfns.o msdos.o \ w32.o w32console.o w32cygwinx.o w32fns.o w32heap.o w32inevt.o w32notify.o \ w32menu.o w32proc.o w32reg.o w32select.o w32term.o w32xfns.o \ w16select.o widget.o xfont.o ftfont.o xftfont.o gtkutil.o \ - xsettings.o xgselect.o termcap.o hbfont.o + xsettings.o xgselect.o termcap.o hbfont.o \ + haikuterm.o haikufns.o haikumenu.o haikufont.o ## gmalloc.o if !SYSTEM_MALLOC && !DOUG_LEA_MALLOC, else empty. GMALLOC_OBJ=@GMALLOC_OBJ@ @@ -455,7 +473,11 @@ FIRSTFILE_OBJ=@FIRSTFILE_OBJ@ ALLOBJS = $(FIRSTFILE_OBJ) $(VMLIMIT_OBJ) $(obj) $(otherobj) # Must be first, before dep inclusion! +ifneq ($(HAVE_BE_APP),yes) all: emacs$(EXEEXT) $(pdmp) $(OTHER_FILES) +else +all: Emacs Emacs.pdmp $(OTHER_FILES) +endif ifeq ($(HAVE_NATIVE_COMP):$(NATIVE_DISABLED),yes:) all: ../native-lisp endif @@ -527,7 +549,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(HARFBUZZ_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \ $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ - $(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT_LIBS) $(XINPUT_LIBS) + $(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT_LIBS) $(XINPUT_LIBS) $(HAIKU_LIBS) ## FORCE it so that admin/unidata can decide whether this file is ## up-to-date. Although since charprop depends on bootstrap-emacs, @@ -584,6 +606,18 @@ else rm -f $@ && cp -f temacs$(EXEEXT) $@ endif +## On Haiku, also produce a binary named Emacs with the appropriate +## icon set. + +ifeq ($(HAVE_BE_APP),yes) +Emacs: emacs$(EXEEXT) + cp -f emacs$(EXEEXT) $@ + $(AM_V_GEN) $(libsrc)/be-resources \ + $(etc)/images/icons/hicolor/32x32/apps/emacs.png $@ +Emacs.pdmp: $(pdmp) + $(AM_V_GEN) cp -f $(pdmp) $@ +endif + ifeq ($(DUMPING),pdumper) $(pdmp): emacs$(EXEEXT) LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump \ @@ -602,11 +636,11 @@ endif ## for the first time, this prevents any variation between configurations ## in the contents of the DOC file. ## -$(etc)/DOC: lisp.mk $(libsrc)/make-docfile$(EXEEXT) $(obj) $(lisp) +$(etc)/DOC: lisp.mk $(libsrc)/make-docfile$(EXEEXT) $(doc_obj) $(lisp) $(AM_V_GEN)$(MKDIR_P) $(etc) $(AM_V_at)rm -f $(etc)/DOC $(AM_V_at)$(libsrc)/make-docfile -d $(srcdir) \ - $(SOME_MACHINE_OBJECTS) $(obj) > $(etc)/DOC + $(SOME_MACHINE_OBJECTS) $(doc_obj) > $(etc)/DOC $(AM_V_at)$(libsrc)/make-docfile -a $(etc)/DOC -d $(lispsource) \ $(shortlisp) @@ -624,7 +658,7 @@ buildobj.h: Makefile GLOBAL_SOURCES = $(base_obj:.o=.c) $(NS_OBJC_OBJ:.o=.m) gl-stamp: $(libsrc)/make-docfile$(EXEEXT) $(GLOBAL_SOURCES) - $(AM_V_GLOBALS)$(libsrc)/make-docfile -d $(srcdir) -g $(obj) > globals.tmp + $(AM_V_GLOBALS)$(libsrc)/make-docfile -d $(srcdir) -g $(doc_obj) > globals.tmp $(AM_V_at)$(top_srcdir)/build-aux/move-if-change globals.tmp globals.h $(AM_V_at)echo timestamp > $@ @@ -649,9 +683,15 @@ endif ## to start if Vinstallation_directory has the wrong value. temacs$(EXEEXT): $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \ $(charsets) $(charscript) ${emoji-zwj} $(MAKE_PDUMPER_FINGERPRINT) - $(AM_V_CCLD)$(CC) -o $@.tmp \ +ifeq ($(HAVE_BE_APP),yes) + $(AM_V_CXXLD)$(CXX) -o $@.tmp \ $(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \ + $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) -lstdc++ +else + $(AM_V_CCLD)$(CC) -o $@.tmp \ + $(ALL_CFLAGS) $(CXXFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \ $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) +endif ifeq ($(HAVE_PDUMPER),yes) $(AM_V_at)$(MAKE_PDUMPER_FINGERPRINT) $@.tmp ifeq ($(DO_CODESIGN),yes) @@ -736,6 +776,7 @@ ${ETAGS}: FORCE # to be built before we can get TAGS. ctagsfiles1 = $(filter-out ${srcdir}/macuvs.h, $(wildcard ${srcdir}/*.[hc])) ctagsfiles2 = $(wildcard ${srcdir}/*.m) +ctagsfiles3 = $(wildcard ${srcdir}/*.cc) ## In out-of-tree builds, TAGS are generated in the build dir, like ## other non-bootstrap build products (see Bug#31744). @@ -750,7 +791,8 @@ TAGS: ${ETAGS} $(ctagsfiles1) $(ctagsfiles2) $(ctagsfiles1) \ --regex='{objc}/[ ]*DEFVAR_[A-Z_ (]+"\([^"]+\)"/\1/' \ --regex='{objc}/[ ]*DEFVAR_[A-Z_ (]+"[^"]+",[ ]\([A-Za-z0-9_]+\)/\1/' \ - $(ctagsfiles2) + $(ctagsfiles2) \ + $(ctagsfiles3) ## Arrange to make tags tables for ../lisp and ../lwlib, ## which the above TAGS file for the C files includes by reference. diff --git a/src/alloc.c b/src/alloc.c index aa790d3afa..f8908c91db 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6149,6 +6149,10 @@ garbage_collect (void) xg_mark_data (); #endif +#ifdef HAVE_HAIKU + mark_haiku_display (); +#endif + #ifdef HAVE_WINDOW_SYSTEM mark_fringe_data (); #endif diff --git a/src/dispextern.h b/src/dispextern.h index f17f095e0d..a698f6546b 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -134,6 +134,13 @@ typedef Emacs_Pixmap Emacs_Pix_Context; #define FACE_COLOR_TO_PIXEL(face_color, frame) face_color #endif +#ifdef HAVE_HAIKU +#include "haikugui.h" +typedef struct haiku_display_info Display_Info; +typedef Emacs_Pixmap Emacs_Pix_Container; +typedef Emacs_Pixmap Emacs_Pix_Context; +#endif + #ifdef HAVE_WINDOW_SYSTEM # include # include "fontset.h" @@ -3011,7 +3018,7 @@ struct redisplay_interface #ifdef HAVE_WINDOW_SYSTEM # if (defined USE_CAIRO || defined HAVE_XRENDER \ - || defined HAVE_NS || defined HAVE_NTGUI) + || defined HAVE_NS || defined HAVE_NTGUI || defined HAVE_HAIKU) # define HAVE_NATIVE_TRANSFORMS # endif @@ -3050,6 +3057,14 @@ struct image #ifdef HAVE_NTGUI XFORM xform; #endif +#ifdef HAVE_HAIKU + /* Non-zero if the image has not yet been transformed for display. */ + int have_be_transforms_p; + + double be_rotate; + double be_scale_x; + double be_scale_y; +#endif /* Colors allocated for this image, if any. Allocated via xmalloc. */ unsigned long *colors; @@ -3489,7 +3504,8 @@ bool valid_image_p (Lisp_Object); void prepare_image_for_display (struct frame *, struct image *); ptrdiff_t lookup_image (struct frame *, Lisp_Object, int); -#if defined HAVE_X_WINDOWS || defined USE_CAIRO || defined HAVE_NS +#if defined HAVE_X_WINDOWS || defined USE_CAIRO || defined HAVE_NS \ + || defined HAVE_HAIKU #define RGB_PIXEL_COLOR unsigned long #endif diff --git a/src/dispnew.c b/src/dispnew.c index 632eec2f03..f3f110a8f2 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -6146,7 +6146,7 @@ sit_for (Lisp_Object timeout, bool reading, int display_option) wrong_type_argument (Qnumberp, timeout); -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) gobble_input (); #endif @@ -6453,6 +6453,15 @@ init_display_interactive (void) } #endif +#ifdef HAVE_HAIKU + if (!inhibit_window_system && !will_dump_p ()) + { + Vinitial_window_system = Qhaiku; + Vwindow_system_version = make_fixnum (1); + return; + } +#endif + /* If no window system has been specified, try to use the terminal. */ if (! isatty (STDIN_FILENO)) fatal ("standard input is not a tty"); diff --git a/src/emacs.c b/src/emacs.c index 032b27fcf3..63f2a39308 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -109,6 +109,10 @@ along with GNU Emacs. If not, see . */ #include "getpagesize.h" #include "gnutls.h" +#ifdef HAVE_HAIKU +#include +#endif + #ifdef PROFILING # include extern void moncontrol (int mode); @@ -2207,6 +2211,18 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_fontset (); #endif /* HAVE_NS */ +#ifdef HAVE_HAIKU + syms_of_haikuterm (); + syms_of_haikufns (); + syms_of_haikumenu (); + syms_of_haikufont (); + syms_of_haikuselect (); +#ifdef HAVE_NATIVE_IMAGE_API + syms_of_haikuimage (); +#endif + syms_of_fontset (); +#endif /* HAVE_HAIKU */ + syms_of_gnutls (); #ifdef HAVE_INOTIFY @@ -2261,6 +2277,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #if defined WINDOWSNT || defined HAVE_NTGUI globals_of_w32select (); #endif + +#ifdef HAVE_HAIKU + init_haiku_select (); +#endif } init_charset (); @@ -2728,6 +2748,9 @@ shut_down_emacs (int sig, Lisp_Object stuff) /* Don't update display from now on. */ Vinhibit_redisplay = Qt; +#ifdef HAVE_HAIKU + be_app_quit (); +#endif /* If we are controlling the terminal, reset terminal modes. */ #ifndef DOS_NT pid_t tpgrp = tcgetpgrp (STDIN_FILENO); @@ -2737,6 +2760,10 @@ shut_down_emacs (int sig, Lisp_Object stuff) if (sig && sig != SIGTERM) { static char const fmt[] = "Fatal error %d: %n%s\n"; +#ifdef HAVE_HAIKU + if (haiku_debug_on_fatal_error) + debugger ("Fatal error in Emacs"); +#endif char buf[max ((sizeof fmt - sizeof "%d%n%s\n" + INT_STRLEN_BOUND (int) + 1), min (PIPE_BUF, MAX_ALLOCA))]; @@ -3229,6 +3256,7 @@ Special values: `ms-dos' compiled as an MS-DOS application. `windows-nt' compiled as a native W32 application. `cygwin' compiled using the Cygwin library. + `haiku' compiled for a Haiku system. Anything else (in Emacs 26, the possibilities are: aix, berkeley-unix, hpux, usg-unix-v) indicates some sort of Unix system. */); Vsystem_type = intern_c_string (SYSTEM_TYPE); diff --git a/src/fileio.c b/src/fileio.c index 4015448ece..859b30564a 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -6190,7 +6190,7 @@ before any other event (mouse or keypress) is handled. */) (void) { #if (defined USE_GTK || defined USE_MOTIF \ - || defined HAVE_NS || defined HAVE_NTGUI) + || defined HAVE_NS || defined HAVE_NTGUI || defined HAVE_HAIKU) if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event)) && use_dialog_box && use_file_dialog diff --git a/src/filelock.c b/src/filelock.c index cc185d96cd..c12776246b 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -65,7 +65,7 @@ along with GNU Emacs. If not, see . */ #define BOOT_TIME_FILE "/var/run/random-seed" #endif -#if !defined WTMP_FILE && !defined WINDOWSNT +#if !defined WTMP_FILE && !defined WINDOWSNT && defined BOOT_TIME #define WTMP_FILE "/var/log/wtmp" #endif diff --git a/src/floatfns.c b/src/floatfns.c index aadae4fd9d..f52dae4719 100644 --- a/src/floatfns.c +++ b/src/floatfns.c @@ -347,6 +347,21 @@ int double_integer_scale (double d) { int exponent = ilogb (d); +#ifdef HAIKU + /* On Haiku, the values returned by ilogb are nonsensical when + confronted with tiny numbers, inf, or NaN, which breaks the trick + used by code on other platforms, so we have to test for each case + manually, and return the appropriate value. */ + if (exponent == FP_ILOGB0) + { + if (isnan (d)) + return (DBL_MANT_DIG - DBL_MIN_EXP) + 2; + if (isinf (d)) + return (DBL_MANT_DIG - DBL_MIN_EXP) + 1; + + return (DBL_MANT_DIG - DBL_MIN_EXP); + } +#endif return (DBL_MIN_EXP - 1 <= exponent && exponent < INT_MAX ? DBL_MANT_DIG - 1 - exponent : (DBL_MANT_DIG - DBL_MIN_EXP diff --git a/src/font.c b/src/font.c index b503123b96..d423fd46b7 100644 --- a/src/font.c +++ b/src/font.c @@ -5751,6 +5751,9 @@ match. */); #ifdef HAVE_NTGUI syms_of_w32font (); #endif /* HAVE_NTGUI */ +#ifdef USE_BE_CAIRO + syms_of_ftcrfont (); +#endif #endif /* HAVE_WINDOW_SYSTEM */ } diff --git a/src/font.h b/src/font.h index 6694164e09..2da5ec4504 100644 --- a/src/font.h +++ b/src/font.h @@ -965,7 +965,7 @@ extern struct font_driver const nsfont_driver; extern void syms_of_nsfont (void); extern void syms_of_macfont (void); #endif /* HAVE_NS */ -#ifdef USE_CAIRO +#if defined (USE_CAIRO) || defined (USE_BE_CAIRO) extern struct font_driver const ftcrfont_driver; #ifdef HAVE_HARFBUZZ extern struct font_driver ftcrhbfont_driver; @@ -999,7 +999,7 @@ extern void font_deferred_log (const char *, Lisp_Object, Lisp_Object); INLINE bool font_data_structures_may_be_ill_formed (void) { -#ifdef USE_CAIRO +#if defined USE_CAIRO || defined USE_BE_CAIRO /* Although this works around Bug#20890, it is probably not the right thing to do. */ return gc_in_progress; diff --git a/src/frame.c b/src/frame.c index 79a7c89e0d..a21dd0d927 100644 --- a/src/frame.c +++ b/src/frame.c @@ -226,6 +226,7 @@ Value is: `w32' for an Emacs frame that is a window on MS-Windows display, `ns' for an Emacs frame on a GNUstep or Macintosh Cocoa display, `pc' for a direct-write MS-DOS frame. + `haiku` for an Emacs frame running in Haiku. See also `frame-live-p'. */) (Lisp_Object object) { @@ -244,6 +245,8 @@ See also `frame-live-p'. */) return Qpc; case output_ns: return Qns; + case output_haiku: + return Qhaiku; default: emacs_abort (); } @@ -6020,6 +6023,7 @@ syms_of_frame (void) DEFSYM (Qw32, "w32"); DEFSYM (Qpc, "pc"); DEFSYM (Qns, "ns"); + DEFSYM (Qhaiku, "haiku"); DEFSYM (Qvisible, "visible"); DEFSYM (Qbuffer_predicate, "buffer-predicate"); DEFSYM (Qbuffer_list, "buffer-list"); diff --git a/src/frame.h b/src/frame.h index 3dd76805dd..cb2bad71c5 100644 --- a/src/frame.h +++ b/src/frame.h @@ -585,6 +585,7 @@ struct frame struct x_output *x; /* From xterm.h. */ struct w32_output *w32; /* From w32term.h. */ struct ns_output *ns; /* From nsterm.h. */ + struct haiku_output *haiku; /* From haikuterm.h. */ } output_data; @@ -852,6 +853,11 @@ default_pixels_per_inch_y (void) #else #define FRAME_NS_P(f) ((f)->output_method == output_ns) #endif +#ifndef HAVE_HAIKU +#define FRAME_HAIKU_P(f) false +#else +#define FRAME_HAIKU_P(f) ((f)->output_method == output_haiku) +#endif /* FRAME_WINDOW_P tests whether the frame is a graphical window system frame. */ @@ -864,6 +870,9 @@ default_pixels_per_inch_y (void) #ifdef HAVE_NS #define FRAME_WINDOW_P(f) FRAME_NS_P(f) #endif +#ifdef HAVE_HAIKU +#define FRAME_WINDOW_P(f) FRAME_HAIKU_P (f) +#endif #ifndef FRAME_WINDOW_P #define FRAME_WINDOW_P(f) ((void) (f), false) #endif diff --git a/src/ftcrfont.c b/src/ftcrfont.c index db417b3e77..5d75f18357 100644 --- a/src/ftcrfont.c +++ b/src/ftcrfont.c @@ -22,7 +22,13 @@ along with GNU Emacs. If not, see . */ #include #include "lisp.h" +#ifdef HAVE_X_WINDOWS #include "xterm.h" +#else /* Otherwise, Haiku */ +#include "haikuterm.h" +#include "haiku_support.h" +#include "termchar.h" +#endif #include "blockinput.h" #include "charset.h" #include "composite.h" @@ -30,6 +36,12 @@ along with GNU Emacs. If not, see . */ #include "ftfont.h" #include "pdumper.h" +#ifdef USE_BE_CAIRO +#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff) +#define GREEN_FROM_ULONG(color) (((color) >> 8) & 0xff) +#define BLUE_FROM_ULONG(color) ((color) & 0xff) +#endif + #define METRICS_NCOLS_PER_ROW (128) enum metrics_status @@ -513,11 +525,37 @@ ftcrfont_draw (struct glyph_string *s, block_input (); +#ifndef USE_BE_CAIRO cr = x_begin_cr_clip (f, s->gc); +#else + BView_draw_lock (FRAME_HAIKU_VIEW (f)); + EmacsWindow_begin_cr_critical_section (FRAME_HAIKU_WINDOW (f)); + cr = haiku_begin_cr_clip (f, s); + if (!cr) + { + BView_draw_unlock (FRAME_HAIKU_VIEW (f)); + EmacsWindow_end_cr_critical_section (FRAME_HAIKU_WINDOW (f)); + unblock_input (); + return 0; + } + BView_cr_dump_clipping (FRAME_HAIKU_VIEW (f), cr); +#endif if (with_background) { +#ifndef USE_BE_CAIRO x_set_cr_source_with_gc_background (f, s->gc); + s->background_filled_p = 1; +#else + struct face *face = s->face; + + uint32_t col = s->hl == DRAW_CURSOR ? + FRAME_CURSOR_COLOR (s->f).pixel : face->background; + + cairo_set_source_rgb (cr, RED_FROM_ULONG (col) / 255.0, + GREEN_FROM_ULONG (col) / 255.0, + BLUE_FROM_ULONG (col) / 255.0); +#endif cairo_rectangle (cr, x, y - FONT_BASE (face->font), s->width, FONT_HEIGHT (face->font)); cairo_fill (cr); @@ -533,13 +571,25 @@ ftcrfont_draw (struct glyph_string *s, glyphs[i].index, NULL)); } - +#ifndef USE_BE_CAIRO x_set_cr_source_with_gc_foreground (f, s->gc); +#else + uint32_t col = s->hl == DRAW_CURSOR ? + FRAME_OUTPUT_DATA (s->f)->cursor_fg : face->foreground; + + cairo_set_source_rgb (cr, RED_FROM_ULONG (col) / 255.0, + GREEN_FROM_ULONG (col) / 255.0, + BLUE_FROM_ULONG (col) / 255.0); +#endif cairo_set_scaled_font (cr, ftcrfont_info->cr_scaled_font); cairo_show_glyphs (cr, glyphs, len); - +#ifndef USE_BE_CAIRO x_end_cr_clip (f); - +#else + haiku_end_cr_clip (cr); + EmacsWindow_end_cr_critical_section (FRAME_HAIKU_WINDOW (f)); + BView_draw_unlock (FRAME_HAIKU_VIEW (f)); +#endif unblock_input (); return len; diff --git a/src/ftfont.c b/src/ftfont.c index 03e44ec30e..cf592759ab 100644 --- a/src/ftfont.c +++ b/src/ftfont.c @@ -3108,6 +3108,10 @@ syms_of_ftfont (void) Fput (Qfreetype, Qfont_driver_superseded_by, Qfreetypehb); #endif /* HAVE_HARFBUZZ */ +#ifdef HAVE_HAIKU + DEFSYM (Qmono, "mono"); +#endif + /* Fontconfig's generic families and their aliases. */ DEFSYM (Qmonospace, "monospace"); DEFSYM (Qsans_serif, "sans-serif"); diff --git a/src/ftfont.h b/src/ftfont.h index f771dc159b..0e0bebb6f6 100644 --- a/src/ftfont.h +++ b/src/ftfont.h @@ -29,6 +29,10 @@ along with GNU Emacs. If not, see . */ # include FT_BDF_H #endif +#ifdef USE_BE_CAIRO +#include +#endif + #ifdef HAVE_HARFBUZZ #include #include @@ -62,7 +66,7 @@ struct font_info hb_font_t *hb_font; #endif /* HAVE_HARFBUZZ */ -#ifdef USE_CAIRO +#if defined (USE_CAIRO) || defined (USE_BE_CAIRO) cairo_scaled_font_t *cr_scaled_font; /* Scale factor from the bitmap strike metrics in 1/64 pixels, used as the hb_position_t value in HarfBuzz, to those in (scaled) diff --git a/src/haiku.c b/src/haiku.c new file mode 100644 index 0000000000..485d86983c --- /dev/null +++ b/src/haiku.c @@ -0,0 +1,286 @@ +/* Haiku subroutines that are general to the Haiku operating system. + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include "lisp.h" +#include "process.h" +#include "coding.h" + +#include + +#include +#include + +Lisp_Object +list_system_processes (void) +{ + team_info info; + int32 cookie = 0; + Lisp_Object lval = Qnil; + + while (get_next_team_info (&cookie, &info) == B_OK) + lval = Fcons (make_fixnum (info.team), lval); + + return lval; +} + +Lisp_Object +system_process_attributes (Lisp_Object pid) +{ + CHECK_FIXNUM (pid); + + team_info info; + Lisp_Object lval = Qnil; + thread_info inf; + area_info area; + team_id id = (team_id) XFIXNUM (pid); + struct passwd *g; + size_t mem = 0; + + if (get_team_info (id, &info) != B_OK) + return Qnil; + + bigtime_t everything = 0, vsample = 0; + bigtime_t cpu_eaten = 0, esample = 0; + + lval = Fcons (Fcons (Qeuid, make_fixnum (info.uid)), lval); + lval = Fcons (Fcons (Qegid, make_fixnum (info.gid)), lval); + lval = Fcons (Fcons (Qthcount, make_fixnum (info.thread_count)), lval); + lval = Fcons (Fcons (Qcomm, build_string_from_utf8 (info.args)), lval); + + g = getpwuid (info.uid); + + if (g && g->pw_name) + lval = Fcons (Fcons (Quser, build_string (g->pw_name)), lval); + + /* FIXME: Calculating this makes Emacs show up as using 100% CPU! */ + + for (int32 team_cookie = 0; + get_next_team_info (&team_cookie, &info) == B_OK;) + for (int32 thread_cookie = 0; + get_next_thread_info (info.team, &thread_cookie, &inf) == B_OK;) + { + if (inf.team == id && strncmp (inf.name, "idle thread ", 12)) + cpu_eaten += inf.user_time + inf.kernel_time; + everything += inf.user_time + inf.kernel_time; + } + + sleep (0.05); + + for (int32 team_cookie = 0; + get_next_team_info (&team_cookie, &info) == B_OK;) + for (int32 thread_cookie = 0; + get_next_thread_info (info.team, &thread_cookie, &inf) == B_OK;) + { + if (inf.team == id && strncmp (inf.name, "idle thread ", 12)) + esample += inf.user_time + inf.kernel_time; + vsample += inf.user_time + inf.kernel_time; + } + + cpu_eaten = esample - cpu_eaten; + everything = vsample - everything; + + if (everything) + lval = Fcons (Fcons (Qpcpu, make_float (((double) (cpu_eaten) / + (double) (everything)) * 100)), + lval); + else + lval = Fcons (Fcons (Qpcpu, make_float (0.0)), lval); + + for (ssize_t area_cookie = 0; + get_next_area_info (id, &area_cookie, &area) == B_OK;) + mem += area.ram_size; + + system_info sinfo; + get_system_info (&sinfo); + int64 max = (int64) sinfo.max_pages * B_PAGE_SIZE; + + lval = Fcons (Fcons (Qpmem, make_float (((double) mem / + (double) max) * 100)), + lval); + lval = Fcons (Fcons (Qrss, make_fixnum (mem / 1024)), lval); + + return lval; +} + + +/* Borrowed from w32 implementation. */ + +struct load_sample +{ + time_t sample_time; + bigtime_t idle; + bigtime_t kernel; + bigtime_t user; +}; + +/* We maintain 1-sec samples for the last 16 minutes in a circular buffer. */ +static struct load_sample samples[16*60]; +static int first_idx = -1, last_idx = -1; +static int max_idx = ARRAYELTS (samples); +static unsigned num_of_processors = 0; + +static int +buf_next (int from) +{ + int next_idx = from + 1; + + if (next_idx >= max_idx) + next_idx = 0; + + return next_idx; +} + +static int +buf_prev (int from) +{ + int prev_idx = from - 1; + + if (prev_idx < 0) + prev_idx = max_idx - 1; + + return prev_idx; +} + +static double +getavg (int which) +{ + double retval = -1.0; + double tdiff; + int idx; + double span = (which == 0 ? 1.0 : (which == 1 ? 5.0 : 15.0)) * 60; + time_t now = samples[last_idx].sample_time; + + if (first_idx != last_idx) + { + for (idx = buf_prev (last_idx); ; idx = buf_prev (idx)) + { + tdiff = difftime (now, samples[idx].sample_time); + if (tdiff >= span - 2 * DBL_EPSILON * now) + { + long double sys = + (samples[last_idx].kernel + samples[last_idx].user) - + (samples[idx].kernel + samples[idx].user); + long double idl = samples[last_idx].idle - samples[idx].idle; + + retval = (idl / (sys + idl)) * num_of_processors; + break; + } + if (idx == first_idx) + break; + } + } + + return retval; +} + +static void +sample_sys_load (bigtime_t *idle, bigtime_t *system, bigtime_t *user) +{ + bigtime_t i = 0, s = 0, u = 0; + team_info info; + thread_info inf; + + for (int32 team_cookie = 0; + get_next_team_info (&team_cookie, &info) == B_OK;) + for (int32 thread_cookie = 0; + get_next_thread_info (info.team, &thread_cookie, &inf) == B_OK;) + { + if (!strncmp (inf.name, "idle thread ", 12)) + i += inf.user_time + inf.kernel_time; + else + s += inf.kernel_time, u += inf.user_time; + } + + *idle = i; + *system = s; + *user = u; +} + +int +getloadavg (double loadavg[], int nelem) +{ + int elem; + bigtime_t idle, kernel, user; + time_t now = time (NULL); + + if (num_of_processors <= 0) + { + system_info i; + if (get_system_info (&i) == B_OK) + num_of_processors = i.cpu_count; + } + + /* If system time jumped back for some reason, delete all samples + whose time is later than the current wall-clock time. This + prevents load average figures from becoming frozen for prolonged + periods of time, when system time is reset backwards. */ + if (last_idx >= 0) + { + while (difftime (now, samples[last_idx].sample_time) < -1.0) + { + if (last_idx == first_idx) + { + first_idx = last_idx = -1; + break; + } + last_idx = buf_prev (last_idx); + } + } + + /* Store another sample. We ignore samples that are less than 1 sec + apart. */ + if (last_idx < 0 + || (difftime (now, samples[last_idx].sample_time) + >= 1.0 - 2 * DBL_EPSILON * now)) + { + sample_sys_load (&idle, &kernel, &user); + last_idx = buf_next (last_idx); + samples[last_idx].sample_time = now; + samples[last_idx].idle = idle; + samples[last_idx].kernel = kernel; + samples[last_idx].user = user; + /* If the buffer has more that 15 min worth of samples, discard + the old ones. */ + if (first_idx == -1) + first_idx = last_idx; + while (first_idx != last_idx + && (difftime (now, samples[first_idx].sample_time) + >= 15.0 * 60 + 2 * DBL_EPSILON * now)) + first_idx = buf_next (first_idx); + } + + for (elem = 0; elem < nelem; elem++) + { + double avg = getavg (elem); + + if (avg < 0) + break; + loadavg[elem] = avg; + } + + /* Always return at least one element, otherwise load-average + returns nil, and Lisp programs might decide we cannot measure + system load. For example, jit-lock-stealth-load's defcustom + might decide that feature is "unsupported". */ + if (elem == 0) + loadavg[elem++] = 0.09; /* < display-time-load-average-threshold */ + + return elem; +} diff --git a/src/haiku_draw_support.cc b/src/haiku_draw_support.cc new file mode 100644 index 0000000000..5b1eccfbe6 --- /dev/null +++ b/src/haiku_draw_support.cc @@ -0,0 +1,488 @@ +/* Haiku window system support. Hey, Emacs, this is -*- C++ -*- + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include +#include +#include +#include +#include + +#include + +#include "haiku_support.h" + +#define RGB_TO_UINT32(r, g, b) ((255 << 24) | ((r) << 16) | ((g) << 8) | (b)) +#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff) +#define GREEN_FROM_ULONG(color) (((color) >> 8) & 0xff) +#define BLUE_FROM_ULONG(color) ((color) & 0xff) + +#define RGB_COLOR_UINT32(r) RGB_TO_UINT32 ((r).red, (r).green, (r).blue) + +static void +rgb32_to_rgb_color (uint32_t rgb, rgb_color *color) +{ + color->red = RED_FROM_ULONG (rgb); + color->green = GREEN_FROM_ULONG (rgb); + color->blue = BLUE_FROM_ULONG (rgb); + color->alpha = 255; +} + +static BView * +get_view (void *vw) +{ + BView *view = (BView *) find_appropriate_view_for_draw (vw); + return view; +} + +void +BView_StartClip (void *view) +{ + BView *vw = get_view (view); + vw->PushState (); +} + +void +BView_EndClip (void *view) +{ + BView *vw = get_view (view); + vw->PopState (); +} + +void +BView_SetHighColor (void *view, uint32_t color) +{ + BView *vw = get_view (view); + rgb_color col; + rgb32_to_rgb_color (color, &col); + + vw->SetHighColor (col); +} + +void +BView_SetLowColor (void *view, uint32_t color) +{ + BView *vw = get_view (view); + rgb_color col; + rgb32_to_rgb_color (color, &col); + + vw->SetLowColor (col); +} + +void +BView_SetPenSize (void *view, int u) +{ + BView *vw = get_view (view); + vw->SetPenSize (u); +} + +void +BView_FillRectangle (void *view, int x, int y, int width, int height) +{ + BView *vw = get_view (view); + BRect rect = BRect (x, y, x + width - 1, y + height - 1); + + vw->FillRect (rect); +} + +void +BView_FillRectangleAbs (void *view, int x, int y, int x1, int y1) +{ + BView *vw = get_view (view); + BRect rect = BRect (x, y, x1, y1); + + vw->FillRect (rect); +} + +void +BView_StrokeRectangle (void *view, int x, int y, int width, int height) +{ + BView *vw = get_view (view); + BRect rect = BRect (x, y, x + width - 1, y + height - 1); + + vw->StrokeRect (rect); +} + +void +BView_SetViewColor (void *view, uint32_t color) +{ + BView *vw = get_view (view); + rgb_color col; + rgb32_to_rgb_color (color, &col); + +#ifndef USE_BE_CAIRO + vw->SetViewColor (col); +#else + vw->SetViewColor (B_TRANSPARENT_32_BIT); +#endif +} + +void +BView_ClipToRect (void *view, int x, int y, int width, int height) +{ + BView *vw = get_view (view); + BRect rect = BRect (x, y, x + width - 1, y + height - 1); + + vw->ClipToRect (rect); +} + +void +BView_ClipToInverseRect (void *view, int x, int y, int width, int height) +{ + BView *vw = get_view (view); + BRect rect = BRect (x, y, x + width - 1, y + height - 1); + + vw->ClipToInverseRect (rect); +} + +void +BView_StrokeLine (void *view, int sx, int sy, int tx, int ty) +{ + BView *vw = get_view (view); + BPoint from = BPoint (sx, sy); + BPoint to = BPoint (tx, ty); + + vw->StrokeLine (from, to); +} + +void +BView_SetFont (void *view, void *font) +{ + BView *vw = get_view (view); + + vw->SetFont ((BFont *) font); +} + +void +BView_MovePenTo (void *view, int x, int y) +{ + BView *vw = get_view (view); + BPoint pt = BPoint (x, y); + + vw->MovePenTo (pt); +} + +void +BView_DrawString (void *view, const char *chr, ptrdiff_t len) +{ + BView *vw = get_view (view); + + vw->DrawString (chr, len); +} + +void +BView_DrawChar (void *view, char chr) +{ + BView *vw = get_view (view); + + vw->DrawChar (chr); +} + +void +BView_CopyBits (void *view, int x, int y, int width, int height, + int tox, int toy, int towidth, int toheight) +{ + BView *vw = get_view (view); + + vw->CopyBits (BRect (x, y, x + width - 1, y + height - 1), + BRect (tox, toy, tox + towidth - 1, toy + toheight - 1)); + vw->Sync (); +} + +/* Convert RGB32 color color from RGB color space to its + HSL components pointed to by H, S and L. */ +void +rgb_color_hsl (uint32_t rgb, double *h, double *s, double *l) +{ + rgb_color col; + rgb32_to_rgb_color (rgb, &col); + + double red = col.red / 255.0; + double green = col.green / 255.0; + double blue = col.blue / 255.0; + + double max = std::fmax (std::fmax (red, blue), green); + double min = std::fmin (std::fmin (red, blue), green); + double delta = max - min; + *l = (max + min) / 2.0; + + if (!delta) + { + *h = 0; + *s = 0; + return; + } + + *s = (*l < 0.5) ? delta / (max + min) : + delta / (20 - max - min); + double rc = (max - red) / delta; + double gc = (max - green) / delta; + double bc = (max - blue) / delta; + + if (red == max) + *h = bc - gc; + else if (green == max) + *h = 2.0 + rc + -bc; + else + *h = 4.0 + gc + -rc; + *h = std::fmod (*h / 6, 1.0); +} + +static double +hue_to_rgb (double v1, double v2, double h) +{ + if (h < 1 / 6) + return v1 + (v2 - v1) * h * 6.0; + else if (h < 0.5) + return v2; + else if (h < 2.0 / 3) + return v1 + (v2 - v1) * (2.0 / 3 - h) * 6.0; + return v1; +} + +void +hsl_color_rgb (double h, double s, double l, uint32_t *rgb) +{ + if (!s) + *rgb = RGB_TO_UINT32 (std::lrint (l * 255), + std::lrint (l * 255), + std::lrint (l * 255)); + else + { + double m2 = l <= 0.5 ? l * (1 + s) : l + s - l * s; + double m1 = 2.0 * l - m2; + + *rgb = RGB_TO_UINT32 + (std::lrint (hue_to_rgb (m1, m2, + std::fmod (h + 1 / 3.0, 1)) * 255), + std::lrint (hue_to_rgb (m1, m2, h) * 255), + std::lrint (hue_to_rgb (m1, m2, + std::fmod (h - 1 / 3.0, 1)) * 255)); + } +} + +void +BView_DrawBitmap (void *view, void *bitmap, int x, int y, + int width, int height, int vx, int vy, int vwidth, + int vheight) +{ + BView *vw = get_view (view); + BBitmap *bm = (BBitmap *) bitmap; + + vw->PushState (); + vw->SetDrawingMode (B_OP_OVER); + vw->DrawBitmap (bm, BRect (x, y, x + width - 1, y + height - 1), + BRect (vx, vy, vx + vwidth - 1, vy + vheight - 1)); + vw->PopState (); +} + +void +BView_DrawBitmapWithEraseOp (void *view, void *bitmap, int x, + int y, int width, int height) +{ + BView *vw = get_view (view); + BBitmap *bm = (BBitmap *) bitmap; + BBitmap bc (bm->Bounds (), B_RGBA32); + BRect rect (x, y, x + width - 1, y + height - 1); + + if (bc.InitCheck () != B_OK || bc.ImportBits (bm) != B_OK) + return; + + uint32_t *bits = (uint32_t *) bc.Bits (); + size_t stride = bc.BytesPerRow (); + + if (bm->ColorSpace () == B_GRAY1) + { + rgb_color low_color = vw->LowColor (); + for (int y = 0; y <= bc.Bounds ().Height (); ++y) + { + for (int x = 0; x <= bc.Bounds ().Width (); ++x) + { + if (bits[y * (stride / 4) + x] == 0xFF000000) + bits[y * (stride / 4) + x] = RGB_COLOR_UINT32 (low_color); + else + bits[y * (stride / 4) + x] = 0; + } + } + } + + vw->PushState (); + vw->SetDrawingMode (bm->ColorSpace () == B_GRAY1 ? B_OP_OVER : B_OP_ERASE); + vw->DrawBitmap (&bc, rect); + vw->PopState (); +} + +void +BView_DrawMask (void *src, void *view, + int x, int y, int width, int height, + int vx, int vy, int vwidth, int vheight, + uint32_t color) +{ + BBitmap *source = (BBitmap *) src; + BBitmap bm (source->Bounds (), B_RGBA32); + if (bm.InitCheck () != B_OK) + return; + for (int y = 0; y <= bm.Bounds ().Height (); ++y) + { + for (int x = 0; x <= bm.Bounds ().Width (); ++x) + { + int bit = haiku_get_pixel ((void *) source, x, y); + + if (!bit) + haiku_put_pixel ((void *) &bm, x, y, ((uint32_t) 255 << 24) | color); + else + haiku_put_pixel ((void *) &bm, x, y, 0); + } + } + BView *vw = get_view (view); + vw->SetDrawingMode (B_OP_OVER); + vw->DrawBitmap (&bm, BRect (x, y, x + width - 1, y + height - 1), + BRect (vx, vy, vx + vwidth - 1, vy + vheight - 1)); +} + +static BBitmap * +rotate_bitmap_270 (BBitmap *bmp) +{ + BRect r = bmp->Bounds (); + BBitmap *bm = new BBitmap (BRect (r.top, r.left, r.bottom, r.right), + bmp->ColorSpace (), true); + if (bm->InitCheck () != B_OK) + gui_abort ("Failed to init bitmap for rotate"); + int w = bmp->Bounds ().Width () + 1; + int h = bmp->Bounds ().Height () + 1; + + for (int y = 0; y < h; ++y) + for (int x = 0; x < w; ++x) + haiku_put_pixel ((void *) bm, y, w - x - 1, + haiku_get_pixel ((void *) bmp, x, y)); + + return bm; +} + +static BBitmap * +rotate_bitmap_90 (BBitmap *bmp) +{ + BRect r = bmp->Bounds (); + BBitmap *bm = new BBitmap (BRect (r.top, r.left, r.bottom, r.right), + bmp->ColorSpace (), true); + if (bm->InitCheck () != B_OK) + gui_abort ("Failed to init bitmap for rotate"); + int w = bmp->Bounds ().Width () + 1; + int h = bmp->Bounds ().Height () + 1; + + for (int y = 0; y < h; ++y) + for (int x = 0; x < w; ++x) + haiku_put_pixel ((void *) bm, h - y - 1, x, + haiku_get_pixel ((void *) bmp, x, y)); + + return bm; +} + +void * +BBitmap_transform_bitmap (void *bitmap, void *mask, uint32_t m_color, + double rot, int desw, int desh) +{ + BBitmap *bm = (BBitmap *) bitmap; + BBitmap *mk = (BBitmap *) mask; + int copied_p = 0; + + if (rot == 90) + { + copied_p = 1; + bm = rotate_bitmap_90 (bm); + if (mk) + mk = rotate_bitmap_90 (mk); + } + + if (rot == 270) + { + copied_p = 1; + bm = rotate_bitmap_270 (bm); + if (mk) + mk = rotate_bitmap_270 (mk); + } + + BRect r = bm->Bounds (); + if (r.Width () != desw || r.Height () != desh) + { + BRect n = BRect (0, 0, desw - 1, desh - 1); + BView vw (n, NULL, B_FOLLOW_NONE, 0); + BBitmap *dst = new BBitmap (n, bm->ColorSpace (), true); + if (dst->InitCheck () != B_OK) + if (bm->InitCheck () != B_OK) + gui_abort ("Failed to init bitmap for scale"); + dst->AddChild (&vw); + + if (!vw.LockLooper ()) + gui_abort ("Failed to lock offscreen view for scale"); + + if (rot != 90 && rot != 270) + { + BAffineTransform tr; + tr.RotateBy (BPoint (desw / 2, desh / 2), rot * M_PI / 180.0); + vw.SetTransform (tr); + } + + vw.MovePenTo (0, 0); + vw.DrawBitmap (bm, n); + if (mk) + BView_DrawMask ((void *) mk, (void *) &vw, + 0, 0, mk->Bounds ().Width (), + mk->Bounds ().Height (), + 0, 0, desw, desh, m_color); + vw.Sync (); + vw.RemoveSelf (); + + if (copied_p) + delete bm; + if (copied_p && mk) + delete mk; + return dst; + } + + return bm; +} + +void +BView_FillTriangle (void *view, int x1, int y1, + int x2, int y2, int x3, int y3) +{ + BView *vw = get_view (view); + vw->FillTriangle (BPoint (x1, y1), BPoint (x2, y2), + BPoint (x3, y3)); +} + +void +BView_SetHighColorForVisibleBell (void *view, uint32_t color) +{ + BView *vw = (BView *) view; + rgb_color col; + rgb32_to_rgb_color (color, &col); + + vw->SetHighColor (col); +} + +void +BView_FillRectangleForVisibleBell (void *view, int x, int y, int width, int height) +{ + BView *vw = (BView *) view; + BRect rect = BRect (x, y, x + width - 1, y + height - 1); + + vw->FillRect (rect); +} diff --git a/src/haiku_font_support.cc b/src/haiku_font_support.cc new file mode 100644 index 0000000000..9ac0400969 --- /dev/null +++ b/src/haiku_font_support.cc @@ -0,0 +1,596 @@ +/* Haiku window system support. Hey, Emacs, this is -*- C++ -*- + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include +#include +#include + +#include +#include + +#include "haiku_support.h" + +/* Haiku doesn't expose font language data in BFont objects. Thus, we + select a few representative characters for each supported `:lang' + (currently Chinese, Korean and Japanese,) and test for those + instead. */ + +static uint32_t language_code_points[MAX_LANGUAGE][4] = + {{20154, 20754, 22996, 0}, /* Chinese. */ + {51312, 49440, 44544, 0}, /* Korean. */ + {26085, 26412, 12371, 0}, /* Japanese. */}; + +static void +estimate_font_ascii (BFont *font, int *max_width, + int *min_width, int *avg_width) +{ + char ch[2]; + bool tems[1]; + int total = 0; + int count = 0; + int min = 0; + int max = 0; + + std::memset (ch, 0, sizeof ch); + for (ch[0] = 32; ch[0] < 127; ++ch[0]) + { + tems[0] = false; + font->GetHasGlyphs (ch, 1, tems); + if (tems[0]) + { + int w = font->StringWidth (ch); + ++count; + total += w; + + if (!min || min > w) + min = w; + if (max < w) + max = w; + } + } + + *min_width = min; + *max_width = max; + *avg_width = total / count; +} + +void +BFont_close (void *font) +{ + if (font != (void *) be_fixed_font && + font != (void *) be_plain_font && + font != (void *) be_bold_font) + delete (BFont *) font; +} + +void +BFont_dat (void *font, int *px_size, int *min_width, int *max_width, + int *avg_width, int *height, int *space_width, int *ascent, + int *descent, int *underline_position, int *underline_thickness) +{ + BFont *ft = (BFont *) font; + struct font_height fheight; + bool have_space_p; + + char atem[1]; + bool otem[1]; + + ft->GetHeight (&fheight); + atem[0] = ' '; + otem[0] = false; + ft->GetHasGlyphs (atem, 1, otem); + have_space_p = otem[0]; + + estimate_font_ascii (ft, max_width, min_width, avg_width); + *ascent = std::lrint (fheight.ascent); + *descent = std::lrint (fheight.descent); + *height = *ascent + *descent; + + *space_width = have_space_p ? ft->StringWidth (" ") : 0; + + *px_size = std::lrint (ft->Size ()); + *underline_position = 0; + *underline_thickness = 0; +} + +/* Return non-null if FONT contains CHR, a Unicode code-point. */ +int +BFont_have_char_p (void *font, int32_t chr) +{ + BFont *ft = (BFont *) font; + return ft->IncludesBlock (chr, chr); +} + +/* Return non-null if font contains a block from BEG to END. */ +int +BFont_have_char_block (void *font, int32_t beg, int32_t end) +{ + BFont *ft = (BFont *) font; + return ft->IncludesBlock (beg, end); +} + +/* Compute bounds for MB_STR, a character in multibyte encoding, + used with font. The width (in pixels) is returned in ADVANCE, + the left bearing in LB, and the right bearing in RB. */ +void +BFont_char_bounds (void *font, const char *mb_str, int *advance, + int *lb, int *rb) +{ + BFont *ft = (BFont *) font; + edge_info edge_info; + float size, escapement; + size = ft->Size (); + + ft->GetEdges (mb_str, 1, &edge_info); + ft->GetEscapements (mb_str, 1, &escapement); + *advance = std::lrint (escapement * size); + *lb = std::lrint (edge_info.left * size); + *rb = *advance + std::lrint (edge_info.right * size); +} + +/* The same, but for a variable amount of chars. */ +void +BFont_nchar_bounds (void *font, const char *mb_str, int *advance, + int *lb, int *rb, int32_t n) +{ + BFont *ft = (BFont *) font; + edge_info edge_info[n]; + float size; + float escapement[n]; + + size = ft->Size (); + + ft->GetEdges (mb_str, n, edge_info); + ft->GetEscapements (mb_str, n, (float *) escapement); + + for (int32_t i = 0; i < n; ++i) + { + advance[i] = std::lrint (escapement[i] * size); + lb[i] = advance[i] - std::lrint (edge_info[i].left * size); + rb[i] = advance[i] + std::lrint (edge_info[i].right * size); + } +} + +static void +font_style_to_flags (char *st, struct haiku_font_pattern *pattern) +{ + char *style = strdup (st); + char *token; + pattern->weight = -1; + pattern->width = NO_WIDTH; + pattern->slant = NO_SLANT; + int tok = 0; + + while ((token = std::strtok (!tok ? style : NULL, " ")) && tok < 3) + { + if (token && !strcmp (token, "Thin")) + pattern->weight = HAIKU_THIN; + else if (token && !strcmp (token, "UltraLight")) + pattern->weight = HAIKU_ULTRALIGHT; + else if (token && !strcmp (token, "ExtraLight")) + pattern->weight = HAIKU_EXTRALIGHT; + else if (token && !strcmp (token, "Light")) + pattern->weight = HAIKU_LIGHT; + else if (token && !strcmp (token, "SemiLight")) + pattern->weight = HAIKU_SEMI_LIGHT; + else if (token && !strcmp (token, "Regular")) + { + if (pattern->slant == NO_SLANT) + pattern->slant = SLANT_REGULAR; + + if (pattern->width == NO_WIDTH) + pattern->width = NORMAL_WIDTH; + + if (pattern->weight == -1) + pattern->weight = HAIKU_REGULAR; + } + else if (token && !strcmp (token, "SemiBold")) + pattern->weight = HAIKU_SEMI_BOLD; + else if (token && !strcmp (token, "Bold")) + pattern->weight = HAIKU_BOLD; + else if (token && (!strcmp (token, "ExtraBold") || + /* This has actually been seen in the wild. */ + !strcmp (token, "Extrabold"))) + pattern->weight = HAIKU_EXTRA_BOLD; + else if (token && !strcmp (token, "UltraBold")) + pattern->weight = HAIKU_ULTRA_BOLD; + else if (token && !strcmp (token, "Book")) + pattern->weight = HAIKU_BOOK; + else if (token && !strcmp (token, "Heavy")) + pattern->weight = HAIKU_HEAVY; + else if (token && !strcmp (token, "UltraHeavy")) + pattern->weight = HAIKU_ULTRA_HEAVY; + else if (token && !strcmp (token, "Black")) + pattern->weight = HAIKU_BLACK; + else if (token && !strcmp (token, "Medium")) + pattern->weight = HAIKU_MEDIUM; + else if (token && !strcmp (token, "Oblique")) + pattern->slant = SLANT_OBLIQUE; + else if (token && !strcmp (token, "Italic")) + pattern->slant = SLANT_ITALIC; + else if (token && !strcmp (token, "UltraCondensed")) + pattern->width = ULTRA_CONDENSED; + else if (token && !strcmp (token, "ExtraCondensed")) + pattern->width = EXTRA_CONDENSED; + else if (token && !strcmp (token, "Condensed")) + pattern->width = CONDENSED; + else if (token && !strcmp (token, "SemiCondensed")) + pattern->width = SEMI_CONDENSED; + else if (token && !strcmp (token, "SemiExpanded")) + pattern->width = SEMI_EXPANDED; + else if (token && !strcmp (token, "Expanded")) + pattern->width = EXPANDED; + else if (token && !strcmp (token, "ExtraExpanded")) + pattern->width = EXTRA_EXPANDED; + else if (token && !strcmp (token, "UltraExpanded")) + pattern->width = ULTRA_EXPANDED; + else + { + tok = 1000; + break; + } + tok++; + } + + if (pattern->weight != -1) + pattern->specified |= FSPEC_WEIGHT; + if (pattern->slant != NO_SLANT) + pattern->specified |= FSPEC_SLANT; + if (pattern->width != NO_WIDTH) + pattern->specified |= FSPEC_WIDTH; + + if (tok > 3) + { + pattern->specified &= ~FSPEC_SLANT; + pattern->specified &= ~FSPEC_WEIGHT; + pattern->specified &= ~FSPEC_WIDTH; + pattern->specified |= FSPEC_STYLE; + std::strncpy ((char *) &pattern->style, st, + sizeof pattern->style - 1); + } + + free (style); +} + +static bool +font_check_wanted_chars (struct haiku_font_pattern *pattern, font_family family, + char *style) +{ + BFont ft; + + if (ft.SetFamilyAndStyle (family, style) != B_OK) + return false; + + for (int i = 0; i < pattern->want_chars_len; ++i) + if (!ft.IncludesBlock (pattern->wanted_chars[i], + pattern->wanted_chars[i])) + return false; + + return true; +} + +static bool +font_check_one_of (struct haiku_font_pattern *pattern, font_family family, + char *style) +{ + BFont ft; + + if (ft.SetFamilyAndStyle (family, style) != B_OK) + return false; + + for (int i = 0; i < pattern->need_one_of_len; ++i) + if (ft.IncludesBlock (pattern->need_one_of[i], + pattern->need_one_of[i])) + return true; + + return false; +} + +static bool +font_check_language (struct haiku_font_pattern *pattern, font_family family, + char *style) +{ + BFont ft; + + if (ft.SetFamilyAndStyle (family, style) != B_OK) + return false; + + if (pattern->language == MAX_LANGUAGE) + return false; + + for (uint32_t *ch = (uint32_t *) + &language_code_points[pattern->language]; *ch; ch++) + if (!ft.IncludesBlock (*ch, *ch)) + return false; + + return true; +} + +static bool +font_family_style_matches_p (font_family family, char *style, uint32_t flags, + struct haiku_font_pattern *pattern, + int ignore_flags_p = 0) +{ + struct haiku_font_pattern m; + m.specified = 0; + + if (style) + font_style_to_flags (style, &m); + + if ((pattern->specified & FSPEC_FAMILY) && + strcmp ((char *) &pattern->family, family)) + return false; + + if (!ignore_flags_p && (pattern->specified & FSPEC_SPACING) && + !(pattern->mono_spacing_p) != !(flags & B_IS_FIXED)) + return false; + + if (pattern->specified & FSPEC_STYLE) + return style && !strcmp (style, pattern->style); + + if ((pattern->specified & FSPEC_WEIGHT) + && (pattern->weight + != ((m.specified & FSPEC_WEIGHT) ? m.weight : HAIKU_REGULAR))) + return false; + + if ((pattern->specified & FSPEC_SLANT) + && (pattern->slant + != ((m.specified & FSPEC_SLANT) ? m.slant : SLANT_REGULAR))) + return false; + + if ((pattern->specified & FSPEC_WANTED) + && !font_check_wanted_chars (pattern, family, style)) + return false; + + if ((pattern->specified & FSPEC_WIDTH) + && (pattern->width != + ((m.specified & FSPEC_WIDTH) ? m.width : NORMAL_WIDTH))) + return false; + + if ((pattern->specified & FSPEC_NEED_ONE_OF) + && !font_check_one_of (pattern, family, style)) + return false; + + if ((pattern->specified & FSPEC_LANGUAGE) + && !font_check_language (pattern, family, style)) + return false; + + return true; +} + +static void +haiku_font_fill_pattern (struct haiku_font_pattern *pattern, + font_family family, char *style, + uint32_t flags) +{ + if (style) + font_style_to_flags (style, pattern); + + pattern->specified |= FSPEC_FAMILY; + std::strncpy (pattern->family, family, + sizeof pattern->family - 1); + pattern->specified |= FSPEC_SPACING; + pattern->mono_spacing_p = flags & B_IS_FIXED; +} + +/* Delete every element of the font pattern PT. */ +void +haiku_font_pattern_free (struct haiku_font_pattern *pt) +{ + struct haiku_font_pattern *tem = pt; + while (tem) + { + struct haiku_font_pattern *t = tem; + tem = t->next; + delete t; + } +} + +/* Find all fonts matching the font pattern PT. */ +struct haiku_font_pattern * +BFont_find (struct haiku_font_pattern *pt) +{ + struct haiku_font_pattern *r = NULL; + font_family name; + font_style sname; + uint32 flags; + int sty_count; + int fam_count = count_font_families (); + + for (int fi = 0; fi < fam_count; ++fi) + { + if (get_font_family (fi, &name, &flags) == B_OK) + { + sty_count = count_font_styles (name); + if (!sty_count && + font_family_style_matches_p (name, NULL, flags, pt)) + { + struct haiku_font_pattern *p = new struct haiku_font_pattern; + p->specified = 0; + p->oblique_seen_p = 1; + haiku_font_fill_pattern (p, name, NULL, flags); + p->next = r; + if (p->next) + p->next->last = p; + p->last = NULL; + p->next_family = r; + r = p; + } + else if (sty_count) + { + for (int si = 0; si < sty_count; ++si) + { + int oblique_seen_p = 0; + struct haiku_font_pattern *head = r; + struct haiku_font_pattern *p = NULL; + + if (get_font_style (name, si, &sname, &flags) == B_OK) + { + if (font_family_style_matches_p (name, (char *) &sname, flags, pt)) + { + p = new struct haiku_font_pattern; + p->specified = 0; + haiku_font_fill_pattern (p, name, (char *) &sname, flags); + if (p->specified & FSPEC_SLANT && + ((p->slant == SLANT_OBLIQUE) || (p->slant == SLANT_ITALIC))) + oblique_seen_p = 1; + + p->next = r; + if (p->next) + p->next->last = p; + r = p; + p->next_family = head; + } + } + + if (p) + p->last = NULL; + + for (; head; head = head->last) + { + head->oblique_seen_p = oblique_seen_p; + } + } + } + } + } + + /* There's a very good chance that this result will get cached if no + slant is specified. Thus, we look through each font that hasn't + seen an oblique style, and add one. */ + + if (!(pt->specified & FSPEC_SLANT)) + { + /* r->last is invalid from here onwards. */ + for (struct haiku_font_pattern *p = r; p;) + { + if (!p->oblique_seen_p) + { + struct haiku_font_pattern *n = new haiku_font_pattern; + *n = *p; + n->slant = SLANT_OBLIQUE; + p->next = n; + p = p->next_family; + } + else + p = p->next_family; + } + } + + return r; +} + +/* Find and open a font matching the pattern PAT, which must have its + family set. */ +int +BFont_open_pattern (struct haiku_font_pattern *pat, void **font, float size) +{ + int sty_count; + font_family name; + font_style sname; + uint32 flags = 0; + if (!(pat->specified & FSPEC_FAMILY)) + return 1; + strncpy (name, pat->family, sizeof name - 1); + sty_count = count_font_styles (name); + + if (!sty_count && + font_family_style_matches_p (name, NULL, flags, pat, 1)) + { + BFont *ft = new BFont; + if (ft->SetFamilyAndStyle (name, NULL) != B_OK) + { + delete ft; + return 1; + } + ft->SetSize (size); + ft->SetEncoding (B_UNICODE_UTF8); + ft->SetSpacing (B_BITMAP_SPACING); + *font = (void *) ft; + return 0; + } + else if (sty_count) + { + for (int si = 0; si < sty_count; ++si) + { + if (get_font_style (name, si, &sname, &flags) == B_OK && + font_family_style_matches_p (name, (char *) &sname, flags, pat)) + { + BFont *ft = new BFont; + if (ft->SetFamilyAndStyle (name, sname) != B_OK) + { + delete ft; + return 1; + } + ft->SetSize (size); + ft->SetEncoding (B_UNICODE_UTF8); + ft->SetSpacing (B_BITMAP_SPACING); + *font = (void *) ft; + return 0; + } + } + } + + if (pat->specified & FSPEC_SLANT && pat->slant == SLANT_OBLIQUE) + { + struct haiku_font_pattern copy = *pat; + copy.slant = SLANT_REGULAR; + int code = BFont_open_pattern (©, font, size); + if (code) + return code; + BFont *ft = (BFont *) *font; + /* XXX Font measurements don't respect shear. Haiku bug? + This apparently worked in BeOS. + ft->SetShear (100.0); */ + ft->SetFace (B_ITALIC_FACE); + return 0; + } + + return 1; +} + +/* Query the family of the default fixed font. */ +void +BFont_populate_fixed_family (struct haiku_font_pattern *ptn) +{ + font_family f; + font_style s; + be_fixed_font->GetFamilyAndStyle (&f, &s); + + ptn->specified |= FSPEC_FAMILY; + strncpy (ptn->family, f, sizeof ptn->family - 1); +} + +void +BFont_populate_plain_family (struct haiku_font_pattern *ptn) +{ + font_family f; + font_style s; + be_plain_font->GetFamilyAndStyle (&f, &s); + + ptn->specified |= FSPEC_FAMILY; + strncpy (ptn->family, f, sizeof ptn->family - 1); +} + +int +BFont_string_width (void *font, const char *utf8) +{ + return ((BFont *) font)->StringWidth (utf8); +} diff --git a/src/haiku_io.c b/src/haiku_io.c new file mode 100644 index 0000000000..c152d9b086 --- /dev/null +++ b/src/haiku_io.c @@ -0,0 +1,207 @@ +/* Haiku window system support. + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include +#include +#include +#include + +#include + +#include "haiku_support.h" +#include "lisp.h" +#include "haikuterm.h" +#include "blockinput.h" + +#define PORT_CAP 1200 + +/* The port used to send messages from the application thread to + Emacs. */ +port_id port_application_to_emacs; + +void +haiku_io_init (void) +{ + port_application_to_emacs = create_port (PORT_CAP, "application emacs port"); +} + +static ssize_t +haiku_len (enum haiku_event_type type) +{ + switch (type) + { + case QUIT_REQUESTED: + return sizeof (struct haiku_quit_requested_event); + case FRAME_RESIZED: + return sizeof (struct haiku_resize_event); + case FRAME_EXPOSED: + return sizeof (struct haiku_expose_event); + case KEY_DOWN: + case KEY_UP: + return sizeof (struct haiku_key_event); + case ACTIVATION: + return sizeof (struct haiku_activation_event); + case MOUSE_MOTION: + return sizeof (struct haiku_mouse_motion_event); + case BUTTON_DOWN: + case BUTTON_UP: + return sizeof (struct haiku_button_event); + case ICONIFICATION: + return sizeof (struct haiku_iconification_event); + case MOVE_EVENT: + return sizeof (struct haiku_move_event); + case SCROLL_BAR_VALUE_EVENT: + return sizeof (struct haiku_scroll_bar_value_event); + case SCROLL_BAR_DRAG_EVENT: + return sizeof (struct haiku_scroll_bar_drag_event); + case WHEEL_MOVE_EVENT: + return sizeof (struct haiku_wheel_move_event); + case MENU_BAR_RESIZE: + return sizeof (struct haiku_menu_bar_resize_event); + case MENU_BAR_OPEN: + case MENU_BAR_CLOSE: + return sizeof (struct haiku_menu_bar_state_event); + case MENU_BAR_SELECT_EVENT: + return sizeof (struct haiku_menu_bar_select_event); + case FILE_PANEL_EVENT: + return sizeof (struct haiku_file_panel_event); + case MENU_BAR_HELP_EVENT: + return sizeof (struct haiku_menu_bar_help_event); + case ZOOM_EVENT: + return sizeof (struct haiku_zoom_event); + case REFS_EVENT: + return sizeof (struct haiku_refs_event); + case APP_QUIT_REQUESTED_EVENT: + return sizeof (struct haiku_app_quit_requested_event); + } + + emacs_abort (); +} + +/* Read the size of the next message into len, returning -1 if the + query fails or there is no next message. */ +void +haiku_read_size (ssize_t *len) +{ + port_id from = port_application_to_emacs; + ssize_t size; + + size = port_buffer_size_etc (from, B_TIMEOUT, 0); + + if (size < B_OK) + *len = -1; + else + *len = size; +} + +/* Read the next message into BUF, putting its type into TYPE, + assuming the message is at most LEN long. Return 0 if successful + and -1 if the read fails. */ +int +haiku_read (enum haiku_event_type *type, void *buf, ssize_t len) +{ + int32 typ; + port_id from = port_application_to_emacs; + + if (read_port (from, &typ, buf, len) < B_OK) + return -1; + + *type = (enum haiku_event_type) typ; + eassert (len >= haiku_len (typ)); + return 0; +} + +/* The same as haiku_read, but time out after TIMEOUT microseconds. + Input is blocked when an attempt to read is in progress. */ +int +haiku_read_with_timeout (enum haiku_event_type *type, void *buf, ssize_t len, + time_t timeout) +{ + int32 typ; + port_id from = port_application_to_emacs; + + block_input (); + if (read_port_etc (from, &typ, buf, len, + B_TIMEOUT, (bigtime_t) timeout) < B_OK) + { + unblock_input (); + return -1; + } + unblock_input (); + *type = (enum haiku_event_type) typ; + eassert (len >= haiku_len (typ)); + return 0; +} + +/* Write a message with type TYPE into BUF. */ +int +haiku_write (enum haiku_event_type type, void *buf) +{ + port_id to = port_application_to_emacs; + + if (write_port (to, (int32_t) type, buf, haiku_len (type)) < B_OK) + return -1; + + kill (getpid (), SIGPOLL); + + return 0; +} + +int +haiku_write_without_signal (enum haiku_event_type type, void *buf) +{ + port_id to = port_application_to_emacs; + + if (write_port (to, (int32_t) type, buf, haiku_len (type)) < B_OK) + return -1; + + return 0; +} + +void +haiku_io_init_in_app_thread (void) +{ + sigset_t set; + sigfillset (&set); + + if (pthread_sigmask (SIG_BLOCK, &set, NULL)) + perror ("pthread_sigmask"); +} + +/* Record an unwind protect from C++ code. */ +void +record_c_unwind_protect_from_cxx (void (*fn) (void *), void *r) +{ + record_unwind_protect_ptr (fn, r); +} + +/* SPECPDL_IDX that is safe from C++ code. */ +ptrdiff_t +c_specpdl_idx_from_cxx (void) +{ + return SPECPDL_INDEX (); +} + +/* unbind_to (IDX, Qnil), but safe from C++ code. */ +void +c_unbind_to_nil_from_cxx (ptrdiff_t idx) +{ + unbind_to (idx, Qnil); +} diff --git a/src/haiku_select.cc b/src/haiku_select.cc new file mode 100644 index 0000000000..8d345ca661 --- /dev/null +++ b/src/haiku_select.cc @@ -0,0 +1,155 @@ +/* Haiku window system selection support. Hey Emacs, this is -*- C++ -*- + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include + +#include +#include + +#include "haikuselect.h" + + +static BClipboard *primary = NULL; +static BClipboard *secondary = NULL; +static BClipboard *system_clipboard = NULL; + +int selection_state_flag; + +static char * +BClipboard_find_data (BClipboard *cb, const char *type, ssize_t *len) +{ + if (!cb->Lock ()) + return 0; + + BMessage *dat = cb->Data (); + if (!dat) + { + cb->Unlock (); + return 0; + } + + const char *ptr; + ssize_t bt; + dat->FindData (type, B_MIME_TYPE, (const void **) &ptr, &bt); + + if (!ptr) + { + cb->Unlock (); + return NULL; + } + + if (len) + *len = bt; + + cb->Unlock (); + + return strndup (ptr, bt); +} + +static void +BClipboard_set_data (BClipboard *cb, const char *type, const char *dat, + ssize_t len) +{ + if (!cb->Lock ()) + return; + cb->Clear (); + BMessage *mdat = cb->Data (); + if (!mdat) + { + cb->Unlock (); + return; + } + + if (dat) + mdat->AddData (type, B_MIME_TYPE, dat, len); + cb->Commit (); + cb->Unlock (); +} + +char * +BClipboard_find_system_data (const char *type, ssize_t *len) +{ + if (!system_clipboard) + return 0; + + return BClipboard_find_data (system_clipboard, type, len); +} + +char * +BClipboard_find_primary_selection_data (const char *type, ssize_t *len) +{ + if (!primary) + return 0; + + return BClipboard_find_data (primary, type, len); +} + +char * +BClipboard_find_secondary_selection_data (const char *type, ssize_t *len) +{ + if (!secondary) + return 0; + + return BClipboard_find_data (secondary, type, len); +} + +void +BClipboard_set_system_data (const char *type, const char *data, + ssize_t len) +{ + if (!system_clipboard) + return; + + BClipboard_set_data (system_clipboard, type, data, len); +} + +void +BClipboard_set_primary_selection_data (const char *type, const char *data, + ssize_t len) +{ + if (!primary) + return; + + BClipboard_set_data (primary, type, data, len); +} + +void +BClipboard_set_secondary_selection_data (const char *type, const char *data, + ssize_t len) +{ + if (!secondary) + return; + + BClipboard_set_data (secondary, type, data, len); +} + +void +BClipboard_free_data (void *ptr) +{ + std::free (ptr); +} + +void +init_haiku_select (void) +{ + system_clipboard = new BClipboard ("system"); + primary = new BClipboard ("primary"); + secondary = new BClipboard ("secondary"); +} diff --git a/src/haiku_support.cc b/src/haiku_support.cc new file mode 100644 index 0000000000..99d4ee7914 --- /dev/null +++ b/src/haiku_support.cc @@ -0,0 +1,2930 @@ +/* Haiku window system support. Hey, Emacs, this is -*- C++ -*- + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include +#include +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include + +#include +#include + +#include +#include +#include +#include +#include +#include + +#include +#include +#include + +#include +#include +#include + +#include +#include +#include + +#include + +#include +#include +#include +#include +#include +#include + +#include + +#ifdef USE_BE_CAIRO +#include +#endif + +#include "haiku_support.h" + +#define SCROLL_BAR_UPDATE 3000 + +static color_space dpy_color_space = B_NO_COLOR_SPACE; +static key_map *key_map = NULL; +static char *key_chars = NULL; +static BLocker key_map_lock; + +extern "C" +{ + extern _Noreturn void emacs_abort (void); + /* Also defined in haikuterm.h. */ + extern void be_app_quit (void); +} + +static thread_id app_thread; + +_Noreturn void +gui_abort (const char *msg) +{ + fprintf (stderr, "Abort in GUI code: %s\n", msg); + fprintf (stderr, "Under Haiku, Emacs cannot recover from errors in GUI code\n"); + fprintf (stderr, "App Server disconnects usually manifest as bitmap " + "initialization failures or lock failures."); + emacs_abort (); +} + +#ifdef USE_BE_CAIRO +static cairo_format_t +cairo_format_from_color_space (color_space space) +{ + switch (space) + { + case B_RGBA32: + return CAIRO_FORMAT_ARGB32; + case B_RGB32: + return CAIRO_FORMAT_RGB24; + case B_RGB16: + return CAIRO_FORMAT_RGB16_565; + case B_GRAY8: + return CAIRO_FORMAT_A8; + case B_GRAY1: + return CAIRO_FORMAT_A1; + default: + gui_abort ("Unsupported color space"); + } +} +#endif + +static void +map_key (char *chars, int32 offset, uint32_t *c) +{ + int size = chars[offset++]; + switch (size) + { + case 0: + break; + + case 1: + *c = chars[offset]; + break; + + default: + { + char str[5]; + int i = (size <= 4) ? size : 4; + strncpy (str, &(chars[offset]), i); + str[i] = '0'; + *c = BUnicodeChar::FromUTF8 ((char *) &str); + break; + } + } +} + +static void +map_shift (uint32_t kc, uint32_t *ch) +{ + if (!key_map_lock.Lock ()) + gui_abort ("Failed to lock keymap"); + if (!key_map) + get_key_map (&key_map, &key_chars); + if (!key_map) + return; + if (kc >= 128) + return; + + int32_t m = key_map->shift_map[kc]; + map_key (key_chars, m, ch); + key_map_lock.Unlock (); +} + +static void +map_normal (uint32_t kc, uint32_t *ch) +{ + if (!key_map_lock.Lock ()) + gui_abort ("Failed to lock keymap"); + if (!key_map) + get_key_map (&key_map, &key_chars); + if (!key_map) + return; + if (kc >= 128) + return; + + int32_t m = key_map->normal_map[kc]; + map_key (key_chars, m, ch); + key_map_lock.Unlock (); +} + +class Emacs : public BApplication +{ +public: + Emacs () : BApplication ("application/x-vnd.GNU-emacs") + { + } + + void + AboutRequested (void) + { + BAlert *about = new BAlert (PACKAGE_NAME, + PACKAGE_STRING + "\nThe extensible, self-documenting, real-time display editor.", + "Close"); + about->Go (); + } + + bool + QuitRequested (void) + { + struct haiku_app_quit_requested_event rq; + haiku_write (APP_QUIT_REQUESTED_EVENT, &rq); + return 0; + } + + void + RefsReceived (BMessage *msg) + { + struct haiku_refs_event rq; + entry_ref ref; + BEntry entry; + BPath path; + int32 cookie = 0; + int32 x, y; + void *window; + + if ((msg->FindPointer ("window", 0, &window) != B_OK) + || (msg->FindInt32 ("x", 0, &x) != B_OK) + || (msg->FindInt32 ("y", 0, &y) != B_OK)) + return; + + rq.window = window; + rq.x = x; + rq.y = y; + + while (msg->FindRef ("refs", cookie++, &ref) == B_OK) + { + if (entry.SetTo (&ref, 0) == B_OK + && entry.GetPath (&path) == B_OK) + { + rq.ref = strdup (path.Path ()); + haiku_write (REFS_EVENT, &rq); + } + } + } +}; + +class EmacsWindow : public BDirectWindow +{ +public: + struct child_frame + { + struct child_frame *next; + int xoff, yoff; + EmacsWindow *window; + } *subset_windows = NULL; + + EmacsWindow *parent = NULL; + BRect pre_fullscreen_rect; + BRect pre_zoom_rect; + int x_before_zoom = INT_MIN; + int y_before_zoom = INT_MIN; + int fullscreen_p = 0; + int zoomed_p = 0; + int shown_flag = 0; + +#ifdef USE_BE_CAIRO + BLocker surface_lock; + cairo_surface_t *cr_surface = NULL; +#endif + + EmacsWindow () : BDirectWindow (BRect (0, 0, 0, 0), "", B_TITLED_WINDOW_LOOK, + B_NORMAL_WINDOW_FEEL, B_NO_SERVER_SIDE_WINDOW_MODIFIERS) + { + + } + + ~EmacsWindow () + { + struct child_frame *next; + for (struct child_frame *f = subset_windows; f; f = next) + { + f->window->Unparent (); + next = f->next; + delete f; + } + + if (this->parent) + UnparentAndUnlink (); + +#ifdef USE_BE_CAIRO + if (!surface_lock.Lock ()) + gui_abort ("Failed to lock cairo surface"); + if (cr_surface) + { + cairo_surface_destroy (cr_surface); + cr_surface = NULL; + } + surface_lock.Unlock (); +#endif + } + + void + UpwardsSubset (EmacsWindow *w) + { + for (; w; w = w->parent) + AddToSubset (w); + } + + void + UpwardsSubsetChildren (EmacsWindow *w) + { + UpwardsSubset (w); + for (struct child_frame *f = subset_windows; f; + f = f->next) + f->window->UpwardsSubsetChildren (w); + } + + void + UpwardsUnSubset (EmacsWindow *w) + { + for (; w; w = w->parent) + RemoveFromSubset (w); + } + + void + UpwardsUnSubsetChildren (EmacsWindow *w) + { + UpwardsUnSubset (w); + for (struct child_frame *f = subset_windows; f; + f = f->next) + f->window->UpwardsUnSubsetChildren (w); + } + + void + Unparent (void) + { + this->SetFeel (B_NORMAL_WINDOW_FEEL); + UpwardsUnSubsetChildren (parent); + this->RemoveFromSubset (this); + this->parent = NULL; + if (fullscreen_p) + { + fullscreen_p = 0; + MakeFullscreen (1); + } + } + + void + UnparentAndUnlink (void) + { + this->parent->UnlinkChild (this); + this->Unparent (); + } + + void + UnlinkChild (EmacsWindow *window) + { + struct child_frame *last = NULL; + struct child_frame *tem = subset_windows; + + for (; tem; last = tem, tem = tem->next) + { + if (tem->window == window) + { + if (last) + last->next = tem->next; + if (tem == subset_windows) + subset_windows = NULL; + delete tem; + return; + } + } + + gui_abort ("Failed to unlink child frame"); + } + + void + ParentTo (EmacsWindow *window) + { + if (this->parent) + UnparentAndUnlink (); + + this->parent = window; + this->SetFeel (B_FLOATING_SUBSET_WINDOW_FEEL); + this->AddToSubset (this); + if (!IsHidden () && this->parent) + UpwardsSubsetChildren (parent); + if (fullscreen_p) + { + fullscreen_p = 0; + MakeFullscreen (1); + } + this->Sync (); + window->LinkChild (this); + } + + void + LinkChild (EmacsWindow *window) + { + struct child_frame *f = new struct child_frame; + + for (struct child_frame *f = subset_windows; f; + f = f->next) + { + if (window == f->window) + gui_abort ("Trying to link a child frame that is already present"); + } + + f->window = window; + f->next = subset_windows; + f->xoff = -1; + f->yoff = -1; + + subset_windows = f; + } + + void + DoMove (struct child_frame *f) + { + BRect frame = this->Frame (); + f->window->MoveTo (frame.left + f->xoff, + frame.top + f->yoff); + this->Sync (); + } + + void + DoUpdateWorkspace (struct child_frame *f) + { + f->window->SetWorkspaces (this->Workspaces ()); + } + + void + MoveChild (EmacsWindow *window, int xoff, int yoff, + int weak_p) + { + for (struct child_frame *f = subset_windows; f; + f = f->next) + { + if (window == f->window) + { + f->xoff = xoff; + f->yoff = yoff; + if (!weak_p) + DoMove (f); + return; + } + } + + gui_abort ("Trying to move a child frame that doesn't exist"); + } + + void + WindowActivated (bool activated) + { + struct haiku_activation_event rq; + rq.window = this; + rq.activated_p = activated; + + haiku_write (ACTIVATION, &rq); + } + + void + DirectConnected (direct_buffer_info *info) + { +#ifdef USE_BE_CAIRO + if (!surface_lock.Lock ()) + gui_abort ("Failed to lock window direct cr surface"); + if (cr_surface) + { + cairo_surface_destroy (cr_surface); + cr_surface = NULL; + } + + if (info->buffer_state != B_DIRECT_STOP) + { + int left, top, right, bottom; + left = info->clip_bounds.left; + top = info->clip_bounds.top; + right = info->clip_bounds.right; + bottom = info->clip_bounds.bottom; + + unsigned char *bits = (unsigned char *) info->bits; + if ((info->bits_per_pixel % 8) == 0) + { + bits += info->bytes_per_row * top; + bits += (left * info->bits_per_pixel / 8); + cr_surface = cairo_image_surface_create_for_data + (bits, + cairo_format_from_color_space (info->pixel_format), + right - left + 1, + bottom - top + 1, + info->bytes_per_row); + } + } + surface_lock.Unlock (); +#endif + } + + void + MessageReceived (BMessage *msg) + { + int32 old_what = 0; + + if (msg->WasDropped ()) + { + entry_ref ref; + BPoint whereto; + + if (msg->FindRef ("refs", &ref) == B_OK) + { + msg->what = B_REFS_RECEIVED; + msg->AddPointer ("window", this); + if (msg->FindPoint ("_drop_point_", &whereto) == B_OK) + { + this->ConvertFromScreen (&whereto); + msg->AddInt32 ("x", whereto.x); + msg->AddInt32 ("y", whereto.y); + } + be_app->PostMessage (msg); + msg->SendReply (B_OK); + } + } + else if (msg->GetPointer ("menuptr")) + { + struct haiku_menu_bar_select_event rq; + rq.window = this; + rq.ptr = (void *) msg->GetPointer ("menuptr"); + haiku_write (MENU_BAR_SELECT_EVENT, &rq); + } + else if (msg->what == 'FPSE' + || ((msg->FindInt32 ("old_what", &old_what) == B_OK + && old_what == 'FPSE'))) + { + struct haiku_file_panel_event rq; + BEntry entry; + BPath path; + entry_ref ref; + + rq.ptr = NULL; + + if (msg->FindRef ("refs", &ref) == B_OK && + entry.SetTo (&ref, 0) == B_OK && + entry.GetPath (&path) == B_OK) + { + const char *str_path = path.Path (); + if (str_path) + rq.ptr = strdup (str_path); + } + + if (msg->FindRef ("directory", &ref), + entry.SetTo (&ref, 0) == B_OK && + entry.GetPath (&path) == B_OK) + { + const char *name = msg->GetString ("name"); + const char *str_path = path.Path (); + + if (name) + { + char str_buf[std::strlen (str_path) + + std::strlen (name) + 2]; + snprintf ((char *) &str_buf, + std::strlen (str_path) + + std::strlen (name) + 2, "%s/%s", + str_path, name); + rq.ptr = strdup (str_buf); + } + } + + haiku_write (FILE_PANEL_EVENT, &rq); + } + else + BDirectWindow::MessageReceived (msg); + } + + void + DispatchMessage (BMessage *msg, BHandler *handler) + { + if (msg->what == B_KEY_DOWN || msg->what == B_KEY_UP) + { + struct haiku_key_event rq; + rq.window = this; + + int32_t code = msg->GetInt32 ("raw_char", 0); + + rq.modifiers = 0; + uint32_t mods = modifiers (); + + if (mods & B_SHIFT_KEY) + rq.modifiers |= HAIKU_MODIFIER_SHIFT; + + if (mods & B_CONTROL_KEY) + rq.modifiers |= HAIKU_MODIFIER_CTRL; + + if (mods & B_COMMAND_KEY) + rq.modifiers |= HAIKU_MODIFIER_ALT; + + if (mods & B_OPTION_KEY) + rq.modifiers |= HAIKU_MODIFIER_SUPER; + + rq.mb_char = code; + rq.kc = msg->GetInt32 ("key", -1); + rq.unraw_mb_char = + BUnicodeChar::FromUTF8 (msg->GetString ("bytes")); + + if ((mods & B_SHIFT_KEY) && rq.kc >= 0) + map_shift (rq.kc, &rq.unraw_mb_char); + else if (rq.kc >= 0) + map_normal (rq.kc, &rq.unraw_mb_char); + + haiku_write (msg->what == B_KEY_DOWN ? KEY_DOWN : KEY_UP, &rq); + } + else if (msg->what == B_MOUSE_WHEEL_CHANGED) + { + struct haiku_wheel_move_event rq; + rq.window = this; + rq.modifiers = 0; + + uint32_t mods = modifiers (); + + if (mods & B_SHIFT_KEY) + rq.modifiers |= HAIKU_MODIFIER_SHIFT; + + if (mods & B_CONTROL_KEY) + rq.modifiers |= HAIKU_MODIFIER_CTRL; + + if (mods & B_COMMAND_KEY) + rq.modifiers |= HAIKU_MODIFIER_ALT; + + if (mods & B_OPTION_KEY) + rq.modifiers |= HAIKU_MODIFIER_SUPER; + + float dx, dy; + if (msg->FindFloat ("be:wheel_delta_x", &dx) == B_OK && + msg->FindFloat ("be:wheel_delta_y", &dy) == B_OK) + { + rq.delta_x = dx * 10; + rq.delta_y = dy * 10; + + haiku_write (WHEEL_MOVE_EVENT, &rq); + }; + } + else + BDirectWindow::DispatchMessage (msg, handler); + } + + void + MenusBeginning () + { + struct haiku_menu_bar_state_event rq; + rq.window = this; + + haiku_write (MENU_BAR_OPEN, &rq); + } + + void + MenusEnded () + { + struct haiku_menu_bar_state_event rq; + rq.window = this; + + haiku_write (MENU_BAR_CLOSE, &rq); + } + + void + FrameResized (float newWidth, float newHeight) + { + struct haiku_resize_event rq; + rq.window = this; + rq.px_heightf = newHeight; + rq.px_widthf = newWidth; + + haiku_write (FRAME_RESIZED, &rq); + BDirectWindow::FrameResized (newWidth, newHeight); + } + + void + FrameMoved (BPoint newPosition) + { + struct haiku_move_event rq; + rq.window = this; + rq.x = std::lrint (newPosition.x); + rq.y = std::lrint (newPosition.y); + + haiku_write (MOVE_EVENT, &rq); + + for (struct child_frame *f = subset_windows; + f; f = f->next) + DoMove (f); + BDirectWindow::FrameMoved (newPosition); + } + + void + WorkspacesChanged (uint32_t old, uint32_t n) + { + for (struct child_frame *f = subset_windows; + f; f = f->next) + DoUpdateWorkspace (f); + } + + void + EmacsMoveTo (int x, int y) + { + if (!this->parent) + this->MoveTo (x, y); + else + this->parent->MoveChild (this, x, y, 0); + } + + bool + QuitRequested () + { + struct haiku_quit_requested_event rq; + rq.window = this; + haiku_write (QUIT_REQUESTED, &rq); + return false; + } + + void + Minimize (bool minimized_p) + { + BDirectWindow::Minimize (minimized_p); + struct haiku_iconification_event rq; + rq.window = this; + rq.iconified_p = !parent && minimized_p; + + haiku_write (ICONIFICATION, &rq); + } + + void + EmacsHide (void) + { + if (this->IsHidden ()) + return; + Hide (); + if (this->parent) + UpwardsUnSubsetChildren (this->parent); + } + + void + EmacsShow (void) + { + if (!this->IsHidden ()) + return; + if (this->parent) + shown_flag = 1; + Show (); + if (this->parent) + UpwardsSubsetChildren (this->parent); + } + + void + Zoom (BPoint o, float w, float h) + { + struct haiku_zoom_event rq; + rq.window = this; + + rq.x = o.x; + rq.y = o.y; + + rq.width = w; + rq.height = h; + + if (fullscreen_p) + MakeFullscreen (0); + + if (o.x != x_before_zoom || + o.y != y_before_zoom) + { + x_before_zoom = Frame ().left; + y_before_zoom = Frame ().top; + pre_zoom_rect = Frame (); + zoomed_p = 1; + haiku_write (ZOOM_EVENT, &rq); + } + else + { + zoomed_p = 0; + x_before_zoom = y_before_zoom = INT_MIN; + } + + BDirectWindow::Zoom (o, w, h); + } + + void + UnZoom (void) + { + if (!zoomed_p) + return; + zoomed_p = 0; + + EmacsMoveTo (pre_zoom_rect.left, pre_zoom_rect.top); + ResizeTo (pre_zoom_rect.Width (), + pre_zoom_rect.Height ()); + } + + void + GetParentWidthHeight (int *width, int *height) + { + if (parent) + { + *width = parent->Frame ().Width (); + *height = parent->Frame ().Height (); + } + else + { + BScreen s (this); + *width = s.Frame ().Width (); + *height = s.Frame ().Height (); + } + } + + void + OffsetChildRect (BRect *r, EmacsWindow *c) + { + for (struct child_frame *f; f; f = f->next) + if (f->window == c) + { + r->top -= f->yoff; + r->bottom -= f->yoff; + r->left -= f->xoff; + r->right -= f->xoff; + return; + } + + gui_abort ("Trying to calculate offsets for a child frame that doesn't exist"); + } + + void + MakeFullscreen (int make_fullscreen_p) + { + BScreen screen (this); + + if (!screen.IsValid ()) + gui_abort ("Trying to make a window fullscreen without a screen"); + + if (make_fullscreen_p == fullscreen_p) + return; + + fullscreen_p = make_fullscreen_p; + uint32 flags = Flags (); + if (fullscreen_p) + { + if (zoomed_p) + UnZoom (); + + flags |= B_NOT_MOVABLE | B_NOT_ZOOMABLE; + pre_fullscreen_rect = Frame (); + if (parent) + parent->OffsetChildRect (&pre_fullscreen_rect, this); + + int w, h; + EmacsMoveTo (0, 0); + GetParentWidthHeight (&w, &h); + ResizeTo (w, h); + } + else + { + flags &= ~(B_NOT_MOVABLE | B_NOT_ZOOMABLE); + EmacsMoveTo (pre_fullscreen_rect.left, + pre_fullscreen_rect.top); + ResizeTo (pre_fullscreen_rect.Width (), + pre_fullscreen_rect.Height ()); + } + SetFlags (flags); + } +}; + +class EmacsMenuBar : public BMenuBar +{ +public: + EmacsMenuBar () : BMenuBar (BRect (0, 0, 0, 0), NULL) + { + } + + void + FrameResized (float newWidth, float newHeight) + { + struct haiku_menu_bar_resize_event rq; + rq.window = this->Window (); + rq.height = std::lrint (newHeight); + rq.width = std::lrint (newWidth); + + haiku_write (MENU_BAR_RESIZE, &rq); + BMenuBar::FrameResized (newWidth, newHeight); + } +}; + +class EmacsView : public BView +{ +public: + uint32_t visible_bell_color = 0; + uint32_t previous_buttons = 0; + int looper_locked_count = 0; + BRegion sb_region; + + BView *offscreen_draw_view = NULL; + BBitmap *offscreen_draw_bitmap_1 = NULL; + BBitmap *copy_bitmap = NULL; + +#ifdef USE_BE_CAIRO + cairo_surface_t *cr_surface = NULL; + BLocker cr_surface_lock; +#endif + + BPoint tt_absl_pos; + + color_space cspace; + + EmacsView () : BView (BRect (0, 0, 0, 0), "Emacs", B_FOLLOW_NONE, B_WILL_DRAW) + { + + } + + ~EmacsView () + { + TearDownDoubleBuffering (); + } + + void + AttachedToWindow (void) + { + cspace = B_RGBA32; + } + +#ifdef USE_BE_CAIRO + void + DetachCairoSurface (void) + { + if (!cr_surface_lock.Lock ()) + gui_abort ("Could not lock cr surface during detachment"); + if (!cr_surface) + gui_abort ("Trying to detach window cr surface when none exists"); + cairo_surface_destroy (cr_surface); + cr_surface = NULL; + cr_surface_lock.Unlock (); + } + + void + AttachCairoSurface (void) + { + if (!cr_surface_lock.Lock ()) + gui_abort ("Could not lock cr surface during attachment"); + if (cr_surface) + gui_abort ("Trying to attach cr surface when one already exists"); + cr_surface = cairo_image_surface_create_for_data + ((unsigned char *) offscreen_draw_bitmap_1->Bits (), + CAIRO_FORMAT_ARGB32, offscreen_draw_bitmap_1->Bounds ().Width (), + offscreen_draw_bitmap_1->Bounds ().Height (), + offscreen_draw_bitmap_1->BytesPerRow ()); + if (!cr_surface) + gui_abort ("Cr surface allocation failed for double-buffered view"); + cr_surface_lock.Unlock (); + } +#endif + + void + TearDownDoubleBuffering (void) + { + if (offscreen_draw_view) + { + if (Window ()) + ClearViewBitmap (); + if (copy_bitmap) + { + delete copy_bitmap; + copy_bitmap = NULL; + } + if (!looper_locked_count) + if (!offscreen_draw_view->LockLooper ()) + gui_abort ("Failed to lock offscreen draw view"); +#ifdef USE_BE_CAIRO + if (cr_surface) + DetachCairoSurface (); +#endif + offscreen_draw_view->RemoveSelf (); + delete offscreen_draw_view; + offscreen_draw_view = NULL; + delete offscreen_draw_bitmap_1; + offscreen_draw_bitmap_1 = NULL; + } + } + + void + AfterResize (float newWidth, float newHeight) + { + if (offscreen_draw_view) + { + if (!LockLooper ()) + gui_abort ("Failed to lock looper after resize"); + + if (!offscreen_draw_view->LockLooper ()) + gui_abort ("Failed to lock offscreen draw view after resize"); +#ifdef USE_BE_CAIRO + DetachCairoSurface (); +#endif + offscreen_draw_view->RemoveSelf (); + delete offscreen_draw_bitmap_1; + offscreen_draw_bitmap_1 = new BBitmap (Frame (), cspace, 1); + if (offscreen_draw_bitmap_1->InitCheck () != B_OK) + gui_abort ("Offscreen draw bitmap initialization failed"); + + offscreen_draw_view->MoveTo (Frame ().left, Frame ().top); + offscreen_draw_view->ResizeTo (Frame ().Width (), Frame ().Height ()); + offscreen_draw_bitmap_1->AddChild (offscreen_draw_view); +#ifdef USE_BE_CAIRO + AttachCairoSurface (); +#endif + + if (looper_locked_count) + { + offscreen_draw_bitmap_1->Lock (); + } + + UnlockLooper (); + } + } + + void + Pulse (void) + { + visible_bell_color = 0; + SetFlags (Flags () & ~B_PULSE_NEEDED); + Window ()->SetPulseRate (0); + Invalidate (); + } + + void + Draw (BRect expose_bounds) + { + struct haiku_expose_event rq; + EmacsWindow *w = (EmacsWindow *) Window (); + + if (visible_bell_color > 0) + { + PushState (); + BView_SetHighColorForVisibleBell (this, visible_bell_color); + FillRect (Frame ()); + PopState (); + return; + } + + if (w->shown_flag) + { + PushState (); + SetDrawingMode (B_OP_ERASE); + FillRect (Frame ()); + PopState (); + return; + } + + if (!offscreen_draw_view) + { + if (sb_region.Contains (std::lrint (expose_bounds.left), + std::lrint (expose_bounds.top)) && + sb_region.Contains (std::lrint (expose_bounds.right), + std::lrint (expose_bounds.top)) && + sb_region.Contains (std::lrint (expose_bounds.left), + std::lrint (expose_bounds.bottom)) && + sb_region.Contains (std::lrint (expose_bounds.right), + std::lrint (expose_bounds.bottom))) + return; + + rq.x = std::floor (expose_bounds.left); + rq.y = std::floor (expose_bounds.top); + rq.width = std::ceil (expose_bounds.right - expose_bounds.left + 1); + rq.height = std::ceil (expose_bounds.bottom - expose_bounds.top + 1); + if (!rq.width) + rq.width = 1; + if (!rq.height) + rq.height = 1; + rq.window = this->Window (); + + haiku_write (FRAME_EXPOSED, &rq); + } + } + + void + DoVisibleBell (uint32_t color) + { + if (!LockLooper ()) + gui_abort ("Failed to lock looper during visible bell"); + visible_bell_color = color | (255 << 24); + SetFlags (Flags () | B_PULSE_NEEDED); + Window ()->SetPulseRate (100 * 1000); + Invalidate (); + UnlockLooper (); + } + + void + FlipBuffers (void) + { + if (!LockLooper ()) + gui_abort ("Failed to lock looper during buffer flip"); + if (!offscreen_draw_view) + gui_abort ("Failed to lock offscreen view during buffer flip"); + + offscreen_draw_view->Flush (); + offscreen_draw_view->Sync (); + + EmacsWindow *w = (EmacsWindow *) Window (); + w->shown_flag = 0; + + if (copy_bitmap && + copy_bitmap->Bounds () != offscreen_draw_bitmap_1->Bounds ()) + { + delete copy_bitmap; + copy_bitmap = NULL; + } + if (!copy_bitmap) + copy_bitmap = new BBitmap (offscreen_draw_bitmap_1); + else + copy_bitmap->ImportBits (offscreen_draw_bitmap_1); + + if (copy_bitmap->InitCheck () != B_OK) + gui_abort ("Failed to init copy bitmap during buffer flip"); + + SetViewBitmap (copy_bitmap, + Frame (), Frame (), B_FOLLOW_NONE, 0); + + Invalidate (); + UnlockLooper (); + return; + } + + void + SetUpDoubleBuffering (void) + { + if (!LockLooper ()) + gui_abort ("Failed to lock self setting up double buffering"); + if (offscreen_draw_view) + gui_abort ("Failed to lock offscreen view setting up double buffering"); + + offscreen_draw_bitmap_1 = new BBitmap (Frame (), cspace, 1); + if (offscreen_draw_bitmap_1->InitCheck () != B_OK) + gui_abort ("Failed to init offscreen bitmap"); +#ifdef USE_BE_CAIRO + AttachCairoSurface (); +#endif + offscreen_draw_view = new BView (Frame (), NULL, B_FOLLOW_NONE, B_WILL_DRAW); + offscreen_draw_bitmap_1->AddChild (offscreen_draw_view); + + if (looper_locked_count) + { + if (!offscreen_draw_bitmap_1->Lock ()) + gui_abort ("Failed to lock bitmap after double buffering was set up."); + } + + UnlockLooper (); + Invalidate (); + } + + void + MouseMoved (BPoint point, uint32 transit, const BMessage *msg) + { + struct haiku_mouse_motion_event rq; + + rq.just_exited_p = transit == B_EXITED_VIEW; + rq.x = point.x; + rq.y = point.y; + rq.be_code = transit; + rq.window = this->Window (); + + if (ToolTip ()) + ToolTip ()->SetMouseRelativeLocation (BPoint (-(point.x - tt_absl_pos.x), + -(point.y - tt_absl_pos.y))); + + haiku_write (MOUSE_MOTION, &rq); + } + + void + MouseDown (BPoint point) + { + struct haiku_button_event rq; + uint32 buttons; + + this->GetMouse (&point, &buttons, false); + + rq.window = this->Window (); + rq.btn_no = 0; + + if (!(previous_buttons & B_PRIMARY_MOUSE_BUTTON) && + (buttons & B_PRIMARY_MOUSE_BUTTON)) + rq.btn_no = 0; + else if (!(previous_buttons & B_SECONDARY_MOUSE_BUTTON) && + (buttons & B_SECONDARY_MOUSE_BUTTON)) + rq.btn_no = 2; + else if (!(previous_buttons & B_TERTIARY_MOUSE_BUTTON) && + (buttons & B_TERTIARY_MOUSE_BUTTON)) + rq.btn_no = 1; + previous_buttons = buttons; + + rq.x = point.x; + rq.y = point.y; + + uint32_t mods = modifiers (); + + rq.modifiers = 0; + if (mods & B_SHIFT_KEY) + rq.modifiers |= HAIKU_MODIFIER_SHIFT; + + if (mods & B_CONTROL_KEY) + rq.modifiers |= HAIKU_MODIFIER_CTRL; + + if (mods & B_COMMAND_KEY) + rq.modifiers |= HAIKU_MODIFIER_ALT; + + if (mods & B_OPTION_KEY) + rq.modifiers |= HAIKU_MODIFIER_SUPER; + + SetMouseEventMask (B_POINTER_EVENTS, B_LOCK_WINDOW_FOCUS); + + haiku_write (BUTTON_DOWN, &rq); + } + + void + MouseUp (BPoint point) + { + struct haiku_button_event rq; + uint32 buttons; + + this->GetMouse (&point, &buttons, false); + + rq.window = this->Window (); + rq.btn_no = 0; + + if ((previous_buttons & B_PRIMARY_MOUSE_BUTTON) + && !(buttons & B_PRIMARY_MOUSE_BUTTON)) + rq.btn_no = 0; + else if ((previous_buttons & B_SECONDARY_MOUSE_BUTTON) + && !(buttons & B_SECONDARY_MOUSE_BUTTON)) + rq.btn_no = 2; + else if ((previous_buttons & B_TERTIARY_MOUSE_BUTTON) + && !(buttons & B_TERTIARY_MOUSE_BUTTON)) + rq.btn_no = 1; + previous_buttons = buttons; + + rq.x = point.x; + rq.y = point.y; + + uint32_t mods = modifiers (); + + rq.modifiers = 0; + if (mods & B_SHIFT_KEY) + rq.modifiers |= HAIKU_MODIFIER_SHIFT; + + if (mods & B_CONTROL_KEY) + rq.modifiers |= HAIKU_MODIFIER_CTRL; + + if (mods & B_COMMAND_KEY) + rq.modifiers |= HAIKU_MODIFIER_ALT; + + if (mods & B_OPTION_KEY) + rq.modifiers |= HAIKU_MODIFIER_SUPER; + + if (!buttons) + SetMouseEventMask (0, 0); + + haiku_write (BUTTON_UP, &rq); + } +}; + +class EmacsScrollBar : public BScrollBar +{ +public: + void *scroll_bar; + + EmacsScrollBar (int x, int y, int x1, int y1, bool horizontal_p) : + BScrollBar (BRect (x, y, x1, y1), NULL, NULL, 0, 0, horizontal_p ? + B_HORIZONTAL : B_VERTICAL) + { + BView *vw = (BView *) this; + vw->SetResizingMode (B_FOLLOW_NONE); + } + + void + MessageReceived (BMessage *msg) + { + if (msg->what == SCROLL_BAR_UPDATE) + { + this->SetRange (0, msg->GetInt32 ("emacs:range", 0)); + this->SetValue (msg->GetInt32 ("emacs:units", 0)); + } + + BScrollBar::MessageReceived (msg); + } + + void + ValueChanged (float new_value) + { + struct haiku_scroll_bar_value_event rq; + rq.scroll_bar = scroll_bar; + rq.position = new_value; + + haiku_write (SCROLL_BAR_VALUE_EVENT, &rq); + } + + void + MouseDown (BPoint pt) + { + struct haiku_scroll_bar_drag_event rq; + rq.dragging_p = 1; + rq.scroll_bar = scroll_bar; + + haiku_write (SCROLL_BAR_DRAG_EVENT, &rq); + BScrollBar::MouseDown (pt); + } + + void + MouseUp (BPoint pt) + { + struct haiku_scroll_bar_drag_event rq; + rq.dragging_p = 0; + rq.scroll_bar = scroll_bar; + + haiku_write (SCROLL_BAR_DRAG_EVENT, &rq); + BScrollBar::MouseUp (pt); + } +}; + +class EmacsTitleMenuItem : public BMenuItem +{ +public: + EmacsTitleMenuItem (const char *str) : BMenuItem (str, NULL) + { + SetEnabled (0); + } + + void + DrawContent (void) + { + BMenu *menu = Menu (); + + menu->PushState (); + menu->SetFont (be_bold_font); + BView_SetHighColorForVisibleBell (menu, 0); + BMenuItem::DrawContent (); + menu->PopState (); + } +}; + +class EmacsMenuItem : public BMenuItem +{ +public: + int menu_bar_id = -1; + void *wind_ptr = NULL; + char *key = NULL; + char *help = NULL; + + EmacsMenuItem (const char *ky, + const char *str, + const char *help, + BMessage *message = NULL) : BMenuItem (str, message) + { + if (ky) + { + key = strdup (ky); + if (!key) + gui_abort ("strdup failed"); + } + + if (help) + { + this->help = strdup (help); + if (!this->help) + gui_abort ("strdup failed"); + } + } + + ~EmacsMenuItem () + { + if (key) + free (key); + if (help) + free (help); + } + + void + DrawContent (void) + { + BMenu *menu = Menu (); + + BMenuItem::DrawContent (); + + if (key) + { + BRect r = menu->Frame (); + int w = menu->StringWidth (key); + menu->MovePenTo (BPoint (r.Width () - w - 4, + menu->PenLocation ().y)); + menu->DrawString (key); + } + } + + void + GetContentSize (float *w, float *h) + { + BMenuItem::GetContentSize (w, h); + if (Menu () && key) + *w += 4 + Menu ()->StringWidth (key); + } + + void + Highlight (bool highlight_p) + { + struct haiku_menu_bar_help_event rq; + + if (menu_bar_id >= 0) + { + rq.window = wind_ptr; + rq.mb_idx = highlight_p ? menu_bar_id : -1; + + haiku_write (MENU_BAR_HELP_EVENT, &rq); + } + else if (help) + { + Menu ()->SetToolTip (highlight_p ? help : NULL); + } + + BMenuItem::Highlight (highlight_p); + } +}; + +class EmacsPopUpMenu : public BPopUpMenu +{ +public: + EmacsPopUpMenu (const char *name) : BPopUpMenu (name, 0) + { + + } + + void + FrameResized (float w, float h) + { + Invalidate (); + BPopUpMenu::FrameResized (w, h); + } +}; + +static int32 +start_running_application (void *data) +{ + haiku_io_init_in_app_thread (); + + if (!((Emacs *) data)->Lock ()) + gui_abort ("Failed to lock application"); + + ((Emacs *) data)->Run (); + ((Emacs *) data)->Unlock (); + return 0; +} + +/* Take BITMAP, a reference to a BBitmap, and return a pointer to its + data. */ +void * +BBitmap_data (void *bitmap) +{ + return ((BBitmap *) bitmap)->Bits (); +} + +/* Convert bitmap if required, placing the new bitmap in NEW_BITMAP, + and return non-null if bitmap was successfully converted. Bitmaps + should be freed with `BBitmap_free'. */ +int +BBitmap_convert (void *_bitmap, void **new_bitmap) +{ + BBitmap *bitmap = (BBitmap *) _bitmap; + if (bitmap->ColorSpace () == B_RGBA32) + return -1; + BRect bounds = bitmap->Bounds (); + BBitmap *bmp = new (std::nothrow) BBitmap (bounds, B_RGBA32); + if (!bmp || bmp->InitCheck () != B_OK) + { + if (bmp) + delete bmp; + return 0; + } + if (bmp->ImportBits (bitmap) != B_OK) + { + delete bmp; + return 0; + } + *(BBitmap **) new_bitmap = bmp; + return 1; +} + +void +BBitmap_free (void *bitmap) +{ + delete (BBitmap *) bitmap; +} + +/* Create new bitmap in RGB32 format, or in GRAY1 if MONO_P is + non-zero. */ +void * +BBitmap_new (int width, int height, int mono_p) +{ + BBitmap *bn = new (std::nothrow) BBitmap (BRect (0, 0, width - 1, height - 1), + mono_p ? B_GRAY1 : B_RGB32); + + return bn->InitCheck () == B_OK ? (void *) bn : (void *) (delete bn, NULL); +} + +void +BBitmap_dimensions (void *bitmap, int *left, int *top, + int *right, int *bottom, + int32_t *bytes_per_row, int *mono_p) +{ + BRect rect = ((BBitmap *) bitmap)->Bounds (); + *left = rect.left; + *top = rect.top; + *right = rect.right; + *bottom = rect.bottom; + + *bytes_per_row = ((BBitmap *) bitmap)->BytesPerRow (); + *mono_p = (((BBitmap *) bitmap)->ColorSpace () == B_GRAY1); +} + +/* Set up an application and return it. If starting the application + thread fails, abort Emacs. */ +void * +BApplication_setup (void) +{ + if (be_app) + return be_app; + thread_id id; + Emacs *app; + + app = new Emacs; + app->Unlock (); + if ((id = spawn_thread (start_running_application, "Emacs app thread", + B_DEFAULT_MEDIA_PRIORITY, app)) < 0) + gui_abort ("spawn_thread failed"); + + resume_thread (id); + + app_thread = id; + return app; +} + +/* Set up and return a window with its view put in VIEW. */ +void * +BWindow_new (void *_view) +{ + BWindow *window = new (std::nothrow) EmacsWindow; + BView **v = (BView **) _view; + if (!window) + { + *v = NULL; + return window; + } + + BView *vw = new (std::nothrow) EmacsView; + if (!vw) + { + *v = NULL; + window->Lock (); + window->Quit (); + return NULL; + } + window->AddChild (vw); + *v = vw; + return window; +} + +void +BWindow_quit (void *window) +{ + ((BWindow *) window)->Lock (); + ((BWindow *) window)->Quit (); +} + +/* Set WINDOW's offset to X, Y. */ +void +BWindow_set_offset (void *window, int x, int y) +{ + BWindow *wn = (BWindow *) window; + EmacsWindow *w = dynamic_cast (wn); + if (w) + { + if (!w->LockLooper ()) + gui_abort ("Failed to lock window looper setting offset"); + w->EmacsMoveTo (x, y); + w->UnlockLooper (); + } + else + wn->MoveTo (x, y); +} + +/* Iconify WINDOW. */ +void +BWindow_iconify (void *window) +{ + if (((BWindow *) window)->IsHidden ()) + BWindow_set_visible (window, true); + ((BWindow *) window)->Minimize (true); +} + +/* Show or hide WINDOW. */ +void +BWindow_set_visible (void *window, int visible_p) +{ + EmacsWindow *win = (EmacsWindow *) window; + if (visible_p) + { + if (win->IsMinimized ()) + win->Minimize (false); + win->EmacsShow (); + } + else if (!win->IsHidden ()) + { + if (win->IsMinimized ()) + win->Minimize (false); + win->EmacsHide (); + } + win->Sync (); +} + +/* Change the title of WINDOW to the multibyte string TITLE. */ +void +BWindow_retitle (void *window, const char *title) +{ + ((BWindow *) window)->SetTitle (title); +} + +/* Resize WINDOW to WIDTH by HEIGHT. */ +void +BWindow_resize (void *window, int width, int height) +{ + ((BWindow *) window)->ResizeTo (width, height); +} + +/* Activate WINDOW, making it the subject of keyboard focus and + bringing it to the front of the screen. */ +void +BWindow_activate (void *window) +{ + ((BWindow *) window)->Activate (); +} + +/* Return the pixel dimensions of the main screen in WIDTH and + HEIGHT. */ +void +BScreen_px_dim (int *width, int *height) +{ + BScreen screen; + if (!screen.IsValid ()) + gui_abort ("Invalid screen"); + BRect frame = screen.Frame (); + + *width = frame.right - frame.left; + *height = frame.bottom - frame.top; +} + +/* Resize VIEW to WIDTH, HEIGHT. */ +void +BView_resize_to (void *view, int width, int height) +{ + EmacsView *vw = (EmacsView *) view; + if (!vw->LockLooper ()) + gui_abort ("Failed to lock view for resize"); + vw->ResizeTo (width, height); + vw->AfterResize (width, height); + vw->UnlockLooper (); +} + +void * +BCursor_create_default (void) +{ + return new BCursor (B_CURSOR_ID_SYSTEM_DEFAULT); +} + +void * +BCursor_create_modeline (void) +{ + return new BCursor (B_CURSOR_ID_CONTEXT_MENU); +} + +void * +BCursor_from_id (enum haiku_cursor cursor) +{ + return new BCursor ((enum BCursorID) cursor); +} + +void * +BCursor_create_i_beam (void) +{ + return new BCursor (B_CURSOR_ID_I_BEAM); +} + +void * +BCursor_create_progress_cursor (void) +{ + return new BCursor (B_CURSOR_ID_PROGRESS); +} + +void * +BCursor_create_grab (void) +{ + return new BCursor (B_CURSOR_ID_GRAB); +} + +void +BCursor_delete (void *cursor) +{ + delete (BCursor *) cursor; +} + +void +BView_set_view_cursor (void *view, void *cursor) +{ + if (!((BView *) view)->LockLooper ()) + gui_abort ("Failed to lock view setting cursor"); + ((BView *) view)->SetViewCursor ((BCursor *) cursor); + ((BView *) view)->UnlockLooper (); +} + +void +BWindow_Flush (void *window) +{ + ((BWindow *) window)->Flush (); +} + +/* Map the keycode KC, storing the result in CODE and 1 in + NON_ASCII_P if it should be used. */ +void +BMapKey (uint32_t kc, int *non_ascii_p, unsigned *code) +{ + if (*code == 10 && kc != 0x42) + { + *code = XK_Return; + *non_ascii_p = 1; + return; + } + + switch (kc) + { + default: + *non_ascii_p = 0; + if (kc < 0xe && kc > 0x1) + { + *code = XK_F1 + kc - 2; + *non_ascii_p = 1; + } + return; + case 0x1e: + *code = XK_BackSpace; + break; + case 0x61: + *code = XK_Left; + break; + case 0x63: + *code = XK_Right; + break; + case 0x57: + *code = XK_Up; + break; + case 0x62: + *code = XK_Down; + break; + case 0x64: + *code = XK_Insert; + break; + case 0x65: + *code = XK_Delete; + break; + case 0x37: + *code = XK_Home; + break; + case 0x58: + *code = XK_End; + break; + case 0x39: + *code = XK_Page_Up; + break; + case 0x5a: + *code = XK_Page_Down; + break; + case 0x1: + *code = XK_Escape; + break; + case 0x68: + *code = XK_Menu; + break; + } + *non_ascii_p = 1; +} + +/* Make a scrollbar, attach it to VIEW's window, and return it. */ +void * +BScrollBar_make_for_view (void *view, int horizontal_p, + int x, int y, int x1, int y1, + void *scroll_bar_ptr) +{ + EmacsScrollBar *sb = new EmacsScrollBar (x, y, x1, y1, horizontal_p); + sb->scroll_bar = scroll_bar_ptr; + + BView *vw = (BView *) view; + BView *sv = (BView *) sb; + if (!vw->LockLooper ()) + gui_abort ("Failed to lock scrollbar owner"); + vw->AddChild ((BView *) sb); + sv->WindowActivated (vw->Window ()->IsActive ()); + vw->UnlockLooper (); + return sb; +} + +void +BScrollBar_delete (void *sb) +{ + BView *view = (BView *) sb; + BView *pr = view->Parent (); + + if (!pr->LockLooper ()) + gui_abort ("Failed to lock scrollbar parent"); + pr->RemoveChild (view); + pr->UnlockLooper (); + + delete (EmacsScrollBar *) sb; +} + +void +BView_move_frame (void *view, int x, int y, int x1, int y1) +{ + BView *vw = (BView *) view; + + if (!vw->LockLooper ()) + gui_abort ("Failed to lock view moving frame"); + vw->MoveTo (x, y); + vw->ResizeTo (x1 - x, y1 - y); + vw->Flush (); + vw->Sync (); + vw->UnlockLooper (); +} + +void +BView_scroll_bar_update (void *sb, int portion, int whole, int position) +{ + BScrollBar *bar = (BScrollBar *) sb; + BMessage msg = BMessage (SCROLL_BAR_UPDATE); + BMessenger mr = BMessenger (bar); + msg.AddInt32 ("emacs:range", whole); + msg.AddInt32 ("emacs:units", position); + + mr.SendMessage (&msg); +} + +/* Return the default scrollbar size. */ +int +BScrollBar_default_size (int horizontal_p) +{ + return horizontal_p ? B_H_SCROLL_BAR_HEIGHT : B_V_SCROLL_BAR_WIDTH; +} + +/* Invalidate VIEW, causing it to be drawn again. */ +void +BView_invalidate (void *view) +{ + BView *vw = (BView *) view; + if (!vw->LockLooper ()) + gui_abort ("Couldn't lock view while invalidating it"); + vw->Invalidate (); + vw->UnlockLooper (); +} + +/* Lock VIEW in preparation for drawing operations. This should be + called before any attempt to draw onto VIEW or to lock it for Cairo + drawing. `BView_draw_unlock' should be called afterwards. */ +void +BView_draw_lock (void *view) +{ + EmacsView *vw = (EmacsView *) view; + if (vw->looper_locked_count) + { + vw->looper_locked_count++; + return; + } + BView *v = (BView *) find_appropriate_view_for_draw (vw); + if (v != vw) + { + if (!vw->offscreen_draw_bitmap_1->Lock ()) + gui_abort ("Failed to lock offscreen bitmap while acquiring draw lock"); + } + else if (!v->LockLooper ()) + gui_abort ("Failed to lock draw view while acquiring draw lock"); + + if (v != vw && !vw->LockLooper ()) + gui_abort ("Failed to lock view while acquiring draw lock"); + vw->looper_locked_count++; +} + +void +BView_draw_unlock (void *view) +{ + EmacsView *vw = (EmacsView *) view; + if (--vw->looper_locked_count) + return; + + BView *v = (BView *) find_appropriate_view_for_draw (view); + if (v == vw) + vw->UnlockLooper (); + else + { + vw->offscreen_draw_bitmap_1->Unlock (); + vw->UnlockLooper (); + } +} + +void +BWindow_center_on_screen (void *window) +{ + BWindow *w = (BWindow *) window; + w->CenterOnScreen (); +} + +/* Tell VIEW it has been clicked at X by Y. */ +void +BView_mouse_down (void *view, int x, int y) +{ + BView *vw = (BView *) view; + if (vw->LockLooper ()) + { + vw->MouseDown (BPoint (x, y)); + vw->UnlockLooper (); + } +} + +/* Tell VIEW the mouse has been released at X by Y. */ +void +BView_mouse_up (void *view, int x, int y) +{ + BView *vw = (BView *) view; + if (vw->LockLooper ()) + { + vw->MouseUp (BPoint (x, y)); + vw->UnlockLooper (); + } +} + +/* Tell VIEW that the mouse has moved to Y by Y. */ +void +BView_mouse_moved (void *view, int x, int y, uint32_t transit) +{ + BView *vw = (BView *) view; + if (vw->LockLooper ()) + { + vw->MouseMoved (BPoint (x, y), transit, NULL); + vw->UnlockLooper (); + } +} + +/* Import BITS into BITMAP using the B_GRAY1 colorspace. */ +void +BBitmap_import_mono_bits (void *bitmap, void *bits, int wd, int h) +{ + BBitmap *bmp = (BBitmap *) bitmap; + unsigned char *data = (unsigned char *) bmp->Bits (); + unsigned short *bts = (unsigned short *) bits; + + for (int i = 0; i < (h * (wd / 8)); i++) + { + *((unsigned short *) data) = bts[i]; + data += bmp->BytesPerRow (); + } +} + +/* Make a scrollbar at X, Y known to the view VIEW. */ +void +BView_publish_scroll_bar (void *view, int x, int y, int width, int height) +{ + EmacsView *vw = (EmacsView *) view; + if (vw->LockLooper ()) + { + vw->sb_region.Include (BRect (x, y, x - 1 + width, + y - 1 + height)); + vw->UnlockLooper (); + } +} + +void +BView_forget_scroll_bar (void *view, int x, int y, int width, int height) +{ + EmacsView *vw = (EmacsView *) view; + if (vw->LockLooper ()) + { + vw->sb_region.Exclude (BRect (x, y, x - 1 + width, + y - 1 + height)); + vw->UnlockLooper (); + } +} + +void +BView_get_mouse (void *view, int *x, int *y) +{ + BPoint l; + BView *vw = (BView *) view; + if (!vw->LockLooper ()) + gui_abort ("Failed to lock view in BView_get_mouse"); + vw->GetMouse (&l, NULL, 1); + vw->UnlockLooper (); + + *x = std::lrint (l.x); + *y = std::lrint (l.y); +} + +/* Perform an in-place conversion of X and Y from VIEW's coordinate + system to its screen's coordinate system. */ +void +BView_convert_to_screen (void *view, int *x, int *y) +{ + BPoint l = BPoint (*x, *y); + BView *vw = (BView *) view; + if (!vw->LockLooper ()) + gui_abort ("Failed to lock view in convert_to_screen"); + vw->ConvertToScreen (&l); + vw->UnlockLooper (); + + *x = std::lrint (l.x); + *y = std::lrint (l.y); +} + +void +BView_convert_from_screen (void *view, int *x, int *y) +{ + BPoint l = BPoint (*x, *y); + BView *vw = (BView *) view; + if (!vw->LockLooper ()) + gui_abort ("Failed to lock view in convert_from_screen"); + vw->ConvertFromScreen (&l); + vw->UnlockLooper (); + + *x = std::lrint (l.x); + *y = std::lrint (l.y); +} + +/* Decorate or undecorate WINDOW depending on DECORATE_P. */ +void +BWindow_change_decoration (void *window, int decorate_p) +{ + BWindow *w = (BWindow *) window; + if (!w->LockLooper ()) + gui_abort ("Failed to lock window while changing its decorations"); + if (decorate_p) + w->SetLook (B_TITLED_WINDOW_LOOK); + else + w->SetLook (B_NO_BORDER_WINDOW_LOOK); + w->UnlockLooper (); +} + +/* Decorate WINDOW appropriately for use as a tooltip. */ +void +BWindow_set_tooltip_decoration (void *window) +{ + BWindow *w = (BWindow *) window; + if (!w->LockLooper ()) + gui_abort ("Failed to lock window while setting ttip decoration"); + w->SetLook (B_BORDERED_WINDOW_LOOK); + w->SetFeel (B_FLOATING_APP_WINDOW_FEEL); + w->UnlockLooper (); +} + +/* Set B_AVOID_FOCUS on WINDOW if AVOID_FOCUS_P is non-nil, or clear + it otherwise. */ +void +BWindow_set_avoid_focus (void *window, int avoid_focus_p) +{ + BWindow *w = (BWindow *) window; + if (!w->LockLooper ()) + gui_abort ("Failed to lock window while setting avoid focus"); + + if (!avoid_focus_p) + w->SetFlags (w->Flags () & ~B_AVOID_FOCUS); + else + w->SetFlags (w->Flags () | B_AVOID_FOCUS); + w->Sync (); + w->UnlockLooper (); +} + +void +BView_emacs_delete (void *view) +{ + EmacsView *vw = (EmacsView *) view; + if (!vw->LockLooper ()) + gui_abort ("Failed to lock view while deleting it"); + vw->RemoveSelf (); + delete vw; +} + +/* Return the current workspace. */ +uint32_t +haiku_current_workspace (void) +{ + return current_workspace (); +} + +/* Return a bitmask consisting of workspaces WINDOW is on. */ +uint32_t +BWindow_workspaces (void *window) +{ + return ((BWindow *) window)->Workspaces (); +} + +/* Create a popup menu. */ +void * +BPopUpMenu_new (const char *name) +{ + BPopUpMenu *menu = new EmacsPopUpMenu (name); + menu->SetRadioMode (0); + return menu; +} + +/* Add a title item to MENU. These items cannot be highlighted or + triggered, and their labels will display as bold text. */ +void +BMenu_add_title (void *menu, const char *text) +{ + EmacsTitleMenuItem *it = new EmacsTitleMenuItem (text); + BMenu *mn = (BMenu *) menu; + mn->AddItem (it); +} + +/* Add an item to the menu MENU. */ +void +BMenu_add_item (void *menu, const char *label, void *ptr, bool enabled_p, + bool marked_p, bool mbar_p, void *mbw_ptr, const char *key, + const char *help) +{ + BMenu *m = (BMenu *) menu; + BMessage *msg; + if (ptr) + msg = new BMessage (); + EmacsMenuItem *it = new EmacsMenuItem (key, label, help, ptr ? msg : NULL); + it->SetTarget (m->Window ()); + it->SetEnabled (enabled_p); + it->SetMarked (marked_p); + if (mbar_p) + { + it->menu_bar_id = (intptr_t) ptr; + it->wind_ptr = mbw_ptr; + } + if (ptr) + msg->AddPointer ("menuptr", ptr); + m->AddItem (it); +} + +/* Add a separator to the menu MENU. */ +void +BMenu_add_separator (void *menu) +{ + BMenu *m = (BMenu *) menu; + + m->AddSeparatorItem (); +} + +/* Create a submenu and attach it to MENU. */ +void * +BMenu_new_submenu (void *menu, const char *label, bool enabled_p) +{ + BMenu *m = (BMenu *) menu; + BMenu *mn = new BMenu (label, B_ITEMS_IN_COLUMN); + mn->SetRadioMode (0); + BMenuItem *i = new BMenuItem (mn); + i->SetEnabled (enabled_p); + m->AddItem (i); + return mn; +} + +/* Create a submenu that notifies Emacs upon opening. */ +void * +BMenu_new_menu_bar_submenu (void *menu, const char *label) +{ + BMenu *m = (BMenu *) menu; + BMenu *mn = new BMenu (label, B_ITEMS_IN_COLUMN); + mn->SetRadioMode (0); + BMenuItem *i = new BMenuItem (mn); + i->SetEnabled (1); + m->AddItem (i); + return mn; +} + +/* Run MENU, waiting for it to close, and return a pointer to the + data of the selected item (if one exists), or NULL. X, Y should + be in the screen coordinate system. */ +void * +BMenu_run (void *menu, int x, int y) +{ + BPopUpMenu *mn = (BPopUpMenu *) menu; + mn->SetRadioMode (0); + BMenuItem *it = mn->Go (BPoint (x, y)); + if (it) + { + BMessage *mg = it->Message (); + if (mg) + return (void *) mg->GetPointer ("menuptr"); + else + return NULL; + } + return NULL; +} + +/* Delete the entire menu hierarchy of MENU, and then delete MENU + itself. */ +void +BPopUpMenu_delete (void *menu) +{ + delete (BPopUpMenu *) menu; +} + +/* Create a menubar, attach it to VIEW, and return it. */ +void * +BMenuBar_new (void *view) +{ + BView *vw = (BView *) view; + EmacsMenuBar *bar = new EmacsMenuBar (); + + if (!vw->LockLooper ()) + gui_abort ("Failed to lock menu bar parent"); + vw->AddChild ((BView *) bar); + vw->UnlockLooper (); + + return bar; +} + +/* Delete MENUBAR along with all subitems. */ +void +BMenuBar_delete (void *menubar) +{ + BView *vw = (BView *) menubar; + BView *p = vw->Parent (); + if (!p->LockLooper ()) + gui_abort ("Failed to lock menu bar parent while removing menubar"); + vw->RemoveSelf (); + p->UnlockLooper (); + delete vw; +} + +/* Delete all items from MENU. */ +void +BMenu_delete_all (void *menu) +{ + BMenu *mn = (BMenu *) menu; + mn->RemoveItems (0, mn->CountItems (), true); +} + +/* Delete COUNT items from MENU starting from START. */ +void +BMenu_delete_from (void *menu, int start, int count) +{ + BMenu *mn = (BMenu *) menu; + mn->RemoveItems (start, count, true); +} + +/* Count items in menu MENU. */ +int +BMenu_count_items (void *menu) +{ + return ((BMenu *) menu)->CountItems (); +} + +/* Find the item in MENU at IDX. */ +void * +BMenu_item_at (void *menu, int idx) +{ + return ((BMenu *) menu)->ItemAt (idx); +} + +/* Set ITEM's label to LABEL. */ +void +BMenu_item_set_label (void *item, const char *label) +{ + ((BMenuItem *) item)->SetLabel (label); +} + +/* Get ITEM's menu. */ +void * +BMenu_item_get_menu (void *item) +{ + return ((BMenuItem *) item)->Submenu (); +} + +/* Emit a beep noise. */ +void +haiku_ring_bell (void) +{ + beep (); +} + +/* Create a BAlert with TEXT. */ +void * +BAlert_new (const char *text, enum haiku_alert_type type) +{ + return new BAlert (NULL, text, NULL, NULL, NULL, B_WIDTH_AS_USUAL, + (enum alert_type) type); +} + +/* Add a button to ALERT and return the button. */ +void * +BAlert_add_button (void *alert, const char *text) +{ + BAlert *al = (BAlert *) alert; + al->AddButton (text); + return al->ButtonAt (al->CountButtons () - 1); +} + +/* Run ALERT, returning the number of the button that was selected, + or -1 if no button was selected before the alert was closed. */ +int32_t +BAlert_go (void *alert) +{ + return ((BAlert *) alert)->Go (); +} + +/* Enable or disable BUTTON depending on ENABLED_P. */ +void +BButton_set_enabled (void *button, int enabled_p) +{ + ((BButton *) button)->SetEnabled (enabled_p); +} + +/* Set VIEW's tooltip to TOOLTIP. */ +void +BView_set_tooltip (void *view, const char *tooltip) +{ + ((BView *) view)->SetToolTip (tooltip); +} + +/* Set VIEW's tooltip to a sticky tooltip at X by Y. */ +void +BView_set_and_show_sticky_tooltip (void *view, const char *tooltip, + int x, int y) +{ + BToolTip *tip; + BView *vw = (BView *) view; + if (!vw->LockLooper ()) + gui_abort ("Failed to lock view while showing sticky tooltip"); + vw->SetToolTip (tooltip); + tip = vw->ToolTip (); + BPoint pt; + EmacsView *ev = dynamic_cast (vw); + if (ev) + ev->tt_absl_pos = BPoint (x, y); + + vw->GetMouse (&pt, NULL, 1); + pt.x -= x; + pt.y -= y; + + pt.x = -pt.x; + pt.y = -pt.y; + + tip->SetMouseRelativeLocation (pt); + tip->SetSticky (1); + vw->ShowToolTip (tip); + vw->UnlockLooper (); +} + +/* Delete ALERT. */ +void +BAlert_delete (void *alert) +{ + delete (BAlert *) alert; +} + +/* Place the resolution of the monitor in DPI in RSSX and RSSY. */ +void +BScreen_res (double *rrsx, double *rrsy) +{ + BScreen s (B_MAIN_SCREEN_ID); + if (!s.IsValid ()) + gui_abort ("Invalid screen for resolution checks"); + monitor_info i; + + if (s.GetMonitorInfo (&i) == B_OK) + { + *rrsx = (double) i.width / (double) 2.54; + *rrsy = (double) i.height / (double) 2.54; + } + else + { + *rrsx = 72.27; + *rrsy = 72.27; + } +} + +/* Add WINDOW to OTHER_WINDOW's subset and parent it to + OTHER_WINDOW. */ +void +EmacsWindow_parent_to (void *window, void *other_window) +{ + EmacsWindow *w = (EmacsWindow *) window; + if (!w->LockLooper ()) + gui_abort ("Failed to lock window while parenting"); + w->ParentTo ((EmacsWindow *) other_window); + w->UnlockLooper (); +} + +void +EmacsWindow_unparent (void *window) +{ + EmacsWindow *w = (EmacsWindow *) window; + if (!w->LockLooper ()) + gui_abort ("Failed to lock window while unparenting"); + w->UnparentAndUnlink (); + w->UnlockLooper (); +} + +/* Place text describing the current version of Haiku in VERSION, + which should be a buffer LEN bytes wide. */ +void +be_get_version_string (char *version, int len) +{ + std::strncpy (version, "Unknown Haiku release", len - 1); + BPath path; + if (find_directory (B_BEOS_LIB_DIRECTORY, &path) == B_OK) + { + path.Append ("libbe.so"); + + BAppFileInfo appFileInfo; + version_info versionInfo; + BFile file; + if (file.SetTo (path.Path (), B_READ_ONLY) == B_OK + && appFileInfo.SetTo (&file) == B_OK + && appFileInfo.GetVersionInfo (&versionInfo, + B_APP_VERSION_KIND) == B_OK + && versionInfo.short_info[0] != '\0') + std::strncpy (version, versionInfo.short_info, len - 1); + } +} + +/* Return the amount of color planes in the current display. */ +int +be_get_display_planes (void) +{ + color_space space = dpy_color_space; + if (space == B_NO_COLOR_SPACE) + { + BScreen screen; /* This is actually a very slow operation. */ + if (!screen.IsValid ()) + gui_abort ("Invalid screen"); + space = dpy_color_space = screen.ColorSpace (); + } + + if (space == B_RGB32 || space == B_RGB24) + return 24; + if (space == B_RGB16) + return 16; + if (space == B_RGB15) + return 15; + if (space == B_CMAP8) + return 8; + + gui_abort ("Bad colorspace for screen"); + /* https://www.haiku-os.org/docs/api/classBScreen.html + says a valid screen can't be anything else. */ + return -1; +} + +/* Return the amount of colors the display can handle. */ +int +be_get_display_color_cells (void) +{ + color_space space = dpy_color_space; + if (space == B_NO_COLOR_SPACE) + { + BScreen screen; + if (!screen.IsValid ()) + gui_abort ("Invalid screen"); + space = dpy_color_space = screen.ColorSpace (); + } + + if (space == B_RGB32 || space == B_RGB24) + return 1677216; + if (space == B_RGB16) + return 65536; + if (space == B_RGB15) + return 32768; + if (space == B_CMAP8) + return 256; + + gui_abort ("Bad colorspace for screen"); + return -1; +} + +/* Warp the pointer to X by Y. */ +void +be_warp_pointer (int x, int y) +{ + /* We're not supposed to use the following function without a + BWindowScreen object, but in Haiku nothing actually prevents us + from doing so. */ + + set_mouse_position (x, y); +} + +/* Update the position of CHILD in WINDOW without actually moving + it. */ +void +EmacsWindow_move_weak_child (void *window, void *child, int xoff, int yoff) +{ + EmacsWindow *w = (EmacsWindow *) window; + EmacsWindow *c = (EmacsWindow *) child; + + if (!w->LockLooper ()) + gui_abort ("Couldn't lock window for weak move"); + w->MoveChild (c, xoff, yoff, 1); + w->UnlockLooper (); +} + +/* Find an appropriate view to draw onto. If VW is double-buffered, + this will be the view used for double buffering instead of VW + itself. */ +void * +find_appropriate_view_for_draw (void *vw) +{ + BView *v = (BView *) vw; + EmacsView *ev = dynamic_cast(v); + if (!ev) + return v; + + return ev->offscreen_draw_view ? ev->offscreen_draw_view : vw; +} + +/* Set up double buffering for VW. */ +void +EmacsView_set_up_double_buffering (void *vw) +{ + EmacsView *view = (EmacsView *) vw; + if (!view->LockLooper ()) + gui_abort ("Couldn't lock view while setting up double buffering"); + if (view->offscreen_draw_view) + { + view->UnlockLooper (); + return; + } + view->SetUpDoubleBuffering (); + view->UnlockLooper (); +} + +/* Flip and invalidate the view VW. */ +void +EmacsView_flip_and_blit (void *vw) +{ + EmacsView *view = (EmacsView *) vw; + if (!view->offscreen_draw_view) + return; + if (!view->LockLooper ()) + gui_abort ("Couldn't lock view in flip_and_blit"); + view->FlipBuffers (); + view->UnlockLooper (); +} + +/* Disable double buffering for VW. */ +void +EmacsView_disable_double_buffering (void *vw) +{ + EmacsView *view = (EmacsView *) vw; + if (!view->LockLooper ()) + gui_abort ("Couldn't lock view tearing down double buffering"); + view->TearDownDoubleBuffering (); + view->UnlockLooper (); +} + +/* Return non-0 if VW is double-buffered. */ +int +EmacsView_double_buffered_p (void *vw) +{ + EmacsView *view = (EmacsView *) vw; + if (!view->LockLooper ()) + gui_abort ("Couldn't lock view testing double buffering status"); + int db_p = !!view->offscreen_draw_view; + view->UnlockLooper (); + return db_p; +} + +struct popup_file_dialog_data +{ + BMessage *msg; + BFilePanel *panel; + BEntry *entry; +}; + +static void +unwind_popup_file_dialog (void *ptr) +{ + struct popup_file_dialog_data *data = + (struct popup_file_dialog_data *) ptr; + BFilePanel *panel = data->panel; + delete panel; + delete data->entry; + delete data->msg; +} + +static void +be_popup_file_dialog_safe_set_target (BFilePanel *dialog, BWindow *window) +{ + dialog->SetTarget (BMessenger (window)); +} + +/* Popup a file dialog. */ +char * +be_popup_file_dialog (int open_p, const char *default_dir, int must_match_p, int dir_only_p, + void *window, const char *save_text, const char *prompt, + void (*block_input_function) (void), + void (*unblock_input_function) (void)) +{ + ptrdiff_t idx = c_specpdl_idx_from_cxx (); + /* setjmp/longjmp is UB with automatic objects. */ + block_input_function (); + BWindow *w = (BWindow *) window; + uint32_t mode = dir_only_p ? B_DIRECTORY_NODE : B_FILE_NODE | B_DIRECTORY_NODE; + BEntry *path = new BEntry; + BMessage *msg = new BMessage ('FPSE'); + BFilePanel *panel = new BFilePanel (open_p ? B_OPEN_PANEL : B_SAVE_PANEL, + NULL, NULL, mode); + unblock_input_function (); + + struct popup_file_dialog_data dat; + dat.entry = path; + dat.msg = msg; + dat.panel = panel; + + record_c_unwind_protect_from_cxx (unwind_popup_file_dialog, &dat); + if (default_dir) + { + if (path->SetTo (default_dir, 0) != B_OK) + default_dir = NULL; + } + + panel->SetMessage (msg); + if (default_dir) + panel->SetPanelDirectory (path); + if (save_text) + panel->SetSaveText (save_text); + panel->SetHideWhenDone (0); + panel->Window ()->SetTitle (prompt); + be_popup_file_dialog_safe_set_target (panel, w); + + panel->Show (); + panel->Window ()->Show (); + + void *buf = alloca (200); + while (1) + { + enum haiku_event_type type; + char *ptr = NULL; + + if (!haiku_read_with_timeout (&type, buf, 200, 100000)) + { + if (type != FILE_PANEL_EVENT) + haiku_write (type, buf); + else if (!ptr) + ptr = (char *) ((struct haiku_file_panel_event *) buf)->ptr; + } + + ssize_t b_s; + haiku_read_size (&b_s); + if (!b_s || b_s == -1 || ptr || panel->Window ()->IsHidden ()) + { + c_unbind_to_nil_from_cxx (idx); + return ptr; + } + } +} + +void +be_app_quit (void) +{ + if (be_app) + { + status_t e; + while (!be_app->Lock ()); + be_app->Quit (); + wait_for_thread (app_thread, &e); + } +} + +/* Temporarily fill VIEW with COLOR. */ +void +EmacsView_do_visible_bell (void *view, uint32_t color) +{ + EmacsView *vw = (EmacsView *) view; + vw->DoVisibleBell (color); +} + +/* Zoom WINDOW. */ +void +BWindow_zoom (void *window) +{ + BWindow *w = (BWindow *) window; + w->Zoom (); +} + +/* Make WINDOW fullscreen if FULLSCREEN_P. */ +void +EmacsWindow_make_fullscreen (void *window, int fullscreen_p) +{ + EmacsWindow *w = (EmacsWindow *) window; + w->MakeFullscreen (fullscreen_p); +} + +/* Unzoom (maximize) WINDOW. */ +void +EmacsWindow_unzoom (void *window) +{ + EmacsWindow *w = (EmacsWindow *) window; + w->UnZoom (); +} + +/* Move the pointer into MBAR and start tracking. */ +void +BMenuBar_start_tracking (void *mbar) +{ + EmacsMenuBar *mb = (EmacsMenuBar *) mbar; + if (!mb->LockLooper ()) + gui_abort ("Couldn't lock menubar"); + BRect frame = mb->Frame (); + BPoint pt = frame.LeftTop (); + BPoint l = pt; + mb->Parent ()->ConvertToScreen (&pt); + set_mouse_position (pt.x, pt.y); + mb->MouseDown (l); + mb->UnlockLooper (); +} + +#ifdef HAVE_NATIVE_IMAGE_API +int +be_can_translate_type_to_bitmap_p (const char *mime) +{ + BTranslatorRoster *r = BTranslatorRoster::Default (); + translator_id *ids; + int32 id_len; + + if (r->GetAllTranslators (&ids, &id_len) != B_OK) + return 0; + + int found_in = 0; + int found_out = 0; + + for (int i = 0; i < id_len; ++i) + { + found_in = 0; + found_out = 0; + const translation_format *i_fmts; + const translation_format *o_fmts; + + int32 i_count, o_count; + + if (r->GetInputFormats (ids[i], &i_fmts, &i_count) != B_OK) + continue; + + if (r->GetOutputFormats (ids[i], &o_fmts, &o_count) != B_OK) + continue; + + for (int x = 0; x < i_count; ++x) + { + if (!strcmp (i_fmts[x].MIME, mime)) + { + found_in = 1; + break; + } + } + + for (int x = 0; x < i_count; ++x) + { + if (!strcmp (o_fmts[x].MIME, "image/x-be-bitmap") || + !strcmp (o_fmts[x].MIME, "image/x-vnd.Be-bitmap")) + { + found_out = 1; + break; + } + } + + if (found_in && found_out) + break; + } + + delete [] ids; + + return found_in && found_out; +} + +void * +be_translate_bitmap_from_file_name (const char *filename) +{ + BBitmap *bm = BTranslationUtils::GetBitmap (filename); + return bm; +} + +void * +be_translate_bitmap_from_memory (const void *buf, size_t bytes) +{ + BMemoryIO io (buf, bytes); + BBitmap *bm = BTranslationUtils::GetBitmap (&io); + return bm; +} +#endif + +/* Return the size of BITMAP's data, in bytes. */ +size_t +BBitmap_bytes_length (void *bitmap) +{ + BBitmap *bm = (BBitmap *) bitmap; + return bm->BitsLength (); +} + +/* Show VIEW's tooltip. */ +void +BView_show_tooltip (void *view) +{ + BView *vw = (BView *) view; + if (vw->LockLooper ()) + { + vw->ShowToolTip (vw->ToolTip ()); + vw->UnlockLooper (); + } +} + + +#ifdef USE_BE_CAIRO +/* Return VIEW's cairo surface. */ +cairo_surface_t * +EmacsView_cairo_surface (void *view) +{ + EmacsView *vw = (EmacsView *) view; + EmacsWindow *wn = (EmacsWindow *) vw->Window (); + return vw->cr_surface ? vw->cr_surface : wn->cr_surface; +} + +/* Transfer each clip rectangle in VIEW to the cairo context + CTX. */ +void +BView_cr_dump_clipping (void *view, cairo_t *ctx) +{ + BView *vw = (BView *) find_appropriate_view_for_draw (view); + BRegion cr; + vw->GetClippingRegion (&cr); + + for (int i = 0; i < cr.CountRects (); ++i) + { + BRect r = cr.RectAt (i); + cairo_rectangle (ctx, r.left, r.top, r.Width () + 1, + r.Height () + 1); + } + + cairo_clip (ctx); +} + +/* Lock WINDOW in preparation for drawing using Cairo. */ +void +EmacsWindow_begin_cr_critical_section (void *window) +{ + EmacsWindow *w = (EmacsWindow *) window; + if (!w->surface_lock.Lock ()) + gui_abort ("Couldn't lock cairo surface"); + + BView *vw = (BView *) w->FindView ("Emacs"); + EmacsView *ev = dynamic_cast (vw); + if (ev && !ev->cr_surface_lock.Lock ()) + gui_abort ("Couldn't lock view cairo surface"); +} + +/* Unlock WINDOW in preparation for drawing using Cairo. */ +void +EmacsWindow_end_cr_critical_section (void *window) +{ + EmacsWindow *w = (EmacsWindow *) window; + w->surface_lock.Unlock (); + BView *vw = (BView *) w->FindView ("Emacs"); + EmacsView *ev = dynamic_cast (vw); + if (ev) + ev->cr_surface_lock.Unlock (); +} +#endif + +/* Get the width of STR in the plain font. */ +int +be_string_width_with_plain_font (const char *str) +{ + return be_plain_font->StringWidth (str); +} + +/* Get the ascent + descent of the plain font. */ +int +be_plain_font_height (void) +{ + struct font_height fheight; + be_plain_font->GetHeight (&fheight); + + return fheight.ascent + fheight.descent; +} + +/* Return the number of physical displays connected. */ +int +be_get_display_screens (void) +{ + int count = 1; + BScreen scr; + + if (!scr.IsValid ()) + gui_abort ("Main screen vanished!"); + while (scr.SetToNext () == B_OK && scr.IsValid ()) + ++count; + + return count; +} + +/* Set the minimum width the user can resize WINDOW to. */ +void +BWindow_set_min_size (void *window, int width, int height) +{ + BWindow *w = (BWindow *) window; + + if (!w->LockLooper ()) + gui_abort ("Failed to lock window looper setting min size"); + w->SetSizeLimits (width, -1, height, -1); + w->UnlockLooper (); +} + +/* Set the alignment of WINDOW's dimensions. */ +void +BWindow_set_size_alignment (void *window, int align_width, int align_height) +{ + BWindow *w = (BWindow *) window; + + if (!w->LockLooper ()) + gui_abort ("Failed to lock window looper setting alignment"); +#if 0 /* Haiku does not currently implement SetWindowAlignment. */ + if (w->SetWindowAlignment (B_PIXEL_ALIGNMENT, -1, -1, align_width, + align_width, -1, -1, align_height, + align_height) != B_NO_ERROR) + gui_abort ("Invalid pixel alignment"); +#endif + w->UnlockLooper (); +} diff --git a/src/haiku_support.h b/src/haiku_support.h new file mode 100644 index 0000000000..9f5f3c77e3 --- /dev/null +++ b/src/haiku_support.h @@ -0,0 +1,869 @@ +/* Haiku window system support. Hey Emacs, this is -*- C++ -*- + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#ifndef _HAIKU_SUPPORT_H +#define _HAIKU_SUPPORT_H + +#include + +#ifdef HAVE_FREETYPE +#include +#include +#include FT_FREETYPE_H +#include FT_SIZES_H +#endif + +#ifdef USE_BE_CAIRO +#include +#endif + +enum haiku_cursor + { + CURSOR_ID_NO_CURSOR = 12, + CURSOR_ID_RESIZE_NORTH = 15, + CURSOR_ID_RESIZE_EAST = 16, + CURSOR_ID_RESIZE_SOUTH = 17, + CURSOR_ID_RESIZE_WEST = 18, + CURSOR_ID_RESIZE_NORTH_EAST = 19, + CURSOR_ID_RESIZE_NORTH_WEST = 20, + CURSOR_ID_RESIZE_SOUTH_EAST = 21, + CURSOR_ID_RESIZE_SOUTH_WEST = 22, + CURSOR_ID_RESIZE_NORTH_SOUTH = 23, + CURSOR_ID_RESIZE_EAST_WEST = 24, + CURSOR_ID_RESIZE_NORTH_EAST_SOUTH_WEST = 25, + CURSOR_ID_RESIZE_NORTH_WEST_SOUTH_EAST = 26 + }; + +enum haiku_alert_type + { + HAIKU_EMPTY_ALERT = 0, + HAIKU_INFO_ALERT, + HAIKU_IDEA_ALERT, + HAIKU_WARNING_ALERT, + HAIKU_STOP_ALERT + }; + +enum haiku_event_type + { + QUIT_REQUESTED, + FRAME_RESIZED, + FRAME_EXPOSED, + KEY_DOWN, + KEY_UP, + ACTIVATION, + MOUSE_MOTION, + BUTTON_DOWN, + BUTTON_UP, + ICONIFICATION, + MOVE_EVENT, + SCROLL_BAR_VALUE_EVENT, + SCROLL_BAR_DRAG_EVENT, + WHEEL_MOVE_EVENT, + MENU_BAR_RESIZE, + MENU_BAR_OPEN, + MENU_BAR_SELECT_EVENT, + MENU_BAR_CLOSE, + FILE_PANEL_EVENT, + MENU_BAR_HELP_EVENT, + ZOOM_EVENT, + REFS_EVENT, + APP_QUIT_REQUESTED_EVENT + }; + +struct haiku_quit_requested_event +{ + void *window; +}; + +struct haiku_resize_event +{ + void *window; + float px_heightf; + float px_widthf; +}; + +struct haiku_expose_event +{ + void *window; + int x; + int y; + int width; + int height; +}; + +struct haiku_refs_event +{ + void *window; + int x, y; + /* Free this with free! */ + char *ref; +}; + +struct haiku_app_quit_requested_event +{ + char dummy; +}; + +#define HAIKU_MODIFIER_ALT (1) +#define HAIKU_MODIFIER_CTRL (1 << 1) +#define HAIKU_MODIFIER_SHIFT (1 << 2) +#define HAIKU_MODIFIER_SUPER (1 << 3) + +struct haiku_key_event +{ + void *window; + int modifiers; + uint32_t mb_char; + uint32_t unraw_mb_char; + short kc; +}; + +struct haiku_activation_event +{ + void *window; + int activated_p; +}; + +struct haiku_mouse_motion_event +{ + void *window; + bool just_exited_p; + int x; + int y; + uint32_t be_code; +}; + +struct haiku_button_event +{ + void *window; + int btn_no; + int modifiers; + int x; + int y; +}; + +struct haiku_iconification_event +{ + void *window; + int iconified_p; +}; + +struct haiku_move_event +{ + void *window; + int x; + int y; +}; + +struct haiku_wheel_move_event +{ + void *window; + int modifiers; + float delta_x; + float delta_y; +}; + +struct haiku_menu_bar_select_event +{ + void *window; + void *ptr; +}; + +struct haiku_file_panel_event +{ + void *ptr; +}; + +struct haiku_menu_bar_help_event +{ + void *window; + int mb_idx; +}; + +struct haiku_zoom_event +{ + void *window; + int x; + int y; + int width; + int height; +}; + +#define FSPEC_FAMILY 1 +#define FSPEC_STYLE (1 << 1) +#define FSPEC_SLANT (1 << 2) +#define FSPEC_WEIGHT (1 << 3) +#define FSPEC_SPACING (1 << 4) +#define FSPEC_WANTED (1 << 5) +#define FSPEC_NEED_ONE_OF (1 << 6) +#define FSPEC_WIDTH (1 << 7) +#define FSPEC_LANGUAGE (1 << 8) + +typedef char haiku_font_family_or_style[64]; + +enum haiku_font_slant + { + NO_SLANT = -1, + SLANT_OBLIQUE, + SLANT_REGULAR, + SLANT_ITALIC + }; + +enum haiku_font_width + { + NO_WIDTH = -1, + ULTRA_CONDENSED, + EXTRA_CONDENSED, + CONDENSED, + SEMI_CONDENSED, + NORMAL_WIDTH, + SEMI_EXPANDED, + EXPANDED, + EXTRA_EXPANDED, + ULTRA_EXPANDED + }; + +enum haiku_font_language + { + LANGUAGE_CN, + LANGUAGE_KO, + LANGUAGE_JP, + MAX_LANGUAGE /* This isn't a language. */ + }; + +struct haiku_font_pattern +{ + int specified; + struct haiku_font_pattern *next; + /* The next two fields are only temporarily used during the font + discovery process! Do not rely on them being correct outside + BFont_find. */ + struct haiku_font_pattern *last; + struct haiku_font_pattern *next_family; + haiku_font_family_or_style family; + haiku_font_family_or_style style; + int weight; + int mono_spacing_p; + int want_chars_len; + int need_one_of_len; + enum haiku_font_slant slant; + enum haiku_font_width width; + enum haiku_font_language language; + uint32_t *wanted_chars; + uint32_t *need_one_of; + + int oblique_seen_p; +}; + +struct haiku_scroll_bar_value_event +{ + void *scroll_bar; + int position; +}; + +struct haiku_scroll_bar_drag_event +{ + void *scroll_bar; + int dragging_p; +}; + +struct haiku_menu_bar_resize_event +{ + void *window; + int width; + int height; +}; + +struct haiku_menu_bar_state_event +{ + void *window; +}; + +#define HAIKU_THIN 0 +#define HAIKU_ULTRALIGHT 20 +#define HAIKU_EXTRALIGHT 40 +#define HAIKU_LIGHT 50 +#define HAIKU_SEMI_LIGHT 75 +#define HAIKU_REGULAR 100 +#define HAIKU_SEMI_BOLD 180 +#define HAIKU_BOLD 200 +#define HAIKU_EXTRA_BOLD 205 +#define HAIKU_ULTRA_BOLD 210 +#define HAIKU_BOOK 400 +#define HAIKU_HEAVY 800 +#define HAIKU_ULTRA_HEAVY 900 +#define HAIKU_BLACK 1000 +#define HAIKU_MEDIUM 2000 + +#ifdef __cplusplus +extern "C" +{ +#endif +#include +#include + +#ifdef __cplusplus + typedef void *haiku; + + extern void + haiku_put_pixel (haiku bitmap, int x, int y, unsigned long pixel); + + extern unsigned long + haiku_get_pixel (haiku bitmap, int x, int y); +#endif + + extern port_id port_application_to_emacs; + + extern void haiku_io_init (void); + extern void haiku_io_init_in_app_thread (void); + + extern void + haiku_read_size (ssize_t *len); + + extern int + haiku_read (enum haiku_event_type *type, void *buf, ssize_t len); + + extern int + haiku_read_with_timeout (enum haiku_event_type *type, void *buf, ssize_t len, + time_t timeout); + + extern int + haiku_write (enum haiku_event_type type, void *buf); + + extern int + haiku_write_without_signal (enum haiku_event_type type, void *buf); + + extern void + rgb_color_hsl (uint32_t rgb, double *h, double *s, double *l); + + extern void + hsl_color_rgb (double h, double s, double l, uint32_t *rgb); + + extern void * + BBitmap_new (int width, int height, int mono_p); + + extern void * + BBitmap_data (void *bitmap); + + extern int + BBitmap_convert (void *bitmap, void **new_bitmap); + + extern void + BBitmap_free (void *bitmap); + + extern void + BBitmap_dimensions (void *bitmap, int *left, int *top, + int *right, int *bottom, int32_t *bytes_per_row, + int *mono_p); + + extern void * + BApplication_setup (void); + + extern void * + BWindow_new (void *view); + + extern void + BWindow_quit (void *window); + + extern void + BWindow_set_offset (void *window, int x, int y); + + extern void + BWindow_iconify (void *window); + + extern void + BWindow_set_visible (void *window, int visible_p); + + extern void + BFont_close (void *font); + + extern void + BFont_dat (void *font, int *px_size, int *min_width, int *max_width, + int *avg_width, int *height, int *space_width, int *ascent, + int *descent, int *underline_position, int *underline_thickness); + + extern int + BFont_have_char_p (void *font, int32_t chr); + + extern int + BFont_have_char_block (void *font, int32_t beg, int32_t end); + + extern void + BFont_char_bounds (void *font, const char *mb_str, int *advance, + int *lb, int *rb); + + extern void + BFont_nchar_bounds (void *font, const char *mb_str, int *advance, + int *lb, int *rb, int32_t n); + + extern void + BWindow_retitle (void *window, const char *title); + + extern void + BWindow_resize (void *window, int width, int height); + + extern void + BWindow_activate (void *window); + + extern void + BView_StartClip (void *view); + + extern void + BView_EndClip (void *view); + + extern void + BView_SetHighColor (void *view, uint32_t color); + + extern void + BView_SetHighColorForVisibleBell (void *view, uint32_t color); + + extern void + BView_FillRectangleForVisibleBell (void *view, int x, int y, int width, + int height); + + extern void + BView_SetLowColor (void *view, uint32_t color); + + extern void + BView_SetPenSize (void *view, int u); + + extern void + BView_SetFont (void *view, void *font); + + extern void + BView_MovePenTo (void *view, int x, int y); + + extern void + BView_DrawString (void *view, const char *chr, ptrdiff_t len); + + extern void + BView_DrawChar (void *view, char chr); + + extern void + BView_FillRectangle (void *view, int x, int y, int width, int height); + + extern void + BView_FillRectangleAbs (void *view, int x, int y, int x1, int y1); + + extern void + BView_FillTriangle (void *view, int x1, int y1, + int x2, int y2, int x3, int y3); + + extern void + BView_StrokeRectangle (void *view, int x, int y, int width, int height); + + extern void + BView_SetViewColor (void *view, uint32_t color); + + extern void + BView_ClipToRect (void *view, int x, int y, int width, int height); + + extern void + BView_ClipToInverseRect (void *view, int x, int y, int width, int height); + + extern void + BView_StrokeLine (void *view, int sx, int sy, int tx, int ty); + + extern void + BView_CopyBits (void *view, int x, int y, int width, int height, + int tox, int toy, int towidth, int toheight); + + extern void + BView_DrawBitmap (void *view, void *bitmap, int x, int y, + int width, int height, int vx, int vy, int vwidth, + int vheight); + + extern void + BView_DrawBitmapWithEraseOp (void *view, void *bitmap, int x, + int y, int width, int height); + + extern void + BView_DrawMask (void *src, void *view, + int x, int y, int width, int height, + int vx, int vy, int vwidth, int vheight, + uint32_t color); + + extern void * + BBitmap_transform_bitmap (void *bitmap, void *mask, uint32_t m_color, + double rot, int desw, int desh); + + extern void + BScreen_px_dim (int *width, int *height); + + extern void + BView_resize_to (void *view, int width, int height); + + /* Functions for creating and freeing cursors. */ + extern void * + BCursor_create_default (void); + + extern void * + BCursor_from_id (enum haiku_cursor cursor); + + extern void * + BCursor_create_modeline (void); + + extern void * + BCursor_create_i_beam (void); + + extern void * + BCursor_create_progress_cursor (void); + + extern void * + BCursor_create_grab (void); + + extern void + BCursor_delete (void *cursor); + + extern void + BView_set_view_cursor (void *view, void *cursor); + + extern void + BWindow_Flush (void *window); + + extern void + BMapKey (uint32_t kc, int *non_ascii_p, unsigned *code); + + extern void * + BScrollBar_make_for_view (void *view, int horizontal_p, + int x, int y, int x1, int y1, + void *scroll_bar_ptr); + + extern void + BScrollBar_delete (void *sb); + + extern void + BView_move_frame (void *view, int x, int y, int x1, int y1); + + extern void + BView_scroll_bar_update (void *sb, int portion, int whole, int position); + + extern int + BScrollBar_default_size (int horizontal_p); + + extern void + BView_invalidate (void *view); + + extern void + BView_draw_lock (void *view); + + extern void + BView_draw_unlock (void *view); + + extern void + BWindow_center_on_screen (void *window); + + extern void + BView_mouse_moved (void *view, int x, int y, uint32_t transit); + + extern void + BView_mouse_down (void *view, int x, int y); + + extern void + BView_mouse_up (void *view, int x, int y); + + extern void + BBitmap_import_mono_bits (void *bitmap, void *bits, int wd, int h); + + extern void + haiku_font_pattern_free (struct haiku_font_pattern *pt); + + extern struct haiku_font_pattern * + BFont_find (struct haiku_font_pattern *pt); + + extern int + BFont_open_pattern (struct haiku_font_pattern *pat, void **font, float size); + + extern void + BFont_populate_fixed_family (struct haiku_font_pattern *ptn); + + extern void + BFont_populate_plain_family (struct haiku_font_pattern *ptn); + + extern void + BView_publish_scroll_bar (void *view, int x, int y, int width, int height); + + extern void + BView_forget_scroll_bar (void *view, int x, int y, int width, int height); + + extern void + BView_get_mouse (void *view, int *x, int *y); + + extern void + BView_convert_to_screen (void *view, int *x, int *y); + + extern void + BView_convert_from_screen (void *view, int *x, int *y); + + extern void + BWindow_change_decoration (void *window, int decorate_p); + + extern void + BWindow_set_tooltip_decoration (void *window); + + extern void + BWindow_set_avoid_focus (void *window, int avoid_focus_p); + + extern void + BView_emacs_delete (void *view); + + extern uint32_t + haiku_current_workspace (void); + + extern uint32_t + BWindow_workspaces (void *window); + + extern void * + BPopUpMenu_new (const char *name); + + extern void + BMenu_add_item (void *menu, const char *label, void *ptr, bool enabled_p, + bool marked_p, bool mbar_p, void *mbw_ptr, const char *key, + const char *help); + + extern void + BMenu_add_separator (void *menu); + + extern void * + BMenu_new_submenu (void *menu, const char *label, bool enabled_p); + + extern void * + BMenu_new_menu_bar_submenu (void *menu, const char *label); + + extern int + BMenu_count_items (void *menu); + + extern void * + BMenu_item_at (void *menu, int idx); + + extern void * + BMenu_run (void *menu, int x, int y); + + extern void + BPopUpMenu_delete (void *menu); + + extern void * + BMenuBar_new (void *view); + + extern void + BMenu_delete_all (void *menu); + + extern void + BMenuBar_delete (void *menubar); + + extern void + BMenu_item_set_label (void *item, const char *label); + + extern void * + BMenu_item_get_menu (void *item); + + extern void + BMenu_delete_from (void *menu, int start, int count); + + extern void + haiku_ring_bell (void); + + extern void * + BAlert_new (const char *text, enum haiku_alert_type type); + + extern void * + BAlert_add_button (void *alert, const char *text); + + extern int32_t + BAlert_go (void *alert); + + extern void + BButton_set_enabled (void *button, int enabled_p); + + extern void + BView_set_tooltip (void *view, const char *tooltip); + + extern void + BAlert_delete (void *alert); + + extern void + BScreen_res (double *rrsx, double *rrsy); + + extern void + EmacsWindow_parent_to (void *window, void *other_window); + + extern void + EmacsWindow_unparent (void *window); + + extern int + BFont_string_width (void *font, const char *utf8); + + extern void + be_get_version_string (char *version, int len); + + extern int + be_get_display_planes (void); + + extern int + be_get_display_color_cells (void); + + extern void + be_warp_pointer (int x, int y); + + extern void + EmacsWindow_move_weak_child (void *window, void *child, int xoff, int yoff); + + extern void + EmacsView_set_up_double_buffering (void *vw); + + extern void + EmacsView_disable_double_buffering (void *vw); + + extern void + EmacsView_flip_and_blit (void *vw); + + extern int + EmacsView_double_buffered_p (void *vw); + + extern char * + be_popup_file_dialog (int open_p, const char *default_dir, int must_match_p, + int dir_only_p, void *window, const char *save_text, + const char *prompt, + void (*block_input_function) (void), + void (*unblock_input_function) (void)); + + extern void + record_c_unwind_protect_from_cxx (void (*) (void *), void *); + + extern ptrdiff_t + c_specpdl_idx_from_cxx (void); + + extern void + c_unbind_to_nil_from_cxx (ptrdiff_t idx); + + extern void + EmacsView_do_visible_bell (void *view, uint32_t color); + + extern void + BWindow_zoom (void *window); + + extern void + EmacsWindow_make_fullscreen (void *window, int fullscreen_p); + + extern void + EmacsWindow_unzoom (void *window); + +#ifdef HAVE_NATIVE_IMAGE_API + extern int + be_can_translate_type_to_bitmap_p (const char *mime); + + extern void * + be_translate_bitmap_from_file_name (const char *filename); + + extern void * + be_translate_bitmap_from_memory (const void *buf, size_t bytes); +#endif + + extern void + BMenuBar_start_tracking (void *mbar); + + extern size_t + BBitmap_bytes_length (void *bitmap); + + extern void + BView_show_tooltip (void *view); + +#ifdef USE_BE_CAIRO + extern cairo_surface_t * + EmacsView_cairo_surface (void *view); + + extern void + BView_cr_dump_clipping (void *view, cairo_t *ctx); + + extern void + EmacsWindow_begin_cr_critical_section (void *window); + + extern void + EmacsWindow_end_cr_critical_section (void *window); +#endif + + extern void + BView_set_and_show_sticky_tooltip (void *view, const char *tooltip, + int x, int y); + + extern void + BMenu_add_title (void *menu, const char *text); + + extern int + be_plain_font_height (void); + + extern int + be_string_width_with_plain_font (const char *str); + + extern int + be_get_display_screens (void); + + extern void + BWindow_set_min_size (void *window, int width, int height); + + extern void + BWindow_set_size_alignment (void *window, int align_width, int align_height); + +#ifdef __cplusplus + extern void * + find_appropriate_view_for_draw (void *vw); +} + +extern _Noreturn void +gui_abort (const char *msg); +#endif /* _cplusplus */ + +/* Borrowed from X.Org keysymdef.h */ +#define XK_BackSpace 0xff08 /* Back space, back char */ +#define XK_Tab 0xff09 +#define XK_Linefeed 0xff0a /* Linefeed, LF */ +#define XK_Clear 0xff0b +#define XK_Return 0xff0d /* Return, enter */ +#define XK_Pause 0xff13 /* Pause, hold */ +#define XK_Scroll_Lock 0xff14 +#define XK_Sys_Req 0xff15 +#define XK_Escape 0xff1b +#define XK_Delete 0xffff /* Delete, rubout */ +#define XK_Home 0xff50 +#define XK_Left 0xff51 /* Move left, left arrow */ +#define XK_Up 0xff52 /* Move up, up arrow */ +#define XK_Right 0xff53 /* Move right, right arrow */ +#define XK_Down 0xff54 /* Move down, down arrow */ +#define XK_Prior 0xff55 /* Prior, previous */ +#define XK_Page_Up 0xff55 +#define XK_Next 0xff56 /* Next */ +#define XK_Page_Down 0xff56 +#define XK_End 0xff57 /* EOL */ +#define XK_Begin 0xff58 /* BOL */ +#define XK_Select 0xff60 /* Select, mark */ +#define XK_Print 0xff61 +#define XK_Execute 0xff62 /* Execute, run, do */ +#define XK_Insert 0xff63 /* Insert, insert here */ +#define XK_Undo 0xff65 +#define XK_Redo 0xff66 /* Redo, again */ +#define XK_Menu 0xff67 +#define XK_Find 0xff68 /* Find, search */ +#define XK_Cancel 0xff69 /* Cancel, stop, abort, exit */ +#define XK_Help 0xff6a /* Help */ +#define XK_Break 0xff6b +#define XK_Mode_switch 0xff7e /* Character set switch */ +#define XK_script_switch 0xff7e /* Alias for mode_switch */ +#define XK_Num_Lock 0xff7f +#define XK_F1 0xffbe + +#endif /* _HAIKU_SUPPORT_H_ */ diff --git a/src/haikufns.c b/src/haikufns.c new file mode 100644 index 0000000000..868fc71f97 --- /dev/null +++ b/src/haikufns.c @@ -0,0 +1,2448 @@ +/* Haiku window system support + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include + +#include "lisp.h" +#include "frame.h" +#include "blockinput.h" +#include "termchar.h" +#include "font.h" +#include "keyboard.h" +#include "buffer.h" +#include "dispextern.h" + +#include "haikugui.h" +#include "haikuterm.h" +#include "haiku_support.h" +#include "termhooks.h" + +#include + +#include + +#define RGB_TO_ULONG(r, g, b) \ + (((r) << 16) | ((g) << 8) | (b)); +#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff) +#define GREEN_FROM_ULONG(color) (((color) >> 8) & 0xff) +#define BLUE_FROM_ULONG(color) ((color) & 0xff) + +/* The frame of the currently visible tooltip. */ +static Lisp_Object tip_frame; + +/* The window-system window corresponding to the frame of the + currently visible tooltip. */ +static Window tip_window; + +/* A timer that hides or deletes the currently visible tooltip when it + fires. */ +static Lisp_Object tip_timer; + +/* STRING argument of last `x-show-tip' call. */ +static Lisp_Object tip_last_string; + +/* Normalized FRAME argument of last `x-show-tip' call. */ +static Lisp_Object tip_last_frame; + +/* PARMS argument of last `x-show-tip' call. */ +static Lisp_Object tip_last_parms; + +static void +haiku_explicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval); +static void +haiku_set_title (struct frame *f, Lisp_Object name, Lisp_Object old_name); + +static ptrdiff_t image_cache_refcount; + +static Lisp_Object +get_geometry_from_preferences (struct haiku_display_info *dpyinfo, + Lisp_Object parms) +{ + struct { + const char *val; + const char *cls; + Lisp_Object tem; + } r[] = { + { "width", "Width", Qwidth }, + { "height", "Height", Qheight }, + { "left", "Left", Qleft }, + { "top", "Top", Qtop }, + }; + + int i; + for (i = 0; i < ARRAYELTS (r); ++i) + { + if (NILP (Fassq (r[i].tem, parms))) + { + Lisp_Object value + = gui_display_get_arg (dpyinfo, parms, r[i].tem, r[i].val, r[i].cls, + RES_TYPE_NUMBER); + if (! EQ (value, Qunbound)) + parms = Fcons (Fcons (r[i].tem, value), parms); + } + } + + return parms; +} + +void +haiku_change_tool_bar_height (struct frame *f, int height) +{ + int unit = FRAME_LINE_HEIGHT (f); + int old_height = FRAME_TOOL_BAR_HEIGHT (f); + int lines = (height + unit - 1) / unit; + Lisp_Object fullscreen = get_frame_param (f, Qfullscreen); + + /* Make sure we redisplay all windows in this frame. */ + fset_redisplay (f); + + FRAME_TOOL_BAR_HEIGHT (f) = height; + FRAME_TOOL_BAR_LINES (f) = lines; + store_frame_param (f, Qtool_bar_lines, make_fixnum (lines)); + + if (FRAME_HAIKU_WINDOW (f) && FRAME_TOOL_BAR_HEIGHT (f) == 0) + { + clear_frame (f); + clear_current_matrices (f); + } + + if ((height < old_height) && WINDOWP (f->tool_bar_window)) + clear_glyph_matrix (XWINDOW (f->tool_bar_window)->current_matrix); + + if (!f->tool_bar_resized) + { + /* As long as tool_bar_resized is false, effectively try to change + F's native height. */ + if (NILP (fullscreen) || EQ (fullscreen, Qfullwidth)) + adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), + 1, false, Qtool_bar_lines); + else + adjust_frame_size (f, -1, -1, 4, false, Qtool_bar_lines); + + f->tool_bar_resized = f->tool_bar_redisplayed; + } + else + /* Any other change may leave the native size of F alone. */ + adjust_frame_size (f, -1, -1, 3, false, Qtool_bar_lines); + + /* adjust_frame_size might not have done anything, garbage frame + here. */ + adjust_frame_glyphs (f); + SET_FRAME_GARBAGED (f); + + if (FRAME_HAIKU_WINDOW (f)) + haiku_clear_under_internal_border (f); +} + +void +haiku_change_tab_bar_height (struct frame *f, int height) +{ + int unit = FRAME_LINE_HEIGHT (f); + int old_height = FRAME_TAB_BAR_HEIGHT (f); + int lines = (height + unit - 1) / unit; + Lisp_Object fullscreen = get_frame_param (f, Qfullscreen); + + /* Make sure we redisplay all windows in this frame. */ + fset_redisplay (f); + + /* Recalculate tab bar and frame text sizes. */ + FRAME_TAB_BAR_HEIGHT (f) = height; + FRAME_TAB_BAR_LINES (f) = lines; + store_frame_param (f, Qtab_bar_lines, make_fixnum (lines)); + + if (FRAME_HAIKU_WINDOW (f) && FRAME_TAB_BAR_HEIGHT (f) == 0) + { + clear_frame (f); + clear_current_matrices (f); + } + + if ((height < old_height) && WINDOWP (f->tab_bar_window)) + clear_glyph_matrix (XWINDOW (f->tab_bar_window)->current_matrix); + + if (!f->tab_bar_resized) + { + /* As long as tab_bar_resized is false, effectively try to change + F's native height. */ + if (NILP (fullscreen) || EQ (fullscreen, Qfullwidth)) + adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), + 1, false, Qtab_bar_lines); + else + adjust_frame_size (f, -1, -1, 4, false, Qtab_bar_lines); + + f->tab_bar_resized = f->tab_bar_redisplayed; + } + else + /* Any other change may leave the native size of F alone. */ + adjust_frame_size (f, -1, -1, 3, false, Qtab_bar_lines); + + /* adjust_frame_size might not have done anything, garbage frame + here. */ + adjust_frame_glyphs (f); + SET_FRAME_GARBAGED (f); + if (FRAME_HAIKU_WINDOW (f)) + haiku_clear_under_internal_border (f); +} + +static void +haiku_set_no_focus_on_map (struct frame *f, Lisp_Object value, + Lisp_Object oldval) +{ + if (!EQ (value, oldval)) + FRAME_NO_FOCUS_ON_MAP (f) = !NILP (value); +} + +static void +haiku_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) +{ + if (FRAME_TOOLTIP_P (f)) + return; + int nlines; + + /* Treat tool bars like menu bars. */ + if (FRAME_MINIBUF_ONLY_P (f)) + return; + + /* Use VALUE only if an int >= 0. */ + if (RANGED_FIXNUMP (0, value, INT_MAX)) + nlines = XFIXNAT (value); + else + nlines = 0; + + haiku_change_tool_bar_height (f, nlines * FRAME_LINE_HEIGHT (f)); +} + +static void +haiku_set_tab_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) +{ + if (FRAME_TOOLTIP_P (f)) + return; + int olines = FRAME_TAB_BAR_LINES (f); + int nlines; + + /* Treat tab bars like menu bars. */ + if (FRAME_MINIBUF_ONLY_P (f)) + return; + + /* Use VALUE only if an int >= 0. */ + if (RANGED_FIXNUMP (0, value, INT_MAX)) + nlines = XFIXNAT (value); + else + nlines = 0; + + if (nlines != olines && (olines == 0 || nlines == 0)) + haiku_change_tab_bar_height (f, nlines * FRAME_LINE_HEIGHT (f)); +} + + +int +haiku_get_color (const char *name, Emacs_Color *color) +{ + unsigned short r16, g16, b16; + Lisp_Object tem; + + if (parse_color_spec (name, &r16, &g16, &b16)) + { + color->pixel = RGB_TO_ULONG (r16 / 256, g16 / 256, b16 / 256); + color->red = r16; + color->green = g16; + color->blue = b16; + return 0; + } + else + { + block_input (); + eassert (x_display_list && !NILP (x_display_list->color_map)); + tem = x_display_list->color_map; + for (; CONSP (tem); tem = XCDR (tem)) + { + Lisp_Object col = XCAR (tem); + if (CONSP (col) && !xstrcasecmp (SSDATA (XCAR (col)), name)) + { + int32_t clr = XFIXNUM (XCDR (col)); + color->pixel = clr; + color->red = RED_FROM_ULONG (clr) * 257; + color->green = GREEN_FROM_ULONG (clr) * 257; + color->blue = BLUE_FROM_ULONG (clr) * 257; + unblock_input (); + return 0; + } + } + + unblock_input (); + } + + return 1; +} + +static struct haiku_display_info * +haiku_display_info_for_name (Lisp_Object name) +{ + CHECK_STRING (name); + + if (!NILP (Fstring_equal (name, build_string ("be")))) + { + if (!x_display_list) + return x_display_list; + + error ("Be windowing not initialized"); + } + + error ("Be displays can only be named \"be\""); +} + +static struct haiku_display_info * +check_haiku_display_info (Lisp_Object object) +{ + struct haiku_display_info *dpyinfo = NULL; + + if (NILP (object)) + { + struct frame *sf = XFRAME (selected_frame); + + if (FRAME_HAIKU_P (sf) && FRAME_LIVE_P (sf)) + dpyinfo = FRAME_DISPLAY_INFO (sf); + else if (x_display_list) + dpyinfo = x_display_list; + else + error ("Be windowing not present"); + } + else if (TERMINALP (object)) + { + struct terminal *t = decode_live_terminal (object); + + if (t->type != output_haiku) + error ("Terminal %d is not a Be display", t->id); + + dpyinfo = t->display_info.haiku; + } + else if (STRINGP (object)) + dpyinfo = haiku_display_info_for_name (object); + else + { + struct frame *f = decode_window_system_frame (object); + dpyinfo = FRAME_DISPLAY_INFO (f); + } + + return dpyinfo; +} + +static void +haiku_set_title_bar_text (struct frame *f, Lisp_Object text) +{ + if (FRAME_HAIKU_WINDOW (f)) + { + block_input (); + BWindow_retitle (FRAME_HAIKU_WINDOW (f), SSDATA (ENCODE_UTF_8 (text))); + unblock_input (); + } +} + +static void +haiku_set_title (struct frame *f, Lisp_Object name, Lisp_Object old_name) +{ + /* Don't change the title if it's already NAME. */ + if (EQ (name, f->title)) + return; + + update_mode_lines = 26; + + fset_title (f, name); + + if (NILP (name)) + name = f->name; + + haiku_set_title_bar_text (f, name); +} + +static void +haiku_set_child_frame_border_width (struct frame *f, + Lisp_Object arg, Lisp_Object oldval) +{ + int border; + + if (NILP (arg)) + border = -1; + else if (RANGED_FIXNUMP (0, arg, INT_MAX)) + border = XFIXNAT (arg); + else + signal_error ("Invalid child frame border width", arg); + + if (border != FRAME_CHILD_FRAME_BORDER_WIDTH (f)) + { + f->child_frame_border_width = border; + + if (FRAME_HAIKU_WINDOW (f)) + adjust_frame_size (f, -1, -1, 3, 0, Qchild_frame_border_width); + + SET_FRAME_GARBAGED (f); + } +} + +static void +haiku_set_parent_frame (struct frame *f, + Lisp_Object new_value, Lisp_Object old_value) +{ + struct frame *p = NULL; + block_input (); + if (!NILP (new_value) + && (!FRAMEP (new_value) + || !FRAME_LIVE_P (p = XFRAME (new_value)) + || !FRAME_HAIKU_P (p))) + { + store_frame_param (f, Qparent_frame, old_value); + unblock_input (); + error ("Invalid specification of `parent-frame'"); + } + + if (EQ (new_value, old_value)) + { + unblock_input (); + return; + } + + if (!NILP (old_value)) + EmacsWindow_unparent (FRAME_HAIKU_WINDOW (f)); + if (!NILP (new_value)) + { + EmacsWindow_parent_to (FRAME_HAIKU_WINDOW (f), + FRAME_HAIKU_WINDOW (p)); + BWindow_set_offset (FRAME_HAIKU_WINDOW (f), + f->left_pos, f->top_pos); + } + fset_parent_frame (f, new_value); + unblock_input (); +} + +static void +haiku_explicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + haiku_set_name (f, arg, 1); +} + +static void +haiku_set_no_accept_focus (struct frame *f, Lisp_Object new_value, Lisp_Object old_value) +{ + block_input (); + if (!EQ (new_value, old_value)) + FRAME_NO_ACCEPT_FOCUS (f) = !NILP (new_value); + + if (FRAME_HAIKU_WINDOW (f)) + { + BWindow_set_avoid_focus (FRAME_HAIKU_WINDOW (f), + FRAME_NO_ACCEPT_FOCUS (f)); + } + unblock_input (); +} + +static void +unwind_create_frame (Lisp_Object frame) +{ + struct frame *f = XFRAME (frame); + + /* If frame is already dead, nothing to do. This can happen if the + display is disconnected after the frame has become official, but + before x_create_frame removes the unwind protect. */ + if (!FRAME_LIVE_P (f)) + return; + + /* If frame is ``official'', nothing to do. */ + if (NILP (Fmemq (frame, Vframe_list))) + { +#if defined GLYPH_DEBUG && defined ENABLE_CHECKING + struct haiku_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); +#endif + + /* If the frame's image cache refcount is still the same as our + private shadow variable, it means we are unwinding a frame + for which we didn't yet call init_frame_faces, where the + refcount is incremented. Therefore, we increment it here, so + that free_frame_faces, called in free_frame_resources later, + will not mistakenly decrement the counter that was not + incremented yet to account for this new frame. */ + if (FRAME_IMAGE_CACHE (f) != NULL + && FRAME_IMAGE_CACHE (f)->refcount == image_cache_refcount) + FRAME_IMAGE_CACHE (f)->refcount++; + + haiku_free_frame_resources (f); + free_glyphs (f); + +#if defined GLYPH_DEBUG && defined ENABLE_CHECKING + /* Check that reference counts are indeed correct. */ + if (dpyinfo->terminal->image_cache) + eassert (dpyinfo->terminal->image_cache->refcount == image_cache_refcount); +#endif + } +} + +static void +unwind_create_tip_frame (Lisp_Object frame) +{ + unwind_create_frame (frame); + tip_window = NULL; + tip_frame = Qnil; +} + +static void +haiku_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + struct haiku_output *output = FRAME_OUTPUT_DATA (f); + unsigned long old_fg; + + Emacs_Color color; + + if (haiku_get_color (SSDATA (arg), &color)) + { + store_frame_param (f, Qforeground_color, oldval); + unblock_input (); + error ("Bad color"); + } + + old_fg = FRAME_FOREGROUND_PIXEL (f); + FRAME_FOREGROUND_PIXEL (f) = color.pixel; + + if (FRAME_HAIKU_WINDOW (f)) + { + + block_input (); + if (output->cursor_color.pixel == old_fg) + { + output->cursor_color.pixel = old_fg; + output->cursor_color.red = RED_FROM_ULONG (old_fg); + output->cursor_color.green = GREEN_FROM_ULONG (old_fg); + output->cursor_color.blue = BLUE_FROM_ULONG (old_fg); + } + + unblock_input (); + + update_face_from_frame_parameter (f, Qforeground_color, arg); + + if (FRAME_VISIBLE_P (f)) + redraw_frame (f); + } +} + +static void +unwind_popup (void) +{ + if (!popup_activated_p) + emacs_abort (); + --popup_activated_p; +} + +static Lisp_Object +haiku_create_frame (Lisp_Object parms, int ttip_p) +{ + struct frame *f; + Lisp_Object frame, tem; + Lisp_Object name; + bool minibuffer_only = false; + bool face_change_before = face_change; + long window_prompting = 0; + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object display; + struct haiku_display_info *dpyinfo = NULL; + struct kboard *kb; + + parms = Fcopy_alist (parms); + + Vx_resource_name = Vinvocation_name; + + display = gui_display_get_arg (dpyinfo, parms, Qterminal, 0, 0, + RES_TYPE_STRING); + if (EQ (display, Qunbound)) + display = Qnil; + dpyinfo = check_haiku_display_info (display); + kb = dpyinfo->terminal->kboard; + + if (!dpyinfo->terminal->name) + error ("Terminal is not live, can't create new frames on it"); + + name = gui_display_get_arg (dpyinfo, parms, Qname, 0, 0, + RES_TYPE_STRING); + if (!STRINGP (name) + && ! EQ (name, Qunbound) + && ! NILP (name)) + error ("Invalid frame name--not a string or nil"); + + if (STRINGP (name)) + Vx_resource_name = name; + + block_input (); + + /* make_frame_without_minibuffer can run Lisp code and garbage collect. */ + /* No need to protect DISPLAY because that's not used after passing + it to make_frame_without_minibuffer. */ + frame = Qnil; + tem = gui_display_get_arg (dpyinfo, parms, Qminibuffer, + "minibuffer", "Minibuffer", + RES_TYPE_SYMBOL); + if (ttip_p) + f = make_frame (0); + else if (EQ (tem, Qnone) || NILP (tem)) + f = make_frame_without_minibuffer (Qnil, kb, display); + else if (EQ (tem, Qonly)) + { + f = make_minibuffer_frame (); + minibuffer_only = 1; + } + else if (WINDOWP (tem)) + f = make_frame_without_minibuffer (tem, kb, display); + else + f = make_frame (1); + XSETFRAME (frame, f); + + f->terminal = dpyinfo->terminal; + + f->output_method = output_haiku; + f->output_data.haiku = xzalloc (sizeof *f->output_data.haiku); + + f->output_data.haiku->pending_zoom_x = INT_MIN; + f->output_data.haiku->pending_zoom_y = INT_MIN; + f->output_data.haiku->pending_zoom_width = INT_MIN; + f->output_data.haiku->pending_zoom_height = INT_MIN; + + if (ttip_p) + f->wants_modeline = false; + + fset_icon_name (f, gui_display_get_arg (dpyinfo, parms, Qicon_name, + "iconName", "Title", + RES_TYPE_STRING)); + if (! STRINGP (f->icon_name) || ttip_p) + fset_icon_name (f, Qnil); + + FRAME_DISPLAY_INFO (f) = dpyinfo; + + /* With FRAME_DISPLAY_INFO set up, this unwind-protect is safe. */ + if (!ttip_p) + record_unwind_protect (unwind_create_frame, frame); + else + record_unwind_protect (unwind_create_tip_frame, frame); + + FRAME_OUTPUT_DATA (f)->parent_desc = NULL; + FRAME_OUTPUT_DATA (f)->explicit_parent = 0; + + /* Set the name; the functions to which we pass f expect the name to + be set. */ + if (EQ (name, Qunbound) || NILP (name) || ! STRINGP (name)) + { + fset_name (f, Vinvocation_name); + f->explicit_name = 0; + } + else + { + fset_name (f, name); + f->explicit_name = 1; + specbind (Qx_resource_name, name); + } + +#ifdef USE_BE_CAIRO + register_font_driver (&ftcrfont_driver, f); +#ifdef HAVE_HARFBUZZ + register_font_driver (&ftcrhbfont_driver, f); +#endif +#endif + register_font_driver (&haikufont_driver, f); + + f->tooltip = ttip_p; + + image_cache_refcount = + FRAME_IMAGE_CACHE (f) ? FRAME_IMAGE_CACHE (f)->refcount : 0; + + gui_default_parameter (f, parms, Qfont_backend, Qnil, + "fontBackend", "FontBackend", RES_TYPE_STRING); + + FRAME_RIF (f)->default_font_parameter (f, parms); + + unblock_input (); + + gui_default_parameter (f, parms, Qborder_width, make_fixnum (0), + "borderwidth", "BorderWidth", RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qinternal_border_width, make_fixnum (ttip_p ? 1 : 2), + "internalBorderWidth", "InternalBorderWidth", + RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qchild_frame_border_width, Qnil, + "childFrameBorderWidth", "childFrameBorderWidth", + RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qright_divider_width, make_fixnum (0), + NULL, NULL, RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qbottom_divider_width, make_fixnum (0), + NULL, NULL, RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qvertical_scroll_bars, !ttip_p ? Qt : Qnil, + "verticalScrollBars", "VerticalScrollBars", + RES_TYPE_SYMBOL); + gui_default_parameter (f, parms, Qhorizontal_scroll_bars, Qnil, + "horizontalScrollBars", "HorizontalScrollBars", + RES_TYPE_SYMBOL); + gui_default_parameter (f, parms, Qforeground_color, build_string ("black"), + "foreground", "Foreground", RES_TYPE_STRING); + gui_default_parameter (f, parms, Qbackground_color, build_string ("white"), + "background", "Background", RES_TYPE_STRING); + gui_default_parameter (f, parms, Qline_spacing, Qnil, + "lineSpacing", "LineSpacing", RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qleft_fringe, Qnil, + "leftFringe", "LeftFringe", RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qright_fringe, Qnil, + "rightFringe", "RightFringe", RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qno_special_glyphs, ttip_p ? Qnil : Qt, + NULL, NULL, RES_TYPE_BOOLEAN); + + init_frame_faces (f); + + /* Read comment about this code in corresponding place in xfns.c. */ + tem = gui_display_get_arg (dpyinfo, parms, Qmin_width, NULL, NULL, + RES_TYPE_NUMBER); + if (FIXNUMP (tem)) + store_frame_param (f, Qmin_width, tem); + tem = gui_display_get_arg (dpyinfo, parms, Qmin_height, NULL, NULL, + RES_TYPE_NUMBER); + if (FIXNUMP (tem)) + store_frame_param (f, Qmin_height, tem); + adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), + FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1, + Qx_create_frame_1); + + if (!ttip_p) + { + gui_default_parameter (f, parms, Qz_group, Qnil, NULL, NULL, RES_TYPE_SYMBOL); + gui_default_parameter (f, parms, Qno_focus_on_map, Qnil, + NULL, NULL, RES_TYPE_BOOLEAN); + gui_default_parameter (f, parms, Qno_accept_focus, Qnil, + NULL, NULL, RES_TYPE_BOOLEAN); + + /* The resources controlling the menu-bar, tool-bar, and tab-bar are + processed specially at startup, and reflected in the mode + variables; ignore them here. */ + gui_default_parameter (f, parms, Qmenu_bar_lines, + NILP (Vmenu_bar_mode) + ? make_fixnum (0) : make_fixnum (1), + NULL, NULL, RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qtab_bar_lines, + NILP (Vtab_bar_mode) + ? make_fixnum (0) : make_fixnum (1), + NULL, NULL, RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qtool_bar_lines, + NILP (Vtool_bar_mode) + ? make_fixnum (0) : make_fixnum (1), + NULL, NULL, RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qbuffer_predicate, Qnil, "bufferPredicate", + "BufferPredicate", RES_TYPE_SYMBOL); + gui_default_parameter (f, parms, Qtitle, Qnil, "title", "Title", + RES_TYPE_STRING); + } + + parms = get_geometry_from_preferences (dpyinfo, parms); + window_prompting = gui_figure_window_size (f, parms, false, true); + + if (ttip_p) + { + /* No fringes on tip frame. */ + f->fringe_cols = 0; + f->left_fringe_width = 0; + f->right_fringe_width = 0; + /* No dividers on tip frame. */ + f->right_divider_width = 0; + f->bottom_divider_width = 0; + } + + tem = gui_display_get_arg (dpyinfo, parms, Qunsplittable, 0, 0, + RES_TYPE_BOOLEAN); + f->no_split = minibuffer_only || (!EQ (tem, Qunbound) && !NILP (tem)); + + /* Add `tooltip' frame parameter's default value. */ + if (NILP (Fframe_parameter (frame, Qtooltip)) && ttip_p) + Fmodify_frame_parameters (frame, Fcons (Fcons (Qtooltip, Qt), Qnil)); + +#define ASSIGN_CURSOR(cursor, be_cursor) \ + (FRAME_OUTPUT_DATA (f)->cursor = be_cursor) + + ASSIGN_CURSOR (text_cursor, BCursor_create_i_beam ()); + ASSIGN_CURSOR (nontext_cursor, BCursor_create_default ()); + ASSIGN_CURSOR (modeline_cursor, BCursor_create_modeline ()); + ASSIGN_CURSOR (hand_cursor, BCursor_create_grab ()); + ASSIGN_CURSOR (hourglass_cursor, BCursor_create_progress_cursor ()); + ASSIGN_CURSOR (horizontal_drag_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_EAST_WEST)); + ASSIGN_CURSOR (vertical_drag_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH_SOUTH)); + ASSIGN_CURSOR (left_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_WEST)); + ASSIGN_CURSOR (top_left_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH_WEST)); + ASSIGN_CURSOR (top_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH)); + ASSIGN_CURSOR (top_right_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH_EAST)); + ASSIGN_CURSOR (right_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_EAST)); + ASSIGN_CURSOR (bottom_right_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_EAST)); + ASSIGN_CURSOR (bottom_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_SOUTH)); + ASSIGN_CURSOR (bottom_left_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_WEST)); + ASSIGN_CURSOR (no_cursor, + BCursor_from_id (CURSOR_ID_NO_CURSOR)); + + ASSIGN_CURSOR (current_cursor, FRAME_OUTPUT_DATA (f)->text_cursor); +#undef ASSIGN_CURSOR + + + if (ttip_p) + f->no_split = true; + f->terminal->reference_count++; + + FRAME_OUTPUT_DATA (f)->window = BWindow_new (&FRAME_OUTPUT_DATA (f)->view); + if (!FRAME_OUTPUT_DATA (f)->window) + xsignal1 (Qerror, build_unibyte_string ("Could not create window")); + + if (!minibuffer_only && !ttip_p && FRAME_EXTERNAL_MENU_BAR (f)) + initialize_frame_menubar (f); + + FRAME_OUTPUT_DATA (f)->window_desc = FRAME_OUTPUT_DATA (f)->window; + + Vframe_list = Fcons (frame, Vframe_list); + + Lisp_Object parent_frame = gui_display_get_arg (dpyinfo, parms, Qparent_frame, NULL, NULL, + RES_TYPE_SYMBOL); + + if (EQ (parent_frame, Qunbound) + || NILP (parent_frame) + || !FRAMEP (parent_frame) + || !FRAME_LIVE_P (XFRAME (parent_frame))) + parent_frame = Qnil; + + fset_parent_frame (f, parent_frame); + store_frame_param (f, Qparent_frame, parent_frame); + + if (!NILP (parent_frame)) + haiku_set_parent_frame (f, parent_frame, Qnil); + + gui_default_parameter (f, parms, Qundecorated, Qnil, NULL, NULL, RES_TYPE_BOOLEAN); + + gui_default_parameter (f, parms, Qicon_type, Qnil, + "bitmapIcon", "BitmapIcon", RES_TYPE_SYMBOL); + if (ttip_p) + { + gui_default_parameter (f, parms, Qundecorated, Qt, NULL, NULL, RES_TYPE_BOOLEAN); + gui_default_parameter (f, parms, Qno_accept_focus, Qt, NULL, NULL, + RES_TYPE_BOOLEAN); + } + else + { + gui_default_parameter (f, parms, Qauto_raise, Qnil, + "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN); + gui_default_parameter (f, parms, Qauto_lower, Qnil, + "autoLower", "AutoLower", RES_TYPE_BOOLEAN); + gui_default_parameter (f, parms, Qcursor_type, Qbox, + "cursorType", "CursorType", RES_TYPE_SYMBOL); + gui_default_parameter (f, parms, Qscroll_bar_width, Qnil, + "scrollBarWidth", "ScrollBarWidth", + RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qscroll_bar_height, Qnil, + "scrollBarHeight", "ScrollBarHeight", + RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qalpha, Qnil, + "alpha", "Alpha", RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qfullscreen, Qnil, + "fullscreen", "Fullscreen", RES_TYPE_SYMBOL); + } + + gui_default_parameter (f, parms, Qinhibit_double_buffering, Qnil, + "inhibitDoubleBuffering", "InhibitDoubleBuffering", + RES_TYPE_BOOLEAN); + + if (ttip_p) + { + Lisp_Object bg = Fframe_parameter (frame, Qbackground_color); + + call2 (Qface_set_after_frame_default, frame, Qnil); + + if (!EQ (bg, Fframe_parameter (frame, Qbackground_color))) + { + AUTO_FRAME_ARG (arg, Qbackground_color, bg); + Fmodify_frame_parameters (frame, arg); + } + } + + if (ttip_p) + face_change = face_change_before; + + f->can_set_window_size = true; + + adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), + 0, true, ttip_p ? Qtip_frame : Qx_create_frame_2); + + if (!FRAME_OUTPUT_DATA (f)->explicit_parent && !ttip_p) + { + Lisp_Object visibility; + + visibility = gui_display_get_arg (dpyinfo, parms, Qvisibility, 0, 0, + RES_TYPE_SYMBOL); + if (EQ (visibility, Qunbound)) + visibility = Qt; + if (EQ (visibility, Qicon)) + haiku_iconify_frame (f); + else if (!NILP (visibility)) + haiku_visualize_frame (f); + else /* Qnil */ + { + f->was_invisible = true; + } + } + + if (!ttip_p) + { + if (FRAME_HAS_MINIBUF_P (f) + && (!FRAMEP (KVAR (kb, Vdefault_minibuffer_frame)) + || !FRAME_LIVE_P (XFRAME (KVAR (kb, Vdefault_minibuffer_frame))))) + kset_default_minibuffer_frame (kb, frame); + } + + for (tem = parms; CONSP (tem); tem = XCDR (tem)) + if (CONSP (XCAR (tem)) && !NILP (XCAR (XCAR (tem)))) + fset_param_alist (f, Fcons (XCAR (tem), f->param_alist)); + + if (window_prompting & (USPosition | PPosition)) + haiku_set_offset (f, f->left_pos, f->top_pos, 1); + else + BWindow_center_on_screen (FRAME_HAIKU_WINDOW (f)); + + /* Make sure windows on this frame appear in calls to next-window + and similar functions. */ + Vwindow_list = Qnil; + + if (ttip_p) + adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), + 0, true, Qtip_frame); + + return unbind_to (count, frame); +} + +static void +compute_tip_xy (struct frame *f, + Lisp_Object parms, Lisp_Object dx, Lisp_Object dy, + int width, int height, int *root_x, int *root_y) +{ + Lisp_Object left, top, right, bottom; + int min_x = 0, min_y = 0, max_x = 0, max_y = 0; + + /* User-specified position? */ + left = Fcdr (Fassq (Qleft, parms)); + top = Fcdr (Fassq (Qtop, parms)); + right = Fcdr (Fassq (Qright, parms)); + bottom = Fcdr (Fassq (Qbottom, parms)); + + /* Move the tooltip window where the mouse pointer is. Resize and + show it. */ + if ((!FIXNUMP (left) && !FIXNUMP (right)) + || (!FIXNUMP (top) && !FIXNUMP (bottom))) + { + int x, y; + + /* Default min and max values. */ + min_x = 0; + min_y = 0; + BScreen_px_dim (&max_x, &max_y); + + block_input (); + BView_get_mouse (FRAME_HAIKU_VIEW (f), &x, &y); + BView_convert_to_screen (FRAME_HAIKU_VIEW (f), &x, &y); + *root_x = x; + *root_y = y; + unblock_input (); + } + + if (FIXNUMP (top)) + *root_y = XFIXNUM (top); + else if (FIXNUMP (bottom)) + *root_y = XFIXNUM (bottom) - height; + else if (*root_y + XFIXNUM (dy) <= min_y) + *root_y = min_y; /* Can happen for negative dy */ + else if (*root_y + XFIXNUM (dy) + height <= max_y) + /* It fits below the pointer */ + *root_y += XFIXNUM (dy); + else if (height + XFIXNUM (dy) + min_y <= *root_y) + /* It fits above the pointer. */ + *root_y -= height + XFIXNUM (dy); + else + /* Put it on the top. */ + *root_y = min_y; + + if (FIXNUMP (left)) + *root_x = XFIXNUM (left); + else if (FIXNUMP (right)) + *root_x = XFIXNUM (right) - width; + else if (*root_x + XFIXNUM (dx) <= min_x) + *root_x = 0; /* Can happen for negative dx */ + else if (*root_x + XFIXNUM (dx) + width <= max_x) + /* It fits to the right of the pointer. */ + *root_x += XFIXNUM (dx); + else if (width + XFIXNUM (dx) + min_x <= *root_x) + /* It fits to the left of the pointer. */ + *root_x -= width + XFIXNUM (dx); + else + /* Put it left justified on the screen -- it ought to fit that way. */ + *root_x = min_x; +} + +static Lisp_Object +haiku_hide_tip (bool delete) +{ + if (!NILP (tip_timer)) + { + call1 (Qcancel_timer, tip_timer); + tip_timer = Qnil; + } + + Lisp_Object it, frame; + FOR_EACH_FRAME (it, frame) + if (FRAME_WINDOW_P (XFRAME (frame)) && + FRAME_HAIKU_VIEW (XFRAME (frame))) + BView_set_tooltip (FRAME_HAIKU_VIEW (XFRAME (frame)), NULL); + + if (NILP (tip_frame) + || (!delete && !NILP (tip_frame) + && !FRAME_VISIBLE_P (XFRAME (tip_frame)))) + return Qnil; + else + { + ptrdiff_t count; + Lisp_Object was_open = Qnil; + + count = SPECPDL_INDEX (); + specbind (Qinhibit_redisplay, Qt); + specbind (Qinhibit_quit, Qt); + + if (!NILP (tip_frame)) + { + if (FRAME_LIVE_P (XFRAME (tip_frame))) + { + if (delete) + { + delete_frame (tip_frame, Qnil); + tip_frame = Qnil; + } + else + haiku_unvisualize_frame (XFRAME (tip_frame)); + + was_open = Qt; + } + else + tip_frame = Qnil; + } + else + tip_frame = Qnil; + + return unbind_to (count, was_open); + } +} + +static void +haiku_set_undecorated (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) +{ + if (EQ (new_value, old_value)) + return; + + block_input (); + FRAME_UNDECORATED (f) = !NILP (new_value); + BWindow_change_decoration (FRAME_HAIKU_WINDOW (f), NILP (new_value)); + unblock_input (); +} + +static void +haiku_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) +{ + if (FRAME_TOOLTIP_P (f)) + return; + int nlines; + if (TYPE_RANGED_FIXNUMP (int, value)) + nlines = XFIXNUM (value); + else + nlines = 0; + + fset_redisplay (f); + + FRAME_MENU_BAR_LINES (f) = 0; + FRAME_MENU_BAR_HEIGHT (f) = 0; + + if (nlines) + { + FRAME_EXTERNAL_MENU_BAR (f) = 1; + if (FRAME_HAIKU_P (f) && !FRAME_HAIKU_MENU_BAR (f)) + XWINDOW (FRAME_SELECTED_WINDOW (f))->update_mode_line = 1; + } + else + { + if (FRAME_EXTERNAL_MENU_BAR (f)) + free_frame_menubar (f); + FRAME_EXTERNAL_MENU_BAR (f) = 0; + if (FRAME_HAIKU_P (f)) + FRAME_HAIKU_MENU_BAR (f) = 0; + } + + adjust_frame_glyphs (f); +} + +/* Return geometric attributes of FRAME. According to the value of + ATTRIBUTES return the outer edges of FRAME (Qouter_edges), the inner + edges of FRAME, the root window edges of frame (Qroot_edges). Any + other value means to return the geometry as returned by + Fx_frame_geometry. */ +static Lisp_Object +frame_geometry (Lisp_Object frame, Lisp_Object attribute) +{ + struct frame *f = decode_live_frame (frame); + check_window_system (f); + + if (EQ (attribute, Qouter_edges)) + return list4i (f->left_pos, f->top_pos, + f->left_pos, f->top_pos); + else if (EQ (attribute, Qnative_edges)) + return list4i (f->left_pos, f->top_pos, + f->left_pos + FRAME_PIXEL_WIDTH (f), + f->top_pos + FRAME_PIXEL_HEIGHT (f)); + else if (EQ (attribute, Qinner_edges)) + return list4i (f->left_pos + FRAME_INTERNAL_BORDER_WIDTH (f), + f->top_pos + FRAME_INTERNAL_BORDER_WIDTH (f) + + FRAME_MENU_BAR_HEIGHT (f) + FRAME_TOOL_BAR_HEIGHT (f), + f->left_pos - FRAME_INTERNAL_BORDER_WIDTH (f) + + FRAME_PIXEL_WIDTH (f), + f->top_pos + FRAME_PIXEL_HEIGHT (f) - + FRAME_INTERNAL_BORDER_WIDTH (f)); + + else + return + list (Fcons (Qouter_position, + Fcons (make_fixnum (f->left_pos), + make_fixnum (f->top_pos))), + Fcons (Qouter_size, + Fcons (make_fixnum (FRAME_PIXEL_WIDTH (f)), + make_fixnum (FRAME_PIXEL_HEIGHT (f)))), + Fcons (Qexternal_border_size, + Fcons (make_fixnum (0), make_fixnum (0))), + Fcons (Qtitle_bar_size, + Fcons (make_fixnum (0), make_fixnum (0))), + Fcons (Qmenu_bar_external, Qnil), + Fcons (Qmenu_bar_size, Fcons (make_fixnum (FRAME_PIXEL_WIDTH (f) - + (FRAME_INTERNAL_BORDER_WIDTH (f) * 2)), + make_fixnum (FRAME_MENU_BAR_HEIGHT (f)))), + Fcons (Qtool_bar_external, Qnil), + Fcons (Qtool_bar_position, Qtop), + Fcons (Qtool_bar_size, Fcons (make_fixnum (FRAME_PIXEL_WIDTH (f) - + (FRAME_INTERNAL_BORDER_WIDTH (f) * 2)), + make_fixnum (FRAME_TOOL_BAR_HEIGHT (f)))), + Fcons (Qinternal_border_width, make_fixnum (FRAME_INTERNAL_BORDER_WIDTH (f)))); +} + +void +haiku_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + CHECK_STRING (arg); + + block_input (); + Emacs_Color color; + + if (haiku_get_color (SSDATA (arg), &color)) + { + store_frame_param (f, Qbackground_color, oldval); + unblock_input (); + error ("Bad color"); + } + + FRAME_OUTPUT_DATA (f)->cursor_fg = color.pixel; + FRAME_BACKGROUND_PIXEL (f) = color.pixel; + + if (FRAME_HAIKU_VIEW (f)) + { + struct face *defface; + + BView_draw_lock (FRAME_HAIKU_VIEW (f)); + BView_SetViewColor (FRAME_HAIKU_VIEW (f), color.pixel); + BView_draw_unlock (FRAME_HAIKU_VIEW (f)); + + defface = FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID); + if (defface) + { + defface->background = color.pixel; + update_face_from_frame_parameter (f, Qbackground_color, arg); + clear_frame (f); + } + } + + if (FRAME_VISIBLE_P (f)) + SET_FRAME_GARBAGED (f); + unblock_input (); +} + +void +haiku_set_cursor_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + CHECK_STRING (arg); + + block_input (); + Emacs_Color color; + + if (haiku_get_color (SSDATA (arg), &color)) + { + store_frame_param (f, Qcursor_color, oldval); + unblock_input (); + error ("Bad color"); + } + + FRAME_CURSOR_COLOR (f) = color; + if (FRAME_VISIBLE_P (f)) + { + gui_update_cursor (f, 0); + gui_update_cursor (f, 1); + } + update_face_from_frame_parameter (f, Qcursor_color, arg); + unblock_input (); +} + +void +haiku_set_cursor_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + set_frame_cursor_types (f, arg); +} + +unsigned long +haiku_get_pixel (haiku bitmap, int x, int y) +{ + unsigned char *data; + int32_t bytes_per_row; + int mono_p; + int left; + int right; + int top; + int bottom; + + data = BBitmap_data (bitmap); + BBitmap_dimensions (bitmap, &left, &top, &right, &bottom, + &bytes_per_row, &mono_p); + + if (x < left || x > right || y < top || y > bottom) + emacs_abort (); + + if (!mono_p) + return ((uint32_t *) (data + (bytes_per_row * y)))[x]; + + int byte = y * bytes_per_row + x / 8; + return data[byte] & (1 << (x % 8)); +} + +void +haiku_put_pixel (haiku bitmap, int x, int y, unsigned long pixel) +{ + unsigned char *data; + int32_t bytes_per_row; + int mono_p; + int left; + int right; + int top; + int bottom; + + data = BBitmap_data (bitmap); + BBitmap_dimensions (bitmap, &left, &top, &right, &bottom, + &bytes_per_row, &mono_p); + + if (x < left || x > right || y < top || y > bottom) + emacs_abort (); + + if (mono_p) + { + ptrdiff_t off = y * bytes_per_row; + ptrdiff_t bit = x % 8; + ptrdiff_t xoff = x / 8; + + unsigned char *byte = data + off + xoff; + if (!pixel) + *byte &= ~(1 << bit); + else + *byte |= 1 << bit; + } + else + ((uint32_t *) (data + (bytes_per_row * y)))[x] = pixel; +} + +void +haiku_free_frame_resources (struct frame *f) +{ + haiku window, drawable, mbar; + Mouse_HLInfo *hlinfo; + struct haiku_display_info *dpyinfo; + Lisp_Object bar; + struct scroll_bar *b; + + block_input (); + check_window_system (f); + + hlinfo = MOUSE_HL_INFO (f); + window = FRAME_HAIKU_WINDOW (f); + drawable = FRAME_HAIKU_VIEW (f); + mbar = FRAME_HAIKU_MENU_BAR (f); + dpyinfo = FRAME_DISPLAY_INFO (f); + + free_frame_faces (f); + + /* Free scroll bars */ + for (bar = FRAME_SCROLL_BARS (f); !NILP (bar); bar = b->next) + { + b = XSCROLL_BAR (bar); + haiku_scroll_bar_remove (b); + } + + if (f == dpyinfo->highlight_frame) + dpyinfo->highlight_frame = 0; + if (f == dpyinfo->focused_frame) + dpyinfo->focused_frame = 0; + if (f == dpyinfo->last_mouse_motion_frame) + dpyinfo->last_mouse_motion_frame = NULL; + if (f == dpyinfo->last_mouse_frame) + dpyinfo->last_mouse_frame = NULL; + if (f == dpyinfo->focus_event_frame) + dpyinfo->focus_event_frame = NULL; + + if (f == hlinfo->mouse_face_mouse_frame) + reset_mouse_highlight (hlinfo); + + if (mbar) + { + BMenuBar_delete (mbar); + if (f->output_data.haiku->menu_bar_open_p) + { + --popup_activated_p; + f->output_data.haiku->menu_bar_open_p = 0; + } + } + + if (drawable) + BView_emacs_delete (drawable); + + if (window) + BWindow_quit (window); + + /* Free cursors */ + + BCursor_delete (f->output_data.haiku->text_cursor); + BCursor_delete (f->output_data.haiku->nontext_cursor); + BCursor_delete (f->output_data.haiku->modeline_cursor); + BCursor_delete (f->output_data.haiku->hand_cursor); + BCursor_delete (f->output_data.haiku->hourglass_cursor); + BCursor_delete (f->output_data.haiku->horizontal_drag_cursor); + BCursor_delete (f->output_data.haiku->vertical_drag_cursor); + BCursor_delete (f->output_data.haiku->left_edge_cursor); + BCursor_delete (f->output_data.haiku->top_left_corner_cursor); + BCursor_delete (f->output_data.haiku->top_edge_cursor); + BCursor_delete (f->output_data.haiku->top_right_corner_cursor); + BCursor_delete (f->output_data.haiku->right_edge_cursor); + BCursor_delete (f->output_data.haiku->bottom_right_corner_cursor); + BCursor_delete (f->output_data.haiku->bottom_edge_cursor); + BCursor_delete (f->output_data.haiku->bottom_left_corner_cursor); + BCursor_delete (f->output_data.haiku->no_cursor); + + xfree (FRAME_OUTPUT_DATA (f)); + FRAME_OUTPUT_DATA (f) = NULL; + + unblock_input (); +} + +void +haiku_iconify_frame (struct frame *frame) +{ + if (FRAME_ICONIFIED_P (frame)) + return; + + block_input (); + + SET_FRAME_VISIBLE (frame, false); + SET_FRAME_ICONIFIED (frame, true); + + BWindow_iconify (FRAME_HAIKU_WINDOW (frame)); + + unblock_input (); +} + +void +haiku_visualize_frame (struct frame *f) +{ + block_input (); + + if (!FRAME_VISIBLE_P (f)) + { + if (FRAME_NO_FOCUS_ON_MAP (f)) + BWindow_set_avoid_focus (FRAME_HAIKU_WINDOW (f), 1); + BWindow_set_visible (FRAME_HAIKU_WINDOW (f), 1); + if (FRAME_NO_FOCUS_ON_MAP (f) && + !FRAME_NO_ACCEPT_FOCUS (f)) + BWindow_set_avoid_focus (FRAME_HAIKU_WINDOW (f), 0); + + haiku_set_offset (f, f->left_pos, f->top_pos, 0); + + SET_FRAME_VISIBLE (f, 1); + SET_FRAME_ICONIFIED (f, 0); + } + + unblock_input (); +} + +void +haiku_unvisualize_frame (struct frame *f) +{ + block_input (); + + BWindow_set_visible (FRAME_HAIKU_WINDOW (f), 0); + SET_FRAME_VISIBLE (f, 0); + SET_FRAME_ICONIFIED (f, 0); + + unblock_input (); +} + +void +haiku_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + int old_width = FRAME_INTERNAL_BORDER_WIDTH (f); + int new_width = check_int_nonnegative (arg); + + if (new_width == old_width) + return; + f->internal_border_width = new_width; + + if (FRAME_HAIKU_WINDOW (f)) + { + adjust_frame_size (f, -1, -1, 3, 0, Qinternal_border_width); + haiku_clear_under_internal_border (f); + } + + SET_FRAME_GARBAGED (f); +} + +void +haiku_set_frame_visible_invisible (struct frame *f, bool visible_p) +{ + if (visible_p) + haiku_visualize_frame (f); + else + haiku_unvisualize_frame (f); +} + +void +frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y) +{ + block_input (); + + BView_convert_to_screen (FRAME_HAIKU_VIEW (f), &pix_x, &pix_y); + be_warp_pointer (pix_x, pix_y); + + unblock_input (); +} + +void +haiku_query_color (uint32_t col, Emacs_Color *color_def) +{ + color_def->red = RED_FROM_ULONG (col) * 257; + color_def->green = GREEN_FROM_ULONG (col) * 257; + color_def->blue = BLUE_FROM_ULONG (col) * 257; + + color_def->pixel = col; +} + +Display_Info * +check_x_display_info (Lisp_Object object) +{ + return check_haiku_display_info (object); +} + +/* Rename frame F to NAME. If NAME is nil, set F's name to "GNU + Emacs". If EXPLICIT_P is non-zero, that indicates Lisp code is + setting the name, not redisplay; in that case, set F's name to NAME + and set F->explicit_name; if NAME is nil, clear F->explicit_name. + + If EXPLICIT_P is zero, it means redisplay is setting the name; the + name provided will be ignored if explicit_name is set. */ +void +haiku_set_name (struct frame *f, Lisp_Object name, bool explicit_p) +{ + if (explicit_p) + { + if (f->explicit_name && NILP (name)) + update_mode_lines = 24; + + f->explicit_name = !NILP (name); + } + else if (f->explicit_name) + return; + + if (NILP (name)) + name = build_unibyte_string ("GNU Emacs"); + + if (!NILP (Fstring_equal (name, f->name))) + return; + + fset_name (f, name); + + if (!NILP (f->title)) + name = f->title; + + haiku_set_title_bar_text (f, name); +} + +static void +haiku_set_inhibit_double_buffering (struct frame *f, + Lisp_Object new_value, + Lisp_Object old_value) +{ + block_input (); + if (FRAME_HAIKU_WINDOW (f)) + { + if (NILP (new_value)) + { + EmacsView_set_up_double_buffering (FRAME_HAIKU_VIEW (f)); + if (!NILP (old_value)) + { + SET_FRAME_GARBAGED (f); + expose_frame (f, 0, 0, 0, 0); + } + } + else + EmacsView_disable_double_buffering (FRAME_HAIKU_VIEW (f)); + } + unblock_input (); +} + + + +DEFUN ("haiku-set-mouse-absolute-pixel-position", + Fhaiku_set_mouse_absolute_pixel_position, + Shaiku_set_mouse_absolute_pixel_position, 2, 2, 0, + doc: /* Move mouse pointer to a pixel position at (X, Y). The +coordinates X and Y are interpreted to start from the top-left +corner of the screen. */) + (Lisp_Object x, Lisp_Object y) +{ + int xval = check_integer_range (x, INT_MIN, INT_MAX); + int yval = check_integer_range (y, INT_MIN, INT_MAX); + + if (!x_display_list) + error ("Window system not initialized"); + + block_input (); + be_warp_pointer (xval, yval); + unblock_input (); + return Qnil; +} + +DEFUN ("haiku-mouse-absolute-pixel-position", Fhaiku_mouse_absolute_pixel_position, + Shaiku_mouse_absolute_pixel_position, 0, 0, 0, + doc: /* Return absolute position of mouse cursor in pixels. +The position is returned as a cons cell (X . Y) of the coordinates of +the mouse cursor position in pixels relative to a position (0, 0) of the +selected frame's display. */) + (void) +{ + if (!x_display_list) + return Qnil; + + struct frame *f = SELECTED_FRAME (); + + if (FRAME_INITIAL_P (f) || !FRAME_HAIKU_P (f) + || !FRAME_HAIKU_VIEW (f)) + return Qnil; + + block_input (); + void *view = FRAME_HAIKU_VIEW (f); + + int x, y; + BView_get_mouse (view, &x, &y); + BView_convert_to_screen (view, &x, &y); + unblock_input (); + + return Fcons (make_fixnum (x), make_fixnum (y)); +} + +DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + return Qt; +} + +DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object color, Lisp_Object frame) +{ + Emacs_Color col; + CHECK_STRING (color); + decode_window_system_frame (frame); + + return haiku_get_color (SSDATA (color), &col) ? Qnil : Qt; +} + +DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object color, Lisp_Object frame) +{ + Emacs_Color col; + CHECK_STRING (color); + decode_window_system_frame (frame); + + block_input (); + if (haiku_get_color (SSDATA (color), &col)) + { + unblock_input (); + return Qnil; + } + unblock_input (); + return list3i (lrint (col.red), lrint (col.green), lrint (col.blue)); +} + +DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, Sx_display_grayscale_p, + 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + return Qnil; +} + +DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection, + 1, 3, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object display, Lisp_Object resource_string, Lisp_Object must_succeed) +{ + struct haiku_display_info *dpy_info; + CHECK_STRING (display); + + if (NILP (Fstring_equal (display, build_string ("be")))) + !NILP (must_succeed) ? fatal ("Bad display") : error ("Bad display"); + dpy_info = haiku_term_init (); + + if (!dpy_info) + !NILP (must_succeed) ? fatal ("Display not responding") : + error ("Display not responding"); + + return Qnil; +} + +DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width, + 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) + +{ + check_haiku_display_info (terminal); + + int width, height; + BScreen_px_dim (&width, &height); + return make_fixnum (width); +} + +DEFUN ("x-display-pixel-height", Fx_display_pixel_height, Sx_display_pixel_height, + 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) + +{ + check_haiku_display_info (terminal); + + int width, height; + BScreen_px_dim (&width, &height); + return make_fixnum (width); +} + +DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + struct haiku_display_info *dpyinfo = check_haiku_display_info (terminal); + + int width, height; + BScreen_px_dim (&width, &height); + + return make_fixnum (height / (dpyinfo->resy / 25.4)); +} + + +DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + struct haiku_display_info *dpyinfo = check_haiku_display_info (terminal); + + int width, height; + BScreen_px_dim (&width, &height); + + return make_fixnum (height / (dpyinfo->resy / 25.4)); +} + +DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, + 1, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object parms) +{ + return haiku_create_frame (parms, 0); +} + +DEFUN ("x-display-visual-class", Fx_display_visual_class, + Sx_display_visual_class, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + + int planes = be_get_display_planes (); + + if (planes == 8) + return intern ("static-color"); + else if (planes == 16 || planes == 15) + return intern ("pseudo-color"); + + return intern ("direct-color"); +} + +DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object string, Lisp_Object frame, Lisp_Object parms, + Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy) +{ + struct frame *tip_f; + struct window *w; + int root_x, root_y; + struct buffer *old_buffer; + struct text_pos pos; + int width, height; + int old_windows_or_buffers_changed = windows_or_buffers_changed; + ptrdiff_t count = SPECPDL_INDEX (); + ptrdiff_t count_1; + Lisp_Object window, size, tip_buf; + + AUTO_STRING (tip, " *tip*"); + + specbind (Qinhibit_redisplay, Qt); + + CHECK_STRING (string); + + if (NILP (frame)) + frame = selected_frame; + decode_window_system_frame (frame); + + if (NILP (timeout)) + timeout = make_fixnum (5); + else + CHECK_FIXNAT (timeout); + + if (NILP (dx)) + dx = make_fixnum (5); + else + CHECK_FIXNUM (dx); + + if (NILP (dy)) + dy = make_fixnum (-10); + else + CHECK_FIXNUM (dy); + + if (haiku_use_system_tooltips) + { + int root_x, root_y; + CHECK_STRING (string); + if (STRING_MULTIBYTE (string)) + string = ENCODE_UTF_8 (string); + + if (NILP (frame)) + frame = selected_frame; + + struct frame *f = decode_window_system_frame (frame); + block_input (); + + char *str = xstrdup (SSDATA (string)); + int height = be_plain_font_height (); + int width; + char *tok = strtok (str, "\n"); + width = be_string_width_with_plain_font (tok); + + while ((tok = strtok (NULL, "\n"))) + { + height = be_plain_font_height (); + int w = be_string_width_with_plain_font (tok); + if (w > width) + w = width; + } + free (str); + + height += 16; /* Default margin. */ + width += 16; /* Ditto. Unfortunately there isn't a more + reliable way to get it. */ + compute_tip_xy (f, parms, dx, dy, width, height, &root_x, &root_y); + BView_convert_from_screen (FRAME_HAIKU_VIEW (f), &root_x, &root_y); + BView_set_and_show_sticky_tooltip (FRAME_HAIKU_VIEW (f), SSDATA (string), + root_x, root_y); + unblock_input (); + goto start_timer; + } + + if (!NILP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame))) + { + if (FRAME_VISIBLE_P (XFRAME (tip_frame)) + && EQ (frame, tip_last_frame) + && !NILP (Fequal_including_properties (string, tip_last_string)) + && !NILP (Fequal (parms, tip_last_parms))) + { + /* Only DX and DY have changed. */ + tip_f = XFRAME (tip_frame); + if (!NILP (tip_timer)) + { + Lisp_Object timer = tip_timer; + + tip_timer = Qnil; + call1 (Qcancel_timer, timer); + } + + block_input (); + compute_tip_xy (tip_f, parms, dx, dy, FRAME_PIXEL_WIDTH (tip_f), + FRAME_PIXEL_HEIGHT (tip_f), &root_x, &root_y); + haiku_set_offset (tip_f, root_x, root_y, 1); + haiku_visualize_frame (tip_f); + unblock_input (); + + goto start_timer; + } + else if (tooltip_reuse_hidden_frame && EQ (frame, tip_last_frame)) + { + bool delete = false; + Lisp_Object tail, elt, parm, last; + + /* Check if every parameter in PARMS has the same value in + tip_last_parms. This may destruct tip_last_parms + which, however, will be recreated below. */ + for (tail = parms; CONSP (tail); tail = XCDR (tail)) + { + elt = XCAR (tail); + parm = Fcar (elt); + /* The left, top, right and bottom parameters are handled + by compute_tip_xy so they can be ignored here. */ + if (!EQ (parm, Qleft) && !EQ (parm, Qtop) + && !EQ (parm, Qright) && !EQ (parm, Qbottom)) + { + last = Fassq (parm, tip_last_parms); + if (NILP (Fequal (Fcdr (elt), Fcdr (last)))) + { + /* We lost, delete the old tooltip. */ + delete = true; + break; + } + else + tip_last_parms = + call2 (Qassq_delete_all, parm, tip_last_parms); + } + else + tip_last_parms = + call2 (Qassq_delete_all, parm, tip_last_parms); + } + + /* Now check if there's a parameter left in tip_last_parms with a + non-nil value. */ + for (tail = tip_last_parms; CONSP (tail); tail = XCDR (tail)) + { + elt = XCAR (tail); + parm = Fcar (elt); + if (!EQ (parm, Qleft) && !EQ (parm, Qtop) && !EQ (parm, Qright) + && !EQ (parm, Qbottom) && !NILP (Fcdr (elt))) + { + /* We lost, delete the old tooltip. */ + delete = true; + break; + } + } + + haiku_hide_tip (delete); + } + else + haiku_hide_tip (true); + } + else + haiku_hide_tip (true); + + tip_last_frame = frame; + tip_last_string = string; + tip_last_parms = parms; + + /* Block input until the tip has been fully drawn, to avoid crashes + when drawing tips in menus. */ + block_input (); + + if (NILP (tip_frame) || !FRAME_LIVE_P (XFRAME (tip_frame))) + { + /* Add default values to frame parameters. */ + if (NILP (Fassq (Qname, parms))) + parms = Fcons (Fcons (Qname, build_string ("tooltip")), parms); + if (NILP (Fassq (Qinternal_border_width, parms))) + parms = Fcons (Fcons (Qinternal_border_width, make_fixnum (3)), parms); + if (NILP (Fassq (Qborder_width, parms))) + parms = Fcons (Fcons (Qborder_width, make_fixnum (1)), parms); + if (NILP (Fassq (Qborder_color, parms))) + parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")), + parms); + if (NILP (Fassq (Qbackground_color, parms))) + parms = Fcons (Fcons (Qbackground_color, build_string ("lightyellow")), + parms); + + /* Create a frame for the tooltip and record it in the global + variable tip_frame. */ + + if (NILP (tip_frame = haiku_create_frame (parms, 1))) + { + /* Creating the tip frame failed. */ + unblock_input (); + return unbind_to (count, Qnil); + } + } + + tip_f = XFRAME (tip_frame); + window = FRAME_ROOT_WINDOW (tip_f); + tip_buf = Fget_buffer_create (tip, Qnil); + /* We will mark the tip window a "pseudo-window" below, and such + windows cannot have display margins. */ + bset_left_margin_cols (XBUFFER (tip_buf), make_fixnum (0)); + bset_right_margin_cols (XBUFFER (tip_buf), make_fixnum (0)); + set_window_buffer (window, tip_buf, false, false); + w = XWINDOW (window); + w->pseudo_window_p = true; + /* Try to avoid that `other-window' select us (Bug#47207). */ + Fset_window_parameter (window, Qno_other_window, Qt); + + /* Set up the frame's root window. Note: The following code does not + try to size the window or its frame correctly. Its only purpose is + to make the subsequent text size calculations work. The right + sizes should get installed when the toolkit gets back to us. */ + w->left_col = 0; + w->top_line = 0; + w->pixel_left = 0; + w->pixel_top = 0; + + if (CONSP (Vx_max_tooltip_size) + && RANGED_FIXNUMP (1, XCAR (Vx_max_tooltip_size), INT_MAX) + && RANGED_FIXNUMP (1, XCDR (Vx_max_tooltip_size), INT_MAX)) + { + w->total_cols = XFIXNAT (XCAR (Vx_max_tooltip_size)); + w->total_lines = XFIXNAT (XCDR (Vx_max_tooltip_size)); + } + else + { + w->total_cols = 80; + w->total_lines = 40; + } + + w->pixel_width = w->total_cols * FRAME_COLUMN_WIDTH (tip_f); + w->pixel_height = w->total_lines * FRAME_LINE_HEIGHT (tip_f); + FRAME_TOTAL_COLS (tip_f) = WINDOW_TOTAL_COLS (w); + adjust_frame_glyphs (tip_f); + + /* Insert STRING into the root window's buffer and fit the frame to + the buffer. */ + count_1 = SPECPDL_INDEX (); + old_buffer = current_buffer; + set_buffer_internal_1 (XBUFFER (w->contents)); + bset_truncate_lines (current_buffer, Qnil); + specbind (Qinhibit_read_only, Qt); + specbind (Qinhibit_modification_hooks, Qt); + specbind (Qinhibit_point_motion_hooks, Qt); + Ferase_buffer (); + Finsert (1, &string); + clear_glyph_matrix (w->desired_matrix); + clear_glyph_matrix (w->current_matrix); + SET_TEXT_POS (pos, BEGV, BEGV_BYTE); + try_window (window, pos, TRY_WINDOW_IGNORE_FONTS_CHANGE); + /* Calculate size of tooltip window. */ + size = Fwindow_text_pixel_size (window, Qnil, Qnil, Qnil, + make_fixnum (w->pixel_height), Qnil); + /* Add the frame's internal border to calculated size. */ + width = XFIXNUM (Fcar (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f); + height = XFIXNUM (Fcdr (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f); + /* Calculate position of tooltip frame. */ + compute_tip_xy (tip_f, parms, dx, dy, width, height, &root_x, &root_y); + BWindow_resize (FRAME_HAIKU_WINDOW (tip_f), width, height); + haiku_set_offset (tip_f, root_x, root_y, 1); + BWindow_set_tooltip_decoration (FRAME_HAIKU_WINDOW (tip_f)); + BView_set_view_cursor (FRAME_HAIKU_VIEW (tip_f), + FRAME_OUTPUT_DATA (XFRAME (frame))->current_cursor); + SET_FRAME_VISIBLE (tip_f, 1); + BWindow_set_visible (FRAME_HAIKU_WINDOW (tip_f), 1); + + w->must_be_updated_p = true; + flush_frame (tip_f); + update_single_window (w); + set_buffer_internal_1 (old_buffer); + unbind_to (count_1, Qnil); + unblock_input (); + windows_or_buffers_changed = old_windows_or_buffers_changed; + + start_timer: + /* Let the tip disappear after timeout seconds. */ + tip_timer = call3 (intern ("run-at-time"), timeout, Qnil, + intern ("x-hide-tip")); + + return unbind_to (count, Qnil); +} + +DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0, + doc: /* SKIP: real doc in xfns.c. */) + (void) +{ + return haiku_hide_tip (!tooltip_reuse_hidden_frame); +} + +DEFUN ("x-close-connection", Fx_close_connection, Sx_close_connection, 1, 1, 0, + doc: /* SKIP: real doc in xfns.c. */ + attributes: noreturn) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + + error ("Cannot close Haiku displays"); +} + +DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0, + doc: /* SKIP: real doc in xfns.c. */) + (void) +{ + if (!x_display_list) + return Qnil; + + return list1 (XCAR (x_display_list->name_list_element)); +} + +DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + return build_string ("Haiku, Inc."); +} + +DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + return list3i (5, 1, 1); +} + +DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + return make_fixnum (be_get_display_screens ()); +} + +DEFUN ("haiku-get-version-string", Fhaiku_get_version_string, + Shaiku_get_version_string, 0, 0, 0, + doc: /* Return a string describing the current Haiku version. */) + (void) +{ + char buf[1024]; + + be_get_version_string ((char *) &buf, sizeof buf); + return build_string (buf); +} + +DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells, + 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + + return make_fixnum (be_get_display_color_cells ()); +} + +DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes, + 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + + return make_fixnum (be_get_display_planes ()); +} + +DEFUN ("x-double-buffered-p", Fx_double_buffered_p, Sx_double_buffered_p, + 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object frame) +{ + struct frame *f = decode_live_frame (frame); + check_window_system (f); + + return EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f)) ? Qt : Qnil; +} + +DEFUN ("x-display-backing-store", Fx_display_backing_store, Sx_display_backing_store, + 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + if (FRAMEP (terminal)) + { + CHECK_LIVE_FRAME (terminal); + struct frame *f = decode_window_system_frame (terminal); + + if (FRAME_HAIKU_VIEW (f) && + EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f))) + return FRAME_PARENT_FRAME (f) ? Qwhen_mapped : Qalways; + else + return Qnot_useful; + } + else + { + check_haiku_display_info (terminal); + return Qnot_useful; + } +} + +DEFUN ("haiku-frame-geometry", Fhaiku_frame_geometry, Shaiku_frame_geometry, 0, 1, 0, + doc: /* Return geometric attributes of FRAME. +FRAME must be a live frame and defaults to the selected one. The return +value is an association list of the attributes listed below. All height +and width values are in pixels. + +`outer-position' is a cons of the outer left and top edges of FRAME + relative to the origin - the position (0, 0) - of FRAME's display. + +`outer-size' is a cons of the outer width and height of FRAME. The + outer size includes the title bar and the external borders as well as + any menu and/or tool bar of frame. + +`external-border-size' is a cons of the horizontal and vertical width of + FRAME's external borders as supplied by the window manager. + +`title-bar-size' is a cons of the width and height of the title bar of + FRAME as supplied by the window manager. If both of them are zero, + FRAME has no title bar. If only the width is zero, Emacs was not + able to retrieve the width information. + +`menu-bar-external', if non-nil, means the menu bar is external (never + included in the inner edges of FRAME). + +`menu-bar-size' is a cons of the width and height of the menu bar of + FRAME. + +`tool-bar-external', if non-nil, means the tool bar is external (never + included in the inner edges of FRAME). + +`tool-bar-position' tells on which side the tool bar on FRAME is and can + be one of `left', `top', `right' or `bottom'. If this is nil, FRAME + has no tool bar. + +`tool-bar-size' is a cons of the width and height of the tool bar of + FRAME. + +`internal-border-width' is the width of the internal border of + FRAME. */) + (Lisp_Object frame) +{ + return frame_geometry (frame, Qnil); +} + +DEFUN ("haiku-frame-edges", Fhaiku_frame_edges, Shaiku_frame_edges, 0, 2, 0, + doc: /* Return edge coordinates of FRAME. +FRAME must be a live frame and defaults to the selected one. The return +value is a list of the form (LEFT, TOP, RIGHT, BOTTOM). All values are +in pixels relative to the origin - the position (0, 0) - of FRAME's +display. + +If optional argument TYPE is the symbol `outer-edges', return the outer +edges of FRAME. The outer edges comprise the decorations of the window +manager (like the title bar or external borders) as well as any external +menu or tool bar of FRAME. If optional argument TYPE is the symbol +`native-edges' or nil, return the native edges of FRAME. The native +edges exclude the decorations of the window manager and any external +menu or tool bar of FRAME. If TYPE is the symbol `inner-edges', return +the inner edges of FRAME. These edges exclude title bar, any borders, +menu bar or tool bar of FRAME. */) + (Lisp_Object frame, Lisp_Object type) +{ + return frame_geometry (frame, ((EQ (type, Qouter_edges) + || EQ (type, Qinner_edges)) + ? type + : Qnative_edges)); +} + +DEFUN ("haiku-read-file-name", Fhaiku_read_file_name, Shaiku_read_file_name, 1, 6, 0, + doc: /* Use a graphical panel to read a file name, using prompt PROMPT. +Optional arg FRAME specifies a frame on which to display the file panel. +If it is nil, the current frame is used instead. +The frame being used will be brought to the front of +the display after the file panel is closed. +Optional arg DIR, if non-nil, supplies a default directory. +Optional arg MUSTMATCH, if non-nil, means the returned file or +directory must exist. +Optional arg DIR_ONLY_P, if non-nil, means choose only directories. +Optional arg SAVE_TEXT, if non-nil, specifies some text to show in the entry field. */) + (Lisp_Object prompt, Lisp_Object frame, + Lisp_Object dir, Lisp_Object mustmatch, + Lisp_Object dir_only_p, Lisp_Object save_text) +{ + ptrdiff_t idx; + if (!x_display_list) + error ("Be windowing not initialized"); + + if (!NILP (dir)) + CHECK_STRING (dir); + + if (!NILP (save_text)) + CHECK_STRING (save_text); + + if (NILP (frame)) + frame = selected_frame; + + CHECK_STRING (prompt); + + CHECK_LIVE_FRAME (frame); + check_window_system (XFRAME (frame)); + + idx = SPECPDL_INDEX (); + record_unwind_protect_void (unwind_popup); + + struct frame *f = XFRAME (frame); + + FRAME_DISPLAY_INFO (f)->focus_event_frame = f; + + ++popup_activated_p; + char *fn = be_popup_file_dialog (!NILP (mustmatch) || !NILP (dir_only_p), + !NILP (dir) ? SSDATA (ENCODE_UTF_8 (dir)) : NULL, + !NILP (mustmatch), !NILP (dir_only_p), + FRAME_HAIKU_WINDOW (f), + !NILP (save_text) ? SSDATA (ENCODE_UTF_8 (save_text)) : NULL, + SSDATA (ENCODE_UTF_8 (prompt)), + block_input, unblock_input); + + unbind_to (idx, Qnil); + + block_input (); + BWindow_activate (FRAME_HAIKU_WINDOW (f)); + unblock_input (); + + if (!fn) + return Qnil; + + Lisp_Object p = build_string_from_utf8 (fn); + free (fn); + return p; +} + +DEFUN ("haiku-put-resource", Fhaiku_put_resource, Shaiku_put_resource, + 2, 2, 0, doc: /* Place STRING by the key RESOURCE in the resource database. +It can later be retrieved with `x-get-resource'. */) + (Lisp_Object resource, Lisp_Object string) +{ + CHECK_STRING (resource); + if (!NILP (string)) + CHECK_STRING (string); + + put_xrm_resource (resource, string); + return Qnil; +} + +DEFUN ("haiku-frame-list-z-order", Fhaiku_frame_list_z_order, + Shaiku_frame_list_z_order, 0, 1, 0, + doc: /* Return list of Emacs' frames, in Z (stacking) order. +If TERMINAL is non-nil and specifies a live frame, return the child +frames of that frame in Z (stacking) order. + +As it is impossible to reliably determine the frame stacking order on +Haiku, the selected frame is always the first element of the returned +list, while the rest are not guaranteed to be in any particular order. + +Frames are listed from topmost (first) to bottommost (last). */) + (Lisp_Object terminal) +{ + Lisp_Object frames = Qnil; + Lisp_Object head, tail; + Lisp_Object sel = Qnil; + + FOR_EACH_FRAME (head, tail) + { + struct frame *f = XFRAME (tail); + if (!FRAME_HAIKU_P (f) || + (FRAMEP (terminal) && + FRAME_LIVE_P (XFRAME (terminal)) && + !EQ (terminal, get_frame_param (f, Qparent_frame)))) + continue; + + if (EQ (tail, selected_frame)) + sel = tail; + else + frames = Fcons (tail, frames); + } + + if (NILP (sel)) + return frames; + return Fcons (sel, frames); +} + +DEFUN ("x-display-save-under", Fx_display_save_under, + Sx_display_save_under, 0, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object terminal) +{ + check_haiku_display_info (terminal); + + if (FRAMEP (terminal)) + { + struct frame *f = decode_window_system_frame (terminal); + return FRAME_HAIKU_VIEW (f) && EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f)) ? + Qt : Qnil; + } + + return Qnil; +} + +frame_parm_handler haiku_frame_parm_handlers[] = + { + gui_set_autoraise, + gui_set_autolower, + haiku_set_background_color, + NULL, /* x_set_border_color */ + gui_set_border_width, + haiku_set_cursor_color, + haiku_set_cursor_type, + gui_set_font, + haiku_set_foreground_color, + NULL, /* set icon name */ + NULL, /* set icon type */ + haiku_set_child_frame_border_width, + haiku_set_internal_border_width, + gui_set_right_divider_width, + gui_set_bottom_divider_width, + haiku_set_menu_bar_lines, + NULL, /* set mouse color */ + haiku_explicitly_set_name, + gui_set_scroll_bar_width, + gui_set_scroll_bar_height, + haiku_set_title, + gui_set_unsplittable, + gui_set_vertical_scroll_bars, + gui_set_horizontal_scroll_bars, + gui_set_visibility, + haiku_set_tab_bar_lines, + haiku_set_tool_bar_lines, + NULL, /* set scroll bar fg */ + NULL, /* set scroll bar bkg */ + gui_set_screen_gamma, + gui_set_line_spacing, + gui_set_left_fringe, + gui_set_right_fringe, + NULL, /* x wait for wm */ + gui_set_fullscreen, + gui_set_font_backend, + gui_set_alpha, + NULL, /* set sticky */ + NULL, /* set tool bar pos */ + haiku_set_inhibit_double_buffering, + haiku_set_undecorated, + haiku_set_parent_frame, + NULL, /* set skip taskbar */ + haiku_set_no_focus_on_map, + haiku_set_no_accept_focus, + NULL, /* set z group */ + NULL, /* set override redir */ + gui_set_no_special_glyphs + }; + +void +syms_of_haikufns (void) +{ + DEFSYM (Qfont_parameter, "font-parameter"); + DEFSYM (Qcancel_timer, "cancel-timer"); + DEFSYM (Qassq_delete_all, "assq-delete-all"); + + DEFSYM (Qalways, "always"); + DEFSYM (Qnot_useful, "not-useful"); + DEFSYM (Qwhen_mapped, "when-mapped"); + + defsubr (&Sx_hide_tip); + defsubr (&Sxw_display_color_p); + defsubr (&Sx_display_grayscale_p); + defsubr (&Sx_open_connection); + defsubr (&Sx_create_frame); + defsubr (&Sx_display_pixel_width); + defsubr (&Sx_display_pixel_height); + defsubr (&Sxw_color_values); + defsubr (&Sxw_color_defined_p); + defsubr (&Sx_display_visual_class); + defsubr (&Sx_show_tip); + defsubr (&Sx_display_mm_height); + defsubr (&Sx_display_mm_width); + defsubr (&Sx_close_connection); + defsubr (&Sx_display_list); + defsubr (&Sx_server_vendor); + defsubr (&Sx_server_version); + defsubr (&Sx_display_screens); + defsubr (&Shaiku_get_version_string); + defsubr (&Sx_display_color_cells); + defsubr (&Sx_display_planes); + defsubr (&Shaiku_set_mouse_absolute_pixel_position); + defsubr (&Shaiku_mouse_absolute_pixel_position); + defsubr (&Shaiku_frame_geometry); + defsubr (&Shaiku_frame_edges); + defsubr (&Sx_double_buffered_p); + defsubr (&Sx_display_backing_store); + defsubr (&Shaiku_read_file_name); + defsubr (&Shaiku_put_resource); + defsubr (&Shaiku_frame_list_z_order); + defsubr (&Sx_display_save_under); + + tip_timer = Qnil; + staticpro (&tip_timer); + tip_frame = Qnil; + staticpro (&tip_frame); + tip_last_frame = Qnil; + staticpro (&tip_last_frame); + tip_last_string = Qnil; + staticpro (&tip_last_string); + tip_last_parms = Qnil; + staticpro (&tip_last_parms); + + DEFVAR_LISP ("x-max-tooltip-size", Vx_max_tooltip_size, + doc: /* SKIP: real doc in xfns.c. */); + Vx_max_tooltip_size = Fcons (make_fixnum (80), make_fixnum (40)); + + DEFVAR_BOOL ("haiku-use-system-tooltips", haiku_use_system_tooltips, + doc: /* When non-nil, Emacs will display tooltips using the App Kit. +This can avoid a great deal of consing that does not play +well with the Haiku memory allocator, but comes with the +disadvantage of not being able to use special display properties +within tooltips. */); + haiku_use_system_tooltips = 1; + +#ifdef USE_BE_CAIRO + DEFVAR_LISP ("cairo-version-string", Vcairo_version_string, + doc: /* Version info for cairo. */); + { + char cairo_version[sizeof ".." + 3 * INT_STRLEN_BOUND (int)]; + int len = sprintf (cairo_version, "%d.%d.%d", + CAIRO_VERSION_MAJOR, CAIRO_VERSION_MINOR, + CAIRO_VERSION_MICRO); + Vcairo_version_string = make_pure_string (cairo_version, len, len, false); + } +#endif + + return; +} diff --git a/src/haikufont.c b/src/haikufont.c new file mode 100644 index 0000000000..811fa62a84 --- /dev/null +++ b/src/haikufont.c @@ -0,0 +1,1072 @@ +/* Font support for Haiku windowing + +Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include "lisp.h" +#include "dispextern.h" +#include "composite.h" +#include "blockinput.h" +#include "charset.h" +#include "frame.h" +#include "window.h" +#include "fontset.h" +#include "haikuterm.h" +#include "character.h" +#include "font.h" +#include "termchar.h" +#include "pdumper.h" +#include "haiku_support.h" + +#include +#include + +static Lisp_Object font_cache; + +#define METRICS_NCOLS_PER_ROW (128) + +enum metrics_status + { + METRICS_INVALID = -1, /* metrics entry is invalid */ + }; + +#define METRICS_STATUS(metrics) ((metrics)->ascent + (metrics)->descent) +#define METRICS_SET_STATUS(metrics, status) \ + ((metrics)->ascent = 0, (metrics)->descent = (status)) + +static struct +{ + /* registry name */ + const char *name; + /* characters to distinguish the charset from the others */ + int uniquifier[6]; + /* additional constraint by language */ + const char *lang; +} em_charset_table[] = + { { "iso8859-1", { 0x00A0, 0x00A1, 0x00B4, 0x00BC, 0x00D0 } }, + { "iso8859-2", { 0x00A0, 0x010E }}, + { "iso8859-3", { 0x00A0, 0x0108 }}, + { "iso8859-4", { 0x00A0, 0x00AF, 0x0128, 0x0156, 0x02C7 }}, + { "iso8859-5", { 0x00A0, 0x0401 }}, + { "iso8859-6", { 0x00A0, 0x060C }}, + { "iso8859-7", { 0x00A0, 0x0384 }}, + { "iso8859-8", { 0x00A0, 0x05D0 }}, + { "iso8859-9", { 0x00A0, 0x00A1, 0x00BC, 0x011E }}, + { "iso8859-10", { 0x00A0, 0x00D0, 0x0128, 0x2015 }}, + { "iso8859-11", { 0x00A0, 0x0E01 }}, + { "iso8859-13", { 0x00A0, 0x201C }}, + { "iso8859-14", { 0x00A0, 0x0174 }}, + { "iso8859-15", { 0x00A0, 0x00A1, 0x00D0, 0x0152 }}, + { "iso8859-16", { 0x00A0, 0x0218}}, + { "gb2312.1980-0", { 0x4E13 }, "zh-cn"}, + { "big5-0", { 0x9C21 }, "zh-tw" }, + { "jisx0208.1983-0", { 0x4E55 }, "ja"}, + { "ksc5601.1985-0", { 0xAC00 }, "ko"}, + { "cns11643.1992-1", { 0xFE32 }, "zh-tw"}, + { "cns11643.1992-2", { 0x4E33, 0x7934 }}, + { "cns11643.1992-3", { 0x201A9 }}, + { "cns11643.1992-4", { 0x20057 }}, + { "cns11643.1992-5", { 0x20000 }}, + { "cns11643.1992-6", { 0x20003 }}, + { "cns11643.1992-7", { 0x20055 }}, + { "gbk-0", { 0x4E06 }, "zh-cn"}, + { "jisx0212.1990-0", { 0x4E44 }}, + { "jisx0213.2000-1", { 0xFA10 }, "ja"}, + { "jisx0213.2000-2", { 0xFA49 }}, + { "jisx0213.2004-1", { 0x20B9F }}, + { "viscii1.1-1", { 0x1EA0, 0x1EAE, 0x1ED2 }, "vi"}, + { "tis620.2529-1", { 0x0E01 }, "th"}, + { "microsoft-cp1251", { 0x0401, 0x0490 }, "ru"}, + { "koi8-r", { 0x0401, 0x2219 }, "ru"}, + { "mulelao-1", { 0x0E81 }, "lo"}, + { "unicode-sip", { 0x20000 }}, + { "mulearabic-0", { 0x628 }}, + { "mulearabic-1", { 0x628 }}, + { "mulearabic-2", { 0x628 }}, + { NULL } + }; + +static void +haikufont_apply_registry (struct haiku_font_pattern *pattern, + Lisp_Object registry) +{ + char *str = SSDATA (SYMBOL_NAME (registry)); + USE_SAFE_ALLOCA; + char *re = SAFE_ALLOCA (SBYTES (SYMBOL_NAME (registry)) * 2 + 1); + int i, j; + + for (i = j = 0; i < SBYTES (SYMBOL_NAME (registry)); i++, j++) + { + if (str[i] == '.') + re[j++] = '\\'; + else if (str[i] == '*') + re[j++] = '.'; + re[j] = str[i]; + if (re[j] == '?') + re[j] = '.'; + } + re[j] = '\0'; + AUTO_STRING_WITH_LEN (regexp, re, j); + for (i = 0; em_charset_table[i].name; i++) + if (fast_c_string_match_ignore_case + (regexp, em_charset_table[i].name, + strlen (em_charset_table[i].name)) >= 0) + break; + SAFE_FREE (); + if (!em_charset_table[i].name) + return; + int *uniquifier = em_charset_table[i].uniquifier; + int l; + + for (l = 0; uniquifier[l]; ++l); + + uint32_t *a = xmalloc (l * sizeof *a); + for (l = 0; uniquifier[l]; ++l) + a[l] = uniquifier[l]; + + if (pattern->specified & FSPEC_WANTED) + { + int old_l = l; + l += pattern->want_chars_len; + a = xrealloc (a, l * sizeof *a); + memcpy (&a[old_l], pattern->wanted_chars, (l - old_l) * sizeof *a); + xfree (pattern->wanted_chars); + } + pattern->specified |= FSPEC_WANTED; + pattern->want_chars_len = l; + pattern->wanted_chars = a; + + if (em_charset_table[i].lang) + { + if (!strncmp (em_charset_table[i].lang, "zh", 2)) + { + pattern->specified |= FSPEC_LANGUAGE; + pattern->language = LANGUAGE_CN; + } + else if (!strncmp (em_charset_table[i].lang, "ko", 2)) + { + pattern->specified |= FSPEC_LANGUAGE; + pattern->language = LANGUAGE_KO; + } + else if (!strncmp (em_charset_table[i].lang, "ja", 2)) + { + pattern->specified |= FSPEC_LANGUAGE; + pattern->language = LANGUAGE_JP; + } + } + + return; +} + +static Lisp_Object +haikufont_get_fallback_entity (void) +{ + Lisp_Object ent = font_make_entity (); + ASET (ent, FONT_TYPE_INDEX, Qhaiku); + ASET (ent, FONT_FOUNDRY_INDEX, Qhaiku); + ASET (ent, FONT_FAMILY_INDEX, Qnil); + ASET (ent, FONT_ADSTYLE_INDEX, Qnil); + ASET (ent, FONT_REGISTRY_INDEX, Qutf_8); + ASET (ent, FONT_SIZE_INDEX, make_fixnum (0)); + ASET (ent, FONT_AVGWIDTH_INDEX, make_fixnum (0)); + ASET (ent, FONT_SPACING_INDEX, make_fixnum (FONT_SPACING_MONO)); + FONT_SET_STYLE (ent, FONT_WIDTH_INDEX, Qnil); + FONT_SET_STYLE (ent, FONT_WEIGHT_INDEX, Qnil); + FONT_SET_STYLE (ent, FONT_SLANT_INDEX, Qnil); + + return ent; +} + +static Lisp_Object +haikufont_get_cache (struct frame *frame) +{ + return font_cache; +} + +static Lisp_Object +haikufont_weight_to_lisp (int weight) +{ + switch (weight) + { + case HAIKU_THIN: + return Qthin; + case HAIKU_ULTRALIGHT: + return Qultra_light; + case HAIKU_EXTRALIGHT: + return Qextra_light; + case HAIKU_LIGHT: + return Qlight; + case HAIKU_SEMI_LIGHT: + return Qsemi_light; + case HAIKU_REGULAR: + return Qnormal; + case HAIKU_SEMI_BOLD: + return Qsemi_bold; + case HAIKU_BOLD: + return Qbold; + case HAIKU_EXTRA_BOLD: + return Qextra_bold; + case HAIKU_ULTRA_BOLD: + return Qultra_bold; + case HAIKU_BOOK: + return Qbook; + case HAIKU_HEAVY: + return Qheavy; + case HAIKU_ULTRA_HEAVY: + return Qultra_heavy; + case HAIKU_BLACK: + return Qblack; + case HAIKU_MEDIUM: + return Qmedium; + } + emacs_abort (); +} + +static int +haikufont_lisp_to_weight (Lisp_Object weight) +{ + if (EQ (weight, Qthin)) + return HAIKU_THIN; + if (EQ (weight, Qultra_light)) + return HAIKU_ULTRALIGHT; + if (EQ (weight, Qextra_light)) + return HAIKU_EXTRALIGHT; + if (EQ (weight, Qlight)) + return HAIKU_LIGHT; + if (EQ (weight, Qsemi_light)) + return HAIKU_SEMI_LIGHT; + if (EQ (weight, Qnormal)) + return HAIKU_REGULAR; + if (EQ (weight, Qsemi_bold)) + return HAIKU_SEMI_BOLD; + if (EQ (weight, Qbold)) + return HAIKU_BOLD; + if (EQ (weight, Qextra_bold)) + return HAIKU_EXTRA_BOLD; + if (EQ (weight, Qultra_bold)) + return HAIKU_ULTRA_BOLD; + if (EQ (weight, Qbook)) + return HAIKU_BOOK; + if (EQ (weight, Qheavy)) + return HAIKU_HEAVY; + if (EQ (weight, Qultra_heavy)) + return HAIKU_ULTRA_HEAVY; + if (EQ (weight, Qblack)) + return HAIKU_BLACK; + if (EQ (weight, Qmedium)) + return HAIKU_MEDIUM; + + emacs_abort (); +} + +static Lisp_Object +haikufont_slant_to_lisp (enum haiku_font_slant slant) +{ + switch (slant) + { + case NO_SLANT: + emacs_abort (); + case SLANT_ITALIC: + return Qitalic; + case SLANT_REGULAR: + return Qnormal; + case SLANT_OBLIQUE: + return Qoblique; + } + emacs_abort (); +} + +static enum haiku_font_slant +haikufont_lisp_to_slant (Lisp_Object slant) +{ + if (EQ (slant, Qitalic) || + EQ (slant, Qreverse_italic)) + return SLANT_ITALIC; + if (EQ (slant, Qoblique) || + EQ (slant, Qreverse_oblique)) + return SLANT_OBLIQUE; + if (EQ (slant, Qnormal)) + return SLANT_REGULAR; + emacs_abort (); +} + +static Lisp_Object +haikufont_width_to_lisp (enum haiku_font_width width) +{ + switch (width) + { + case NO_WIDTH: + emacs_abort (); + case ULTRA_CONDENSED: + return Qultra_condensed; + case EXTRA_CONDENSED: + return Qextra_condensed; + case CONDENSED: + return Qcondensed; + case SEMI_CONDENSED: + return Qsemi_condensed; + case NORMAL_WIDTH: + return Qnormal; + case SEMI_EXPANDED: + return Qsemi_expanded; + case EXPANDED: + return Qexpanded; + case EXTRA_EXPANDED: + return Qextra_expanded; + case ULTRA_EXPANDED: + return Qultra_expanded; + } + + emacs_abort (); +} + +static enum haiku_font_width +haikufont_lisp_to_width (Lisp_Object lisp) +{ + if (EQ (lisp, Qultra_condensed)) + return ULTRA_CONDENSED; + if (EQ (lisp, Qextra_condensed)) + return EXTRA_CONDENSED; + if (EQ (lisp, Qcondensed)) + return CONDENSED; + if (EQ (lisp, Qsemi_condensed)) + return SEMI_CONDENSED; + if (EQ (lisp, Qnormal)) + return NORMAL_WIDTH; + if (EQ (lisp, Qexpanded)) + return EXPANDED; + if (EQ (lisp, Qextra_expanded)) + return EXTRA_EXPANDED; + if (EQ (lisp, Qultra_expanded)) + return ULTRA_EXPANDED; + emacs_abort (); +} + +static int +haikufont_maybe_handle_special_family (Lisp_Object family, + struct haiku_font_pattern *ptn) +{ + CHECK_SYMBOL (family); + + if (EQ (family, Qmonospace) || EQ (family, Qfixed) || + EQ (family, Qdefault)) + { + BFont_populate_fixed_family (ptn); + return 1; + } + else if (EQ (family, intern ("Sans Serif"))) + { + BFont_populate_plain_family (ptn); + return 1; + } + return 0; +} + +static Lisp_Object +haikufont_pattern_to_entity (struct haiku_font_pattern *ptn) +{ + Lisp_Object ent = font_make_entity (); + ASET (ent, FONT_TYPE_INDEX, Qhaiku); + ASET (ent, FONT_FOUNDRY_INDEX, Qhaiku); + ASET (ent, FONT_FAMILY_INDEX, Qdefault); + ASET (ent, FONT_ADSTYLE_INDEX, Qnil); + ASET (ent, FONT_REGISTRY_INDEX, Qutf_8); + ASET (ent, FONT_SIZE_INDEX, make_fixnum (0)); + ASET (ent, FONT_AVGWIDTH_INDEX, make_fixnum (0)); + ASET (ent, FONT_SPACING_INDEX, make_fixnum (FONT_SPACING_MONO)); + FONT_SET_STYLE (ent, FONT_WIDTH_INDEX, Qnormal); + FONT_SET_STYLE (ent, FONT_WEIGHT_INDEX, Qnormal); + FONT_SET_STYLE (ent, FONT_SLANT_INDEX, Qnormal); + + if (ptn->specified & FSPEC_FAMILY) + ASET (ent, FONT_FAMILY_INDEX, intern (ptn->family)); + else + ASET (ent, FONT_FAMILY_INDEX, Qdefault); + + if (ptn->specified & FSPEC_STYLE) + ASET (ent, FONT_ADSTYLE_INDEX, intern (ptn->style)); + else + { + if (ptn->specified & FSPEC_WEIGHT) + FONT_SET_STYLE (ent, FONT_WEIGHT_INDEX, + haikufont_weight_to_lisp (ptn->weight)); + if (ptn->specified & FSPEC_SLANT) + FONT_SET_STYLE (ent, FONT_SLANT_INDEX, + haikufont_slant_to_lisp (ptn->slant)); + if (ptn->specified & FSPEC_WIDTH) + FONT_SET_STYLE (ent, FONT_WIDTH_INDEX, + haikufont_width_to_lisp (ptn->width)); + } + + if (ptn->specified & FSPEC_SPACING) + ASET (ent, FONT_SPACING_INDEX, + make_fixnum (ptn->mono_spacing_p ? + FONT_SPACING_MONO : FONT_SPACING_PROPORTIONAL)); + return ent; +} + +static void +haikufont_spec_or_entity_to_pattern (Lisp_Object ent, + int list_p, + struct haiku_font_pattern *ptn) +{ + Lisp_Object tem; + ptn->specified = 0; + + tem = AREF (ent, FONT_ADSTYLE_INDEX); + if (!NILP (tem)) + { + ptn->specified |= FSPEC_STYLE; + strncpy ((char *) &ptn->style, + SSDATA (SYMBOL_NAME (tem)), + sizeof ptn->style - 1); + } + + tem = FONT_SLANT_SYMBOLIC (ent); + if (!NILP (tem)) + { + ptn->specified |= FSPEC_SLANT; + ptn->slant = haikufont_lisp_to_slant (tem); + } + + tem = FONT_WEIGHT_SYMBOLIC (ent); + if (!NILP (tem)) + { + ptn->specified |= FSPEC_WEIGHT; + ptn->weight = haikufont_lisp_to_weight (tem); + } + + tem = FONT_WIDTH_SYMBOLIC (ent); + if (!NILP (tem)) + { + ptn->specified |= FSPEC_WIDTH; + ptn->width = haikufont_lisp_to_width (tem); + } + + tem = AREF (ent, FONT_SPACING_INDEX); + if (FIXNUMP (tem)) + { + ptn->specified |= FSPEC_SPACING; + ptn->mono_spacing_p = XFIXNUM (tem) != FONT_SPACING_PROPORTIONAL; + } + + tem = AREF (ent, FONT_FAMILY_INDEX); + if (!NILP (tem) && + (list_p && !haikufont_maybe_handle_special_family (tem, ptn))) + { + ptn->specified |= FSPEC_FAMILY; + strncpy ((char *) &ptn->family, + SSDATA (SYMBOL_NAME (tem)), + sizeof ptn->family - 1); + } + + tem = assq_no_quit (QCscript, AREF (ent, FONT_EXTRA_INDEX)); + if (!NILP (tem)) + { + tem = assq_no_quit (XCDR (tem), Vscript_representative_chars); + + if (CONSP (tem) && VECTORP (XCDR (tem))) + { + tem = XCDR (tem); + + int count = 0; + + for (int j = 0; j < ASIZE (tem); ++j) + if (TYPE_RANGED_FIXNUMP (uint32_t, AREF (tem, j))) + ++count; + + if (count) + { + ptn->specified |= FSPEC_NEED_ONE_OF; + ptn->need_one_of_len = count; + ptn->need_one_of = xmalloc (count * sizeof *ptn->need_one_of); + count = 0; + for (int j = 0; j < ASIZE (tem); ++j) + if (TYPE_RANGED_FIXNUMP (uint32_t, AREF (tem, j))) + { + ptn->need_one_of[j] = XFIXNAT (AREF (tem, j)); + ++count; + } + } + } + else if (CONSP (tem) && CONSP (XCDR (tem))) + { + int count = 0; + + for (Lisp_Object it = XCDR (tem); CONSP (it); it = XCDR (it)) + if (TYPE_RANGED_FIXNUMP (uint32_t, XCAR (it))) + ++count; + + if (count) + { + ptn->specified |= FSPEC_WANTED; + ptn->want_chars_len = count; + ptn->wanted_chars = xmalloc (count * sizeof *ptn->wanted_chars); + count = 0; + + for (tem = XCDR (tem); CONSP (tem); tem = XCDR (tem)) + if (TYPE_RANGED_FIXNUMP (uint32_t, XCAR (tem))) + { + ptn->wanted_chars[count] = XFIXNAT (XCAR (tem)); + ++count; + } + } + } + } + + tem = assq_no_quit (QClang, AREF (ent, FONT_EXTRA_INDEX)); + if (CONSP (tem)) + { + tem = XCDR (tem); + if (EQ (tem, Qzh)) + { + ptn->specified |= FSPEC_LANGUAGE; + ptn->language = LANGUAGE_CN; + } + else if (EQ (tem, Qko)) + { + ptn->specified |= FSPEC_LANGUAGE; + ptn->language = LANGUAGE_KO; + } + else if (EQ (tem, Qjp)) + { + ptn->specified |= FSPEC_LANGUAGE; + ptn->language = LANGUAGE_JP; + } + } + + tem = AREF (ent, FONT_REGISTRY_INDEX); + if (SYMBOLP (tem)) + haikufont_apply_registry (ptn, tem); +} + +static void +haikufont_done_with_query_pattern (struct haiku_font_pattern *ptn) +{ + if (ptn->specified & FSPEC_WANTED) + xfree (ptn->wanted_chars); + + if (ptn->specified & FSPEC_NEED_ONE_OF) + xfree (ptn->need_one_of); +} + +static Lisp_Object +haikufont_match (struct frame *f, Lisp_Object font_spec) +{ + block_input (); + Lisp_Object tem = Qnil; + struct haiku_font_pattern ptn; + haikufont_spec_or_entity_to_pattern (font_spec, 0, &ptn); + ptn.specified &= ~FSPEC_FAMILY; + struct haiku_font_pattern *found = BFont_find (&ptn); + haikufont_done_with_query_pattern (&ptn); + if (found) + { + tem = haikufont_pattern_to_entity (found); + haiku_font_pattern_free (found); + } + unblock_input (); + return !NILP (tem) ? tem : haikufont_get_fallback_entity (); +} + +static Lisp_Object +haikufont_list (struct frame *f, Lisp_Object font_spec) +{ + block_input (); + Lisp_Object lst = Qnil; + + /* Returning irrelevant results on receiving an OTF form will cause + fontset.c to loop over and over, making displaying some + characters very slow. */ + Lisp_Object tem = assq_no_quit (QCotf, AREF (font_spec, FONT_EXTRA_INDEX)); + if (CONSP (tem) && !NILP (XCDR (tem))) + { + unblock_input (); + return Qnil; + } + + struct haiku_font_pattern ptn; + haikufont_spec_or_entity_to_pattern (font_spec, 1, &ptn); + struct haiku_font_pattern *found = BFont_find (&ptn); + haikufont_done_with_query_pattern (&ptn); + if (found) + { + for (struct haiku_font_pattern *pt = found; + pt; pt = pt->next) + lst = Fcons (haikufont_pattern_to_entity (pt), lst); + haiku_font_pattern_free (found); + } + unblock_input (); + return lst; +} + +static void +haiku_bulk_encode (struct haikufont_info *font_info, int block) +{ + unsigned short *unichars = xmalloc (0x101 * sizeof (*unichars)); + unsigned int i, idx; + + block_input (); + + font_info->glyphs[block] = unichars; + if (!unichars) + emacs_abort (); + + for (idx = block << 8, i = 0; i < 0x100; idx++, i++) + unichars[i] = idx; + unichars[0x100] = 0; + + + /* If the font contains the entire block, just store it. */ + if (!BFont_have_char_block (font_info->be_font, + unichars[0], unichars[0xff])) + { + for (int i = 0; i < 0x100; ++i) + if (!BFont_have_char_p (font_info->be_font, unichars[i])) + unichars[i] = 0xFFFF; + } + + unblock_input (); +} + +static unsigned int +haikufont_encode_char (struct font *font, int c) +{ + struct haikufont_info *font_info = (struct haikufont_info *) font; + unsigned char high = (c & 0xff00) >> 8, low = c & 0x00ff; + unsigned short g; + + if (c > 0xFFFF) + return FONT_INVALID_CODE; + + if (!font_info->glyphs[high]) + haiku_bulk_encode (font_info, high); + g = font_info->glyphs[high][low]; + return g == 0xFFFF ? FONT_INVALID_CODE : g; +} + +static Lisp_Object +haikufont_open (struct frame *f, Lisp_Object font_entity, int x) +{ + struct haikufont_info *font_info; + struct haiku_font_pattern ptn; + struct font *font; + void *be_font; + Lisp_Object font_object; + Lisp_Object tem; + + block_input (); + if (x <= 0) + { + /* Get pixel size from frame instead. */ + tem = get_frame_param (f, Qfontsize); + x = NILP (tem) ? 0 : XFIXNAT (tem); + } + + haikufont_spec_or_entity_to_pattern (font_entity, 1, &ptn); + + if (BFont_open_pattern (&ptn, &be_font, x)) + { + haikufont_done_with_query_pattern (&ptn); + unblock_input (); + return Qnil; + } + + haikufont_done_with_query_pattern (&ptn); + + font_object = font_make_object (VECSIZE (struct haikufont_info), + font_entity, x); + + ASET (font_object, FONT_TYPE_INDEX, Qhaiku); + font_info = (struct haikufont_info *) XFONT_OBJECT (font_object); + font = (struct font *) font_info; + + if (!font) + { + unblock_input (); + return Qnil; + } + + font_info->be_font = be_font; + font_info->glyphs = xzalloc (0x100 * sizeof *font_info->glyphs); + + font->pixel_size = 0; + font->driver = &haikufont_driver; + font->encoding_charset = -1; + font->repertory_charset = -1; + font->default_ascent = 0; + font->vertical_centering = 0; + font->baseline_offset = 0; + font->relative_compose = 0; + + font_info->metrics = NULL; + font_info->metrics_nrows = 0; + + int px_size, min_width, max_width, + avg_width, height, space_width, ascent, + descent, underline_pos, underline_thickness; + + BFont_dat (be_font, &px_size, &min_width, + &max_width, &avg_width, &height, + &space_width, &ascent, &descent, + &underline_pos, &underline_thickness); + + font->pixel_size = px_size; + font->min_width = min_width; + font->max_width = max_width; + font->average_width = avg_width; + font->height = height; + font->space_width = space_width; + font->ascent = ascent; + font->descent = descent; + font->default_ascent = ascent; + font->underline_position = underline_pos; + font->underline_thickness = underline_thickness; + + font->vertical_centering = 0; + font->baseline_offset = 0; + font->relative_compose = 0; + + font->props[FONT_NAME_INDEX] = Ffont_xlfd_name (font_object, Qnil); + + unblock_input (); + return font_object; +} + +static void +haikufont_close (struct font *font) +{ + if (font_data_structures_may_be_ill_formed ()) + return; + struct haikufont_info *info = (struct haikufont_info *) font; + + block_input (); + if (info && info->be_font) + BFont_close (info->be_font); + + for (int i = 0; i < info->metrics_nrows; i++) + if (info->metrics[i]) + xfree (info->metrics[i]); + if (info->metrics) + xfree (info->metrics); + for (int i = 0; i < 0x100; ++i) + if (info->glyphs[i]) + xfree (info->glyphs[i]); + xfree (info->glyphs); + unblock_input (); +} + +static void +haikufont_prepare_face (struct frame *f, struct face *face) +{ + +} + +static void +haikufont_glyph_extents (struct font *font, unsigned code, + struct font_metrics *metrics) +{ + struct haikufont_info *info = (struct haikufont_info *) font; + + struct font_metrics *cache; + int row, col; + + row = code / METRICS_NCOLS_PER_ROW; + col = code % METRICS_NCOLS_PER_ROW; + if (row >= info->metrics_nrows) + { + info->metrics = + xrealloc (info->metrics, + sizeof (struct font_metrics *) * (row + 1)); + memset (info->metrics + info->metrics_nrows, 0, + (sizeof (struct font_metrics *) + * (row + 1 - info->metrics_nrows))); + info->metrics_nrows = row + 1; + } + + if (info->metrics[row] == NULL) + { + struct font_metrics *new; + int i; + + new = xmalloc (sizeof (struct font_metrics) * METRICS_NCOLS_PER_ROW); + for (i = 0; i < METRICS_NCOLS_PER_ROW; i++) + METRICS_SET_STATUS (new + i, METRICS_INVALID); + info->metrics[row] = new; + } + cache = info->metrics[row] + col; + + if (METRICS_STATUS (cache) == METRICS_INVALID) + { + unsigned char utf8[MAX_MULTIBYTE_LENGTH]; + memset (utf8, 0, MAX_MULTIBYTE_LENGTH); + CHAR_STRING (code, utf8); + int advance, lb, rb; + BFont_char_bounds (info->be_font, (const char *) utf8, &advance, &lb, &rb); + + cache->lbearing = lb; + cache->rbearing = rb; + cache->width = advance; + cache->ascent = font->ascent; + cache->descent = font->descent; + } + + if (metrics) + *metrics = *cache; +} + +static void +haikufont_text_extents (struct font *font, const unsigned int *code, + int nglyphs, struct font_metrics *metrics) +{ + int totalwidth = 0; + memset (metrics, 0, sizeof (struct font_metrics)); + + block_input (); + for (int i = 0; i < nglyphs; i++) + { + struct font_metrics m; + haikufont_glyph_extents (font, code[i], &m); + if (metrics) + { + if (totalwidth + m.lbearing < metrics->lbearing) + metrics->lbearing = totalwidth + m.lbearing; + if (totalwidth + m.rbearing > metrics->rbearing) + metrics->rbearing = totalwidth + m.rbearing; + if (m.ascent > metrics->ascent) + metrics->ascent = m.ascent; + if (m.descent > metrics->descent) + metrics->descent = m.descent; + } + totalwidth += m.width; + } + + unblock_input (); + + if (metrics) + metrics->width = totalwidth; +} + +static Lisp_Object +haikufont_shape (Lisp_Object lgstring, Lisp_Object direction) +{ + struct haikufont_info *font = + (struct haikufont_info *) CHECK_FONT_GET_OBJECT (LGSTRING_FONT (lgstring)); + int *advance, *lb, *rb; + ptrdiff_t glyph_len, len, i, b_len; + Lisp_Object tem; + char *b; + uint32_t *mb_buf; + + glyph_len = LGSTRING_GLYPH_LEN (lgstring); + for (i = 0; i < glyph_len; ++i) + { + tem = LGSTRING_GLYPH (lgstring, i); + + if (NILP (tem)) + break; + } + + len = i; + + if (INT_MAX / 2 < len) + memory_full (SIZE_MAX); + + block_input (); + + b_len = 0; + b = xmalloc (b_len); + mb_buf = alloca (len * sizeof *mb_buf); + + for (i = b_len; i < len; ++i) + { + uint32_t c = LGLYPH_CHAR (LGSTRING_GLYPH (lgstring, i)); + mb_buf[i] = c; + unsigned char mb[MAX_MULTIBYTE_LENGTH]; + int slen = CHAR_STRING (c, mb); + + b = xrealloc (b, b_len = (b_len + slen)); + if (len == 1) + b[b_len - slen] = mb[0]; + else + memcpy (b + b_len - slen, mb, slen); + } + + advance = alloca (len * sizeof *advance); + lb = alloca (len * sizeof *lb); + rb = alloca (len * sizeof *rb); + + eassert (font->be_font); + BFont_nchar_bounds (font->be_font, b, advance, lb, rb, len); + xfree (b); + + for (i = 0; i < len; ++i) + { + tem = LGSTRING_GLYPH (lgstring, i); + if (NILP (tem)) + { + tem = LGLYPH_NEW (); + LGSTRING_SET_GLYPH (lgstring, i, tem); + } + + LGLYPH_SET_FROM (tem, i); + LGLYPH_SET_TO (tem, i); + LGLYPH_SET_CHAR (tem, mb_buf[i]); + LGLYPH_SET_CODE (tem, mb_buf[i]); + + LGLYPH_SET_WIDTH (tem, advance[i]); + LGLYPH_SET_LBEARING (tem, lb[i]); + LGLYPH_SET_RBEARING (tem, rb[i]); + LGLYPH_SET_ASCENT (tem, font->font.ascent); + LGLYPH_SET_DESCENT (tem, font->font.descent); + } + + unblock_input (); + + return make_fixnum (len); +} + +static int +haikufont_draw (struct glyph_string *s, int from, int to, + int x, int y, bool with_background) +{ + struct frame *f = s->f; + struct face *face = s->face; + struct font_info *info = (struct font_info *) s->font; + unsigned char mb[MAX_MULTIBYTE_LENGTH]; + void *view = FRAME_HAIKU_VIEW (f); + + block_input (); + prepare_face_for_display (s->f, face); + + BView_draw_lock (view); + BView_StartClip (view); + if (with_background) + { + int height = FONT_HEIGHT (s->font), ascent = FONT_BASE (s->font); + + /* Font's global height and ascent values might be + preposterously large for some fonts. We fix here the case + when those fonts are used for display of glyphless + characters, because drawing background with font dimensions + in those cases makes the display illegible. There's only one + more call to the draw method with with_background set to + true, and that's in x_draw_glyph_string_foreground, when + drawing the cursor, where we have no such heuristics + available. FIXME. */ + if (s->first_glyph->type == GLYPHLESS_GLYPH + && (s->first_glyph->u.glyphless.method == GLYPHLESS_DISPLAY_HEX_CODE + || s->first_glyph->u.glyphless.method == GLYPHLESS_DISPLAY_ACRONYM)) + height = ascent = + s->first_glyph->slice.glyphless.lower_yoff + - s->first_glyph->slice.glyphless.upper_yoff; + + BView_SetHighColor (view, s->hl == DRAW_CURSOR ? + FRAME_CURSOR_COLOR (s->f).pixel : face->background); + + BView_FillRectangle (view, x, y - ascent, s->width, height); + s->background_filled_p = 1; + } + + if (s->left_overhang && s->clip_head && !s->for_overlaps) + { + /* XXX: Why is this neccessary? */ + BView_ClipToRect (view, s->clip_head->x, 0, + FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f)); + } + + if (s->hl == DRAW_CURSOR) + BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg); + else + BView_SetHighColor (view, face->foreground); + + BView_MovePenTo (view, x, y); + BView_SetFont (view, ((struct haikufont_info *) info)->be_font); + + if (from == to) + { + int len = CHAR_STRING (s->char2b[from], mb); + BView_DrawString (view, (char *) mb, len); + } + else + { + ptrdiff_t b_len = 0; + char *b = xmalloc (b_len); + + for (int idx = from; idx < to; ++idx) + { + int len = CHAR_STRING (s->char2b[idx], mb); + b = xrealloc (b, b_len = (b_len + len)); + if (len == 1) + b[b_len - len] = mb[0]; + else + memcpy (b + b_len - len, mb, len); + } + + BView_DrawString (view, b, b_len); + xfree (b); + } + BView_EndClip (view); + BView_draw_unlock (view); + unblock_input (); + return 1; +} + +struct font_driver const haikufont_driver = + { + .type = LISPSYM_INITIALLY (Qhaiku), + .case_sensitive = true, + .get_cache = haikufont_get_cache, + .list = haikufont_list, + .match = haikufont_match, + .draw = haikufont_draw, + .open_font = haikufont_open, + .close_font = haikufont_close, + .prepare_face = haikufont_prepare_face, + .encode_char = haikufont_encode_char, + .text_extents = haikufont_text_extents, + .shape = haikufont_shape + }; + +void +syms_of_haikufont (void) +{ + DEFSYM (Qfontsize, "fontsize"); + DEFSYM (Qfixed, "fixed"); + DEFSYM (Qplain, "plain"); + DEFSYM (Qultra_light, "ultra-light"); + DEFSYM (Qthin, "thin"); + DEFSYM (Qreverse_italic, "reverse-italic"); + DEFSYM (Qreverse_oblique, "reverse-oblique"); + DEFSYM (Qmonospace, "monospace"); + DEFSYM (Qultra_condensed, "ultra-condensed"); + DEFSYM (Qextra_condensed, "extra-condensed"); + DEFSYM (Qcondensed, "condensed"); + DEFSYM (Qsemi_condensed, "semi-condensed"); + DEFSYM (Qsemi_expanded, "semi-expanded"); + DEFSYM (Qexpanded, "expanded"); + DEFSYM (Qextra_expanded, "extra-expanded"); + DEFSYM (Qultra_expanded, "ultra-expanded"); + DEFSYM (Qzh, "zh"); + DEFSYM (Qko, "ko"); + DEFSYM (Qjp, "jp"); + + font_cache = list (Qnil); + staticpro (&font_cache); +} diff --git a/src/haikugui.h b/src/haikugui.h new file mode 100644 index 0000000000..cfc693fb55 --- /dev/null +++ b/src/haikugui.h @@ -0,0 +1,106 @@ +/* Haiku window system support + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#ifndef _HAIKU_GUI_H_ +#define _HAIKU_GUI_H_ + +#ifdef _cplusplus +extern "C" +{ +#endif + +typedef struct haiku_char_struct +{ + int rbearing; + int lbearing; + int width; + int ascent; + int descent; +} XCharStruct; + +struct haiku_rect +{ + int x, y; + int width, height; +}; + +typedef void *haiku; + +typedef haiku Emacs_Pixmap; +typedef haiku Emacs_Window; +typedef haiku Emacs_Cursor; +typedef haiku Drawable; + +#define NativeRectangle struct haiku_rect +#define CONVERT_TO_EMACS_RECT(xr, nr) \ + ((xr).x = (nr).x, \ + (xr).y = (nr).y, \ + (xr).width = (nr).width, \ + (xr).height = (nr).height) + +#define CONVERT_FROM_EMACS_RECT(xr, nr) \ + ((nr).x = (xr).x, \ + (nr).y = (xr).y, \ + (nr).width = (xr).width, \ + (nr).height = (xr).height) + +#define STORE_NATIVE_RECT(nr, px, py, pwidth, pheight) \ + ((nr).x = (px), \ + (nr).y = (py), \ + (nr).width = (pwidth), \ + (nr).height = (pheight)) + +#define ForgetGravity 0 +#define NorthWestGravity 1 +#define NorthGravity 2 +#define NorthEastGravity 3 +#define WestGravity 4 +#define CenterGravity 5 +#define EastGravity 6 +#define SouthWestGravity 7 +#define SouthGravity 8 +#define SouthEastGravity 9 +#define StaticGravity 10 + +#define NoValue 0x0000 +#define XValue 0x0001 +#define YValue 0x0002 +#define WidthValue 0x0004 +#define HeightValue 0x0008 +#define AllValues 0x000F +#define XNegative 0x0010 +#define YNegative 0x0020 + +#define USPosition (1L << 0) /* user specified x, y */ +#define USSize (1L << 1) /* user specified width, height */ +#define PPosition (1L << 2) /* program specified position */ +#define PSize (1L << 3) /* program specified size */ +#define PMinSize (1L << 4) /* program specified minimum size */ +#define PMaxSize (1L << 5) /* program specified maximum size */ +#define PResizeInc (1L << 6) /* program specified resize increments */ +#define PAspect (1L << 7) /* program specified min, max aspect ratios */ +#define PBaseSize (1L << 8) /* program specified base for incrementing */ +#define PWinGravity (1L << 9) /* program specified window gravity */ + +typedef haiku Window; +typedef int Display; + +#ifdef _cplusplus +}; +#endif +#endif /* _HAIKU_GUI_H_ */ diff --git a/src/haikuimage.c b/src/haikuimage.c new file mode 100644 index 0000000000..138e5b84e6 --- /dev/null +++ b/src/haikuimage.c @@ -0,0 +1,109 @@ +/* Haiku window system support. + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include "lisp.h" +#include "dispextern.h" +#include "haikuterm.h" +#include "coding.h" + +#include "haiku_support.h" + +bool +haiku_can_use_native_image_api (Lisp_Object type) +{ + const char *mime_type = NULL; + + if (EQ (type, Qnative_image)) + return 1; + +#ifdef HAVE_RSVG + if (EQ (type, Qsvg)) + return 0; +#endif + + if (EQ (type, Qjpeg)) + mime_type = "image/jpeg"; + else if (EQ (type, Qpng)) + mime_type = "image/png"; + else if (EQ (type, Qgif)) + mime_type = "image/gif"; + else if (EQ (type, Qtiff)) + mime_type = "image/tiff"; + else if (EQ (type, Qbmp)) + mime_type = "image/bmp"; + else if (EQ (type, Qsvg)) + mime_type = "image/svg"; + else if (EQ (type, Qpbm)) + mime_type = "image/pbm"; + + if (!mime_type) + return 0; + + return be_can_translate_type_to_bitmap_p (mime_type); +} + +extern int +haiku_load_image (struct frame *f, struct image *img, + Lisp_Object spec_file, Lisp_Object spec_data) +{ + eassert (valid_image_p (img->spec)); + + void *pixmap = NULL; + + if (STRINGP (spec_file)) + { + pixmap = be_translate_bitmap_from_file_name + (SSDATA (ENCODE_UTF_8 (spec_file))); + } + else if (STRINGP (spec_data)) + { + pixmap = be_translate_bitmap_from_memory + (SSDATA (spec_data), SBYTES (spec_data)); + } + + void *conv = NULL; + + if (!pixmap || !BBitmap_convert (pixmap, &conv)) + { + add_to_log ("Unable to load image %s", img->spec); + return 0; + } + + if (conv) + { + BBitmap_free (pixmap); + pixmap = conv; + } + + int left, top, right, bottom, stride, mono_p; + BBitmap_dimensions (pixmap, &left, &top, &right, &bottom, &stride, &mono_p); + + img->width = (1 + right - left); + img->height = (1 + bottom - top); + img->pixmap = pixmap; + + return 1; +} + +void +syms_of_haikuimage (void) +{ + DEFSYM (Qbmp, "bmp"); +} diff --git a/src/haikumenu.c b/src/haikumenu.c new file mode 100644 index 0000000000..698da9d639 --- /dev/null +++ b/src/haikumenu.c @@ -0,0 +1,656 @@ +/* Haiku window system support + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include "lisp.h" +#include "frame.h" +#include "keyboard.h" +#include "menu.h" +#include "buffer.h" +#include "blockinput.h" + +#include "haikuterm.h" +#include "haiku_support.h" + +static Lisp_Object *volatile menu_item_selection; + +int popup_activated_p = 0; + +struct submenu_stack_cell +{ + void *parent_menu; + void *pane; +}; + +static void +digest_menu_items (void *first_menu, int start, int menu_items_used, + int mbar_p) +{ + void **menus, **panes; + ssize_t menu_len = (menu_items_used + 1 - start) * sizeof *menus; + ssize_t pane_len = (menu_items_used + 1 - start) * sizeof *panes; + + menus = alloca (menu_len); + panes = alloca (pane_len); + + int i = start, menu_depth = 0; + + memset (menus, 0, menu_len); + memset (panes, 0, pane_len); + + void *menu = first_menu; + + menus[0] = first_menu; + + void *window = NULL; + if (FRAMEP (Vmenu_updating_frame) && + FRAME_LIVE_P (XFRAME (Vmenu_updating_frame)) && + FRAME_HAIKU_P (XFRAME (Vmenu_updating_frame))) + window = FRAME_HAIKU_WINDOW (XFRAME (Vmenu_updating_frame)); + + while (i < menu_items_used) + { + if (NILP (AREF (menu_items, i))) + { + menus[++menu_depth] = menu; + i++; + } + else if (EQ (AREF (menu_items, i), Qlambda)) + { + panes[menu_depth] = NULL; + menu = panes[--menu_depth] ? panes[menu_depth] : menus[menu_depth]; + i++; + } + else if (EQ (AREF (menu_items, i), Qquote)) + i += 1; + else if (EQ (AREF (menu_items, i), Qt)) + { + Lisp_Object pane_name, prefix; + const char *pane_string; + + if (menu_items_n_panes == 1) + { + i += MENU_ITEMS_PANE_LENGTH; + continue; + } + + pane_name = AREF (menu_items, i + MENU_ITEMS_PANE_NAME); + prefix = AREF (menu_items, i + MENU_ITEMS_PANE_PREFIX); + + if (STRINGP (pane_name) && STRING_MULTIBYTE (pane_name)) + { + pane_name = ENCODE_UTF_8 (pane_name); + ASET (menu_items, i + MENU_ITEMS_PANE_NAME, pane_name); + } + + pane_string = (NILP (pane_name) + ? "" : SSDATA (pane_name)); + if (!NILP (prefix)) + pane_string++; + + if (strcmp (pane_string, "")) + { + panes[menu_depth] = + menu = BMenu_new_submenu (menus[menu_depth], pane_string, 1); + } + + i += MENU_ITEMS_PANE_LENGTH; + } + else + { + Lisp_Object item_name, enable, descrip, def, selected, help; + item_name = AREF (menu_items, i + MENU_ITEMS_ITEM_NAME); + enable = AREF (menu_items, i + MENU_ITEMS_ITEM_ENABLE); + descrip = AREF (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY); + def = AREF (menu_items, i + MENU_ITEMS_ITEM_DEFINITION); + selected = AREF (menu_items, i + MENU_ITEMS_ITEM_SELECTED); + help = AREF (menu_items, i + MENU_ITEMS_ITEM_HELP); + + if (STRINGP (item_name) && STRING_MULTIBYTE (item_name)) + { + item_name = ENCODE_UTF_8 (item_name); + ASET (menu_items, i + MENU_ITEMS_ITEM_NAME, item_name); + } + + if (STRINGP (descrip) && STRING_MULTIBYTE (descrip)) + { + descrip = ENCODE_UTF_8 (descrip); + ASET (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY, descrip); + } + + if (STRINGP (help) && STRING_MULTIBYTE (help)) + { + help = ENCODE_UTF_8 (help); + ASET (menu_items, i + MENU_ITEMS_ITEM_HELP, help); + } + + if (i + MENU_ITEMS_ITEM_LENGTH < menu_items_used && + NILP (AREF (menu_items, i + MENU_ITEMS_ITEM_LENGTH))) + menu = BMenu_new_submenu (menu, SSDATA (item_name), !NILP (enable)); + else if (NILP (def) && menu_separator_name_p (SSDATA (item_name))) + BMenu_add_separator (menu); + else if (!mbar_p) + BMenu_add_item (menu, SSDATA (item_name), + !NILP (def) ? aref_addr (menu_items, i) : NULL, + !NILP (enable), !NILP (selected), 0, window, + !NILP (descrip) ? SSDATA (descrip) : NULL, + STRINGP (help) ? SSDATA (help) : NULL); + else + BMenu_add_item (menu, SSDATA (item_name), + !NILP (def) ? (void *) (intptr_t) i : NULL, + !NILP (enable), !NILP (selected), 1, window, + !NILP (descrip) ? SSDATA (descrip) : NULL, + STRINGP (help) ? SSDATA (help) : NULL); + + i += MENU_ITEMS_ITEM_LENGTH; + } + } +} + +static Lisp_Object +haiku_dialog_show (struct frame *f, Lisp_Object title, + Lisp_Object header, const char **error_name) +{ + int i, nb_buttons = 0; + + *error_name = NULL; + + if (menu_items_n_panes > 1) + { + *error_name = "Multiple panes in dialog box"; + return Qnil; + } + + Lisp_Object pane_name = AREF (menu_items, MENU_ITEMS_PANE_NAME); + i = MENU_ITEMS_PANE_LENGTH; + + if (STRING_MULTIBYTE (pane_name)) + pane_name = ENCODE_UTF_8 (pane_name); + + block_input (); + void *alert = BAlert_new (SSDATA (pane_name), NILP (header) ? HAIKU_INFO_ALERT : + HAIKU_IDEA_ALERT); + + Lisp_Object vals[10]; + + while (i < menu_items_used) + { + Lisp_Object item_name, enable, descrip, value; + item_name = AREF (menu_items, i + MENU_ITEMS_ITEM_NAME); + enable = AREF (menu_items, i + MENU_ITEMS_ITEM_ENABLE); + descrip = AREF (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY); + value = AREF (menu_items, i + MENU_ITEMS_ITEM_VALUE); + + if (NILP (item_name)) + { + BAlert_delete (alert); + *error_name = "Submenu in dialog items"; + unblock_input (); + return Qnil; + } + + if (EQ (item_name, Qquote)) + { + i++; + } + + if (nb_buttons >= 9) + { + BAlert_delete (alert); + *error_name = "Too many dialog items"; + unblock_input (); + return Qnil; + } + + if (STRING_MULTIBYTE (item_name)) + item_name = ENCODE_UTF_8 (item_name); + if (!NILP (descrip) && STRING_MULTIBYTE (descrip)) + descrip = ENCODE_UTF_8 (descrip); + + void *button = BAlert_add_button (alert, SSDATA (item_name)); + + BButton_set_enabled (button, !NILP (enable)); + if (!NILP (descrip)) + BView_set_tooltip (button, SSDATA (descrip)); + + vals[nb_buttons] = value; + ++nb_buttons; + i += MENU_ITEMS_ITEM_LENGTH; + } + + int32_t val = BAlert_go (alert); + unblock_input (); + + if (val < 0) + quit (); + else + return vals[val]; + + return Qnil; +} + +Lisp_Object +haiku_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) +{ + Lisp_Object title; + const char *error_name = NULL; + Lisp_Object selection; + ptrdiff_t specpdl_count = SPECPDL_INDEX (); + + check_window_system (f); + + /* Decode the dialog items from what was specified. */ + title = Fcar (contents); + CHECK_STRING (title); + record_unwind_protect_void (unuse_menu_items); + + if (NILP (Fcar (Fcdr (contents)))) + /* No buttons specified, add an "Ok" button so users can pop down + the dialog. Also, the lesstif/motif version crashes if there are + no buttons. */ + contents = list2 (title, Fcons (build_string ("Ok"), Qt)); + + list_of_panes (list1 (contents)); + + /* Display them in a dialog box. */ + block_input (); + selection = haiku_dialog_show (f, title, header, &error_name); + unblock_input (); + + unbind_to (specpdl_count, Qnil); + discard_menu_items (); + + if (error_name) + error ("%s", error_name); + return selection; +} + +Lisp_Object +haiku_menu_show (struct frame *f, int x, int y, int menuflags, + Lisp_Object title, const char **error_name) +{ + int i = 0, submenu_depth = 0; + void *view = FRAME_HAIKU_VIEW (f); + void *menu; + + Lisp_Object *subprefix_stack = + alloca (menu_items_used * sizeof (Lisp_Object)); + + eassert (FRAME_HAIKU_P (f)); + + *error_name = NULL; + + if (menu_items_used <= MENU_ITEMS_PANE_LENGTH) + { + *error_name = "Empty menu"; + return Qnil; + } + + block_input (); + if (STRINGP (title) && STRING_MULTIBYTE (title)) + title = ENCODE_UTF_8 (title); + + menu = BPopUpMenu_new (STRINGP (title) ? SSDATA (title) : NULL); + if (STRINGP (title)) + { + BMenu_add_title (menu, SSDATA (title)); + BMenu_add_separator (menu); + } + digest_menu_items (menu, 0, menu_items_used, 0); + BView_convert_to_screen (view, &x, &y); + unblock_input (); + + menu_item_selection = BMenu_run (menu, x, y); + + FRAME_DISPLAY_INFO (f)->grabbed = 0; + + if (menu_item_selection) + { + Lisp_Object prefix, entry; + + prefix = entry = Qnil; + i = 0; + while (i < menu_items_used) + { + if (NILP (AREF (menu_items, i))) + { + subprefix_stack[submenu_depth++] = prefix; + prefix = entry; + i++; + } + else if (EQ (AREF (menu_items, i), Qlambda)) + { + prefix = subprefix_stack[--submenu_depth]; + i++; + } + else if (EQ (AREF (menu_items, i), Qt)) + { + prefix + = AREF (menu_items, i + MENU_ITEMS_PANE_PREFIX); + i += MENU_ITEMS_PANE_LENGTH; + } + /* Ignore a nil in the item list. + It's meaningful only for dialog boxes. */ + else if (EQ (AREF (menu_items, i), Qquote)) + i += 1; + else + { + entry + = AREF (menu_items, i + MENU_ITEMS_ITEM_VALUE); + if (menu_item_selection == aref_addr (menu_items, i)) + { + if (menuflags & MENU_KEYMAPS) + { + int j; + + entry = list1 (entry); + if (!NILP (prefix)) + entry = Fcons (prefix, entry); + for (j = submenu_depth - 1; j >= 0; j--) + if (!NILP (subprefix_stack[j])) + entry = Fcons (subprefix_stack[j], entry); + } + BPopUpMenu_delete (menu); + return entry; + } + i += MENU_ITEMS_ITEM_LENGTH; + } + } + } + else if (!(menuflags & MENU_FOR_CLICK)) + { + BPopUpMenu_delete (menu); + quit (); + } + BPopUpMenu_delete (menu); + return Qnil; +} + +void +free_frame_menubar (struct frame *f) +{ + FRAME_MENU_BAR_LINES (f) = 0; + FRAME_MENU_BAR_HEIGHT (f) = 0; + FRAME_EXTERNAL_MENU_BAR (f) = 0; + + block_input (); + void *mbar = FRAME_HAIKU_MENU_BAR (f); + if (mbar) + BMenuBar_delete (mbar); + if (FRAME_OUTPUT_DATA (f)->menu_bar_open_p) + --popup_activated_p; + FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 0; + unblock_input (); + + adjust_frame_size (f, -1, -1, 2, false, Qmenu_bar_lines); +} + +void +initialize_frame_menubar (struct frame *f) +{ + /* This function is called before the first chance to redisplay + the frame. It has to be, so the frame will have the right size. */ + fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f))); + set_frame_menubar (f, true); +} + +void +set_frame_menubar (struct frame *f, bool deep_p) +{ + void *mbar = FRAME_HAIKU_MENU_BAR (f); + void *view = FRAME_HAIKU_VIEW (f); + + int first_time_p = 0; + + if (!mbar) + { + mbar = FRAME_HAIKU_MENU_BAR (f) = BMenuBar_new (view); + first_time_p = 1; + } + + Lisp_Object items; + struct buffer *prev = current_buffer; + Lisp_Object buffer; + ptrdiff_t specpdl_count = SPECPDL_INDEX (); + int previous_menu_items_used = f->menu_bar_items_used; + Lisp_Object *previous_items + = alloca (previous_menu_items_used * sizeof *previous_items); + + XSETFRAME (Vmenu_updating_frame, f); + + if (!deep_p) + { + FRAME_OUTPUT_DATA (f)->menu_up_to_date_p = 0; + items = FRAME_MENU_BAR_ITEMS (f); + Lisp_Object string; + + block_input (); + int count = BMenu_count_items (mbar); + + int i; + for (i = 0; i < ASIZE (items); i += 4) + { + string = AREF (items, i + 1); + + if (!STRINGP (string)) + break; + + if (STRING_MULTIBYTE (string)) + string = ENCODE_UTF_8 (string); + + if (i / 4 < count) + { + void *it = BMenu_item_at (mbar, i / 4); + BMenu_item_set_label (it, SSDATA (string)); + } + else + BMenu_new_menu_bar_submenu (mbar, SSDATA (string)); + } + + if (i / 4 < count) + BMenu_delete_from (mbar, i / 4, count - i / 4 + 1); + unblock_input (); + + f->menu_bar_items_used = 0; + } + else + { + /* If we are making a new widget, its contents are empty, + do always reinitialize them. */ + if (first_time_p) + previous_menu_items_used = 0; + buffer = XWINDOW (FRAME_SELECTED_WINDOW (f))->contents; + specbind (Qinhibit_quit, Qt); + /* Don't let the debugger step into this code + because it is not reentrant. */ + specbind (Qdebug_on_next_call, Qnil); + + record_unwind_save_match_data (); + if (NILP (Voverriding_local_map_menu_flag)) + { + specbind (Qoverriding_terminal_local_map, Qnil); + specbind (Qoverriding_local_map, Qnil); + } + + set_buffer_internal_1 (XBUFFER (buffer)); + + /* Run the Lucid hook. */ + safe_run_hooks (Qactivate_menubar_hook); + + /* If it has changed current-menubar from previous value, + really recompute the menubar from the value. */ + if (! NILP (Vlucid_menu_bar_dirty_flag)) + call0 (Qrecompute_lucid_menubar); + safe_run_hooks (Qmenu_bar_update_hook); + fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f))); + + items = FRAME_MENU_BAR_ITEMS (f); + + /* Save the frame's previous menu bar contents data. */ + if (previous_menu_items_used) + memcpy (previous_items, xvector_contents (f->menu_bar_vector), + previous_menu_items_used * word_size); + + /* Fill in menu_items with the current menu bar contents. + This can evaluate Lisp code. */ + save_menu_items (); + menu_items = f->menu_bar_vector; + menu_items_allocated = VECTORP (menu_items) ? ASIZE (menu_items) : 0; + init_menu_items (); + int i; + int count = BMenu_count_items (mbar); + int subitems = ASIZE (items) / 4; + + int *submenu_start, *submenu_end, *submenu_n_panes; + Lisp_Object *submenu_names; + + submenu_start = alloca ((subitems + 1) * sizeof *submenu_start); + submenu_end = alloca (subitems * sizeof *submenu_end); + submenu_n_panes = alloca (subitems * sizeof *submenu_n_panes); + submenu_names = alloca (subitems * sizeof (Lisp_Object)); + + for (i = 0; i < subitems; ++i) + { + Lisp_Object key, string, maps; + + key = AREF (items, i * 4); + string = AREF (items, i * 4 + 1); + maps = AREF (items, i * 4 + 2); + + if (NILP (string)) + break; + + if (STRINGP (string) && STRING_MULTIBYTE (string)) + string = ENCODE_UTF_8 (string); + + submenu_start[i] = menu_items_used; + menu_items_n_panes = 0; + parse_single_submenu (key, string, maps); + submenu_n_panes[i] = menu_items_n_panes; + submenu_end[i] = menu_items_used; + submenu_names[i] = string; + } + finish_menu_items (); + submenu_start[i] = -1; + + block_input (); + for (i = 0; submenu_start[i] >= 0; ++i) + { + void *mn = NULL; + if (i < count) + mn = BMenu_item_get_menu (BMenu_item_at (mbar, i)); + if (mn) + BMenu_delete_all (mn); + else + mn = BMenu_new_menu_bar_submenu (mbar, SSDATA (submenu_names[i])); + + menu_items_n_panes = submenu_n_panes[i]; + digest_menu_items (mn, submenu_start[i], submenu_end[i], 1); + } + unblock_input (); + + set_buffer_internal_1 (prev); + + FRAME_OUTPUT_DATA (f)->menu_up_to_date_p = 1; + fset_menu_bar_vector (f, menu_items); + f->menu_bar_items_used = menu_items_used; + } + unbind_to (specpdl_count, Qnil); +} + +void +run_menu_bar_help_event (struct frame *f, int mb_idx) +{ + Lisp_Object frame; + Lisp_Object vec; + Lisp_Object help; + + block_input (); + if (!FRAME_OUTPUT_DATA (f)->menu_up_to_date_p) + { + unblock_input (); + return; + } + + XSETFRAME (frame, f); + + if (mb_idx < 0) + { + kbd_buffer_store_help_event (frame, Qnil); + unblock_input (); + return; + } + + vec = f->menu_bar_vector; + if (mb_idx >= ASIZE (vec)) + emacs_abort (); + + help = AREF (vec, mb_idx + MENU_ITEMS_ITEM_HELP); + if (STRINGP (help) || NILP (help)) + kbd_buffer_store_help_event (frame, help); + unblock_input (); +} + +DEFUN ("menu-or-popup-active-p", Fmenu_or_popup_active_p, Smenu_or_popup_active_p, + 0, 0, 0, doc: /* SKIP: real doc in xmenu.c. */) + (void) +{ + return popup_activated_p ? Qt : Qnil; +} + +DEFUN ("haiku-menu-bar-open", Fhaiku_menu_bar_open, Shaiku_menu_bar_open, 0, 1, "i", + doc: /* Show the menu bar in FRAME. + +Move the mouse pointer onto the first element of FRAME's menu bar, and +cause it to be opened. If FRAME is nil or not given, use the selected +frame. If FRAME has no menu bar, a pop-up is displayed at the position +of the last non-menu event instead. */) + (Lisp_Object frame) +{ + struct frame *f = decode_window_system_frame (frame); + + if (FRAME_EXTERNAL_MENU_BAR (f)) + { + if (!FRAME_OUTPUT_DATA (f)->menu_up_to_date_p) + set_frame_menubar (f, 1); + } + else + { + return call2 (Qpopup_menu, call0 (Qmouse_menu_bar_map), + last_nonmenu_event); + } + + block_input (); + BMenuBar_start_tracking (FRAME_HAIKU_MENU_BAR (f)); + unblock_input (); + + return Qnil; +} + +void +syms_of_haikumenu (void) +{ + DEFSYM (Qdebug_on_next_call, "debug-on-next-call"); + DEFSYM (Qpopup_menu, "popup-menu"); + DEFSYM (Qmouse_menu_bar_map, "mouse-menu-bar-map"); + + defsubr (&Smenu_or_popup_active_p); + defsubr (&Shaiku_menu_bar_open); + return; +} diff --git a/src/haikuselect.c b/src/haikuselect.c new file mode 100644 index 0000000000..3f0441e077 --- /dev/null +++ b/src/haikuselect.c @@ -0,0 +1,134 @@ +/* Haiku window system selection support. + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include "lisp.h" +#include "blockinput.h" +#include "coding.h" +#include "haikuselect.h" +#include "haikuterm.h" + +DEFUN ("haiku-selection-data", Fhaiku_selection_data, Shaiku_selection_data, + 2, 2, 0, + doc: /* Retrieve content typed as NAME from the clipboard +CLIPBOARD. CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or +`CLIPBOARD'. NAME is a MIME type denoting the type of the data to +fetch. */) + (Lisp_Object clipboard, Lisp_Object name) +{ + CHECK_SYMBOL (clipboard); + CHECK_STRING (name); + char *dat; + ssize_t len; + + block_input (); + if (EQ (clipboard, QPRIMARY)) + dat = BClipboard_find_primary_selection_data (SSDATA (name), &len); + else if (EQ (clipboard, QSECONDARY)) + dat = BClipboard_find_secondary_selection_data (SSDATA (name), &len); + else if (EQ (clipboard, QCLIPBOARD)) + dat = BClipboard_find_system_data (SSDATA (name), &len); + else + { + unblock_input (); + signal_error ("Bad clipboard", clipboard); + } + unblock_input (); + + if (!dat) + return Qnil; + + Lisp_Object str = make_unibyte_string (dat, len); + Lisp_Object lispy_type = Qnil; + + if (!strcmp (SSDATA (name), "text/utf-8") || + !strcmp (SSDATA (name), "text/plain")) + { + if (string_ascii_p (str)) + lispy_type = QSTRING; + else + lispy_type = QUTF8_STRING; + } + + if (!NILP (lispy_type)) + Fput_text_property (make_fixnum (0), make_fixnum (len), + Qforeign_selection, lispy_type, str); + + block_input (); + BClipboard_free_data (dat); + unblock_input (); + + return str; +} + +DEFUN ("haiku-selection-put", Fhaiku_selection_put, Shaiku_selection_put, + 3, 3, 0, + doc: /* Add or remove content from the clipboard CLIPBOARD. +CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'. NAME +is a MIME type denoting the type of the data to add. DATA is the +string that will be placed in the clipboard, or nil if the content is +to be removed. If NAME is the string `text/utf-8' or the string +`text/plain', encode it as UTF-8 before storing it into the +clipboard. */) + (Lisp_Object clipboard, Lisp_Object name, Lisp_Object data) +{ + CHECK_SYMBOL (clipboard); + CHECK_STRING (name); + if (!NILP (data)) + CHECK_STRING (data); + + block_input (); + /* It seems that Haiku applications counter-intuitively expect + UTF-8 data in both text/utf-8 and text/plain. */ + if (!NILP (data) && STRING_MULTIBYTE (data) && + (!strcmp (SSDATA (name), "text/utf-8") || + !strcmp (SSDATA (name), "text/plain"))) + data = ENCODE_UTF_8 (data); + + char *dat = !NILP (data) ? SSDATA (data) : NULL; + ptrdiff_t len = !NILP (data) ? SBYTES (data) : 0; + + if (EQ (clipboard, QPRIMARY)) + BClipboard_set_primary_selection_data (SSDATA (name), dat, len); + else if (EQ (clipboard, QSECONDARY)) + BClipboard_set_secondary_selection_data (SSDATA (name), dat, len); + else if (EQ (clipboard, QCLIPBOARD)) + BClipboard_set_system_data (SSDATA (name), dat, len); + else + { + unblock_input (); + signal_error ("Bad clipboard", clipboard); + } + unblock_input (); + + return Qnil; +} + +void +syms_of_haikuselect (void) +{ + DEFSYM (QSECONDARY, "SECONDARY"); + DEFSYM (QCLIPBOARD, "CLIPBOARD"); + DEFSYM (QSTRING, "STRING"); + DEFSYM (QUTF8_STRING, "UTF8_STRING"); + DEFSYM (Qforeign_selection, "foreign-selection"); + + defsubr (&Shaiku_selection_data); + defsubr (&Shaiku_selection_put); +} diff --git a/src/haikuselect.h b/src/haikuselect.h new file mode 100644 index 0000000000..542d550d64 --- /dev/null +++ b/src/haikuselect.h @@ -0,0 +1,64 @@ +/* Haiku window system selection support. Hey Emacs, this is -*- C++ -*- + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#ifndef _HAIKU_SELECT_H_ +#define _HAIKU_SELECT_H_ + +#ifdef __cplusplus +#include +#endif + +#ifdef __cplusplus +#include +extern "C" +{ + extern void init_haiku_select (void); +#endif + + /* Whether or not the selection was recently changed. */ + extern int selection_state_flag; + + /* Find a string with the MIME type TYPE in the system clipboard. */ + extern char * + BClipboard_find_system_data (const char *type, ssize_t *len); + + /* Ditto, but for the primary selection and not clipboard. */ + extern char * + BClipboard_find_primary_selection_data (const char *type, ssize_t *len); + + /* Ditto, this time for the secondary selection. */ + extern char * + BClipboard_find_secondary_selection_data (const char *type, ssize_t *len); + + extern void + BClipboard_set_system_data (const char *type, const char *data, ssize_t len); + + extern void + BClipboard_set_primary_selection_data (const char *type, const char *data, + ssize_t len); + + extern void + BClipboard_set_secondary_selection_data (const char *type, const char *data, + ssize_t len); + + /* Free the returned data. */ + extern void BClipboard_free_data (void *ptr); +#ifdef __cplusplus +}; +#endif +#endif /* _HAIKU_SELECT_H_ */ diff --git a/src/haikuterm.c b/src/haikuterm.c new file mode 100644 index 0000000000..05fbd1021b --- /dev/null +++ b/src/haikuterm.c @@ -0,0 +1,3608 @@ +/* Haiku window system support + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include "dispextern.h" +#include "frame.h" +#include "lisp.h" +#include "haikugui.h" +#include "keyboard.h" +#include "haikuterm.h" +#include "blockinput.h" +#include "termchar.h" +#include "termhooks.h" +#include "menu.h" +#include "buffer.h" +#include "haiku_support.h" +#include "thread.h" +#include "window.h" + +#include +#include + +#ifdef USE_BE_CAIRO +#include +#endif + +struct haiku_display_info *x_display_list = NULL; +extern frame_parm_handler haiku_frame_parm_handlers[]; + +static void **fringe_bmps; +static int fringe_bitmap_fillptr = 0; + +static Lisp_Object rdb; + +struct unhandled_event +{ + struct unhandled_event *next; + enum haiku_event_type type; + uint8_t buffer[200]; +}; + +char * +get_keysym_name (int keysym) +{ + static char value[16]; + sprintf (value, "%d", keysym); + return value; +} + +static struct frame * +haiku_window_to_frame (void *window) +{ + Lisp_Object tail, tem; + struct frame *f; + + FOR_EACH_FRAME (tail, tem) + { + f = XFRAME (tem); + if (!FRAME_HAIKU_P (f)) + continue; + + eassert (FRAME_DISPLAY_INFO (f) == x_display_list); + + if (FRAME_HAIKU_WINDOW (f) == window) + return f; + } + + return 0; +} + +static void +haiku_coords_from_parent (struct frame *f, int *x, int *y) +{ + struct frame *p = FRAME_PARENT_FRAME (f); + eassert (p); + + for (struct frame *parent = p; parent; + parent = FRAME_PARENT_FRAME (parent)) + { + *x -= parent->left_pos; + *y -= parent->top_pos; + } +} + +static void +haiku_delete_terminal (struct terminal *terminal) +{ + emacs_abort (); +} + +static const char * +get_string_resource (void *ignored, const char *name, const char *class) +{ + if (!name) + return NULL; + + Lisp_Object lval = assoc_no_quit (build_string (name), rdb); + + if (!NILP (lval)) + return SSDATA (XCDR (lval)); + + return NULL; +} + +static void +haiku_update_size_hints (struct frame *f) +{ + int base_width, base_height; + eassert (FRAME_HAIKU_P (f) && FRAME_HAIKU_WINDOW (f)); + + base_width = FRAME_TEXT_COLS_TO_PIXEL_WIDTH (f, 0); + base_height = FRAME_TEXT_LINES_TO_PIXEL_HEIGHT (f, 0); + + block_input (); + BWindow_set_size_alignment (FRAME_HAIKU_WINDOW (f), + frame_resize_pixelwise ? 1 : FRAME_COLUMN_WIDTH (f), + frame_resize_pixelwise ? 1 : FRAME_LINE_HEIGHT (f)); + BWindow_set_min_size (FRAME_HAIKU_WINDOW (f), base_width, + base_height + + FRAME_TOOL_BAR_HEIGHT (f) + + FRAME_MENU_BAR_HEIGHT (f)); + unblock_input (); +} + +static void +haiku_clip_to_string (struct glyph_string *s) +{ + struct haiku_rect r[2]; + int n = get_glyph_string_clip_rects (s, (struct haiku_rect *) &r, 2); + + if (n) + BView_ClipToRect (FRAME_HAIKU_VIEW (s->f), r[0].x, r[0].y, + r[0].width, r[0].height); + if (n > 1) + { + BView_ClipToRect (FRAME_HAIKU_VIEW (s->f), r[1].x, r[1].y, + r[1].width, r[1].height); + } + + s->num_clips = n; +} + +static void +haiku_clip_to_string_exactly (struct glyph_string *s, struct glyph_string *dst) +{ + BView_ClipToRect (FRAME_HAIKU_VIEW (s->f), s->x, s->y, + s->width, s->height); + dst->num_clips = 1; +} + +static void +haiku_flip_buffers (struct frame *f) +{ + void *view = FRAME_OUTPUT_DATA (f)->view; + block_input (); + + BView_draw_lock (view); + FRAME_DIRTY_P (f) = 0; + EmacsView_flip_and_blit (view); + BView_draw_unlock (view); + + unblock_input (); +} + +static void +haiku_frame_up_to_date (struct frame *f) +{ + block_input (); + FRAME_MOUSE_UPDATE (f); + if (FRAME_DIRTY_P (f) && !buffer_flipping_blocked_p ()) + haiku_flip_buffers (f); + unblock_input (); +} + +static void +haiku_buffer_flipping_unblocked_hook (struct frame *f) +{ + if (FRAME_DIRTY_P (f)) + haiku_flip_buffers (f); +} + +static void +haiku_clear_frame_area (struct frame *f, int x, int y, + int width, int height) +{ + void *vw = FRAME_HAIKU_VIEW (f); + block_input (); + BView_draw_lock (vw); + BView_StartClip (vw); + BView_ClipToRect (vw, x, y, width, height); + BView_SetHighColor (vw, FRAME_BACKGROUND_PIXEL (f)); + BView_FillRectangle (vw, x, y, width, height); + BView_EndClip (vw); + BView_draw_unlock (vw); + unblock_input (); +} + +static void +haiku_clear_frame (struct frame *f) +{ + void *view = FRAME_HAIKU_VIEW (f); + block_input (); + BView_draw_lock (view); + BView_StartClip (view); + BView_ClipToRect (view, 0, 0, FRAME_PIXEL_WIDTH (f), + FRAME_PIXEL_HEIGHT (f)); + BView_SetHighColor (view, FRAME_BACKGROUND_PIXEL (f)); + BView_FillRectangle (view, 0, 0, FRAME_PIXEL_WIDTH (f), + FRAME_PIXEL_HEIGHT (f)); + BView_EndClip (view); + BView_draw_unlock (view); + unblock_input (); +} + +/* Give frame F the font FONT-OBJECT as its default font. The return + value is FONT-OBJECT. FONTSET is an ID of the fontset for the + frame. If it is negative, generate a new fontset from + FONT-OBJECT. */ + +static Lisp_Object +haiku_new_font (struct frame *f, Lisp_Object font_object, int fontset) +{ + struct font *font = XFONT_OBJECT (font_object); + if (fontset < 0) + fontset = fontset_from_font (font_object); + + FRAME_FONTSET (f) = fontset; + if (FRAME_FONT (f) == font) + return font_object; + + FRAME_FONT (f) = font; + FRAME_BASELINE_OFFSET (f) = font->baseline_offset; + FRAME_COLUMN_WIDTH (f) = font->average_width; + + int ascent, descent; + get_font_ascent_descent (font, &ascent, &descent); + FRAME_LINE_HEIGHT (f) = ascent + descent; + FRAME_TAB_BAR_HEIGHT (f) = FRAME_TAB_BAR_LINES (f) * FRAME_LINE_HEIGHT (f); + + int unit = FRAME_COLUMN_WIDTH (f); + if (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) > 0) + FRAME_CONFIG_SCROLL_BAR_COLS (f) + = (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) + unit - 1) / unit; + else + FRAME_CONFIG_SCROLL_BAR_COLS (f) = (14 + unit - 1) / unit; + + if (FRAME_HAIKU_WINDOW (f)) + { + adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), + FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), + 3, false, Qfont); + + haiku_clear_under_internal_border (f); + } + return font_object; +} + +static int +haiku_valid_modifier_p (Lisp_Object sym) +{ + return EQ (sym, Qcommand) || EQ (sym, Qshift) + || EQ (sym, Qcontrol) || EQ (sym, Qoption); +} + +#define MODIFIER_OR(obj, def) (haiku_valid_modifier_p (obj) ? obj : def) + +static void +haiku_add_modifier (int modifier, int toput, Lisp_Object qtem, int *modifiers) +{ + if ((modifier & HAIKU_MODIFIER_ALT && EQ (qtem, Qcommand)) + || (modifier & HAIKU_MODIFIER_SHIFT && EQ (qtem, Qshift)) + || (modifier & HAIKU_MODIFIER_CTRL && EQ (qtem, Qcontrol)) + || (modifier & HAIKU_MODIFIER_SUPER && EQ (qtem, Qoption))) + *modifiers |= toput; +} + +static int +haiku_modifiers_to_emacs (int haiku_key) +{ + int modifiers = 0; + haiku_add_modifier (haiku_key, shift_modifier, + MODIFIER_OR (Vhaiku_shift_keysym, Qshift), &modifiers); + haiku_add_modifier (haiku_key, super_modifier, + MODIFIER_OR (Vhaiku_super_keysym, Qoption), &modifiers); + haiku_add_modifier (haiku_key, meta_modifier, + MODIFIER_OR (Vhaiku_meta_keysym, Qcommand), &modifiers); + haiku_add_modifier (haiku_key, ctrl_modifier, + MODIFIER_OR (Vhaiku_control_keysym, Qcontrol), &modifiers); + return modifiers; +} + +#undef MODIFIER_OR + +static void +haiku_rehighlight (void) +{ + eassert (x_display_list && !x_display_list->next); + + block_input (); + + struct frame *old_hl = x_display_list->highlight_frame; + + if (x_display_list->focused_frame) + { + x_display_list->highlight_frame + = ((FRAMEP (FRAME_FOCUS_FRAME (x_display_list->focused_frame))) + ? XFRAME (FRAME_FOCUS_FRAME (x_display_list->focused_frame)) + : x_display_list->focused_frame); + if (!FRAME_LIVE_P (x_display_list->highlight_frame)) + { + fset_focus_frame (x_display_list->focused_frame, Qnil); + x_display_list->highlight_frame = x_display_list->focused_frame; + } + } + else + x_display_list->highlight_frame = 0; + + if (old_hl) + gui_update_cursor (old_hl, true); + + if (x_display_list->highlight_frame) + gui_update_cursor (x_display_list->highlight_frame, true); + unblock_input (); +} + +static void +haiku_frame_raise_lower (struct frame *f, bool raise_p) +{ + if (raise_p) + { + block_input (); + BWindow_activate (FRAME_HAIKU_WINDOW (f)); + flush_frame (f); + unblock_input (); + } +} + +/* Unfortunately, NOACTIVATE is not implementable on Haiku. */ +static void +haiku_focus_frame (struct frame *frame, bool noactivate) +{ + if (x_display_list->focused_frame != frame) + haiku_frame_raise_lower (frame, 1); +} + +static void +haiku_new_focus_frame (struct frame *frame) +{ + eassert (x_display_list && !x_display_list->next); + + block_input (); + if (frame != x_display_list->focused_frame) + { + if (x_display_list->focused_frame && + x_display_list->focused_frame->auto_lower) + haiku_frame_raise_lower (x_display_list->focused_frame, 0); + + x_display_list->focused_frame = frame; + + if (frame && frame->auto_raise) + haiku_frame_raise_lower (frame, 1); + } + unblock_input (); + + haiku_rehighlight (); +} + +static void +haiku_implicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + haiku_set_name (f, arg, 0); +} + +static void +haiku_query_frame_background_color (struct frame *f, Emacs_Color *bgcolor) +{ + haiku_query_color (FRAME_BACKGROUND_PIXEL (f), bgcolor); +} + +static bool +haiku_defined_color (struct frame *f, + const char *name, + Emacs_Color *color, + bool alloc, + bool make_index) +{ + return !haiku_get_color (name, color); +} + +/* Adapted from xterm `x_draw_box_rect'. */ +static void +haiku_draw_box_rect (struct glyph_string *s, + int left_x, int top_y, int right_x, int bottom_y, int hwidth, + int vwidth, bool left_p, bool right_p, struct haiku_rect *clip_rect) +{ + void *view = FRAME_HAIKU_VIEW (s->f); + struct face *face = s->face; + + BView_StartClip (view); + BView_SetHighColor (view, face->box_color); + if (clip_rect) + BView_ClipToRect (view, clip_rect->x, clip_rect->y, clip_rect->width, + clip_rect->height); + BView_FillRectangle (view, left_x, top_y, right_x - left_x + 1, hwidth); + if (left_p) + BView_FillRectangle (view, left_x, top_y, vwidth, bottom_y - top_y + 1); + + BView_FillRectangle (view, left_x, bottom_y - hwidth + 1, + right_x - left_x + 1, hwidth); + if (right_p) + BView_FillRectangle (view, right_x - vwidth + 1, + top_y, vwidth, bottom_y - top_y + 1); + BView_EndClip (view); +} + +static void +haiku_calculate_relief_colors (struct glyph_string *s, + uint32_t *rgbout_w, uint32_t *rgbout_b, + uint32_t *rgbout_c) +{ + struct face *face = s->face; + + prepare_face_for_display (s->f, s->face); + + uint32_t rgbin = face->use_box_color_for_shadows_p + ? face->box_color : face->background; + + if (s->hl == DRAW_CURSOR) + rgbin = FRAME_CURSOR_COLOR (s->f).pixel; + + double h, cs, l; + rgb_color_hsl (rgbin, &h, &cs, &l); + + hsl_color_rgb (h, cs, fmin (1.0, fmax (0.2, l) * 0.6), rgbout_b); + hsl_color_rgb (h, cs, fmin (1.0, fmax (0.2, l) * 1.2), rgbout_w); + hsl_color_rgb (h, cs, fmin (1.0, fmax (0.2, l) * 1.8), rgbout_c); +} + +static void +haiku_draw_relief_rect (struct glyph_string *s, + int left_x, int top_y, int right_x, int bottom_y, + int hwidth, int vwidth, bool raised_p, bool top_p, bool bot_p, + bool left_p, bool right_p, + struct haiku_rect *clip_rect, bool fancy_p) +{ + uint32_t color_white; + uint32_t color_black; + uint32_t color_corner; + + haiku_calculate_relief_colors (s, &color_white, &color_black, + &color_corner); + + void *view = FRAME_HAIKU_VIEW (s->f); + BView_StartClip (view); + + BView_SetHighColor (view, raised_p ? color_white : color_black); + if (clip_rect) + BView_ClipToRect (view, clip_rect->x, clip_rect->y, clip_rect->width, + clip_rect->height); + if (top_p) + BView_FillRectangle (view, left_x, top_y, right_x - left_x + 1, hwidth); + if (left_p) + BView_FillRectangle (view, left_x, top_y, vwidth, bottom_y - top_y + 1); + BView_SetHighColor (view, !raised_p ? color_white : color_black); + + if (bot_p) + BView_FillRectangle (view, left_x, bottom_y - hwidth + 1, + right_x - left_x + 1, hwidth); + if (right_p) + BView_FillRectangle (view, right_x - vwidth + 1, top_y, + vwidth, bottom_y - top_y + 1); + + /* Draw the triangle for the bottom-left corner. */ + if (bot_p && left_p) + { + BView_SetHighColor (view, raised_p ? color_white : color_black); + BView_FillTriangle (view, left_x, bottom_y - hwidth, left_x + vwidth, + bottom_y - hwidth, left_x, bottom_y); + } + + /* Now draw the triangle for the top-right corner. */ + if (top_p && right_p) + { + BView_SetHighColor (view, raised_p ? color_white : color_black); + BView_FillTriangle (view, right_x - vwidth, top_y, + right_x, top_y, + right_x - vwidth, top_y + hwidth); + } + + /* If (h/v)width is > 1, we draw the outer-most line on each side in the + black relief color. */ + + BView_SetHighColor (view, color_black); + + if (hwidth > 1 && top_p) + BView_StrokeLine (view, left_x, top_y, right_x, top_y); + if (hwidth > 1 && bot_p) + BView_StrokeLine (view, left_x, bottom_y, right_x, bottom_y); + if (vwidth > 1 && left_p) + BView_StrokeLine (view, left_x, top_y, left_x, bottom_y); + if (vwidth > 1 && right_p) + BView_StrokeLine (view, right_x, top_y, right_x, bottom_y); + + BView_SetHighColor (view, color_corner); + + /* Omit corner pixels. */ + if (hwidth > 1 || vwidth > 1) + { + if (left_p && top_p) + BView_FillRectangle (view, left_x, top_y, 1, 1); + if (left_p && bot_p) + BView_FillRectangle (view, left_x, bottom_y, 1, 1); + if (right_p && top_p) + BView_FillRectangle (view, right_x, top_y, 1, 1); + if (right_p && bot_p) + BView_FillRectangle (view, right_x, bottom_y, 1, 1); + } + + BView_EndClip (view); +} + +static void +haiku_draw_string_box (struct glyph_string *s, int clip_p) +{ + int hwidth, vwidth, left_x, right_x, top_y, bottom_y, last_x; + bool raised_p, left_p, right_p; + struct glyph *last_glyph; + struct haiku_rect clip_rect; + + struct face *face = s->face; + + last_x = ((s->row->full_width_p && !s->w->pseudo_window_p) + ? WINDOW_RIGHT_EDGE_X (s->w) + : window_box_right (s->w, s->area)); + + /* The glyph that may have a right box line. For static + compositions and images, the right-box flag is on the first glyph + of the glyph string; for other types it's on the last glyph. */ + if (s->cmp || s->img) + last_glyph = s->first_glyph; + else if (s->first_glyph->type == COMPOSITE_GLYPH + && s->first_glyph->u.cmp.automatic) + { + /* For automatic compositions, we need to look up the last glyph + in the composition. */ + struct glyph *end = s->row->glyphs[s->area] + s->row->used[s->area]; + struct glyph *g = s->first_glyph; + for (last_glyph = g++; + g < end && g->u.cmp.automatic && g->u.cmp.id == s->cmp_id + && g->slice.cmp.to < s->cmp_to; + last_glyph = g++) + ; + } + else + last_glyph = s->first_glyph + s->nchars - 1; + + vwidth = eabs (face->box_vertical_line_width); + hwidth = eabs (face->box_horizontal_line_width); + raised_p = face->box == FACE_RAISED_BOX; + left_x = s->x; + right_x = (s->row->full_width_p && s->extends_to_end_of_line_p + ? last_x - 1 + : min (last_x, s->x + s->background_width) - 1); + + top_y = s->y; + bottom_y = top_y + s->height - 1; + + left_p = (s->first_glyph->left_box_line_p + || (s->hl == DRAW_MOUSE_FACE + && (s->prev == NULL + || s->prev->hl != s->hl))); + right_p = (last_glyph->right_box_line_p + || (s->hl == DRAW_MOUSE_FACE + && (s->next == NULL + || s->next->hl != s->hl))); + + get_glyph_string_clip_rect (s, &clip_rect); + + if (face->box == FACE_SIMPLE_BOX) + haiku_draw_box_rect (s, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, left_p, right_p, &clip_rect); + else + haiku_draw_relief_rect (s, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, raised_p, true, true, left_p, right_p, + &clip_rect, 1); + + if (clip_p) + { + void *view = FRAME_HAIKU_VIEW (s->f); + BView_ClipToInverseRect (view, left_x, top_y, right_x - left_x + 1, hwidth); + if (left_p) + BView_ClipToInverseRect (view, left_x, top_y, vwidth, bottom_y - top_y + 1); + BView_ClipToInverseRect (view, left_x, bottom_y - hwidth + 1, + right_x - left_x + 1, hwidth); + if (right_p) + BView_ClipToInverseRect (view, right_x - vwidth + 1, + top_y, vwidth, bottom_y - top_y + 1); + } +} + +static void +haiku_draw_plain_background (struct glyph_string *s, struct face *face, + int box_line_hwidth, int box_line_vwidth) +{ + void *view = FRAME_HAIKU_VIEW (s->f); + BView_StartClip (view); + if (s->hl == DRAW_CURSOR) + BView_SetHighColor (view, FRAME_CURSOR_COLOR (s->f).pixel); + else + BView_SetHighColor (view, face->background_defaulted_p ? + FRAME_BACKGROUND_PIXEL (s->f) : + face->background); + + BView_FillRectangle (view, s->x, + s->y + box_line_hwidth, + s->background_width, + s->height - 2 * box_line_hwidth); + BView_EndClip (view); +} + +static void +haiku_draw_stipple_background (struct glyph_string *s, struct face *face, + int box_line_hwidth, int box_line_vwidth) +{ +} + +static void +haiku_maybe_draw_background (struct glyph_string *s, int force_p) +{ + if ((s->first_glyph->type != IMAGE_GLYPH) && !s->background_filled_p) + { + struct face *face = s->face; + int box_line_width = max (face->box_horizontal_line_width, 0); + int box_vline_width = max (face->box_vertical_line_width, 0); + + if (FONT_HEIGHT (s->font) < s->height - 2 * box_vline_width + || FONT_TOO_HIGH (s->font) + || s->font_not_found_p || s->extends_to_end_of_line_p || force_p) + { + if (!face->stipple) + haiku_draw_plain_background (s, face, box_line_width, + box_vline_width); + else + haiku_draw_stipple_background (s, face, box_line_width, + box_vline_width); + s->background_filled_p = 1; + } + } +} + +static void +haiku_mouse_face_colors (struct glyph_string *s, uint32_t *fg, + uint32_t *bg) +{ + int face_id; + struct face *face; + + /* What face has to be used last for the mouse face? */ + face_id = MOUSE_HL_INFO (s->f)->mouse_face_face_id; + face = FACE_FROM_ID_OR_NULL (s->f, face_id); + if (face == NULL) + face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + + if (s->first_glyph->type == CHAR_GLYPH) + face_id = FACE_FOR_CHAR (s->f, face, s->first_glyph->u.ch, -1, Qnil); + else + face_id = FACE_FOR_CHAR (s->f, face, 0, -1, Qnil); + + face = FACE_FROM_ID (s->f, face_id); + prepare_face_for_display (s->f, s->face); + + if (fg) + *fg = face->foreground; + if (bg) + *bg = face->background; +} + +static void +haiku_draw_underwave (struct glyph_string *s, int width, int x) +{ + int wave_height = 3, wave_length = 2; + int y, dx, dy, odd, xmax; + dx = wave_length; + dy = wave_height - 1; + y = s->ybase - wave_height + 3; + + float ax, ay, bx, by; + xmax = x + width; + + void *view = FRAME_HAIKU_VIEW (s->f); + + BView_StartClip (view); + BView_ClipToRect (view, x, y, width, wave_height); + ax = x - ((int) (x) % dx) + (float) 0.5; + bx = ax + dx; + odd = (int) (ax / dx) % 2; + ay = by = y + 0.5; + + if (odd) + ay += dy; + else + by += dy; + + while (ax <= xmax) + { + BView_StrokeLine (view, ax, ay, bx, by); + ax = bx, ay = by; + bx += dx, by = y + 0.5 + odd * dy; + odd = !odd; + } + BView_EndClip (view); +} + +static void +haiku_draw_text_decoration (struct glyph_string *s, struct face *face, + uint8_t dcol, int width, int x) +{ + if (s->for_overlaps) + return; + + void *view = FRAME_HAIKU_VIEW (s->f); + BView_draw_lock (view); + BView_StartClip (view); + + if (face->underline) + { + if (s->hl == DRAW_CURSOR) + BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg); + else if (!face->underline_defaulted_p) + BView_SetHighColor (view, face->underline_color); + else + BView_SetHighColor (view, dcol); + + if (face->underline == FACE_UNDER_WAVE) + haiku_draw_underwave (s, width, x); + else if (face->underline == FACE_UNDER_LINE) + { + unsigned long thickness, position; + int y; + + if (s->prev && s->prev && s->prev->hl == DRAW_MOUSE_FACE) + { + struct face *prev_face = s->prev->face; + + if (prev_face && prev_face->underline == FACE_UNDER_LINE) + { + /* We use the same underline style as the previous one. */ + thickness = s->prev->underline_thickness; + position = s->prev->underline_position; + } + else + goto calculate_underline_metrics; + } + else + { + calculate_underline_metrics:; + struct font *font = font_for_underline_metrics (s); + unsigned long minimum_offset; + bool underline_at_descent_line; + bool use_underline_position_properties; + Lisp_Object val = (WINDOW_BUFFER_LOCAL_VALUE + (Qunderline_minimum_offset, s->w)); + + if (FIXNUMP (val)) + minimum_offset = max (0, XFIXNUM (val)); + else + minimum_offset = 1; + + val = (WINDOW_BUFFER_LOCAL_VALUE + (Qx_underline_at_descent_line, s->w)); + underline_at_descent_line + = !(NILP (val) || EQ (val, Qunbound)); + + val = (WINDOW_BUFFER_LOCAL_VALUE + (Qx_use_underline_position_properties, s->w)); + use_underline_position_properties + = !(NILP (val) || EQ (val, Qunbound)); + + /* Get the underline thickness. Default is 1 pixel. */ + if (font && font->underline_thickness > 0) + thickness = font->underline_thickness; + else + thickness = 1; + if (underline_at_descent_line) + position = (s->height - thickness) - (s->ybase - s->y); + else + { + /* Get the underline position. This is the + recommended vertical offset in pixels from + the baseline to the top of the underline. + This is a signed value according to the + specs, and its default is + + ROUND ((maximum descent) / 2), with + ROUND(x) = floor (x + 0.5) */ + + if (use_underline_position_properties + && font && font->underline_position >= 0) + position = font->underline_position; + else if (font) + position = (font->descent + 1) / 2; + else + position = minimum_offset; + } + position = max (position, minimum_offset); + } + /* Check the sanity of thickness and position. We should + avoid drawing underline out of the current line area. */ + if (s->y + s->height <= s->ybase + position) + position = (s->height - 1) - (s->ybase - s->y); + if (s->y + s->height < s->ybase + position + thickness) + thickness = (s->y + s->height) - (s->ybase + position); + s->underline_thickness = thickness; + s->underline_position = position; + y = s->ybase + position; + + BView_FillRectangle (view, s->x, y, s->width, thickness); + } + } + + if (face->overline_p) + { + unsigned long dy = 0, h = 1; + if (s->hl == DRAW_CURSOR) + BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg); + else if (!face->overline_color_defaulted_p) + BView_SetHighColor (view, face->overline_color); + else + BView_SetHighColor (view, dcol); + + BView_FillRectangle (view, s->x, s->y + dy, s->width, h); + } + + if (face->strike_through_p) + { + /* Y-coordinate and height of the glyph string's first + glyph. We cannot use s->y and s->height because those + could be larger if there are taller display elements + (e.g., characters displayed with a larger font) in the + same glyph row. */ + int glyph_y = s->ybase - s->first_glyph->ascent; + int glyph_height = s->first_glyph->ascent + s->first_glyph->descent; + /* Strike-through width and offset from the glyph string's + top edge. */ + unsigned long h = 1; + unsigned long dy = (glyph_height - h) / 2; + + if (s->hl == DRAW_CURSOR) + BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg); + else if (!face->strike_through_color_defaulted_p) + BView_SetHighColor (view, face->strike_through_color); + else + BView_SetHighColor (view, dcol); + + BView_FillRectangle (view, s->x, glyph_y + dy, s->width, h); + } + + BView_EndClip (view); + BView_draw_unlock (view); +} + +static void +haiku_draw_glyph_string_foreground (struct glyph_string *s) +{ + struct face *face = s->face; + + int i, x; + if (face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p) + x = s->x + max (face->box_vertical_line_width, 0); + else + x = s->x; + + void *view = FRAME_HAIKU_VIEW (s->f); + + if (s->font_not_found_p) + { + BView_StartClip (view); + if (s->hl == DRAW_CURSOR) + BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg); + else + BView_SetHighColor (view, face->foreground); + for (i = 0; i < s->nchars; ++i) + { + struct glyph *g = s->first_glyph + i; + BView_StrokeRectangle (view, x, s->y, g->pixel_width, + s->height); + x += g->pixel_width; + } + BView_EndClip (view); + } + else + { + struct font *ft = s->font; + int off = ft->baseline_offset; + int y; + + if (ft->vertical_centering) + off = VCENTER_BASELINE_OFFSET (ft, s->f) - off; + y = s->ybase - off; + if (s->for_overlaps || (s->background_filled_p && s->hl != DRAW_CURSOR)) + ft->driver->draw (s, 0, s->nchars, x, y, false); + else + ft->driver->draw (s, 0, s->nchars, x, y, true); + + if (face->overstrike) + ft->driver->draw (s, 0, s->nchars, x + 1, y, false); + } +} + +static void +haiku_draw_glyphless_glyph_string_foreground (struct glyph_string *s) +{ + struct glyph *glyph = s->first_glyph; + unsigned char2b[8]; + int x, i, j; + struct face *face = s->face; + + /* If first glyph of S has a left box line, start drawing the text + of S to the right of that box line. */ + if (face && face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p) + x = s->x + max (face->box_vertical_line_width, 0); + else + x = s->x; + + s->char2b = char2b; + + for (i = 0; i < s->nchars; i++, glyph++) + { +#ifdef GCC_LINT + enum { PACIFY_GCC_BUG_81401 = 1 }; +#else + enum { PACIFY_GCC_BUG_81401 = 0 }; +#endif + char buf[7 + PACIFY_GCC_BUG_81401]; + char *str = NULL; + int len = glyph->u.glyphless.len; + + if (glyph->u.glyphless.method == GLYPHLESS_DISPLAY_ACRONYM) + { + if (len > 0 + && CHAR_TABLE_P (Vglyphless_char_display) + && (CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (Vglyphless_char_display)) + >= 1)) + { + Lisp_Object acronym + = (! glyph->u.glyphless.for_no_font + ? CHAR_TABLE_REF (Vglyphless_char_display, + glyph->u.glyphless.ch) + : XCHAR_TABLE (Vglyphless_char_display)->extras[0]); + if (STRINGP (acronym)) + str = SSDATA (acronym); + } + } + else if (glyph->u.glyphless.method == GLYPHLESS_DISPLAY_HEX_CODE) + { + unsigned int ch = glyph->u.glyphless.ch; + eassume (ch <= MAX_CHAR); + sprintf (buf, "%0*X", ch < 0x10000 ? 4 : 6, ch); + str = buf; + } + + if (str) + { + int upper_len = (len + 1) / 2; + + /* It is assured that all LEN characters in STR is ASCII. */ + for (j = 0; j < len; j++) + char2b[j] = s->font->driver->encode_char (s->font, str[j]) & 0xFFFF; + + s->font->driver->draw (s, 0, upper_len, + x + glyph->slice.glyphless.upper_xoff, + s->ybase + glyph->slice.glyphless.upper_yoff, + false); + s->font->driver->draw (s, upper_len, len, + x + glyph->slice.glyphless.lower_xoff, + s->ybase + glyph->slice.glyphless.lower_yoff, + false); + } + BView_StartClip (FRAME_HAIKU_VIEW (s->f)); + if (glyph->u.glyphless.method != GLYPHLESS_DISPLAY_THIN_SPACE) + BView_FillRectangle (FRAME_HAIKU_VIEW (s->f), + x, s->ybase - glyph->ascent, + glyph->pixel_width - 1, + glyph->ascent + glyph->descent - 1); + BView_EndClip (FRAME_HAIKU_VIEW (s->f)); + x += glyph->pixel_width; + } +} + +static void +haiku_draw_stretch_glyph_string (struct glyph_string *s) +{ + eassert (s->first_glyph->type == STRETCH_GLYPH); + + struct face *face = s->face; + + if (s->hl == DRAW_CURSOR && !x_stretch_cursor_p) + { + int width, background_width = s->background_width; + int x = s->x; + + if (!s->row->reversed_p) + { + int left_x = window_box_left_offset (s->w, TEXT_AREA); + + if (x < left_x) + { + background_width -= left_x - x; + x = left_x; + } + } + else + { + /* In R2L rows, draw the cursor on the right edge of the + stretch glyph. */ + int right_x = window_box_right (s->w, TEXT_AREA); + if (x + background_width > right_x) + background_width -= x - right_x; + x += background_width; + } + + width = min (FRAME_COLUMN_WIDTH (s->f), background_width); + if (s->row->reversed_p) + x -= width; + + void *view = FRAME_HAIKU_VIEW (s->f); + BView_StartClip (view); + BView_SetHighColor (view, FRAME_CURSOR_COLOR (s->f).pixel); + BView_FillRectangle (view, x, s->y, width, s->height); + BView_EndClip (view); + + if (width < background_width) + { + if (!s->row->reversed_p) + x += width; + else + x = s->x; + + int y = s->y; + int w = background_width - width, h = s->height; + + if (!face->stipple) + { + uint32_t bkg; + if (s->hl == DRAW_MOUSE_FACE || (s->hl == DRAW_CURSOR + && s->row->mouse_face_p + && cursor_in_mouse_face_p (s->w))) + haiku_mouse_face_colors (s, NULL, &bkg); + else + bkg = face->background; + + BView_StartClip (view); + BView_SetHighColor (view, bkg); + BView_FillRectangle (view, x, y, w, h); + BView_EndClip (view); + } + } + } + else if (!s->background_filled_p) + { + int background_width = s->background_width; + int x = s->x, text_left_x = window_box_left (s->w, TEXT_AREA); + + /* Don't draw into left fringe or scrollbar area except for + header line and mode line. */ + if (s->area == TEXT_AREA + && x < text_left_x && !s->row->mode_line_p) + { + background_width -= text_left_x - x; + x = text_left_x; + } + + if (background_width > 0) + { + void *view = FRAME_HAIKU_VIEW (s->f); + BView_StartClip (view); + uint32_t bkg; + if (s->hl == DRAW_MOUSE_FACE) + haiku_mouse_face_colors (s, NULL, &bkg); + else if (s->hl == DRAW_CURSOR) + bkg = FRAME_CURSOR_COLOR (s->f).pixel; + else + bkg = s->face->background; + + BView_SetHighColor (view, bkg); + BView_FillRectangle (view, x, s->y, background_width, s->height); + BView_EndClip (view); + } + } + s->background_filled_p = 1; +} + +static void +haiku_start_clip (struct glyph_string *s) +{ + void *view = FRAME_HAIKU_VIEW (s->f); + BView_draw_lock (view); + BView_StartClip (view); +} + +static void +haiku_end_clip (struct glyph_string *s) +{ + void *view = FRAME_HAIKU_VIEW (s->f); + BView_EndClip (view); + BView_draw_unlock (view); +} + +static void +haiku_clip_to_row (struct window *w, struct glyph_row *row, + enum glyph_row_area area) +{ + struct frame *f = WINDOW_XFRAME (w); + int window_x, window_y, window_width; + int x, y, width, height; + + window_box (w, area, &window_x, &window_y, &window_width, 0); + + x = window_x; + y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, row->y)); + y = max (y, window_y); + width = window_width; + height = row->visible_height; + + BView_ClipToRect (FRAME_HAIKU_VIEW (f), x, y, width, height); +} + +static void +haiku_update_begin (struct frame *f) +{ +} + +static void +haiku_update_end (struct frame *f) +{ + MOUSE_HL_INFO (f)->mouse_face_defer = false; + flush_frame (f); +} + +static void +haiku_draw_composite_glyph_string_foreground (struct glyph_string *s) +{ + int i, j, x; + struct font *font = s->font; + void *view = FRAME_HAIKU_VIEW (s->f); + struct face *face = s->face; + + /* If first glyph of S has a left box line, start drawing the text + of S to the right of that box line. */ + if (face && face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p) + x = s->x + max (face->box_vertical_line_width, 0); + else + x = s->x; + + /* S is a glyph string for a composition. S->cmp_from is the index + of the first character drawn for glyphs of this composition. + S->cmp_from == 0 means we are drawing the very first character of + this composition. */ + + /* Draw a rectangle for the composition if the font for the very + first character of the composition could not be loaded. */ + + if (s->font_not_found_p && !s->cmp_from) + { + BView_StartClip (view); + if (s->hl == DRAW_CURSOR) + BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg); + else + BView_SetHighColor (view, s->face->foreground); + BView_StrokeRectangle (view, s->x, s->y, s->width - 1, s->height - 1); + BView_EndClip (view); + } + else if (!s->first_glyph->u.cmp.automatic) + { + int y = s->ybase; + + for (i = 0, j = s->cmp_from; i < s->nchars; i++, j++) + /* TAB in a composition means display glyphs with padding + space on the left or right. */ + if (COMPOSITION_GLYPH (s->cmp, j) != '\t') + { + int xx = x + s->cmp->offsets[j * 2]; + int yy = y - s->cmp->offsets[j * 2 + 1]; + + font->driver->draw (s, j, j + 1, xx, yy, false); + if (face->overstrike) + font->driver->draw (s, j, j + 1, xx + 1, yy, false); + } + } + else + { + Lisp_Object gstring = composition_gstring_from_id (s->cmp_id); + Lisp_Object glyph; + int y = s->ybase; + int width = 0; + + for (i = j = s->cmp_from; i < s->cmp_to; i++) + { + glyph = LGSTRING_GLYPH (gstring, i); + if (NILP (LGLYPH_ADJUSTMENT (glyph))) + width += LGLYPH_WIDTH (glyph); + else + { + int xoff, yoff, wadjust; + + if (j < i) + { + font->driver->draw (s, j, i, x, y, false); + if (s->face->overstrike) + font->driver->draw (s, j, i, x + 1, y, false); + x += width; + } + xoff = LGLYPH_XOFF (glyph); + yoff = LGLYPH_YOFF (glyph); + wadjust = LGLYPH_WADJUST (glyph); + font->driver->draw (s, i, i + 1, x + xoff, y + yoff, false); + if (face->overstrike) + font->driver->draw (s, i, i + 1, x + xoff + 1, y + yoff, + false); + x += wadjust; + j = i + 1; + width = 0; + } + } + if (j < i) + { + font->driver->draw (s, j, i, x, y, false); + if (face->overstrike) + font->driver->draw (s, j, i, x + 1, y, false); + } + } +} + +static void +haiku_draw_image_relief (struct glyph_string *s) +{ + int x1, y1, thick; + bool raised_p, top_p, bot_p, left_p, right_p; + int extra_x, extra_y; + struct haiku_rect r; + int x = s->x; + int y = s->ybase - image_ascent (s->img, s->face, &s->slice); + + struct face *face = s->face; + + /* If first glyph of S has a left box line, start drawing it to the + right of that line. */ + if (face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p + && s->slice.x == 0) + x += max (face->box_vertical_line_width, 0); + + /* If there is a margin around the image, adjust x- and y-position + by that margin. */ + if (s->slice.x == 0) + x += s->img->hmargin; + if (s->slice.y == 0) + y += s->img->vmargin; + + if (s->hl == DRAW_IMAGE_SUNKEN + || s->hl == DRAW_IMAGE_RAISED) + { + if (s->face->id == TAB_BAR_FACE_ID) + thick = (tab_bar_button_relief < 0 + ? DEFAULT_TAB_BAR_BUTTON_RELIEF + : min (tab_bar_button_relief, 1000000)); + else + thick = (tool_bar_button_relief < 0 + ? DEFAULT_TOOL_BAR_BUTTON_RELIEF + : min (tool_bar_button_relief, 1000000)); + raised_p = s->hl == DRAW_IMAGE_RAISED; + } + else + { + thick = eabs (s->img->relief); + raised_p = s->img->relief > 0; + } + + x1 = x + s->slice.width - 1; + y1 = y + s->slice.height - 1; + + extra_x = extra_y = 0; + + if (s->face->id == TAB_BAR_FACE_ID) + { + if (CONSP (Vtab_bar_button_margin) + && FIXNUMP (XCAR (Vtab_bar_button_margin)) + && FIXNUMP (XCDR (Vtab_bar_button_margin))) + { + extra_x = XFIXNUM (XCAR (Vtab_bar_button_margin)) - thick; + extra_y = XFIXNUM (XCDR (Vtab_bar_button_margin)) - thick; + } + else if (FIXNUMP (Vtab_bar_button_margin)) + extra_x = extra_y = XFIXNUM (Vtab_bar_button_margin) - thick; + } + + if (s->face->id == TOOL_BAR_FACE_ID) + { + if (CONSP (Vtool_bar_button_margin) + && FIXNUMP (XCAR (Vtool_bar_button_margin)) + && FIXNUMP (XCDR (Vtool_bar_button_margin))) + { + extra_x = XFIXNUM (XCAR (Vtool_bar_button_margin)); + extra_y = XFIXNUM (XCDR (Vtool_bar_button_margin)); + } + else if (FIXNUMP (Vtool_bar_button_margin)) + extra_x = extra_y = XFIXNUM (Vtool_bar_button_margin); + } + + top_p = bot_p = left_p = right_p = 0; + + if (s->slice.x == 0) + x -= thick + extra_x, left_p = 1; + if (s->slice.y == 0) + y -= thick + extra_y, top_p = 1; + if (s->slice.x + s->slice.width == s->img->width) + x1 += thick + extra_x, right_p = 1; + if (s->slice.y + s->slice.height == s->img->height) + y1 += thick + extra_y, bot_p = 1; + + get_glyph_string_clip_rect (s, &r); + haiku_draw_relief_rect (s, x, y, x1, y1, thick, thick, raised_p, + top_p, bot_p, left_p, right_p, &r, 0); +} + +static void +haiku_draw_image_glyph_string (struct glyph_string *s) +{ + struct face *face = s->face; + + int box_line_hwidth = max (face->box_vertical_line_width, 0); + int box_line_vwidth = max (face->box_horizontal_line_width, 0); + + int x, y; + int height, width; + + height = s->height; + if (s->slice.y == 0) + height -= box_line_vwidth; + if (s->slice.y + s->slice.height >= s->img->height) + height -= box_line_vwidth; + + width = s->background_width; + x = s->x; + if (s->first_glyph->left_box_line_p + && s->slice.x == 0) + { + x += box_line_hwidth; + width -= box_line_hwidth; + } + + y = s->y; + if (s->slice.y == 0) + y += box_line_vwidth; + + void *view = FRAME_HAIKU_VIEW (s->f); + void *bitmap = s->img->pixmap; + + s->stippled_p = face->stipple != 0; + + BView_draw_lock (view); + BView_StartClip (view); + BView_SetHighColor (view, face->background); + BView_FillRectangle (view, x, y, width, height); + BView_EndClip (view); + BView_draw_unlock (view); + + if (bitmap) + { + struct haiku_rect nr; + Emacs_Rectangle cr, ir, r; + + get_glyph_string_clip_rect (s, &nr); + CONVERT_TO_EMACS_RECT (cr, nr); + x = s->x; + y = s->ybase - image_ascent (s->img, face, &s->slice); + + if (s->slice.x == 0) + x += s->img->hmargin; + if (s->slice.y == 0) + y += s->img->vmargin; + + if (face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p + && s->slice.x == 0) + x += max (face->box_vertical_line_width, 0); + + ir.x = x; + ir.y = y; + ir.width = s->slice.width; + ir.height = s->slice.height; + r = ir; + + void *mask = s->img->mask; + + if (gui_intersect_rectangles (&cr, &ir, &r)) + { + BView_draw_lock (view); + BView_StartClip (view); + + haiku_clip_to_string (s); + if (s->img->have_be_transforms_p) + { + bitmap = BBitmap_transform_bitmap (bitmap, + s->img->mask, + face->background, + s->img->be_rotate, + s->img->width, + s->img->height); + mask = NULL; + } + + BView_DrawBitmap (view, bitmap, + s->slice.x + r.x - x, + s->slice.y + r.y - y, + r.width, r.height, + r.x, r.y, r.width, r.height); + if (mask) + { + BView_DrawMask (mask, view, + s->slice.x + r.x - x, + s->slice.y + r.y - y, + r.width, r.height, + r.x, r.y, r.width, r.height, + face->background); + } + + if (s->img->have_be_transforms_p) + BBitmap_free (bitmap); + BView_EndClip (view); + BView_draw_unlock (view); + } + + if (s->hl == DRAW_CURSOR) + { + BView_draw_lock (view); + BView_StartClip (view); + BView_SetPenSize (view, 1); + BView_SetHighColor (view, FRAME_CURSOR_COLOR (s->f).pixel); + BView_StrokeRectangle (view, r.x, r.y, r.width, r.height); + BView_EndClip (view); + BView_draw_unlock (view); + } + } + + if (s->img->relief + || s->hl == DRAW_IMAGE_RAISED + || s->hl == DRAW_IMAGE_SUNKEN) + haiku_draw_image_relief (s); +} + +static void +haiku_draw_glyph_string (struct glyph_string *s) +{ + block_input (); + prepare_face_for_display (s->f, s->face); + + struct face *face = s->face; + if (face != s->face) + prepare_face_for_display (s->f, face); + + if (s->next && s->right_overhang && !s->for_overlaps) + { + int width; + struct glyph_string *next; + + for (width = 0, next = s->next; + next && width < s->right_overhang; + width += next->width, next = next->next) + if (next->first_glyph->type != IMAGE_GLYPH) + { + prepare_face_for_display (s->f, s->next->face); + haiku_start_clip (s->next); + haiku_clip_to_string (s->next); + if (next->first_glyph->type != STRETCH_GLYPH) + haiku_maybe_draw_background (s->next, 1); + else + haiku_draw_stretch_glyph_string (s->next); + next->num_clips = 0; + haiku_end_clip (s); + } + } + + haiku_start_clip (s); + + int box_filled_p = 0; + + if (!s->for_overlaps && face->box != FACE_NO_BOX + && (s->first_glyph->type == CHAR_GLYPH + || s->first_glyph->type == COMPOSITE_GLYPH)) + { + haiku_clip_to_string (s); + haiku_maybe_draw_background (s, 1); + box_filled_p = 1; + haiku_draw_string_box (s, 0); + } + else if (!s->clip_head && !s->clip_tail && + ((s->prev && s->left_overhang && s->prev->hl != s->hl) || + (s->next && s->right_overhang && s->next->hl != s->hl))) + haiku_clip_to_string_exactly (s, s); + else + haiku_clip_to_string (s); + + if (s->for_overlaps) + s->background_filled_p = 1; + + switch (s->first_glyph->type) + { + case COMPOSITE_GLYPH: + if (s->for_overlaps || (s->cmp_from > 0 + && ! s->first_glyph->u.cmp.automatic)) + s->background_filled_p = 1; + else + haiku_maybe_draw_background (s, 1); + haiku_draw_composite_glyph_string_foreground (s); + break; + case CHAR_GLYPH: + if (s->for_overlaps) + s->background_filled_p = 1; + else + haiku_maybe_draw_background (s, 0); + haiku_draw_glyph_string_foreground (s); + break; + case STRETCH_GLYPH: + haiku_draw_stretch_glyph_string (s); + break; + case IMAGE_GLYPH: + haiku_draw_image_glyph_string (s); + break; + case GLYPHLESS_GLYPH: + if (s->for_overlaps) + s->background_filled_p = 1; + else + haiku_maybe_draw_background (s, 1); + haiku_draw_glyphless_glyph_string_foreground (s); + break; + } + + if (!box_filled_p && face->box != FACE_NO_BOX) + haiku_draw_string_box (s, 1); + + if (!s->for_overlaps) + { + uint32_t dcol; + dcol = face->foreground; + + haiku_draw_text_decoration (s, face, dcol, s->width, s->x); + + if (s->prev) + { + struct glyph_string *prev; + + for (prev = s->prev; prev; prev = prev->prev) + if (prev->hl != s->hl + && prev->x + prev->width + prev->right_overhang > s->x) + { + /* As prev was drawn while clipped to its own area, we + must draw the right_overhang part using s->hl now. */ + enum draw_glyphs_face save = prev->hl; + struct face *save_face = prev->face; + + prev->hl = s->hl; + prev->face = s->face; + haiku_start_clip (s); + haiku_clip_to_string_exactly (s, prev); + if (prev->first_glyph->type == CHAR_GLYPH) + haiku_draw_glyph_string_foreground (prev); + else + haiku_draw_composite_glyph_string_foreground (prev); + haiku_end_clip (s); + prev->hl = save; + prev->face = save_face; + prev->num_clips = 0; + } + } + + if (s->next) + { + struct glyph_string *next; + + for (next = s->next; next; next = next->next) + if (next->hl != s->hl + && next->x - next->left_overhang < s->x + s->width) + { + /* As next will be drawn while clipped to its own area, + we must draw the left_overhang part using s->hl now. */ + enum draw_glyphs_face save = next->hl; + struct face *save_face = next->face; + + next->hl = s->hl; + next->face = s->face; + haiku_start_clip (s); + haiku_clip_to_string_exactly (s, next); + if (next->first_glyph->type == CHAR_GLYPH) + haiku_draw_glyph_string_foreground (next); + else + haiku_draw_composite_glyph_string_foreground (next); + haiku_end_clip (s); + + next->background_filled_p = 0; + next->hl = save; + next->face = save_face; + next->clip_head = next; + next->num_clips = 0; + } + } + } + s->num_clips = 0; + haiku_end_clip (s); + unblock_input (); +} + +static void +haiku_after_update_window_line (struct window *w, + struct glyph_row *desired_row) +{ + eassert (w); + struct frame *f; + int width, height; + + if (!desired_row->mode_line_p && !w->pseudo_window_p) + desired_row->redraw_fringe_bitmaps_p = true; + + if (windows_or_buffers_changed + && desired_row->full_width_p + && (f = XFRAME (w->frame), + width = FRAME_INTERNAL_BORDER_WIDTH (f), + width != 0) + && (height = desired_row->visible_height, + height > 0)) + { + int y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, desired_row->y)); + int face_id = + !NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) + : INTERNAL_BORDER_FACE_ID; + struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); + + block_input (); + if (face) + { + void *view = FRAME_HAIKU_VIEW (f); + BView_draw_lock (view); + BView_StartClip (view); + BView_SetHighColor (view, face->background_defaulted_p ? + FRAME_BACKGROUND_PIXEL (f) : face->background); + BView_FillRectangle (view, 0, y, width, height); + BView_FillRectangle (view, FRAME_PIXEL_WIDTH (f) - width, + y, width, height); + BView_EndClip (view); + BView_draw_unlock (view); + } + else + { + haiku_clear_frame_area (f, 0, y, width, height); + haiku_clear_frame_area (f, FRAME_PIXEL_WIDTH (f) - width, + y, width, height); + } + unblock_input (); + } +} + +static void +haiku_set_window_size (struct frame *f, bool change_gravity, + int width, int height) +{ + haiku_update_size_hints (f); + + if (FRAME_HAIKU_WINDOW (f)) + { + block_input (); + BWindow_resize (FRAME_HAIKU_WINDOW (f), width, height); + unblock_input (); + } +} + +static void +haiku_draw_window_cursor (struct window *w, + struct glyph_row *glyph_row, + int x, int y, + enum text_cursor_kinds cursor_type, + int cursor_width, bool on_p, bool active_p) +{ + struct frame *f = XFRAME (WINDOW_FRAME (w)); + + struct glyph *phys_cursor_glyph; + struct glyph *cursor_glyph; + + void *view = FRAME_HAIKU_VIEW (f); + + int fx, fy, h, cursor_height; + + if (!on_p) + return; + + if (cursor_type == NO_CURSOR) + { + w->phys_cursor_width = 0; + return; + } + + w->phys_cursor_on_p = true; + w->phys_cursor_type = cursor_type; + + phys_cursor_glyph = get_phys_cursor_glyph (w); + + if (!phys_cursor_glyph) + { + if (glyph_row->exact_window_width_line_p + && w->phys_cursor.hpos >= glyph_row->used[TEXT_AREA]) + { + glyph_row->cursor_in_fringe_p = 1; + draw_fringe_bitmap (w, glyph_row, 0); + } + return; + } + + get_phys_cursor_geometry (w, glyph_row, phys_cursor_glyph, &fx, &fy, &h); + + if (cursor_type == BAR_CURSOR) + { + if (cursor_width < 1) + cursor_width = max (FRAME_CURSOR_WIDTH (f), 1); + if (cursor_width < w->phys_cursor_width) + w->phys_cursor_width = cursor_width; + } + else if (cursor_type == HBAR_CURSOR) + { + cursor_height = (cursor_width < 1) ? lrint (0.25 * h) : cursor_width; + if (cursor_height > glyph_row->height) + cursor_height = glyph_row->height; + if (h > cursor_height) + fy += h - cursor_height; + h = cursor_height; + } + + BView_draw_lock (view); + BView_StartClip (view); + BView_SetHighColor (view, FRAME_CURSOR_COLOR (f).pixel); + haiku_clip_to_row (w, glyph_row, TEXT_AREA); + + switch (cursor_type) + { + default: + case DEFAULT_CURSOR: + case NO_CURSOR: + break; + case HBAR_CURSOR: + BView_FillRectangle (view, fx, fy, w->phys_cursor_width, h); + break; + case BAR_CURSOR: + cursor_glyph = get_phys_cursor_glyph (w); + if (cursor_glyph->resolved_level & 1) + BView_FillRectangle (view, fx + cursor_glyph->pixel_width - w->phys_cursor_width, + fy, w->phys_cursor_width, h); + else + BView_FillRectangle (view, fx, fy, w->phys_cursor_width, h); + break; + case HOLLOW_BOX_CURSOR: + if (phys_cursor_glyph->type != IMAGE_GLYPH) + { + BView_SetPenSize (view, 1); + BView_StrokeRectangle (view, fx, fy, w->phys_cursor_width, h); + } + else + draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR); + break; + case FILLED_BOX_CURSOR: + draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR); + } + BView_EndClip (view); + BView_draw_unlock (view); +} + +static void +haiku_show_hourglass (struct frame *f) +{ + if (FRAME_OUTPUT_DATA (f)->hourglass_p) + return; + + block_input (); + FRAME_OUTPUT_DATA (f)->hourglass_p = 1; + + if (FRAME_HAIKU_VIEW (f)) + BView_set_view_cursor (FRAME_HAIKU_VIEW (f), + FRAME_OUTPUT_DATA (f)->hourglass_cursor); + unblock_input (); +} + +static void +haiku_hide_hourglass (struct frame *f) +{ + if (!FRAME_OUTPUT_DATA (f)->hourglass_p) + return; + + block_input (); + FRAME_OUTPUT_DATA (f)->hourglass_p = 0; + + if (FRAME_HAIKU_VIEW (f)) + BView_set_view_cursor (FRAME_HAIKU_VIEW (f), + FRAME_OUTPUT_DATA (f)->current_cursor); + unblock_input (); +} + +static void +haiku_compute_glyph_string_overhangs (struct glyph_string *s) +{ + if (s->cmp == NULL + && (s->first_glyph->type == CHAR_GLYPH + || s->first_glyph->type == COMPOSITE_GLYPH)) + { + struct font_metrics metrics; + + if (s->first_glyph->type == CHAR_GLYPH) + { + struct font *font = s->font; + font->driver->text_extents (font, s->char2b, s->nchars, &metrics); + } + else + { + Lisp_Object gstring = composition_gstring_from_id (s->cmp_id); + + composition_gstring_width (gstring, s->cmp_from, s->cmp_to, &metrics); + } + s->right_overhang = (metrics.rbearing > metrics.width + ? metrics.rbearing - metrics.width : 0); + s->left_overhang = metrics.lbearing < 0 ? - metrics.lbearing : 0; + } + else if (s->cmp) + { + s->right_overhang = s->cmp->rbearing - s->cmp->pixel_width; + s->left_overhang = - s->cmp->lbearing; + } +} + +static void +haiku_draw_vertical_window_border (struct window *w, + int x, int y_0, int y_1) +{ + struct frame *f = XFRAME (WINDOW_FRAME (w)); + struct face *face; + + face = FACE_FROM_ID_OR_NULL (f, VERTICAL_BORDER_FACE_ID); + void *view = FRAME_HAIKU_VIEW (f); + BView_draw_lock (view); + BView_StartClip (view); + if (face) + BView_SetHighColor (view, face->foreground); + BView_StrokeLine (view, x, y_0, x, y_1); + BView_EndClip (view); + BView_draw_unlock (view); +} + +static void +haiku_set_scroll_bar_default_width (struct frame *f) +{ + int unit = FRAME_COLUMN_WIDTH (f); + FRAME_CONFIG_SCROLL_BAR_WIDTH (f) = BScrollBar_default_size (0) + 1; + FRAME_CONFIG_SCROLL_BAR_COLS (f) = + (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) + unit - 1) / unit; +} + +static void +haiku_set_scroll_bar_default_height (struct frame *f) +{ + int height = FRAME_LINE_HEIGHT (f); + FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) = BScrollBar_default_size (1) + 1; + FRAME_CONFIG_SCROLL_BAR_LINES (f) = + (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) + height - 1) / height; +} + +static void +haiku_draw_window_divider (struct window *w, int x0, int x1, int y0, int y1) +{ + struct frame *f = XFRAME (WINDOW_FRAME (w)); + struct face *face = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_FACE_ID); + struct face *face_first + = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_FIRST_PIXEL_FACE_ID); + struct face *face_last + = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_LAST_PIXEL_FACE_ID); + unsigned long color = face ? face->foreground : FRAME_FOREGROUND_PIXEL (f); + unsigned long color_first = (face_first + ? face_first->foreground + : FRAME_FOREGROUND_PIXEL (f)); + unsigned long color_last = (face_last + ? face_last->foreground + : FRAME_FOREGROUND_PIXEL (f)); + void *view = FRAME_HAIKU_VIEW (f); + + BView_draw_lock (view); + BView_StartClip (view); + + if ((y1 - y0 > x1 - x0) && (x1 - x0 >= 3)) + /* A vertical divider, at least three pixels wide: Draw first and + last pixels differently. */ + { + BView_SetHighColor (view, color_first); + BView_StrokeLine (view, x0, y0, x0, y1 - 1); + BView_SetHighColor (view, color); + BView_FillRectangle (view, x0 + 1, y0, x1 - x0 - 2, y1 - y0); + BView_SetHighColor (view, color_last); + BView_StrokeLine (view, x1 - 1, y0, x1 - 1, y1 - 1); + } + else if ((x1 - x0 > y1 - y0) && (y1 - y0 >= 3)) + /* A horizontal divider, at least three pixels high: Draw first and + last pixels differently. */ + { + BView_SetHighColor (view, color_first); + BView_StrokeLine (f, x0, y0, x1 - 1, y0); + BView_SetHighColor (view, color); + BView_FillRectangle (view, x0, y0 + 1, x1 - x0, y1 - y0 - 2); + BView_SetHighColor (view, color_last); + BView_StrokeLine (view, x0, y1, x1 - 1, y1); + } + else + { + BView_SetHighColor (view, color); + BView_FillRectangleAbs (view, x0, y0, x1, y1); + } + BView_EndClip (view); + BView_draw_unlock (view); +} + +static void +haiku_condemn_scroll_bars (struct frame *frame) +{ + if (!NILP (FRAME_SCROLL_BARS (frame))) + { + if (!NILP (FRAME_CONDEMNED_SCROLL_BARS (frame))) + { + /* Prepend scrollbars to already condemned ones. */ + Lisp_Object last = FRAME_SCROLL_BARS (frame); + + while (!NILP (XSCROLL_BAR (last)->next)) + last = XSCROLL_BAR (last)->next; + + XSCROLL_BAR (last)->next = FRAME_CONDEMNED_SCROLL_BARS (frame); + XSCROLL_BAR (FRAME_CONDEMNED_SCROLL_BARS (frame))->prev = last; + } + + fset_condemned_scroll_bars (frame, FRAME_SCROLL_BARS (frame)); + fset_scroll_bars (frame, Qnil); + } +} + +static void +haiku_redeem_scroll_bar (struct window *w) +{ + struct scroll_bar *bar; + Lisp_Object barobj; + struct frame *f; + + if (!NILP (w->vertical_scroll_bar) && WINDOW_HAS_VERTICAL_SCROLL_BAR (w)) + { + bar = XSCROLL_BAR (w->vertical_scroll_bar); + /* Unlink it from the condemned list. */ + f = XFRAME (WINDOW_FRAME (w)); + if (NILP (bar->prev)) + { + /* If the prev pointer is nil, it must be the first in one of + the lists. */ + if (EQ (FRAME_SCROLL_BARS (f), w->vertical_scroll_bar)) + /* It's not condemned. Everything's fine. */ + goto horizontal; + else if (EQ (FRAME_CONDEMNED_SCROLL_BARS (f), + w->vertical_scroll_bar)) + fset_condemned_scroll_bars (f, bar->next); + else + /* If its prev pointer is nil, it must be at the front of + one or the other! */ + emacs_abort (); + } + else + XSCROLL_BAR (bar->prev)->next = bar->next; + + if (! NILP (bar->next)) + XSCROLL_BAR (bar->next)->prev = bar->prev; + + bar->next = FRAME_SCROLL_BARS (f); + bar->prev = Qnil; + XSETVECTOR (barobj, bar); + fset_scroll_bars (f, barobj); + if (! NILP (bar->next)) + XSETVECTOR (XSCROLL_BAR (bar->next)->prev, bar); + } + horizontal: + if (!NILP (w->horizontal_scroll_bar) && WINDOW_HAS_HORIZONTAL_SCROLL_BAR (w)) + { + bar = XSCROLL_BAR (w->horizontal_scroll_bar); + /* Unlink it from the condemned list. */ + f = XFRAME (WINDOW_FRAME (w)); + if (NILP (bar->prev)) + { + /* If the prev pointer is nil, it must be the first in one of + the lists. */ + if (EQ (FRAME_SCROLL_BARS (f), w->horizontal_scroll_bar)) + /* It's not condemned. Everything's fine. */ + return; + else if (EQ (FRAME_CONDEMNED_SCROLL_BARS (f), + w->horizontal_scroll_bar)) + fset_condemned_scroll_bars (f, bar->next); + else + /* If its prev pointer is nil, it must be at the front of + one or the other! */ + emacs_abort (); + } + else + XSCROLL_BAR (bar->prev)->next = bar->next; + + if (! NILP (bar->next)) + XSCROLL_BAR (bar->next)->prev = bar->prev; + + bar->next = FRAME_SCROLL_BARS (f); + bar->prev = Qnil; + XSETVECTOR (barobj, bar); + fset_scroll_bars (f, barobj); + if (! NILP (bar->next)) + XSETVECTOR (XSCROLL_BAR (bar->next)->prev, bar); + } +} + +static void +haiku_judge_scroll_bars (struct frame *f) +{ + Lisp_Object bar, next; + + bar = FRAME_CONDEMNED_SCROLL_BARS (f); + + /* Clear out the condemned list now so we won't try to process any + more events on the hapless scroll bars. */ + fset_condemned_scroll_bars (f, Qnil); + + for (; ! NILP (bar); bar = next) + { + struct scroll_bar *b = XSCROLL_BAR (bar); + + haiku_scroll_bar_remove (b); + + next = b->next; + b->next = b->prev = Qnil; + } + + /* Now there should be no references to the condemned scroll bars, + and they should get garbage-collected. */ +} + +static struct scroll_bar * +haiku_scroll_bar_create (struct window *w, int left, int top, + int width, int height, bool horizontal_p) +{ + struct frame *f = XFRAME (WINDOW_FRAME (w)); + Lisp_Object barobj; + + void *sb = NULL; + void *vw = FRAME_HAIKU_VIEW (f); + + block_input (); + struct scroll_bar *bar + = ALLOCATE_PSEUDOVECTOR (struct scroll_bar, prev, PVEC_OTHER); + + XSETWINDOW (bar->window, w); + bar->top = top; + bar->left = left; + bar->width = width; + bar->height = height; + bar->position = 0; + bar->total = 0; + bar->dragging = 0; + bar->update = -1; + bar->horizontal = horizontal_p; + + sb = BScrollBar_make_for_view (vw, horizontal_p, + left, top, left + width - 1, + top + height - 1, bar); + + BView_publish_scroll_bar (vw, left, top, width, height); + + bar->next = FRAME_SCROLL_BARS (f); + bar->prev = Qnil; + bar->scroll_bar = sb; + XSETVECTOR (barobj, bar); + fset_scroll_bars (f, barobj); + + if (!NILP (bar->next)) + XSETVECTOR (XSCROLL_BAR (bar->next)->prev, bar); + + unblock_input (); + return bar; +} + +static void +haiku_set_horizontal_scroll_bar (struct window *w, int portion, int whole, int position) +{ + eassert (WINDOW_HAS_HORIZONTAL_SCROLL_BAR (w)); + Lisp_Object barobj; + struct scroll_bar *bar; + int top, height, left, width; + int window_x, window_width; + + /* Get window dimensions. */ + window_box (w, ANY_AREA, &window_x, 0, &window_width, 0); + left = window_x; + width = window_width; + top = WINDOW_SCROLL_BAR_AREA_Y (w); + height = WINDOW_CONFIG_SCROLL_BAR_HEIGHT (w); + + block_input (); + + if (NILP (w->horizontal_scroll_bar)) + { + bar = haiku_scroll_bar_create (w, left, top, width, height, true); + BView_scroll_bar_update (bar->scroll_bar, portion, whole, position); + bar->update = position; + bar->position = position; + bar->total = whole; + } + else + { + bar = XSCROLL_BAR (w->horizontal_scroll_bar); + + if (bar->left != left || bar->top != top || + bar->width != width || bar->height != height) + { + void *view = FRAME_HAIKU_VIEW (WINDOW_XFRAME (w)); + BView_forget_scroll_bar (view, bar->left, bar->top, + bar->width, bar->height); + BView_move_frame (bar->scroll_bar, left, top, + left + width - 1, top + height - 1); + BView_publish_scroll_bar (view, left, top, width, height); + bar->left = left; + bar->top = top; + bar->width = width; + bar->height = height; + } + + if (!bar->dragging) + { + BView_scroll_bar_update (bar->scroll_bar, portion, whole, position); + BView_invalidate (bar->scroll_bar); + } + } + bar->position = position; + bar->total = whole; + XSETVECTOR (barobj, bar); + wset_horizontal_scroll_bar (w, barobj); + unblock_input (); +} + +static void +haiku_set_vertical_scroll_bar (struct window *w, + int portion, int whole, int position) +{ + eassert (WINDOW_HAS_VERTICAL_SCROLL_BAR (w)); + Lisp_Object barobj; + struct scroll_bar *bar; + int top, height, left, width; + int window_y, window_height; + + /* Get window dimensions. */ + window_box (w, ANY_AREA, 0, &window_y, 0, &window_height); + top = window_y; + height = window_height; + + /* Compute the left edge and the width of the scroll bar area. */ + left = WINDOW_SCROLL_BAR_AREA_X (w); + width = WINDOW_SCROLL_BAR_AREA_WIDTH (w); + block_input (); + + if (NILP (w->vertical_scroll_bar)) + { + bar = haiku_scroll_bar_create (w, left, top, width, height, false); + BView_scroll_bar_update (bar->scroll_bar, portion, whole, position); + bar->position = position; + bar->total = whole; + } + else + { + bar = XSCROLL_BAR (w->vertical_scroll_bar); + + if (bar->left != left || bar->top != top || + bar->width != width || bar->height != height) + { + void *view = FRAME_HAIKU_VIEW (WINDOW_XFRAME (w)); + BView_forget_scroll_bar (view, bar->left, bar->top, + bar->width, bar->height); + BView_move_frame (bar->scroll_bar, left, top, + left + width - 1, top + height - 1); + flush_frame (WINDOW_XFRAME (w)); + BView_publish_scroll_bar (view, left, top, width, height); + bar->left = left; + bar->top = top; + bar->width = width; + bar->height = height; + } + + if (!bar->dragging) + { + BView_scroll_bar_update (bar->scroll_bar, portion, whole, position); + bar->update = position; + BView_invalidate (bar->scroll_bar); + } + } + + bar->position = position; + bar->total = whole; + + XSETVECTOR (barobj, bar); + wset_vertical_scroll_bar (w, barobj); + unblock_input (); +} + +static void +haiku_draw_fringe_bitmap (struct window *w, struct glyph_row *row, + struct draw_fringe_bitmap_params *p) +{ + void *view = FRAME_HAIKU_VIEW (XFRAME (WINDOW_FRAME (w))); + struct face *face = p->face; + + BView_draw_lock (view); + BView_StartClip (view); + + haiku_clip_to_row (w, row, ANY_AREA); + if (p->bx >= 0 && !p->overlay_p) + { + BView_SetHighColor (view, face->background); + BView_FillRectangle (view, p->bx, p->by, p->nx, p->ny); + } + + if (p->which && p->which < fringe_bitmap_fillptr) + { + void *bitmap = fringe_bmps[p->which]; + + uint32_t col; + + if (!p->cursor_p) + col = face->foreground; + else if (p->overlay_p) + col = face->background; + else + col = FRAME_CURSOR_COLOR (XFRAME (WINDOW_FRAME (w))).pixel; + + if (!p->overlay_p) + { + BView_SetHighColor (view, face->background); + BView_FillRectangle (view, p->x, p->y, p->wd, p->h); + } + + BView_SetLowColor (view, col); + BView_DrawBitmapWithEraseOp (view, bitmap, p->x, p->y, p->wd, p->h); + } + BView_EndClip (view); + BView_draw_unlock (view); +} + +static void +haiku_define_fringe_bitmap (int which, unsigned short *bits, + int h, int wd) +{ + if (which >= fringe_bitmap_fillptr) + { + int i = fringe_bitmap_fillptr; + fringe_bitmap_fillptr = which + 20; + fringe_bmps = !i ? xmalloc (fringe_bitmap_fillptr * sizeof (void *)) : + xrealloc (fringe_bmps, fringe_bitmap_fillptr * sizeof (void *)); + + while (i < fringe_bitmap_fillptr) + fringe_bmps[i++] = NULL; + } + + fringe_bmps[which] = BBitmap_new (wd, h, 1); + BBitmap_import_mono_bits (fringe_bmps[which], bits, wd, h); +} + +static void +haiku_destroy_fringe_bitmap (int which) +{ + if (which >= fringe_bitmap_fillptr) + return; + + if (fringe_bmps[which]) + BBitmap_free (fringe_bmps[which]); + fringe_bmps[which] = NULL; +} + +static void +haiku_scroll_run (struct window *w, struct run *run) +{ + struct frame *f = XFRAME (w->frame); + void *view = FRAME_HAIKU_VIEW (f); + int x, y, width, height, from_y, to_y, bottom_y; + window_box (w, ANY_AREA, &x, &y, &width, &height); + + from_y = WINDOW_TO_FRAME_PIXEL_Y (w, run->current_y); + to_y = WINDOW_TO_FRAME_PIXEL_Y (w, run->desired_y); + bottom_y = y + height; + + if (to_y < from_y) + { + /* Scrolling up. Make sure we don't copy part of the mode + line at the bottom. */ + if (from_y + run->height > bottom_y) + height = bottom_y - from_y; + else + height = run->height; + } + else + { + /* Scrolling down. Make sure we don't copy over the mode line. + at the bottom. */ + if (to_y + run->height > bottom_y) + height = bottom_y - to_y; + else + height = run->height; + } + + if (!height) + return; + + block_input (); + gui_clear_cursor (w); + BView_draw_lock (view); +#ifdef USE_BE_CAIRO + if (EmacsView_double_buffered_p (view)) + { +#endif + BView_StartClip (view); + BView_CopyBits (view, x, from_y, width, height, + x, to_y, width, height); + BView_EndClip (view); +#ifdef USE_BE_CAIRO + } + else + { + EmacsWindow_begin_cr_critical_section (FRAME_HAIKU_WINDOW (f)); + cairo_surface_t *surface = FRAME_CR_SURFACE (f); + cairo_surface_t *s + = cairo_surface_create_similar (surface, + cairo_surface_get_content (surface), + width, height); + cairo_t *cr = cairo_create (s); + if (surface) + { + cairo_set_source_surface (cr, surface, -x, -from_y); + cairo_paint (cr); + cairo_destroy (cr); + + cr = haiku_begin_cr_clip (f, NULL); + cairo_save (cr); + cairo_set_source_surface (cr, s, x, to_y); + cairo_set_operator (cr, CAIRO_OPERATOR_SOURCE); + cairo_rectangle (cr, x, to_y, width, height); + cairo_fill (cr); + cairo_restore (cr); + cairo_surface_destroy (s); + haiku_end_cr_clip (cr); + } + EmacsWindow_end_cr_critical_section (FRAME_HAIKU_WINDOW (f)); + } +#endif + BView_draw_unlock (view); + + unblock_input (); +} + +static void +haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, + enum scroll_bar_part *part, Lisp_Object *x, Lisp_Object *y, + Time *timestamp) +{ + block_input (); + if (!fp) + return; + Lisp_Object frame, tail; + struct frame *f1 = NULL; + FOR_EACH_FRAME (tail, frame) + XFRAME (frame)->mouse_moved = false; + + if (gui_mouse_grabbed (x_display_list) && !EQ (track_mouse, Qdropping)) + f1 = x_display_list->last_mouse_frame; + + if (!f1 || FRAME_TOOLTIP_P (f1)) + f1 = ((EQ (track_mouse, Qdropping) && gui_mouse_grabbed (x_display_list)) + ? x_display_list->last_mouse_frame + : NULL); + + if (!f1 && insist > 0) + f1 = SELECTED_FRAME (); + + if (!f1 || (!FRAME_HAIKU_P (f1) && (insist > 0))) + FOR_EACH_FRAME (tail, frame) + if (FRAME_HAIKU_P (XFRAME (frame)) && + !FRAME_TOOLTIP_P (XFRAME (frame))) + f1 = XFRAME (frame); + + if (FRAME_TOOLTIP_P (f1)) + f1 = NULL; + + if (f1 && FRAME_HAIKU_P (f1)) + { + int sx, sy; + void *view = FRAME_HAIKU_VIEW (f1); + if (view) + { + BView_get_mouse (view, &sx, &sy); + + remember_mouse_glyph (f1, sx, sy, &x_display_list->last_mouse_glyph); + x_display_list->last_mouse_glyph_frame = f1; + + *bar_window = Qnil; + *part = scroll_bar_above_handle; + *fp = f1; + XSETINT (*x, sx); + XSETINT (*y, sy); + } + } + + unblock_input (); +} + +static void +haiku_flush (struct frame *f) +{ + if (FRAME_VISIBLE_P (f)) + BWindow_Flush (FRAME_HAIKU_WINDOW (f)); +} + +static void +haiku_define_frame_cursor (struct frame *f, Emacs_Cursor cursor) +{ + if (f->tooltip) + return; + block_input (); + if (!f->pointer_invisible && FRAME_HAIKU_VIEW (f) + && !FRAME_OUTPUT_DATA (f)->hourglass_p) + BView_set_view_cursor (FRAME_HAIKU_VIEW (f), cursor); + unblock_input (); + FRAME_OUTPUT_DATA (f)->current_cursor = cursor; +} + +static void +haiku_update_window_end (struct window *w, bool cursor_on_p, + bool mouse_face_overwritten_p) +{ + +} + +static void +haiku_default_font_parameter (struct frame *f, Lisp_Object parms) +{ + struct haiku_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + Lisp_Object font_param = gui_display_get_arg (dpyinfo, parms, Qfont, NULL, NULL, + RES_TYPE_STRING); + Lisp_Object font = Qnil; + if (EQ (font_param, Qunbound)) + font_param = Qnil; + + if (NILP (font_param)) + { + /* System font should take precedence over X resources. We suggest this + regardless of font-use-system-font because .emacs may not have been + read yet. */ + struct haiku_font_pattern ptn; + ptn.specified = 0; + + if (f->tooltip) + BFont_populate_plain_family (&ptn); + else + BFont_populate_fixed_family (&ptn); + + if (ptn.specified & FSPEC_FAMILY) + font = font_open_by_name (f, build_unibyte_string (ptn.family)); + } + + if (NILP (font)) + font = !NILP (font_param) ? font_param + : gui_display_get_arg (dpyinfo, parms, Qfont, "font", "Font", + RES_TYPE_STRING); + + if (! FONTP (font) && ! STRINGP (font)) + { + const char **names = (const char *[]) { "monospace-12", + "Noto Sans Mono-12", + "Source Code Pro-12", + NULL }; + int i; + + for (i = 0; names[i]; i++) + { + font + = font_open_by_name (f, build_unibyte_string (names[i])); + if (!NILP (font)) + break; + } + if (NILP (font)) + error ("No suitable font was found"); + } + else if (!NILP (font_param)) + { + /* Remember the explicit font parameter, so we can re-apply it + after we've applied the `default' face settings. */ + AUTO_FRAME_ARG (arg, Qfont_parameter, font_param); + gui_set_frame_parameters (f, arg); + } + + gui_default_parameter (f, parms, Qfont, font, "font", "Font", + RES_TYPE_STRING); +} + +static struct redisplay_interface haiku_redisplay_interface = + { + haiku_frame_parm_handlers, + gui_produce_glyphs, + gui_write_glyphs, + gui_insert_glyphs, + gui_clear_end_of_line, + haiku_scroll_run, + haiku_after_update_window_line, + NULL, + haiku_update_window_end, + haiku_flush, + gui_clear_window_mouse_face, + gui_get_glyph_overhangs, + gui_fix_overlapping_area, + haiku_draw_fringe_bitmap, + haiku_define_fringe_bitmap, + haiku_destroy_fringe_bitmap, + haiku_compute_glyph_string_overhangs, + haiku_draw_glyph_string, + haiku_define_frame_cursor, + haiku_clear_frame_area, + haiku_clear_under_internal_border, + haiku_draw_window_cursor, + haiku_draw_vertical_window_border, + haiku_draw_window_divider, + 0, /* shift glyphs for insert */ + haiku_show_hourglass, + haiku_hide_hourglass, + haiku_default_font_parameter, + }; + +static void +haiku_make_fullscreen_consistent (struct frame *f) +{ + Lisp_Object lval = get_frame_param (f, Qfullscreen); + + if (!EQ (lval, Qmaximized) && FRAME_OUTPUT_DATA (f)->zoomed_p) + lval = Qmaximized; + else if (EQ (lval, Qmaximized) && !FRAME_OUTPUT_DATA (f)->zoomed_p) + lval = Qnil; + + store_frame_param (f, Qfullscreen, lval); +} + +static int +haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) +{ + block_input (); + int message_count = 0; + static void *buf = NULL; + ssize_t b_size; + struct unhandled_event *unhandled_events = NULL; + + if (!buf) + buf = xmalloc (200); + haiku_read_size (&b_size); + while (b_size >= 0) + { + enum haiku_event_type type; + struct input_event inev, inev2; + + if (b_size > 200) + emacs_abort (); + + EVENT_INIT (inev); + EVENT_INIT (inev2); + inev.kind = NO_EVENT; + inev2.kind = NO_EVENT; + inev.arg = Qnil; + inev2.arg = Qnil; + + haiku_read (&type, buf, b_size); + + switch (type) + { + case QUIT_REQUESTED: + { + struct haiku_quit_requested_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + inev.kind = DELETE_WINDOW_EVENT; + XSETFRAME (inev.frame_or_window, f); + break; + } + case FRAME_RESIZED: + { + struct haiku_resize_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + int width = (int) b->px_widthf; + int height = (int) b->px_heightf; + + BView_draw_lock (FRAME_HAIKU_VIEW (f)); + BView_resize_to (FRAME_HAIKU_VIEW (f), width, height); + BView_draw_unlock (FRAME_HAIKU_VIEW (f)); + if (width != FRAME_PIXEL_WIDTH (f) + || height != FRAME_PIXEL_HEIGHT (f) + || (f->new_size_p + && ((f->new_width >= 0 && width != f->new_width) + || (f->new_height >= 0 && height != f->new_height)))) + { + change_frame_size (f, width, height, false, true, false); + SET_FRAME_GARBAGED (f); + cancel_mouse_face (f); + haiku_clear_under_internal_border (f); + } + + if (FRAME_OUTPUT_DATA (f)->pending_zoom_width != width || + FRAME_OUTPUT_DATA (f)->pending_zoom_height != height) + { + FRAME_OUTPUT_DATA (f)->zoomed_p = 0; + haiku_make_fullscreen_consistent (f); + } + else + { + FRAME_OUTPUT_DATA (f)->zoomed_p = 1; + FRAME_OUTPUT_DATA (f)->pending_zoom_width = INT_MIN; + FRAME_OUTPUT_DATA (f)->pending_zoom_height = INT_MIN; + } + break; + } + case FRAME_EXPOSED: + { + struct haiku_expose_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + expose_frame (f, b->x, b->y, b->width, b->height); + + haiku_clear_under_internal_border (f); + break; + } + case KEY_DOWN: + { + struct haiku_key_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + int non_ascii_p; + if (!f) + continue; + + inev.code = b->unraw_mb_char; + + BMapKey (b->kc, &non_ascii_p, &inev.code); + + if (non_ascii_p) + inev.kind = NON_ASCII_KEYSTROKE_EVENT; + else + inev.kind = inev.code > 127 ? MULTIBYTE_CHAR_KEYSTROKE_EVENT : + ASCII_KEYSTROKE_EVENT; + + inev.modifiers = haiku_modifiers_to_emacs (b->modifiers); + XSETFRAME (inev.frame_or_window, f); + break; + } + case ACTIVATION: + { + struct haiku_activation_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + if ((x_display_list->focus_event_frame != f && b->activated_p) || + (x_display_list->focus_event_frame == f && !b->activated_p)) + { + haiku_new_focus_frame (b->activated_p ? f : NULL); + if (b->activated_p) + x_display_list->focus_event_frame = f; + else + x_display_list->focus_event_frame = NULL; + inev.kind = b->activated_p ? FOCUS_IN_EVENT : FOCUS_OUT_EVENT; + XSETFRAME (inev.frame_or_window, f); + } + + break; + } + case MOUSE_MOTION: + { + struct haiku_mouse_motion_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + Lisp_Object frame; + XSETFRAME (frame, f); + + if (b->just_exited_p) + { + Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f); + if (f == hlinfo->mouse_face_mouse_frame) + { + /* If we move outside the frame, then we're + certainly no longer on any text in the frame. */ + clear_mouse_face (hlinfo); + hlinfo->mouse_face_mouse_frame = 0; + } + + haiku_new_focus_frame (x_display_list->focused_frame); + help_echo_string = Qnil; + gen_help_event (Qnil, frame, Qnil, Qnil, 0); + } + else + { + struct haiku_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + struct haiku_rect r = dpyinfo->last_mouse_glyph; + + dpyinfo->last_mouse_motion_x = b->x; + dpyinfo->last_mouse_motion_y = b->y; + dpyinfo->last_mouse_motion_frame = f; + + previous_help_echo_string = help_echo_string; + help_echo_string = Qnil; + + if (f != dpyinfo->last_mouse_glyph_frame || + b->x < r.x || b->x >= r.x + r.width - 1 || b->y < r.y || + b->y >= r.y + r.height - 1) + { + f->mouse_moved = true; + dpyinfo->last_mouse_scroll_bar = NULL; + note_mouse_highlight (f, b->x, b->y); + remember_mouse_glyph (f, b->x, b->y, + &FRAME_DISPLAY_INFO (f)->last_mouse_glyph); + dpyinfo->last_mouse_glyph_frame = f; + gen_help_event (help_echo_string, frame, help_echo_window, + help_echo_object, help_echo_pos); + } + + if (MOUSE_HL_INFO (f)->mouse_face_hidden) + { + MOUSE_HL_INFO (f)->mouse_face_hidden = 0; + clear_mouse_face (MOUSE_HL_INFO (f)); + } + + if (!NILP (Vmouse_autoselect_window)) + { + static Lisp_Object last_mouse_window; + Lisp_Object window = window_from_coordinates (f, b->x, b->y, 0, 0, 0); + + if (WINDOWP (window) + && !EQ (window, last_mouse_window) + && !EQ (window, selected_window) + && (!NILP (focus_follows_mouse) + || (EQ (XWINDOW (window)->frame, + XWINDOW (selected_window)->frame)))) + { + inev.kind = SELECT_WINDOW_EVENT; + inev.frame_or_window = window; + } + + last_mouse_window = window; + } + } + break; + } + case BUTTON_UP: + case BUTTON_DOWN: + { + struct haiku_button_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + Lisp_Object tab_bar_arg = Qnil; + int tab_bar_p = 0, tool_bar_p = 0; + + if (!f) + continue; + + struct haiku_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + + inev.modifiers = haiku_modifiers_to_emacs (b->modifiers); + + x_display_list->last_mouse_glyph_frame = 0; + + /* Is this in the tab-bar? */ + if (WINDOWP (f->tab_bar_window) + && WINDOW_TOTAL_LINES (XWINDOW (f->tab_bar_window))) + { + Lisp_Object window; + int x = b->x; + int y = b->y; + + window = window_from_coordinates (f, x, y, 0, true, true); + tab_bar_p = EQ (window, f->tab_bar_window); + + if (tab_bar_p) + tab_bar_arg = handle_tab_bar_click + (f, x, y, type == BUTTON_DOWN, inev.modifiers); + } + + if (WINDOWP (f->tool_bar_window) + && WINDOW_TOTAL_LINES (XWINDOW (f->tool_bar_window))) + { + Lisp_Object window; + int x = b->x; + int y = b->y; + + window = window_from_coordinates (f, x, y, 0, true, true); + tool_bar_p = EQ (window, f->tool_bar_window); + + if (tool_bar_p) + handle_tool_bar_click + (f, x, y, type == BUTTON_DOWN, inev.modifiers); + } + + if (type == BUTTON_UP) + { + inev.modifiers |= up_modifier; + dpyinfo->grabbed &= ~(1 << b->btn_no); + } + else + { + inev.modifiers |= down_modifier; + dpyinfo->last_mouse_frame = f; + dpyinfo->grabbed |= (1 << b->btn_no); + if (f && !tab_bar_p) + f->last_tab_bar_item = -1; + if (f && !tool_bar_p) + f->last_tool_bar_item = -1; + } + + if (!(tab_bar_p && NILP (tab_bar_arg)) && !tool_bar_p) + inev.kind = MOUSE_CLICK_EVENT; + inev.arg = tab_bar_arg; + inev.code = b->btn_no; + + inev.modifiers |= type == BUTTON_UP ? + up_modifier : down_modifier; + + XSETINT (inev.x, b->x); + XSETINT (inev.y, b->y); + + XSETFRAME (inev.frame_or_window, f); + break; + } + case ICONIFICATION: + { + struct haiku_iconification_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + if (!b->iconified_p) + { + SET_FRAME_VISIBLE (f, 1); + SET_FRAME_ICONIFIED (f, 0); + inev.kind = DEICONIFY_EVENT; + + + /* Haiku doesn't expose frames on deiconification, but + if we are double-buffered, the previous screen + contents should have been preserved. */ + if (!EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f))) + { + SET_FRAME_GARBAGED (f); + expose_frame (f, 0, 0, 0, 0); + } + } + else + { + SET_FRAME_VISIBLE (f, 0); + SET_FRAME_ICONIFIED (f, 1); + inev.kind = ICONIFY_EVENT; + } + + XSETFRAME (inev.frame_or_window, f); + break; + } + case MOVE_EVENT: + { + struct haiku_move_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + if (FRAME_OUTPUT_DATA (f)->pending_zoom_x != b->x || + FRAME_OUTPUT_DATA (f)->pending_zoom_y != b->y) + FRAME_OUTPUT_DATA (f)->zoomed_p = 0; + else + { + FRAME_OUTPUT_DATA (f)->zoomed_p = 1; + FRAME_OUTPUT_DATA (f)->pending_zoom_x = INT_MIN; + FRAME_OUTPUT_DATA (f)->pending_zoom_y = INT_MIN; + } + + if (FRAME_PARENT_FRAME (f)) + haiku_coords_from_parent (f, &b->x, &b->y); + + if (b->x != f->left_pos || b->y != f->top_pos) + { + inev.kind = MOVE_FRAME_EVENT; + + XSETINT (inev.x, b->x); + XSETINT (inev.y, b->y); + + f->left_pos = b->x; + f->top_pos = b->y; + + struct frame *p; + + if ((p = FRAME_PARENT_FRAME (f))) + { + void *window = FRAME_HAIKU_WINDOW (p); + EmacsWindow_move_weak_child (window, b->window, b->x, b->y); + } + + XSETFRAME (inev.frame_or_window, f); + } + + haiku_make_fullscreen_consistent (f); + break; + } + case SCROLL_BAR_VALUE_EVENT: + { + struct haiku_scroll_bar_value_event *b = buf; + struct scroll_bar *bar = b->scroll_bar; + + struct window *w = XWINDOW (bar->window); + + if (bar->update != -1) + { + bar->update = -1; + break; + } + + if (bar->position != b->position) + { + inev.kind = bar->horizontal ? HORIZONTAL_SCROLL_BAR_CLICK_EVENT : + SCROLL_BAR_CLICK_EVENT; + inev.part = bar->horizontal ? + scroll_bar_horizontal_handle : scroll_bar_handle; + + XSETINT (inev.x, b->position); + XSETINT (inev.y, bar->total); + XSETWINDOW (inev.frame_or_window, w); + } + break; + } + case SCROLL_BAR_DRAG_EVENT: + { + struct haiku_scroll_bar_drag_event *b = buf; + struct scroll_bar *bar = b->scroll_bar; + + bar->dragging = b->dragging_p; + if (!b->dragging_p && bar->horizontal) + set_horizontal_scroll_bar (XWINDOW (bar->window)); + else if (!b->dragging_p) + set_vertical_scroll_bar (XWINDOW (bar->window)); + break; + } + case WHEEL_MOVE_EVENT: + { + struct haiku_wheel_move_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + int x, y; + static float px = 0.0f, py = 0.0f; + + if (!f) + continue; + BView_get_mouse (FRAME_HAIKU_VIEW (f), &x, &y); + + inev.modifiers = haiku_modifiers_to_emacs (b->modifiers); + + inev2.modifiers = inev.modifiers; + + if (signbit (px) != signbit (b->delta_x)) + px = 0; + + if (signbit (py) != signbit (b->delta_y)) + py = 0; + + px += b->delta_x; + py += b->delta_y; + + if (fabsf (py) >= FRAME_LINE_HEIGHT (f)) + { + inev.kind = WHEEL_EVENT; + inev.code = 0; + + XSETINT (inev.x, x); + XSETINT (inev.y, y); + XSETINT (inev.arg, lrint (fabsf (py) / FRAME_LINE_HEIGHT (f))); + XSETFRAME (inev.frame_or_window, f); + + inev.modifiers |= signbit (py) ? up_modifier : down_modifier; + py = 0.0f; + } + + if (fabsf (px) >= FRAME_COLUMN_WIDTH (f)) + { + inev2.kind = HORIZ_WHEEL_EVENT; + inev2.code = 0; + + XSETINT (inev2.x, x); + XSETINT (inev2.y, y); + XSETINT (inev2.arg, lrint (fabsf (px) / FRAME_COLUMN_WIDTH (f))); + XSETFRAME (inev2.frame_or_window, f); + + inev2.modifiers |= signbit (px) ? up_modifier : down_modifier; + px = 0.0f; + } + + break; + } + + case MENU_BAR_RESIZE: + { + struct haiku_menu_bar_resize_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f || !FRAME_EXTERNAL_MENU_BAR (f)) + continue; + + int old_height = FRAME_MENU_BAR_HEIGHT (f); + + FRAME_MENU_BAR_HEIGHT (f) = b->height + 1; + FRAME_MENU_BAR_LINES (f) = + (b->height + FRAME_LINE_HEIGHT (f)) / FRAME_LINE_HEIGHT (f); + + if (old_height != b->height) + { + adjust_frame_size (f, -1, -1, 3, true, Qmenu_bar_lines); + haiku_clear_under_internal_border (f); + } + break; + } + case MENU_BAR_OPEN: + case MENU_BAR_CLOSE: + { + struct haiku_menu_bar_state_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f || !FRAME_EXTERNAL_MENU_BAR (f)) + continue; + + if (type == MENU_BAR_OPEN) + { + if (!FRAME_OUTPUT_DATA (f)->menu_up_to_date_p) + { + BView_draw_lock (FRAME_HAIKU_VIEW (f)); + /* This shouldn't be here, but nsmenu does it, so + it should probably be safe. */ + int was_waiting_for_input_p = waiting_for_input; + if (waiting_for_input) + waiting_for_input = 0; + set_frame_menubar (f, 1); + waiting_for_input = was_waiting_for_input_p; + BView_draw_unlock (FRAME_HAIKU_VIEW (f)); + } + FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 1; + popup_activated_p += 1; + } + else + { + if (!popup_activated_p) + emacs_abort (); + if (FRAME_OUTPUT_DATA (f)->menu_bar_open_p) + { + FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 0; + popup_activated_p -= 1; + } + } + break; + } + case MENU_BAR_SELECT_EVENT: + { + struct haiku_menu_bar_select_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f || !FRAME_EXTERNAL_MENU_BAR (f)) + continue; + + if (FRAME_OUTPUT_DATA (f)->menu_up_to_date_p) + find_and_call_menu_selection (f, f->menu_bar_items_used, + f->menu_bar_vector, b->ptr); + break; + } + case FILE_PANEL_EVENT: + { + if (!popup_activated_p) + continue; + + struct unhandled_event *ev = xmalloc (sizeof *ev); + ev->next = unhandled_events; + ev->type = type; + memcpy (&ev->buffer, buf, 200); + + unhandled_events = ev; + break; + } + case MENU_BAR_HELP_EVENT: + { + struct haiku_menu_bar_help_event *b = buf; + + if (!popup_activated_p) + continue; + + struct frame *f = haiku_window_to_frame (b->window); + if (!f || !FRAME_EXTERNAL_MENU_BAR (f) || + !FRAME_OUTPUT_DATA (f)->menu_bar_open_p) + continue; + + run_menu_bar_help_event (f, b->mb_idx); + + break; + } + case ZOOM_EVENT: + { + struct haiku_zoom_event *b = buf; + + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + FRAME_OUTPUT_DATA (f)->pending_zoom_height = b->height; + FRAME_OUTPUT_DATA (f)->pending_zoom_width = b->width; + FRAME_OUTPUT_DATA (f)->pending_zoom_x = b->x; + FRAME_OUTPUT_DATA (f)->pending_zoom_y = b->y; + + FRAME_OUTPUT_DATA (f)->zoomed_p = 1; + haiku_make_fullscreen_consistent (f); + break; + } + case REFS_EVENT: + { + struct haiku_refs_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f) + continue; + + inev.kind = DRAG_N_DROP_EVENT; + inev.arg = build_string_from_utf8 (b->ref); + + XSETINT (inev.x, b->x); + XSETINT (inev.y, b->y); + XSETFRAME (inev.frame_or_window, f); + + /* There should be no problem with calling free here. + free on Haiku is thread-safe. */ + free (b->ref); + break; + } + case APP_QUIT_REQUESTED_EVENT: + case KEY_UP: + default: + break; + } + + haiku_read_size (&b_size); + + if (inev.kind != NO_EVENT) + { + kbd_buffer_store_event_hold (&inev, hold_quit); + ++message_count; + } + + if (inev2.kind != NO_EVENT) + { + kbd_buffer_store_event_hold (&inev2, hold_quit); + ++message_count; + } + } + + for (struct unhandled_event *ev = unhandled_events; ev;) + { + haiku_write_without_signal (ev->type, &ev->buffer); + struct unhandled_event *old = ev; + ev = old->next; + xfree (old); + } + + unblock_input (); + return message_count; +} + +static void +haiku_frame_rehighlight (struct frame *frame) +{ + haiku_rehighlight (); +} + +static void +haiku_delete_window (struct frame *f) +{ + check_window_system (f); + haiku_free_frame_resources (f); +} + +static void +haiku_free_pixmap (struct frame *f, Emacs_Pixmap pixmap) +{ + BBitmap_free (pixmap); +} + +static void +haiku_beep (struct frame *f) +{ + if (visible_bell) + { + void *view = FRAME_HAIKU_VIEW (f); + if (view) + { + block_input (); + BView_draw_lock (view); + if (!EmacsView_double_buffered_p (view)) + { + BView_SetHighColorForVisibleBell (view, FRAME_FOREGROUND_PIXEL (f)); + BView_FillRectangleForVisibleBell (view, 0, 0, FRAME_PIXEL_WIDTH (f), + FRAME_PIXEL_HEIGHT (f)); + SET_FRAME_GARBAGED (f); + expose_frame (f, 0, 0, 0, 0); + } + else + { + EmacsView_do_visible_bell (view, FRAME_FOREGROUND_PIXEL (f)); + haiku_flip_buffers (f); + } + BView_draw_unlock (view); + unblock_input (); + } + } + else + haiku_ring_bell (); +} + +static void +haiku_toggle_invisible_pointer (struct frame *f, bool invisible_p) +{ + void *view = FRAME_HAIKU_VIEW (f); + + if (view) + { + block_input (); + BView_set_view_cursor (view, invisible_p ? + FRAME_OUTPUT_DATA (f)->no_cursor : + FRAME_OUTPUT_DATA (f)->current_cursor); + f->pointer_invisible = invisible_p; + unblock_input (); + } +} + +static void +haiku_fullscreen (struct frame *f) +{ + if (f->want_fullscreen == FULLSCREEN_MAXIMIZED) + { + EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 0); + BWindow_zoom (FRAME_HAIKU_WINDOW (f)); + } + else if (f->want_fullscreen == FULLSCREEN_BOTH) + EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 1); + else if (f->want_fullscreen == FULLSCREEN_NONE) + { + EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 0); + EmacsWindow_unzoom (FRAME_HAIKU_WINDOW (f)); + } + + f->want_fullscreen = FULLSCREEN_NONE; + + haiku_update_size_hints (f); +} + +static struct terminal * +haiku_create_terminal (struct haiku_display_info *dpyinfo) +{ + struct terminal *terminal; + + terminal = create_terminal (output_haiku, &haiku_redisplay_interface); + + terminal->display_info.haiku = dpyinfo; + dpyinfo->terminal = terminal; + terminal->kboard = allocate_kboard (Qhaiku); + + terminal->iconify_frame_hook = haiku_iconify_frame; + terminal->focus_frame_hook = haiku_focus_frame; + terminal->ring_bell_hook = haiku_beep; + terminal->popup_dialog_hook = haiku_popup_dialog; + terminal->frame_visible_invisible_hook = haiku_set_frame_visible_invisible; + terminal->set_frame_offset_hook = haiku_set_offset; + terminal->delete_terminal_hook = haiku_delete_terminal; + terminal->get_string_resource_hook = get_string_resource; + terminal->set_new_font_hook = haiku_new_font; + terminal->defined_color_hook = haiku_defined_color; + terminal->set_window_size_hook = haiku_set_window_size; + terminal->read_socket_hook = haiku_read_socket; + terminal->implicit_set_name_hook = haiku_implicitly_set_name; + terminal->mouse_position_hook = haiku_mouse_position; + terminal->delete_frame_hook = haiku_delete_window; + terminal->frame_up_to_date_hook = haiku_frame_up_to_date; + terminal->buffer_flipping_unblocked_hook = haiku_buffer_flipping_unblocked_hook; + terminal->clear_frame_hook = haiku_clear_frame; + terminal->change_tab_bar_height_hook = haiku_change_tab_bar_height; + terminal->change_tool_bar_height_hook = haiku_change_tool_bar_height; + terminal->set_vertical_scroll_bar_hook = haiku_set_vertical_scroll_bar; + terminal->set_horizontal_scroll_bar_hook = haiku_set_horizontal_scroll_bar; + terminal->set_scroll_bar_default_height_hook = haiku_set_scroll_bar_default_height; + terminal->set_scroll_bar_default_width_hook = haiku_set_scroll_bar_default_width; + terminal->judge_scroll_bars_hook = haiku_judge_scroll_bars; + terminal->condemn_scroll_bars_hook = haiku_condemn_scroll_bars; + terminal->redeem_scroll_bar_hook = haiku_redeem_scroll_bar; + terminal->update_begin_hook = haiku_update_begin; + terminal->update_end_hook = haiku_update_end; + terminal->frame_rehighlight_hook = haiku_frame_rehighlight; + terminal->query_frame_background_color = haiku_query_frame_background_color; + terminal->free_pixmap = haiku_free_pixmap; + terminal->frame_raise_lower_hook = haiku_frame_raise_lower; + terminal->menu_show_hook = haiku_menu_show; + terminal->toggle_invisible_pointer_hook = haiku_toggle_invisible_pointer; + terminal->fullscreen_hook = haiku_fullscreen; + + return terminal; +} + +struct haiku_display_info * +haiku_term_init (void) +{ + struct haiku_display_info *dpyinfo; + struct terminal *terminal; + + Lisp_Object color_file, color_map; + + block_input (); + Fset_input_interrupt_mode (Qnil); + + baud_rate = 19200; + + dpyinfo = xzalloc (sizeof *dpyinfo); + + haiku_io_init (); + + if (port_application_to_emacs < B_OK) + emacs_abort (); + + color_file = Fexpand_file_name (build_string ("rgb.txt"), + Fsymbol_value (intern ("data-directory"))); + + color_map = Fx_load_color_file (color_file); + if (NILP (color_map)) + fatal ("Could not read %s.\n", SDATA (color_file)); + + dpyinfo->color_map = color_map; + + dpyinfo->display = BApplication_setup (); + + BScreen_res (&dpyinfo->resx, &dpyinfo->resy); + + dpyinfo->next = x_display_list; + dpyinfo->n_planes = be_get_display_planes (); + x_display_list = dpyinfo; + + terminal = haiku_create_terminal (dpyinfo); + if (current_kboard == initial_kboard) + current_kboard = terminal->kboard; + + terminal->kboard->reference_count++; + /* Never delete haiku displays -- there can only ever be one, + anyhow. */ + terminal->reference_count++; + terminal->name = xstrdup ("be"); + + dpyinfo->name_list_element = Fcons (build_string ("be"), Qnil); + dpyinfo->smallest_font_height = 1; + dpyinfo->smallest_char_width = 1; + + gui_init_fringe (terminal->rif); + unblock_input (); + + return dpyinfo; +} + +void +put_xrm_resource (Lisp_Object name, Lisp_Object val) +{ + eassert (STRINGP (name)); + eassert (STRINGP (val) || NILP (val)); + + Lisp_Object lval = assoc_no_quit (name, rdb); + if (!NILP (lval)) + Fsetcdr (lval, val); + else + rdb = Fcons (Fcons (name, val), rdb); +} + +void +haiku_clear_under_internal_border (struct frame *f) +{ + if (FRAME_INTERNAL_BORDER_WIDTH (f) > 0) + { + int border = FRAME_INTERNAL_BORDER_WIDTH (f); + int width = FRAME_PIXEL_WIDTH (f); + int height = FRAME_PIXEL_HEIGHT (f); + int margin = FRAME_TOP_MARGIN_HEIGHT (f); + int face_id = + (FRAME_PARENT_FRAME (f) + ? (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, CHILD_FRAME_BORDER_FACE_ID) + : CHILD_FRAME_BORDER_FACE_ID) + : (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) + : INTERNAL_BORDER_FACE_ID)); + struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); + void *view = FRAME_HAIKU_VIEW (f); + block_input (); + BView_draw_lock (view); + BView_StartClip (view); + BView_ClipToRect (view, 0, 0, FRAME_PIXEL_WIDTH (f), + FRAME_PIXEL_HEIGHT (f)); + + if (face) + BView_SetHighColor (view, face->background); + else + BView_SetHighColor (view, FRAME_BACKGROUND_PIXEL (f)); + + BView_FillRectangle (view, 0, margin, width, border); + BView_FillRectangle (view, 0, 0, border, height); + BView_FillRectangle (view, 0, margin, width, border); + BView_FillRectangle (view, width - border, 0, border, height); + BView_FillRectangle (view, 0, height - border, width, border); + BView_EndClip (view); + BView_draw_unlock (view); + unblock_input (); + } +} + +void +mark_haiku_display (void) +{ + if (x_display_list) + mark_object (x_display_list->color_map); +} + +void +haiku_scroll_bar_remove (struct scroll_bar *bar) +{ + block_input (); + void *view = FRAME_HAIKU_VIEW (WINDOW_XFRAME (XWINDOW (bar->window))); + BView_forget_scroll_bar (view, bar->left, bar->top, bar->width, bar->height); + BScrollBar_delete (bar->scroll_bar); + expose_frame (WINDOW_XFRAME (XWINDOW (bar->window)), + bar->left, bar->top, bar->width, bar->height); + + if (bar->horizontal) + wset_horizontal_scroll_bar (XWINDOW (bar->window), Qnil); + else + wset_vertical_scroll_bar (XWINDOW (bar->window), Qnil); + + unblock_input (); +}; + +void +haiku_set_offset (struct frame *frame, int x, int y, + int change_gravity) +{ + if (change_gravity > 0) + { + frame->top_pos = y; + frame->left_pos = x; + frame->size_hint_flags &= ~ (XNegative | YNegative); + if (x < 0) + frame->size_hint_flags |= XNegative; + if (y < 0) + frame->size_hint_flags |= YNegative; + frame->win_gravity = NorthWestGravity; + } + + haiku_update_size_hints (frame); + + block_input (); + if (change_gravity) + BWindow_set_offset (FRAME_HAIKU_WINDOW (frame), x, y); + unblock_input (); +} + +#ifdef USE_BE_CAIRO +cairo_t * +haiku_begin_cr_clip (struct frame *f, struct glyph_string *s) +{ + cairo_surface_t *surface = FRAME_CR_SURFACE (f); + if (!surface) + return NULL; + + cairo_t *context = cairo_create (surface); + return context; +} + +void +haiku_end_cr_clip (cairo_t *cr) +{ + cairo_destroy (cr); +} +#endif + +void +syms_of_haikuterm (void) +{ + DEFVAR_BOOL ("haiku-initialized", haiku_initialized, + doc: /* Non-nil if the Haiku terminal backend has been initialized. */); + + DEFVAR_BOOL ("x-use-underline-position-properties", + x_use_underline_position_properties, + doc: /* SKIP: real doc in xterm.c. */); + x_use_underline_position_properties = 1; + + DEFVAR_BOOL ("x-underline-at-descent-line", + x_underline_at_descent_line, + doc: /* SKIP: real doc in xterm.c. */); + x_underline_at_descent_line = 0; + + DEFVAR_LISP ("x-toolkit-scroll-bars", Vx_toolkit_scroll_bars, + doc: /* SKIP: real doc in xterm.c. */); + Vx_toolkit_scroll_bars = Qt; + + DEFVAR_BOOL ("haiku-debug-on-fatal-error", haiku_debug_on_fatal_error, + doc: /* If non-nil, Emacs will launch the system debugger upon a fatal error. */); + haiku_debug_on_fatal_error = 1; + + DEFSYM (Qshift, "shift"); + DEFSYM (Qcontrol, "control"); + DEFSYM (Qoption, "option"); + DEFSYM (Qcommand, "command"); + + DEFVAR_LISP ("haiku-meta-keysym", Vhaiku_meta_keysym, + doc: /* Which key Emacs uses as the meta modifier. +This is either one of the symbols `shift', `control', `command', and +`option', or nil, in which case it is treated as `command'. + +Setting it to any other value is equivalent to `command'. */); + Vhaiku_meta_keysym = Qnil; + + DEFVAR_LISP ("haiku-control-keysym", Vhaiku_control_keysym, + doc: /* Which key Emacs uses as the control modifier. +This is either one of the symbols `shift', `control', `command', and +`option', or nil, in which case it is treated as `control'. + +Setting it to any other value is equivalent to `control'. */); + Vhaiku_control_keysym = Qnil; + + DEFVAR_LISP ("haiku-super-keysym", Vhaiku_super_keysym, + doc: /* Which key Emacs uses as the super modifier. +This is either one of the symbols `shift', `control', `command', and +`option', or nil, in which case it is treated as `option'. + +Setting it to any other value is equivalent to `option'. */); + Vhaiku_super_keysym = Qnil; + + DEFVAR_LISP ("haiku-shift-keysym", Vhaiku_shift_keysym, + doc: /* Which key Emacs uses as the shift modifier. +This is either one of the symbols `shift', `control', `command', and +`option', or nil, in which case it is treated as `shift'. + +Setting it to any other value is equivalent to `shift'. */); + Vhaiku_shift_keysym = Qnil; + + + DEFSYM (Qx_use_underline_position_properties, + "x-use-underline-position-properties"); + + DEFSYM (Qx_underline_at_descent_line, "x-underline-at-descent-line"); + + rdb = Qnil; + staticpro (&rdb); + + Fprovide (Qhaiku, Qnil); +#ifdef HAVE_BE_FREETYPE + Fprovide (Qfreetype, Qnil); +#endif +#ifdef USE_BE_CAIRO + Fprovide (intern_c_string ("cairo"), Qnil); +#endif +} diff --git a/src/haikuterm.h b/src/haikuterm.h new file mode 100644 index 0000000000..af55f68c67 --- /dev/null +++ b/src/haikuterm.h @@ -0,0 +1,293 @@ +/* Haiku window system support + Copyright (C) 2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#ifndef _HAIKU_TERM_H_ +#define _HAIKU_TERM_H_ + +#include + +#ifdef USE_BE_CAIRO +#include +#endif + +#include "haikugui.h" +#include "frame.h" +#include "character.h" +#include "dispextern.h" +#include "font.h" + +#define C_FRAME struct frame * +#define C_FONT struct font * +#define C_TERMINAL struct terminal * + +#define HAVE_CHAR_CACHE_MAX 65535 + +extern int popup_activated_p; + +extern void be_app_quit (void); + +struct haikufont_info +{ + struct font font; + haiku be_font; + struct font_metrics **metrics; + short metrics_nrows; + + unsigned short **glyphs; +}; + +struct haiku_bitmap_record +{ + haiku img; + char *file; + int refcount; + int height, width, depth; +}; + +struct haiku_display_info +{ + /* Chain of all haiku_display_info structures. */ + struct haiku_display_info *next; + C_TERMINAL terminal; + + Lisp_Object name_list_element; + Lisp_Object color_map; + + int n_fonts; + + int smallest_char_width; + int smallest_font_height; + + struct frame *focused_frame; + struct frame *focus_event_frame; + struct frame *last_mouse_glyph_frame; + + struct haiku_bitmap_record *bitmaps; + ptrdiff_t bitmaps_size; + ptrdiff_t bitmaps_last; + + int grabbed; + int n_planes; + int color_p; + + Window root_window; + Lisp_Object rdb; + + Emacs_Cursor vertical_scroll_bar_cursor; + Emacs_Cursor horizontal_scroll_bar_cursor; + + Mouse_HLInfo mouse_highlight; + + C_FRAME highlight_frame; + C_FRAME last_mouse_frame; + C_FRAME last_mouse_motion_frame; + + int last_mouse_motion_x; + int last_mouse_motion_y; + + struct haiku_rect last_mouse_glyph; + + void *last_mouse_scroll_bar; + + haiku display; + + double resx, resy; +}; + +struct haiku_output +{ + Emacs_Cursor text_cursor; + Emacs_Cursor nontext_cursor; + Emacs_Cursor modeline_cursor; + Emacs_Cursor hand_cursor; + Emacs_Cursor hourglass_cursor; + Emacs_Cursor horizontal_drag_cursor; + Emacs_Cursor vertical_drag_cursor; + Emacs_Cursor left_edge_cursor; + Emacs_Cursor top_left_corner_cursor; + Emacs_Cursor top_edge_cursor; + Emacs_Cursor top_right_corner_cursor; + Emacs_Cursor right_edge_cursor; + Emacs_Cursor bottom_right_corner_cursor; + Emacs_Cursor bottom_edge_cursor; + Emacs_Cursor bottom_left_corner_cursor; + Emacs_Cursor no_cursor; + + Emacs_Cursor current_cursor; + + struct haiku_display_info *display_info; + + int baseline_offset; + int fontset; + + Emacs_Color cursor_color; + + Window window_desc, parent_desc; + char explicit_parent; + + int titlebar_height; + int toolbar_height; + + haiku window; + haiku view; + haiku menubar; + + int menu_up_to_date_p; + int zoomed_p; + + int pending_zoom_x; + int pending_zoom_y; + int pending_zoom_width; + int pending_zoom_height; + + int menu_bar_open_p; + + C_FONT font; + + int hourglass_p; + uint32_t cursor_fg; + bool dirty_p; + + /* The pending position we're waiting for. */ + int pending_top, pending_left; +}; + +struct x_output +{ + /* Unused, makes term.c happy. */ +}; + +extern struct haiku_display_info *x_display_list; +extern struct font_driver const haikufont_driver; + +struct scroll_bar +{ + /* These fields are shared by all vectors. */ + union vectorlike_header header; + + /* The window we're a scroll bar for. */ + Lisp_Object window; + + /* The next and previous in the chain of scroll bars in this frame. */ + Lisp_Object next, prev; + + /* Fields after 'prev' are not traced by the GC. */ + + /* The position and size of the scroll bar in pixels, relative to the + frame. */ + int top, left, width, height; + + /* The actual scrollbar. */ + void *scroll_bar; + + /* Non-nil if the scroll bar handle is currently being dragged by + the user. */ + int dragging; + + /* The update position if we are waiting for a scrollbar update, or + -1. */ + int update; + + /* The last known position of this scrollbar. */ + int position; + + /* The total number of units inside this scrollbar. */ + int total; + + /* True if the scroll bar is horizontal. */ + bool horizontal; +}; + +#define XSCROLL_BAR(vec) ((struct scroll_bar *) XVECTOR (vec)) + +#define FRAME_DIRTY_P(f) (FRAME_OUTPUT_DATA (f)->dirty_p) +#define MAKE_FRAME_DIRTY(f) (FRAME_DIRTY_P (f) = 1) +#define FRAME_OUTPUT_DATA(f) ((f)->output_data.haiku) +#define FRAME_HAIKU_WINDOW(f) (FRAME_OUTPUT_DATA (f)->window) +#define FRAME_HAIKU_VIEW(f) ((MAKE_FRAME_DIRTY (f)), FRAME_OUTPUT_DATA (f)->view) +#define FRAME_HAIKU_MENU_BAR(f) (FRAME_OUTPUT_DATA (f)->menubar) +#define FRAME_DISPLAY_INFO(f) (FRAME_OUTPUT_DATA (f)->display_info) +#define FRAME_FONT(f) (FRAME_OUTPUT_DATA (f)->font) +#define FRAME_FONTSET(f) (FRAME_OUTPUT_DATA (f)->fontset) +#define FRAME_NATIVE_WINDOW(f) (FRAME_OUTPUT_DATA (f)->window) +#define FRAME_BASELINE_OFFSET(f) (FRAME_OUTPUT_DATA (f)->baseline_offset) +#define FRAME_CURSOR_COLOR(f) (FRAME_OUTPUT_DATA (f)->cursor_color) + +#ifdef USE_BE_CAIRO +#define FRAME_CR_SURFACE(f) \ + (FRAME_HAIKU_VIEW (f) ? EmacsView_cairo_surface (FRAME_HAIKU_VIEW (f)) : 0); +#endif + +extern void syms_of_haikuterm (void); +extern void syms_of_haikufns (void); +extern void syms_of_haikumenu (void); +extern void syms_of_haikufont (void); +extern void syms_of_haikuselect (void); +extern void init_haiku_select (void); + +extern void haiku_iconify_frame (struct frame *); +extern void haiku_visualize_frame (struct frame *); +extern void haiku_unvisualize_frame (struct frame *); +extern void haiku_set_offset (struct frame *, int, int, int); +extern void haiku_set_frame_visible_invisible (struct frame *, bool); +extern void haiku_free_frame_resources (struct frame *f); +extern void haiku_scroll_bar_remove (struct scroll_bar *bar); +extern void haiku_clear_under_internal_border (struct frame *f); +extern void haiku_set_name (struct frame *f, Lisp_Object name, bool explicit_p); + +extern struct haiku_display_info *haiku_term_init (void); + +extern void mark_haiku_display (void); + +extern int haiku_get_color (const char *name, Emacs_Color *color); +extern void haiku_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval); +extern void haiku_set_cursor_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval); +extern void haiku_set_cursor_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval); +extern void haiku_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval); +extern void haiku_change_tab_bar_height (struct frame *f, int height); +extern void haiku_change_tool_bar_height (struct frame *f, int height); + +extern void haiku_query_color (uint32_t col, Emacs_Color *color); + +extern unsigned long haiku_get_pixel (haiku bitmap, int x, int y); +extern void haiku_put_pixel (haiku bitmap, int x, int y, unsigned long pixel); + +extern Lisp_Object haiku_menu_show (struct frame *f, int x, int y, int menu_flags, + Lisp_Object title, const char **error_name); +extern Lisp_Object haiku_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents); + +extern void initialize_frame_menubar (struct frame *f); + +extern void run_menu_bar_help_event (struct frame *f, int mb_idx); +extern void put_xrm_resource (Lisp_Object name, Lisp_Object val); + +#ifdef HAVE_NATIVE_IMAGE_API +extern bool haiku_can_use_native_image_api (Lisp_Object type); +extern int haiku_load_image (struct frame *f, struct image *img, + Lisp_Object spec_file, Lisp_Object spec_data); +extern void syms_of_haikuimage (void); +#endif + +#ifdef USE_BE_CAIRO +extern cairo_t * +haiku_begin_cr_clip (struct frame *f, struct glyph_string *s); + +extern void +haiku_end_cr_clip (cairo_t *cr); +#endif +#endif /* _HAIKU_TERM_H_ */ diff --git a/src/image.c b/src/image.c index 6769e49120..734ccdac31 100644 --- a/src/image.c +++ b/src/image.c @@ -20,6 +20,7 @@ along with GNU Emacs. If not, see . */ #include #include +#include #include /* Include this before including to work around bugs with @@ -135,6 +136,27 @@ typedef struct ns_bitmap_record Bitmap_Record; # define COLOR_TABLE_SUPPORT 1 #endif +#ifdef HAVE_HAIKU +#include "haiku_support.h" +typedef struct haiku_bitmap_record Bitmap_Record; + +#define GET_PIXEL(ximg, x, y) haiku_get_pixel (ximg, x, y) +#define PUT_PIXEL haiku_put_pixel +#define NO_PIXMAP 0 + +#define PIX_MASK_RETAIN 0 +#define PIX_MASK_DRAW 1 + +#define RGB_TO_ULONG(r, g, b) (((r) << 16) | ((g) << 8) | (b)) +#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff) +#define GREEN_FROM_ULONG(color) (((color) >> 8) & 0xff) +#define BLUE_FROM_ULONG(color) ((color) & 0xff) +#define RED16_FROM_ULONG(color) (RED_FROM_ULONG (color) * 0x101) +#define GREEN16_FROM_ULONG(color) (GREEN_FROM_ULONG (color) * 0x101) +#define BLUE16_FROM_ULONG(color) (BLUE_FROM_ULONG (color) * 0x101) + +#endif + static void image_disable_image (struct frame *, struct image *); static void image_edge_detection (struct frame *, struct image *, Lisp_Object, Lisp_Object); @@ -430,6 +452,11 @@ image_create_bitmap_from_data (struct frame *f, char *bits, return -1; #endif +#ifdef HAVE_HAIKU + void *bitmap = BBitmap_new (width, height, 1); + BBitmap_import_mono_bits (bitmap, bits, width, height); +#endif + id = image_allocate_bitmap_record (f); #ifdef HAVE_NS @@ -437,6 +464,11 @@ image_create_bitmap_from_data (struct frame *f, char *bits, dpyinfo->bitmaps[id - 1].depth = 1; #endif +#ifdef HAVE_HAIKU + dpyinfo->bitmaps[id - 1].img = bitmap; + dpyinfo->bitmaps[id - 1].depth = 1; +#endif + dpyinfo->bitmaps[id - 1].file = NULL; dpyinfo->bitmaps[id - 1].height = height; dpyinfo->bitmaps[id - 1].width = width; @@ -465,7 +497,7 @@ image_create_bitmap_from_data (struct frame *f, char *bits, ptrdiff_t image_create_bitmap_from_file (struct frame *f, Lisp_Object file) { -#ifdef HAVE_NTGUI +#if defined (HAVE_NTGUI) || defined (HAVE_HAIKU) return -1; /* W32_TODO : bitmap support */ #else Display_Info *dpyinfo = FRAME_DISPLAY_INFO (f); @@ -561,6 +593,10 @@ free_bitmap_record (Display_Info *dpyinfo, Bitmap_Record *bm) ns_release_object (bm->img); #endif +#ifdef HAVE_HAIKU + BBitmap_free (bm->img); +#endif + if (bm->file) { xfree (bm->file); @@ -1834,6 +1870,11 @@ image_size_in_bytes (struct image *img) if (img->mask) size += w32_image_size (img->mask); +#elif defined HAVE_HAIKU + if (img->pixmap) + size += BBitmap_bytes_length (img->pixmap); + if (img->mask) + size += BBitmap_bytes_length (img->mask); #endif return size; @@ -2173,6 +2214,7 @@ compute_image_size (size_t width, size_t height, single step, but the maths for each element is much more complex and performing the steps separately makes for more readable code. */ +#ifndef HAVE_HAIKU typedef double matrix3x3[3][3]; static void @@ -2187,6 +2229,7 @@ matrix3x3_mult (matrix3x3 a, matrix3x3 b, matrix3x3 result) result[i][j] = sum; } } +#endif /* not HAVE_HAIKU */ static void compute_image_rotation (struct image *img, double *rotation) @@ -2244,6 +2287,7 @@ image_set_transform (struct frame *f, struct image *img) double rotation = 0.0; compute_image_rotation (img, &rotation); +#ifndef HAVE_HAIKU # if defined USE_CAIRO || defined HAVE_XRENDER || defined HAVE_NS /* We want scale up operations to use a nearest neighbor filter to show real pixels instead of munging them, but scale down @@ -2414,6 +2458,34 @@ image_set_transform (struct frame *f, struct image *img) img->xform.eDx = matrix[2][0]; img->xform.eDy = matrix[2][1]; # endif +#else + if (rotation != 0 && + rotation != 90 && + rotation != 180 && + rotation != 270 && + rotation != 360) + { + image_error ("No native support for rotation by %g degrees", + make_float (rotation)); + return; + } + + rotation = fmod (rotation, 360.0); + + if (rotation == 90 || rotation == 270) + { + int w = width; + width = height; + height = w; + } + + img->have_be_transforms_p = rotation != 0 || (img->width != width) || (img->height != height); + img->be_rotate = rotation; + img->be_scale_x = 1.0 / (img->width / (double) width); + img->be_scale_y = 1.0 / (img->height / (double) height); + img->width = width; + img->height = height; +#endif /* not HAVE_HAIKU */ } #endif /* HAVE_IMAGEMAGICK || HAVE_NATIVE_TRANSFORMS */ @@ -2820,6 +2892,30 @@ image_create_x_image_and_pixmap_1 (struct frame *f, int width, int height, int d return 1; #endif /* HAVE_X_WINDOWS */ +#ifdef HAVE_HAIKU + if (depth == 0) + depth = 24; + + if (depth != 24 && depth != 1) + { + *pimg = NULL; + image_error ("Invalid image bit depth specified"); + return 0; + } + + *pixmap = BBitmap_new (width, height, depth == 1); + + if (*pixmap == NO_PIXMAP) + { + *pimg = NULL; + image_error ("Unable to create pixmap", Qnil, Qnil); + return 0; + } + + *pimg = *pixmap; + return 1; +#endif + #ifdef HAVE_NTGUI BITMAPINFOHEADER *header; @@ -2960,7 +3056,7 @@ static void gui_put_x_image (struct frame *f, Emacs_Pix_Container pimg, Emacs_Pixmap pixmap, int width, int height) { -#ifdef USE_CAIRO +#if defined USE_CAIRO || defined HAVE_HAIKU eassert (pimg == pixmap); #elif defined HAVE_X_WINDOWS GC gc; @@ -3087,7 +3183,7 @@ image_unget_x_image_or_dc (struct image *img, bool mask_p, static Emacs_Pix_Container image_get_x_image (struct frame *f, struct image *img, bool mask_p) { -#ifdef USE_CAIRO +#if defined USE_CAIRO || defined (HAVE_HAIKU) return !mask_p ? img->pixmap : img->mask; #elif defined HAVE_X_WINDOWS XImage *ximg_in_img = !mask_p ? img->ximg : img->mask_img; @@ -4036,7 +4132,7 @@ xbm_load (struct frame *f, struct image *img) #endif /* not HAVE_NTGUI */ #endif /* HAVE_XPM */ -#if defined HAVE_XPM || defined USE_CAIRO || defined HAVE_NS +#if defined HAVE_XPM || defined USE_CAIRO || defined HAVE_NS || defined HAVE_HAIKU /* Indices of image specification fields in xpm_format, below. */ @@ -4056,7 +4152,7 @@ enum xpm_keyword_index XPM_LAST }; -#if defined HAVE_XPM || defined HAVE_NS +#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_HAIKU /* Vector of image_keyword structures describing the format of valid XPM image specifications. */ @@ -4074,7 +4170,7 @@ static const struct image_keyword xpm_format[XPM_LAST] = {":color-symbols", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, {":background", IMAGE_STRING_OR_NIL_VALUE, 0} }; -#endif /* HAVE_XPM || HAVE_NS */ +#endif /* HAVE_XPM || HAVE_NS || HAVE_HAIKU */ #if defined HAVE_X_WINDOWS && !defined USE_CAIRO @@ -4298,7 +4394,7 @@ init_xpm_functions (void) #endif /* WINDOWSNT */ -#if defined HAVE_XPM || defined HAVE_NS +#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_HAIKU /* Value is true if COLOR_SYMBOLS is a valid color symbols list for XPM images. Such a list must consist of conses whose car and cdr are strings. */ @@ -4334,9 +4430,9 @@ xpm_image_p (Lisp_Object object) && (! fmt[XPM_COLOR_SYMBOLS].count || xpm_valid_color_symbols_p (fmt[XPM_COLOR_SYMBOLS].value))); } -#endif /* HAVE_XPM || HAVE_NS */ +#endif /* HAVE_XPM || HAVE_NS || HAVE_HAIKU */ -#endif /* HAVE_XPM || USE_CAIRO || HAVE_NS */ +#endif /* HAVE_XPM || USE_CAIRO || HAVE_NS || HAVE_HAIKU */ #if defined HAVE_XPM && defined HAVE_X_WINDOWS && !defined USE_GTK ptrdiff_t @@ -4705,9 +4801,10 @@ xpm_load (struct frame *f, struct image *img) #endif /* HAVE_XPM && !USE_CAIRO */ #if (defined USE_CAIRO && defined HAVE_XPM) \ - || (defined HAVE_NS && !defined HAVE_XPM) + || (defined HAVE_NS && !defined HAVE_XPM) \ + || (defined HAVE_HAIKU && !defined HAVE_XPM) -/* XPM support functions for NS where libxpm is not available, and for +/* XPM support functions for NS and Haiku where libxpm is not available, and for Cairo. Only XPM version 3 (without any extensions) is supported. */ static void xpm_put_color_table_v (Lisp_Object, const char *, @@ -5444,7 +5541,7 @@ lookup_rgb_color (struct frame *f, int r, int g, int b) { #ifdef HAVE_NTGUI return PALETTERGB (r >> 8, g >> 8, b >> 8); -#elif defined USE_CAIRO || defined HAVE_NS +#elif defined USE_CAIRO || defined HAVE_NS || defined HAVE_HAIKU return RGB_TO_ULONG (r >> 8, g >> 8, b >> 8); #else xsignal1 (Qfile_error, @@ -5517,7 +5614,7 @@ image_to_emacs_colors (struct frame *f, struct image *img, bool rgb_p) p = colors; for (y = 0; y < img->height; ++y) { -#if !defined USE_CAIRO && !defined HAVE_NS +#if !defined USE_CAIRO && !defined HAVE_NS && !defined HAVE_HAIKU Emacs_Color *row = p; for (x = 0; x < img->width; ++x, ++p) p->pixel = GET_PIXEL (ximg, x, y); @@ -5525,7 +5622,7 @@ image_to_emacs_colors (struct frame *f, struct image *img, bool rgb_p) { FRAME_TERMINAL (f)->query_colors (f, row, img->width); } -#else /* USE_CAIRO || HAVE_NS */ +#else /* USE_CAIRO || HAVE_NS || HAVE_HAIKU */ for (x = 0; x < img->width; ++x, ++p) { p->pixel = GET_PIXEL (ximg, x, y); @@ -5839,6 +5936,7 @@ image_disable_image (struct frame *f, struct image *img) { #ifndef HAVE_NTGUI #ifndef HAVE_NS /* TODO: NS support, however this not needed for toolbars */ +#ifndef HAVE_HAIKU #ifndef USE_CAIRO #define CrossForeground(f) BLACK_PIX_DEFAULT (f) @@ -5856,6 +5954,7 @@ image_disable_image (struct frame *f, struct image *img) if (img->mask) image_pixmap_draw_cross (f, img->mask, 0, 0, img->width, img->height, MaskForeground (f)); +#endif /* !HAVE_HAIKU */ #endif /* !HAVE_NS */ #else HDC hdc, bmpdc; @@ -6413,6 +6512,8 @@ image_can_use_native_api (Lisp_Object type) return w32_can_use_native_image_api (type); # elif defined HAVE_NS return ns_can_use_native_image_api (type); +# elif defined HAVE_HAIKU + return haiku_can_use_native_image_api (type); # else return false; # endif @@ -6486,6 +6587,9 @@ native_image_load (struct frame *f, struct image *img) # elif defined HAVE_NS return ns_load_image (f, img, image_file, image_spec_value (img->spec, QCdata, NULL)); +# elif defined HAVE_HAIKU + return haiku_load_image (f, img, image_file, + image_spec_value (img->spec, QCdata, NULL)); # else return 0; # endif @@ -9635,7 +9739,8 @@ imagemagick_load_image (struct frame *f, struct image *img, init_color_table (); -#if defined (HAVE_MAGICKEXPORTIMAGEPIXELS) && ! defined (HAVE_NS) +#if defined (HAVE_MAGICKEXPORTIMAGEPIXELS) && \ + ! defined (HAVE_NS) && ! defined (HAVE_HAIKU) if (imagemagick_render_type != 0) { /* Magicexportimage is normally faster than pixelpushing. This @@ -10925,7 +11030,8 @@ The list of capabilities can include one or more of the following: if (FRAME_WINDOW_P (f)) { #ifdef HAVE_NATIVE_TRANSFORMS -# if defined HAVE_IMAGEMAGICK || defined (USE_CAIRO) || defined (HAVE_NS) +# if defined HAVE_IMAGEMAGICK || defined (USE_CAIRO) || defined (HAVE_NS) \ + || defined (HAVE_HAIKU) return list2 (Qscale, Qrotate90); # elif defined (HAVE_X_WINDOWS) && defined (HAVE_XRENDER) int event_basep, error_basep; @@ -11015,7 +11121,7 @@ static struct image_type const image_types[] = { SYMBOL_INDEX (Qjpeg), jpeg_image_p, jpeg_load, image_clear_image, IMAGE_TYPE_INIT (init_jpeg_functions) }, #endif -#if defined HAVE_XPM || defined HAVE_NS +#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_HAIKU { SYMBOL_INDEX (Qxpm), xpm_image_p, xpm_load, image_clear_image, IMAGE_TYPE_INIT (init_xpm_functions) }, #endif @@ -11163,7 +11269,7 @@ non-numeric, there is no explicit limit on the size of images. */); DEFSYM (Qxbm, "xbm"); add_image_type (Qxbm); -#if defined (HAVE_XPM) || defined (HAVE_NS) +#if defined (HAVE_XPM) || defined (HAVE_NS) || defined (HAVE_HAIKU) DEFSYM (Qxpm, "xpm"); add_image_type (Qxpm); #endif diff --git a/src/keyboard.c b/src/keyboard.c index 0c48790ce8..3722ba14cc 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -3865,7 +3865,7 @@ kbd_buffer_get_event (KBOARD **kbp, /* One way or another, wait until input is available; then, if interrupt handlers have not read it, read it now. */ -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) gobble_input (); #endif if (kbd_fetch_ptr != kbd_store_ptr) @@ -6156,7 +6156,6 @@ make_lispy_event (struct input_event *event) case CONFIG_CHANGED_EVENT: return list3 (Qconfig_changed_event, event->arg, event->frame_or_window); - /* The 'kind' field of the event is something we don't recognize. */ default: emacs_abort (); @@ -7247,7 +7246,7 @@ totally_unblock_input (void) unblock_input_to (0); } -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) void handle_input_available_signal (int sig) @@ -7263,7 +7262,7 @@ deliver_input_available_signal (int sig) { deliver_process_signal (sig, handle_input_available_signal); } -#endif /* USABLE_SIGIO */ +#endif /* defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) */ /* User signal events. */ @@ -7333,7 +7332,7 @@ handle_user_signal (int sig) } p->npending++; -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) if (interrupt_input) handle_input_available_signal (sig); else @@ -11103,7 +11102,7 @@ See also `current-input-mode'. */) (Lisp_Object interrupt) { bool new_interrupt_input; -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) #ifdef HAVE_X_WINDOWS if (x_display_list != NULL) { @@ -11114,9 +11113,9 @@ See also `current-input-mode'. */) else #endif /* HAVE_X_WINDOWS */ new_interrupt_input = !NILP (interrupt); -#else /* not USABLE_SIGIO */ +#else /* not USABLE_SIGIO || USABLE_SIGPOLL */ new_interrupt_input = false; -#endif /* not USABLE_SIGIO */ +#endif /* not USABLE_SIGIO || USABLE_SIGPOLL */ if (new_interrupt_input != interrupt_input) { @@ -11545,12 +11544,16 @@ init_keyboard (void) sigaction (SIGQUIT, &action, 0); #endif /* not DOS_NT */ } -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) if (!noninteractive) { struct sigaction action; emacs_sigaction_init (&action, deliver_input_available_signal); +#ifdef USABLE_SIGIO sigaction (SIGIO, &action, 0); +#else + sigaction (SIGPOLL, &action, 0); +#endif } #endif diff --git a/src/lisp.h b/src/lisp.h index 31656bb3b1..19caba4001 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -138,7 +138,12 @@ verify (BITS_WORD_MAX >> (BITS_PER_BITS_WORD - 1) == 1); buffers and strings. Emacs never allocates objects larger than PTRDIFF_MAX bytes, as they cause problems with pointer subtraction. In C99, pD can always be "t"; configure it here for the sake of - pre-C99 libraries such as glibc 2.0 and Solaris 8. */ + pre-C99 libraries such as glibc 2.0 and Solaris 8. + + On Haiku, the size of ptrdiff_t is inconsistent with the value of + PTRDIFF_MAX. In that case, "t" should be sufficient. */ + +#ifndef HAIKU #if PTRDIFF_MAX == INT_MAX # define pD "" #elif PTRDIFF_MAX == LONG_MAX @@ -148,6 +153,9 @@ verify (BITS_WORD_MAX >> (BITS_PER_BITS_WORD - 1) == 1); #else # define pD "t" #endif +#else +# define pD "t" +#endif /* Convenience macro for rarely-used functions that do not return. */ #define AVOID _Noreturn ATTRIBUTE_COLD void @@ -3330,7 +3338,7 @@ struct frame; /* Define if the windowing system provides a menu bar. */ #if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \ - || defined (HAVE_NS) || defined (USE_GTK) + || defined (HAVE_NS) || defined (USE_GTK) || defined (HAVE_HAIKU) #define HAVE_EXT_MENU_BAR true #endif @@ -4429,7 +4437,7 @@ extern Lisp_Object menu_bar_items (Lisp_Object); extern Lisp_Object tab_bar_items (Lisp_Object, int *); extern Lisp_Object tool_bar_items (Lisp_Object, int *); extern void discard_mouse_events (void); -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) void handle_input_available_signal (int); #endif extern Lisp_Object pending_funcalls; diff --git a/src/menu.c b/src/menu.c index 1aafa78c3c..ab01e1bfad 100644 --- a/src/menu.c +++ b/src/menu.c @@ -50,7 +50,8 @@ extern AppendMenuW_Proc unicode_append_menu; static bool have_boxes (void) { -#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NTGUI) || defined(HAVE_NS) +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NTGUI) || defined (HAVE_NS) \ + || defined (HAVE_HAIKU) if (FRAME_WINDOW_P (XFRAME (Vmenu_updating_frame))) return 1; #endif @@ -422,7 +423,8 @@ single_menu_item (Lisp_Object key, Lisp_Object item, Lisp_Object dummy, void *sk AREF (item_properties, ITEM_PROPERTY_SELECTED), AREF (item_properties, ITEM_PROPERTY_HELP)); -#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) || defined (HAVE_NTGUI) +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) \ + || defined (HAVE_NTGUI) || defined (HAVE_HAIKU) /* Display a submenu using the toolkit. */ if (FRAME_WINDOW_P (XFRAME (Vmenu_updating_frame)) && ! (NILP (map) || NILP (enabled))) @@ -872,6 +874,10 @@ update_submenu_strings (widget_value *first_wv) } } +#endif /* USE_X_TOOLKIT || USE_GTK || HAVE_NS || HAVE_NTGUI */ +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) \ + || defined (HAVE_NTGUI) || defined (HAVE_HAIKU) + /* Find the menu selection and store it in the keyboard buffer. F is the frame the menu is on. MENU_BAR_ITEMS_USED is the length of VECTOR. @@ -959,7 +965,7 @@ find_and_call_menu_selection (struct frame *f, int menu_bar_items_used, SAFE_FREE (); } -#endif /* USE_X_TOOLKIT || USE_GTK || HAVE_NS || HAVE_NTGUI */ +#endif /* USE_X_TOOLKIT || USE_GTK || HAVE_NS || HAVE_NTGUI || HAVE_HAIKU */ #ifdef HAVE_NS /* As above, but return the menu selection instead of storing in kb buffer. diff --git a/src/process.c b/src/process.c index a00426795b..241ffe9a8d 100644 --- a/src/process.c +++ b/src/process.c @@ -259,7 +259,7 @@ static bool process_output_skip; static void start_process_unwind (Lisp_Object); static void create_process (Lisp_Object, char **, Lisp_Object); -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) static bool keyboard_bit_set (fd_set *); #endif static void deactivate_process (Lisp_Object); @@ -5730,7 +5730,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell))) break; -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) /* If we think we have keyboard input waiting, but didn't get SIGIO, go read it. This can happen with X on BSD after logging out. In that case, there really is no input and no SIGIO, @@ -5738,7 +5738,11 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (read_kbd && interrupt_input && keyboard_bit_set (&Available) && ! noninteractive) +#ifdef USABLE_SIGIO handle_input_available_signal (SIGIO); +#else + handle_input_available_signal (SIGPOLL); +#endif #endif /* If checking input just got us a size-change event from X, @@ -7732,7 +7736,7 @@ delete_gpm_wait_descriptor (int desc) # endif -# ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) /* Return true if *MASK has a bit set that corresponds to one of the keyboard input descriptors. */ diff --git a/src/sound.c b/src/sound.c index 9041076bdc..d42bc8550d 100644 --- a/src/sound.c +++ b/src/sound.c @@ -299,11 +299,15 @@ sound_perror (const char *msg) int saved_errno = errno; turn_on_atimers (1); -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) { sigset_t unblocked; sigemptyset (&unblocked); +#ifdef USABLE_SIGIO sigaddset (&unblocked, SIGIO); +#else + sigaddset (&unblocked, SIGPOLL); +#endif pthread_sigmask (SIG_UNBLOCK, &unblocked, 0); } #endif @@ -698,7 +702,7 @@ static void vox_configure (struct sound_device *sd) { int val; -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) sigset_t oldset, blocked; #endif @@ -708,9 +712,13 @@ vox_configure (struct sound_device *sd) interrupted by a signal. Block the ones we know to cause troubles. */ turn_on_atimers (0); -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) sigemptyset (&blocked); +#ifdef USABLE_SIGIO sigaddset (&blocked, SIGIO); +#else + sigaddset (&blocked, SIGPOLL); +#endif pthread_sigmask (SIG_BLOCK, &blocked, &oldset); #endif @@ -744,7 +752,7 @@ vox_configure (struct sound_device *sd) } turn_on_atimers (1); -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) pthread_sigmask (SIG_SETMASK, &oldset, 0); #endif } @@ -760,10 +768,14 @@ vox_close (struct sound_device *sd) /* On GNU/Linux, it seems that the device driver doesn't like to be interrupted by a signal. Block the ones we know to cause troubles. */ -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) sigset_t blocked, oldset; sigemptyset (&blocked); +#ifdef USABLE_SIGIO sigaddset (&blocked, SIGIO); +#else + sigaddset (&blocked, SIGPOLL); +#endif pthread_sigmask (SIG_BLOCK, &blocked, &oldset); #endif turn_on_atimers (0); @@ -772,7 +784,7 @@ vox_close (struct sound_device *sd) ioctl (sd->fd, SNDCTL_DSP_SYNC, NULL); turn_on_atimers (1); -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) pthread_sigmask (SIG_SETMASK, &oldset, 0); #endif diff --git a/src/sysdep.c b/src/sysdep.c index 8eaee22498..5e13dd097e 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -678,6 +678,9 @@ sys_subshell (void) #ifdef USABLE_SIGIO saved_handlers[3].code = SIGIO; saved_handlers[4].code = 0; +#elif defined (USABLE_SIGPOLL) + saved_handlers[3].code = SIGPOLL; + saved_handlers[4].code = 0; #else saved_handlers[3].code = 0; #endif @@ -788,6 +791,7 @@ init_sigio (int fd) } #ifndef DOS_NT +#ifdef F_SETOWN static void reset_sigio (int fd) { @@ -795,12 +799,13 @@ reset_sigio (int fd) fcntl (fd, F_SETFL, old_fcntl_flags[fd]); #endif } +#endif /* F_SETOWN */ #endif void request_sigio (void) { -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) sigset_t unblocked; if (noninteractive) @@ -810,7 +815,11 @@ request_sigio (void) # ifdef SIGWINCH sigaddset (&unblocked, SIGWINCH); # endif +# ifdef USABLE_SIGIO sigaddset (&unblocked, SIGIO); +# else + sigaddset (&unblocked, SIGPOLL); +# endif pthread_sigmask (SIG_UNBLOCK, &unblocked, 0); interrupts_deferred = 0; @@ -820,7 +829,7 @@ request_sigio (void) void unrequest_sigio (void) { -#ifdef USABLE_SIGIO +#if defined (USABLE_SIGIO) || defined (USABLE_SIGPOLL) sigset_t blocked; if (noninteractive) @@ -830,7 +839,11 @@ unrequest_sigio (void) # ifdef SIGWINCH sigaddset (&blocked, SIGWINCH); # endif +# ifdef USABLE_SIGIO sigaddset (&blocked, SIGIO); +# else + sigaddset (&blocked, SIGPOLL); +# endif pthread_sigmask (SIG_BLOCK, &blocked, 0); interrupts_deferred = 1; #endif @@ -1256,9 +1269,12 @@ init_sys_modes (struct tty_display_info *tty_out) /* This code added to insure that, if flow-control is not to be used, we have an unlocked terminal at the start. */ +#ifndef HAIKU /* On Haiku, TCXONC is a no-op and causes spurious + compiler warnings. */ #ifdef TCXONC if (!tty_out->flow_control) ioctl (fileno (tty_out->input), TCXONC, 1); #endif +#endif /* HAIKU */ #ifdef TIOCSTART if (!tty_out->flow_control) ioctl (fileno (tty_out->input), TIOCSTART, 0); #endif @@ -1674,6 +1690,8 @@ emacs_sigaction_init (struct sigaction *action, signal_handler_t handler) sigaddset (&action->sa_mask, SIGQUIT); #ifdef USABLE_SIGIO sigaddset (&action->sa_mask, SIGIO); +#elif defined (USABLE_SIGPOLL) + sigaddset (&action->sa_mask, SIGPOLL); #endif } @@ -2772,6 +2790,7 @@ static const struct speed_struct speeds[] = #ifdef B150 { 150, B150 }, #endif +#ifndef HAVE_TINY_SPEED_T #ifdef B200 { 200, B200 }, #endif @@ -2859,6 +2878,7 @@ static const struct speed_struct speeds[] = #ifdef B4000000 { 4000000, B4000000 }, #endif +#endif /* HAVE_TINY_SPEED_T */ }; /* Convert a numerical speed (e.g., 9600) to a Bnnn constant (e.g., @@ -3120,8 +3140,9 @@ list_system_processes (void) } /* The WINDOWSNT implementation is in w32.c. - The MSDOS implementation is in dosfns.c. */ -#elif !defined (WINDOWSNT) && !defined (MSDOS) + The MSDOS implementation is in dosfns.c. + The Haiku implementation is in haiku.c. */ +#elif !defined (WINDOWSNT) && !defined (MSDOS) && !defined (HAIKU) Lisp_Object list_system_processes (void) @@ -4200,8 +4221,9 @@ system_process_attributes (Lisp_Object pid) } /* The WINDOWSNT implementation is in w32.c. - The MSDOS implementation is in dosfns.c. */ -#elif !defined (WINDOWSNT) && !defined (MSDOS) + The MSDOS implementation is in dosfns.c. + The HAIKU implementation is in haiku.c. */ +#elif !defined (WINDOWSNT) && !defined (MSDOS) && !defined (HAIKU) Lisp_Object system_process_attributes (Lisp_Object pid) diff --git a/src/termhooks.h b/src/termhooks.h index b274be9e3c..1cf9863f3a 100644 --- a/src/termhooks.h +++ b/src/termhooks.h @@ -60,7 +60,8 @@ enum output_method output_x_window, output_msdos_raw, output_w32, - output_ns + output_ns, + output_haiku }; /* Input queue declarations and hooks. */ @@ -266,7 +267,6 @@ enum event_kind /* File or directory was changed. */ , FILE_NOTIFY_EVENT #endif - }; /* Bit width of an enum event_kind tag at the start of structs and unions. */ @@ -447,6 +447,7 @@ struct terminal struct x_display_info *x; /* xterm.h */ struct w32_display_info *w32; /* w32term.h */ struct ns_display_info *ns; /* nsterm.h */ + struct haiku_display_info *haiku; /* haikuterm.h */ } display_info; @@ -835,6 +836,9 @@ extern struct terminal *terminal_list; #elif defined (HAVE_NS) #define TERMINAL_FONT_CACHE(t) \ (t->type == output_ns ? t->display_info.ns->name_list_element : Qnil) +#elif defined (HAVE_HAIKU) +#define TERMINAL_FONT_CACHE(t) \ + (t->type == output_haiku ? t->display_info.haiku->name_list_element : Qnil) #endif extern struct terminal *decode_live_terminal (Lisp_Object); diff --git a/src/terminal.c b/src/terminal.c index b83adc596b..b5f244ee31 100644 --- a/src/terminal.c +++ b/src/terminal.c @@ -445,6 +445,8 @@ possible return values. */) return Qpc; case output_ns: return Qns; + case output_haiku: + return Qhaiku; default: emacs_abort (); } diff --git a/src/verbose.mk.in b/src/verbose.mk.in index a5ff931ed0..9252971acc 100644 --- a/src/verbose.mk.in +++ b/src/verbose.mk.in @@ -23,7 +23,9 @@ ifeq (${V},1) AM_V_AR = AM_V_at = AM_V_CC = +AM_V_CXX = AM_V_CCLD = +AM_V_CXXLD = AM_V_ELC = AM_V_ELN = AM_V_GEN = @@ -34,7 +36,9 @@ else AM_V_AR = @echo " AR " $@; AM_V_at = @ AM_V_CC = @echo " CC " $@; +AM_V_CXX = @echo " CXX " $@; AM_V_CCLD = @echo " CCLD " $@; +AM_V_CXXLD = @echo " CXXLD " $@; ifeq ($(HAVE_NATIVE_COMP),yes) ifeq ($(NATIVE_DISABLED),1) AM_V_ELC = @echo " ELC " $@; diff --git a/src/xdisp.c b/src/xdisp.c index 6c70ce60bb..8d34b7c4c3 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -15657,6 +15657,11 @@ redisplay_internal (void) } #endif +#if defined (HAVE_HAIKU) + if (popup_activated_p) + return; +#endif + /* I don't think this happens but let's be paranoid. */ if (redisplaying_p) return; @@ -25247,6 +25252,11 @@ display_menu_bar (struct window *w) return; #endif /* HAVE_NS */ +#ifdef HAVE_HAIKU + if (FRAME_HAIKU_P (f)) + return; +#endif /* HAVE_HAIKU */ + #if defined (USE_X_TOOLKIT) || defined (USE_GTK) eassert (!FRAME_WINDOW_P (f)); init_iterator (&it, w, -1, -1, f->desired_matrix->rows, MENU_FACE_ID); @@ -33698,6 +33708,11 @@ note_mouse_highlight (struct frame *f, int x, int y) return; #endif +#if defined (HAVE_HAIKU) + if (popup_activated_p) + return; +#endif + if (!f->glyphs_initialized_p || f->pointer_invisible) return; diff --git a/src/xfaces.c b/src/xfaces.c index d0d73eb828..fec6b2654b 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -246,6 +246,10 @@ along with GNU Emacs. If not, see . */ #ifdef HAVE_NS #define GCGraphicsExposures 0 #endif /* HAVE_NS */ + +#ifdef HAVE_HAIKU +#define GCGraphicsExposures 0 +#endif /* HAVE_HAIKU */ #endif /* HAVE_WINDOW_SYSTEM */ #include "buffer.h" @@ -555,8 +559,8 @@ x_free_gc (struct frame *f, Emacs_GC *gc) #endif /* HAVE_NTGUI */ -#ifdef HAVE_NS -/* NS emulation of GCs */ +#if defined (HAVE_NS) || defined (HAVE_HAIKU) +/* NS and Haiku emulation of GCs */ static Emacs_GC * x_create_gc (struct frame *f, diff --git a/src/xfns.c b/src/xfns.c index 0ea43d1330..a142f5518c 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -4461,7 +4461,8 @@ For GNU and Unix system, the first 2 numbers are the version of the X Protocol used on TERMINAL and the 3rd number is the distributor-specific release number. For MS Windows, the 3 numbers report the OS major and minor version and build number. For Nextstep, the first 2 numbers are -hard-coded and the 3rd represents the OS version. +hard-coded and the 3rd represents the OS version. For Haiku, all 3 +numbers are hard-coded. See also the function `x-server-vendor'. @@ -7419,7 +7420,7 @@ Use a file selection dialog. Select DEFAULT-FILENAME in the dialog's file selection box, if specified. If MUSTMATCH is non-nil, the returned file or directory must exist. -This function is defined only on NS, MS Windows, and X Windows with the +This function is defined only on NS, Haiku, MS Windows, and X Windows with the Motif or Gtk toolkits. With the Motif toolkit, ONLY-DIR-P is ignored. Otherwise, if ONLY-DIR-P is non-nil, the user can select only directories. On MS Windows 7 and later, the file selection dialog "remembers" the last diff --git a/src/xterm.c b/src/xterm.c index 18f8a6062f..9e5aed996a 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -14959,7 +14959,7 @@ selected window or cursor position is preserved. */); A value of nil means Emacs doesn't use toolkit scroll bars. With the X Window system, the value is a symbol describing the X toolkit. Possible values are: gtk, motif, xaw, or xaw3d. -With MS Windows or Nextstep, the value is t. */); +With MS Windows, Haiku windowing or Nextstep, the value is t. */); #ifdef USE_TOOLKIT_SCROLL_BARS #ifdef USE_MOTIF Vx_toolkit_scroll_bars = intern_c_string ("motif"); commit bfcc59371ba74e53c5ce1ba93bcddf9a9aa64230 Author: Michael Albinus Date: Sat Nov 20 13:29:33 2021 +0100 ; Rearrange normal stage in emba files diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index ebfe996513..d53133d8ac 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -32,7 +32,7 @@ stages: - generator - trigger # - fast -# - normal + - normal - platform-images - platforms - native-comp-images diff --git a/test/infra/test-jobs-generator.sh b/test/infra/test-jobs-generator.sh index 15877dd3e6..67205b383b 100755 --- a/test/infra/test-jobs-generator.sh +++ b/test/infra/test-jobs-generator.sh @@ -56,9 +56,6 @@ for subdir in $SUBDIRS; do include: - local: '/test/infra/default-gitlab-ci.yml' -stages: - - normal - EOF cat < Date: Sat Nov 20 13:18:17 2021 +0100 ; Fix my last commit * lisp/play/animate.el (animate-string): Ensure the delay is always a float. diff --git a/lisp/play/animate.el b/lisp/play/animate.el index f3c77b31a5..54ee9dc84e 100644 --- a/lisp/play/animate.el +++ b/lisp/play/animate.el @@ -138,7 +138,7 @@ in the current window." ;; Make sure buffer is displayed starting at the beginning. (set-window-start nil 1) ;; Display it, and wait just a little while. - (sit-for (/ animate-total-added-delay (max animate-n-steps 1))) + (sit-for (/ (float animate-total-added-delay) (max animate-n-steps 1))) ;; Now undo the changes we made in the buffer. (setq list-to-undo buffer-undo-list) (while list-to-undo commit 14cd6ec8d269415ad4c342580c53528ab1bb17b2 Author: Stefan Kangas Date: Sat Nov 20 13:12:38 2021 +0100 Make string-animate smoother * lisp/play/animate.el (animate-total-added-delay): New defcustom. (animate-n-steps): Double the default value. Use :type 'natnum'. (animate-string): Make the delay depend on the above new defcustom divided by the number of steps. diff --git a/lisp/play/animate.el b/lisp/play/animate.el index 7eb1b27717..f3c77b31a5 100644 --- a/lisp/play/animate.el +++ b/lisp/play/animate.el @@ -93,9 +93,17 @@ (unless (eolp) (delete-char 1)) (insert-char char 1)) -(defcustom animate-n-steps 10 +(defcustom animate-n-steps 20 "Number of steps `animate-string' will place a char before its last position." - :type 'integer) + :type 'natnum + :version "29.1") + +(defcustom animate-total-added-delay 0.5 + "Total number of seconds to wait in between steps. +This is added to the total time it takes to run `animate-string' +to ensure that the animation is not too fast to be seen." + :type 'float + :version "29.1") (defvar animation-buffer-name nil "String naming the default buffer for animations. @@ -130,7 +138,7 @@ in the current window." ;; Make sure buffer is displayed starting at the beginning. (set-window-start nil 1) ;; Display it, and wait just a little while. - (sit-for .05) + (sit-for (/ animate-total-added-delay (max animate-n-steps 1))) ;; Now undo the changes we made in the buffer. (setq list-to-undo buffer-undo-list) (while list-to-undo commit 7294a2861d274fe61f61d182d7c74041e738fe75 Author: Po Lu Date: Sat Nov 20 20:00:45 2021 +0800 Prevent crashes when scrolling in an unknown Window on XI2 * src/xterm.c (handle_one_xevent): Fix XI2 frame lookup to handle foreign windows. diff --git a/src/xterm.c b/src/xterm.c index a023a5f9c8..18f8a6062f 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -9939,7 +9939,14 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (delta != DBL_MAX) { - f = mouse_or_wdesc_frame (dpyinfo, xev->event); + if (!f) + { + f = x_any_window_to_frame (dpyinfo, xev->event); + + if (!f) + goto XI_OTHER; + } + scroll_unit = pow (FRAME_PIXEL_HEIGHT (f), 2.0 / 3.0); found_valuator = true; @@ -9952,14 +9959,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, && (fabs (val->emacs_value) < 1)) continue; - if (!f) - { - f = x_any_window_to_frame (dpyinfo, xev->event); - - if (!f) - goto XI_OTHER; - } - bool s = signbit (val->emacs_value); inev.ie.kind = (val->horizontal ? HORIZ_WHEEL_EVENT commit 3b68662a8226805c397f2a9dbd427a7ce716273b Author: Po Lu Date: Sat Nov 20 19:54:51 2021 +0800 Fix xwidgets with XInput 2 builds * src/xwidget.c (Fmake_xwidget): Refrain from synthesizing a focus event here on XI2 builds. (Fxwidget_perform_lispy_event): Try to set embedder on XI2 builds and do nothing otherwise. (synthesize_focus_in_event): Use focus_change.window as opposed to any.window. (x_draw_xwidget_glyph_string): Synthesize focus event here instead on XI2 builds. diff --git a/src/xwidget.c b/src/xwidget.c index b1bf291a16..1ab953d3c8 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -226,8 +226,9 @@ fails. */) gtk_widget_show (xw->widget_osr); gtk_widget_show (xw->widgetwindow_osr); +#ifndef HAVE_XINPUT2 synthesize_focus_in_event (xw->widgetwindow_osr); - +#endif g_signal_connect (G_OBJECT (gtk_widget_get_window (xw->widgetwindow_osr)), "from-embedder", G_CALLBACK (from_embedder), NULL); @@ -326,6 +327,10 @@ selected frame is not an X-Windows frame. */) GtkContainerClass *klass; GtkWidget *widget; GtkWidget *temp = NULL; +#ifdef HAVE_XINPUT2 + GdkWindow *embedder; + GdkWindow *osw; +#endif #endif CHECK_LIVE_XWIDGET (xwidget); @@ -337,6 +342,16 @@ selected frame is not an X-Windows frame. */) f = SELECTED_FRAME (); #ifdef USE_GTK +#ifdef HAVE_XINPUT2 + /* XI2 GDK devices crash if we try this without an embedder set. */ + if (!f) + return Qnil; + + osw = gtk_widget_get_window (xw->widgetwindow_osr); + embedder = gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (f)); + + gdk_offscreen_window_set_embedder (osw, embedder); +#endif widget = gtk_window_get_focus (GTK_WINDOW (xw->widgetwindow_osr)); if (!widget) @@ -1012,7 +1027,7 @@ synthesize_focus_in_event (GtkWidget *offscreen_window) wnd = gtk_widget_get_window (offscreen_window); focus_event = gdk_event_new (GDK_FOCUS_CHANGE); - focus_event->any.window = wnd; + focus_event->focus_change.window = wnd; focus_event->focus_change.in = TRUE; if (FRAME_WINDOW_P (SELECTED_FRAME ())) @@ -1781,6 +1796,11 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) } #endif +#ifdef HAVE_XINPUT2 + record_osr_embedder (xv); + synthesize_focus_in_event (xww->widget_osr); +#endif + #ifdef USE_GTK unblock_input (); #endif commit a3a3d3dd074850a11ade229fc65a07aaa3e44320 Author: Stefan Kangas Date: Sat Nov 20 12:54:48 2021 +0100 Make 'eval' use lexical scoping in most tests * test/lisp/electric-tests.el (electric-pair-define-test-form) (define-electric-pair-test): * test/lisp/emacs-lisp/backtrace-tests.el (backtrace-tests--uncompiled-functions): * test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs-test--symbol-macrolet): * test/lisp/emacs-lisp/let-alist-tests.el (let-alist-list-to-sexp): * test/lisp/emacs-lisp/lisp-tests.el (elisp-tests-with-temp-buffer, core-elisp-tests-3-backquote): * test/lisp/emacs-lisp/testcover-resources/testcases.el (testcover-testcase-nth-case): * test/lisp/ffap-tests.el (ffap-ido-mode): * test/lisp/files-tests.el (file-test--do-local-variables-test): * test/lisp/net/tramp-tests.el (tramp--test-utf8): * test/lisp/progmodes/elisp-mode-tests.el (find-defs-defgeneric-eval, find-defs-defun-eval) (find-defs-defvar-eval, find-defs-face-eval) (find-defs-feature-eval): Give 'eval' non-nil LEXICAL argument. * test/lisp/subr-tests.el (subr-tests--dolist--wrong-number-of-args): * test/src/eval-tests.el (eval-tests--if-dot-string) (eval-tests--mutating-cond) (eval-tests-19790-backquote-comma-dot-substitution): Test 'eval' using LEXICAL as both nil and non-nil. (eval-tests--let-with-circular-defs): Give explicit nil to 'eval'. diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el index feeae2b82a..85727bd091 100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@ -97,8 +97,8 @@ (with-temp-buffer (cl-progv ;; FIXME: avoid `eval' - (mapcar #'car (eval bindings)) - (mapcar #'cdr (eval bindings)) + (mapcar #'car (eval bindings t)) + (mapcar #'cdr (eval bindings t)) (dlet ((python-indent-guess-indent-offset-verbose nil)) (funcall mode) (insert fixture) @@ -187,7 +187,7 @@ The buffer's contents should %s: (fixture-fn '#'electric-pair-mode)) `(progn ,@(cl-loop - for mode in (eval modes) ;FIXME: avoid `eval' + for mode in (eval modes t) ;FIXME: avoid `eval' append (cl-loop for (prefix suffix extra-desc) in diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el index 5c4e5305ec..e35a7a729b 100644 --- a/test/lisp/emacs-lisp/backtrace-tests.el +++ b/test/lisp/emacs-lisp/backtrace-tests.el @@ -49,7 +49,7 @@ (setq backtrace-frames (seq-subseq backtrace-frames 0 (1+ this-index)))) (backtrace-print)))) - (eval backtrace-tests--uncompiled-functions)) + (eval backtrace-tests--uncompiled-functions t)) (defun backtrace-tests--backtrace-lines () (if debugger-stack-frame-as-list diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 033764a7f9..be2c0fa02b 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -529,7 +529,7 @@ collection clause." (should-error ;; Use `eval' so the error is signaled when running the test rather than ;; when macroexpanding it. - (eval '(let ((l (list 1))) (cl-symbol-macrolet ((x 1)) (setq (car l) 0))))) + (eval '(let ((l (list 1))) (cl-symbol-macrolet ((x 1)) (setq (car l) 0))) t)) ;; Make sure `gv-synthetic-place' isn't macro-expanded before `setf' gets to ;; see its `gv-expander'. (should (equal (let ((l '(0))) diff --git a/test/lisp/emacs-lisp/let-alist-tests.el b/test/lisp/emacs-lisp/let-alist-tests.el index 88e689c80b..bbceb04b49 100644 --- a/test/lisp/emacs-lisp/let-alist-tests.el +++ b/test/lisp/emacs-lisp/let-alist-tests.el @@ -82,7 +82,7 @@ (ert-deftest let-alist-list-to-sexp () "Check that multiple dots are handled correctly." - (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1))))))))) + (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1)))))) t))) (should (equal (let-alist--access-sexp '.foo.bar.baz 'var) '(cdr (assq 'baz (cdr (assq 'bar (cdr (assq 'foo var)))))))) (should (equal (let-alist--access-sexp '..foo.bar.baz 'var) '.foo.bar.baz))) diff --git a/test/lisp/emacs-lisp/lisp-tests.el b/test/lisp/emacs-lisp/lisp-tests.el index 78ecf3ff03..8301d9906a 100644 --- a/test/lisp/emacs-lisp/lisp-tests.el +++ b/test/lisp/emacs-lisp/lisp-tests.el @@ -235,7 +235,7 @@ (should (or (not mark-active) (mark))))) (ert-deftest core-elisp-tests-3-backquote () - (should (eq 3 (eval ``,,'(+ 1 2))))) + (should (eq 3 (eval ``,,'(+ 1 2) t)))) ;; Test up-list and backward-up-list. (defun lisp-run-up-list-test (fn data start instructions) @@ -324,7 +324,7 @@ start." (declare (indent 1) (debug (def-form body))) (let* ((var-pos nil) (text (with-temp-buffer - (insert (eval contents)) + (insert (eval contents t)) (goto-char (point-min)) (while (re-search-forward elisp-test-point-position-regex nil t) (push (list (intern (match-string-no-properties 1)) diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el index 29094526d7..4d49e5ae70 100644 --- a/test/lisp/emacs-lisp/testcover-resources/testcases.el +++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el @@ -424,7 +424,7 @@ (defmacro testcover-testcase-nth-case (arg vec) (declare (indent 1) (debug (form (vector &rest form)))) - `(eval (aref ,vec%%% ,arg%%%))%%%) + `(eval (aref ,vec%%% ,arg%%%) t)%%%) (defun testcover-testcase-use-nth-case (choice val) (testcover-testcase-nth-case choice diff --git a/test/lisp/ffap-tests.el b/test/lisp/ffap-tests.el index 84b9cea6c1..df5c264baa 100644 --- a/test/lisp/ffap-tests.el +++ b/test/lisp/ffap-tests.el @@ -132,7 +132,7 @@ left alone when opening a URL in an external browser." ;; Macros in BODY are expanded when the test is defined, not when it ;; is run. If a macro (possibly with side effects) is to be tested, ;; it has to be wrapped in `(eval (quote ...))'. - (eval (quote (ido-everywhere))) + (eval (quote (ido-everywhere)) t) (let ((read-file-name-function (lambda (&rest args) (expand-file-name (nth 4 args) diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 2c4557ead6..d3d58aad5f 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -136,7 +136,7 @@ form.") ;; Prevent any dir-locals file interfering with the tests. (enable-dir-local-variables nil)) (hack-local-variables) - (eval (nth 2 test-settings))))) + (eval (nth 2 test-settings) t)))) (ert-deftest files-tests-local-variables () "Test the file-local variables implementation." diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 52a0384337..47fa18eb80 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -6609,7 +6609,7 @@ Use the \"ls\" command." ;; Use all available language specific snippets. (lambda (x) (and - (stringp (setq x (eval (get-language-info (car x) 'sample-text)))) + (stringp (setq x (eval (get-language-info (car x) 'sample-text) t))) ;; Filter out strings which use unencodable characters. (not (and (or (tramp--test-gvfs-p) (tramp--test-smb-p)) (unencodable-char-position diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index b91f7331a8..63bae79bb4 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -610,7 +610,7 @@ to (xref-elisp-test-descr-to-target xref)." )) (xref-elisp-deftest find-defs-defgeneric-eval - (elisp--xref-find-definitions (eval '(cl-defgeneric stephe-leake-cl-defgeneric ()))) + (elisp--xref-find-definitions (eval '(cl-defgeneric stephe-leake-cl-defgeneric ()) t)) nil) ;; Define some mode-local overloadable/overridden functions for xref to find @@ -712,7 +712,7 @@ to (xref-elisp-test-descr-to-target xref)." (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))))) (xref-elisp-deftest find-defs-defun-eval - (elisp--xref-find-definitions (eval '(defun stephe-leake-defun ()))) + (elisp--xref-find-definitions (eval '(defun stephe-leake-defun ()) t)) nil) (xref-elisp-deftest find-defs-defun-c @@ -797,7 +797,7 @@ to (xref-elisp-test-descr-to-target xref)." "DEFVAR_PER_BUFFER (\"default-directory\""))) (xref-elisp-deftest find-defs-defvar-eval - (elisp--xref-find-definitions (eval '(defvar stephe-leake-defvar nil))) + (elisp--xref-find-definitions (eval '(defvar stephe-leake-defvar nil) t)) nil) (xref-elisp-deftest find-defs-face-el @@ -815,7 +815,7 @@ to (xref-elisp-test-descr-to-target xref)." )) (xref-elisp-deftest find-defs-face-eval - (elisp--xref-find-definitions (eval '(defface stephe-leake-defface nil ""))) + (elisp--xref-find-definitions (eval '(defface stephe-leake-defface nil "") t)) nil) (xref-elisp-deftest find-defs-feature-el @@ -830,7 +830,7 @@ to (xref-elisp-test-descr-to-target xref)." )) (xref-elisp-deftest find-defs-feature-eval - (elisp--xref-find-definitions (eval '(provide 'stephe-leake-feature))) + (elisp--xref-find-definitions (eval '(provide 'stephe-leake-feature) t)) nil) (ert-deftest elisp--preceding-sexp--char-name () diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index ca0ded1ea3..e02de952f2 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -611,12 +611,13 @@ indirectly `mapbacktrace'." (ert-deftest subr-tests--dolist--wrong-number-of-args () "Test that `dolist' doesn't accept wrong types or length of SPEC, cf. Bug#25477." - (should-error (eval '(dolist (a))) - :type 'wrong-number-of-arguments) - (should-error (eval '(dolist (a () 'result 'invalid)) t) - :type 'wrong-number-of-arguments) - (should-error (eval '(dolist "foo") t) - :type 'wrong-type-argument)) + (dolist (lb '(nil t)) + (should-error (eval '(dolist (a)) lb) + :type 'wrong-number-of-arguments) + (should-error (eval '(dolist (a () 'result 'invalid)) lb) + :type 'wrong-number-of-arguments) + (should-error (eval '(dolist "foo") lb) + :type 'wrong-type-argument))) (ert-deftest subr-tests-bug22027 () "Test for https://debbugs.gnu.org/22027 ." diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el index 4f05d99136..727c98aa5f 100644 --- a/test/src/eval-tests.el +++ b/test/src/eval-tests.el @@ -86,23 +86,27 @@ Bug#24912." (ert-deftest eval-tests--if-dot-string () "Check that Emacs rejects (if . \"string\")." - (should-error (eval '(if . "abc")) :type 'wrong-type-argument) + (should-error (eval '(if . "abc") nil) :type 'wrong-type-argument) + (should-error (eval '(if . "abc") t) :type 'wrong-type-argument) (let ((if-tail (list '(setcdr if-tail "abc") t))) - (should-error (eval (cons 'if if-tail)))) + (should-error (eval (cons 'if if-tail) nil) :type 'void-variable) + (should-error (eval (cons 'if if-tail) t) :type 'void-variable)) (let ((if-tail (list '(progn (setcdr if-tail "abc") nil) t))) - (should-error (eval (cons 'if if-tail))))) + (should-error (eval (cons 'if if-tail) nil) :type 'void-variable) + (should-error (eval (cons 'if if-tail) t) :type 'void-variable))) (ert-deftest eval-tests--let-with-circular-defs () "Check that Emacs reports an error for (let VARS ...) when VARS is circular." (let ((vars (list 'v))) (setcdr vars vars) (dolist (let-sym '(let let*)) - (should-error (eval (list let-sym vars)))))) + (should-error (eval (list let-sym vars) nil))))) (ert-deftest eval-tests--mutating-cond () "Check that Emacs doesn't crash on a cond clause that mutates during eval." (let ((clauses (list '((progn (setcdr clauses "ouch") nil))))) - (should-error (eval (cons 'cond clauses))))) + (should-error (eval (cons 'cond clauses) nil)) + (should-error (eval (cons 'cond clauses) t)))) (defun eval-tests--exceed-specbind-limit () (defvar eval-tests--var1) @@ -184,7 +188,8 @@ are found on the stack and therefore not garbage collected." Don't handle destructive splicing in backquote expressions (like in Common Lisp). Instead, make sure substitution in backquote expressions works for identifiers starting with period." - (should (equal (let ((.x 'identity)) (eval `(,.x 'ok))) 'ok))) + (should (equal (let ((.x 'identity)) (eval `(,.x 'ok) nil)) 'ok)) + (should (equal (let ((.x 'identity)) (eval `(,.x 'ok) t)) 'ok))) (ert-deftest eval-tests/backtrace-in-batch-mode () (let ((emacs (expand-file-name invocation-name invocation-directory))) commit 244baa550beb3ca6f6b87cf86e2dae4465a87cbd Author: Stefan Kangas Date: Sat Nov 20 11:09:23 2021 +0100 image-dired: Improve some messages * lisp/image-dired.el (image-dired-dir) (image-dired-create-thumb-1): Improve messages. (image-dired-rotate-original): Signal 'user-error' instead of 'error'. diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 852ef0f103..47a44a4a60 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -520,14 +520,14 @@ Return the last form in BODY." ,@body)) (defun image-dired-dir () - "Return the current thumbnails directory (from variable `image-dired-dir'). -Create the thumbnails directory if it does not exist." + "Return the current thumbnail directory (from variable `image-dired-dir'). +Create the thumbnail directory if it does not exist." (let ((image-dired-dir (file-name-as-directory - (expand-file-name image-dired-dir)))) + (expand-file-name image-dired-dir)))) (unless (file-directory-p image-dired-dir) (with-file-modes #o700 (make-directory image-dired-dir t)) - (message "Creating thumbnails directory")) + (message "Thumbnail directory created: %s" image-dired-dir)) image-dired-dir)) (defun image-dired-insert-image (file type relief margin) @@ -743,9 +743,9 @@ and remove the cached thumbnail files between each trial run.") (thumbnail-dir (file-name-directory thumbnail-file)) process) (when (not (file-exists-p thumbnail-dir)) - (message "Creating thumbnail directory") (with-file-modes #o700 - (make-directory thumbnail-dir t))) + (make-directory thumbnail-dir t)) + (message "Thumbnail directory created: %s" thumbnail-dir)) ;; Thumbnail file creation processes begin here and are marshaled ;; in a queue by `image-dired-create-thumb'. @@ -2013,7 +2013,7 @@ With prefix argument ARG, display image in its original size." (cons ?o (expand-file-name file)) (cons ?t image-dired-temp-rotate-image-file)))) (unless (eq 'jpeg (image-type file)) - (error "Only JPEG images can be rotated!")) + (user-error "Only JPEG images can be rotated")) (if (not (= 0 (apply #'call-process image-dired-cmd-rotate-original-program nil nil nil (mapcar (lambda (arg) (format-spec arg spec)) commit 67e06d692a655985f9e7406e81d717639938427b Author: Stefan Kangas Date: Sat Nov 20 11:00:19 2021 +0100 Convert snake and tetris keymaps to defvar-keymap * lisp/play/snake.el (snake-mode-map, snake-null-map): * lisp/play/tetris.el (tetris-mode-map, tetris-null-map): Convert to defvar-keymap. diff --git a/lisp/play/snake.el b/lisp/play/snake.el index 29effa2346..dbdecde973 100644 --- a/lisp/play/snake.el +++ b/lisp/play/snake.el @@ -160,31 +160,28 @@ and then start moving it leftwards.") ;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar snake-mode-map - (let ((map (make-sparse-keymap 'snake-mode-map))) - - (define-key map "n" 'snake-start-game) - (define-key map "q" 'snake-end-game) - (define-key map "p" 'snake-pause-game) - - (define-key map [left] 'snake-move-left) - (define-key map [right] 'snake-move-right) - (define-key map [up] 'snake-move-up) - (define-key map [down] 'snake-move-down) - - (define-key map "\C-b" 'snake-move-left) - (define-key map "\C-f" 'snake-move-right) - (define-key map "\C-p" 'snake-move-up) - (define-key map "\C-n" 'snake-move-down) - map) - "Keymap for Snake games.") - -(defvar snake-null-map - (let ((map (make-sparse-keymap 'snake-null-map))) - (define-key map "n" 'snake-start-game) - (define-key map "q" 'quit-window) - map) - "Keymap for finished Snake games.") +(defvar-keymap snake-mode-map + :doc "Keymap for Snake games." + :name 'snake-mode-map + "n" #'snake-start-game + "q" #'snake-end-game + "p" #'snake-pause-game + + "" #'snake-move-left + "" #'snake-move-right + "" #'snake-move-up + "" #'snake-move-down + + "C-b" #'snake-move-left + "C-f" #'snake-move-right + "C-p" #'snake-move-up + "C-n" #'snake-move-down) + +(defvar-keymap snake-null-map + :doc "Keymap for finished Snake games." + :name 'snake-null-map + "n" #'snake-start-game + "q" #'quit-window) (defconst snake--menu-def '("Snake" diff --git a/lisp/play/tetris.el b/lisp/play/tetris.el index 3d6ddd5307..693bfe4935 100644 --- a/lisp/play/tetris.el +++ b/lisp/play/tetris.el @@ -236,26 +236,24 @@ each one of its four blocks.") ;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar tetris-mode-map - (let ((map (make-sparse-keymap 'tetris-mode-map))) - (define-key map "n" 'tetris-start-game) - (define-key map "q" 'tetris-end-game) - (define-key map "p" 'tetris-pause-game) - - (define-key map " " 'tetris-move-bottom) - (define-key map [left] 'tetris-move-left) - (define-key map [right] 'tetris-move-right) - (define-key map [up] 'tetris-rotate-prev) - (define-key map [down] 'tetris-move-down) - map) - "Keymap for Tetris games.") - -(defvar tetris-null-map - (let ((map (make-sparse-keymap 'tetris-null-map))) - (define-key map "n" 'tetris-start-game) - (define-key map "q" 'quit-window) - map) - "Keymap for finished Tetris games.") +(defvar-keymap tetris-mode-map + :doc "Keymap for Tetris games." + :name 'tetris-mode-map + "n" #'tetris-start-game + "q" #'tetris-end-game + "p" #'tetris-pause-game + + "SPC" #'tetris-move-bottom + "" #'tetris-move-left + "" #'tetris-move-right + "" #'tetris-rotate-prev + "" #'tetris-move-down) + +(defvar-keymap tetris-null-map + :doc "Keymap for finished Tetris games." + :name 'tetris-null-map + "n" #'tetris-start-game + "q" #'quit-window) (defconst tetris--menu-def '("Tetris" commit 5cb003c31c2484ec4281631df6a4c84631dbecc8 Author: Michael Albinus Date: Sat Nov 20 12:14:49 2021 +0100 ; Rearrange include in emba scripts diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 738e709c6b..ebfe996513 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -64,7 +64,6 @@ test-jobs-pipeline: stage: trigger trigger: include: - - local: '/test/infra/default-gitlab-ci.yml' - artifact: test-jobs.yml job: test-jobs-generator strategy: depend diff --git a/test/infra/test-jobs-generator.sh b/test/infra/test-jobs-generator.sh index 49f491ea66..15877dd3e6 100755 --- a/test/infra/test-jobs-generator.sh +++ b/test/infra/test-jobs-generator.sh @@ -53,6 +53,9 @@ for subdir in $SUBDIRS; do esac cat < Date: Sat Nov 20 13:00:42 2021 +0200 ; Avoid byte-compilation warnings in edmacro.el * lisp/edmacro.el (mouse-wheel-down-event, mouse-wheel-up-event) (mouse-wheel-right-event, mouse-wheel-left-event): Defvar them, to avoid compilation warnings in --without-x builds. diff --git a/lisp/edmacro.el b/lisp/edmacro.el index e90b3a006e..42c164a088 100644 --- a/lisp/edmacro.el +++ b/lisp/edmacro.el @@ -601,6 +601,12 @@ This function assumes that the events can be stored in a string." (setf (aref seq i) (logand (aref seq i) 127)))) seq) +;; These are needed in a --without-x build. +(defvar mouse-wheel-down-event) +(defvar mouse-wheel-up-event) +(defvar mouse-wheel-right-event) +(defvar mouse-wheel-left-event) + (defun edmacro-fix-menu-commands (macro &optional noerror) (if (vectorp macro) (let (result) commit 9ccfdd54fab1ac23243e211cdda7cec16fe8fd57 Author: Eli Zaretskii Date: Sat Nov 20 12:44:13 2021 +0200 ; * configure.ac (emacs_config_features): Add XINPUT2. diff --git a/configure.ac b/configure.ac index 239bf72f71..82661c975e 100644 --- a/configure.ac +++ b/configure.ac @@ -5955,7 +5955,7 @@ for opt in ACL CAIRO DBUS FREETYPE GCONF GIF GLIB GMP GNUTLS GPM GSETTINGS \ HARFBUZZ IMAGEMAGICK JPEG JSON LCMS2 LIBOTF LIBSELINUX LIBSYSTEMD LIBXML2 \ M17N_FLT MODULES NATIVE_COMP NOTIFY NS OLDXMENU PDUMPER PNG RSVG SECCOMP \ SOUND THREADS TIFF TOOLKIT_SCROLL_BARS \ - UNEXEC WEBP X11 XAW3D XDBE XFT XIM XPM XWIDGETS X_TOOLKIT \ + UNEXEC WEBP X11 XAW3D XDBE XFT XIM XINPUT2 XPM XWIDGETS X_TOOLKIT \ ZLIB; do case $opt in commit 4351722477cda59d88e5b1a90aa92cd6902021a8 Author: Lars Ingebrigtsen Date: Sat Nov 20 11:42:38 2021 +0100 Make shr render text with superscripts prettier * lisp/net/shr.el (shr-sup): New face. (shr-tag-sup, shr-tag-sub): Use it to make the super/subscripts slightly smaller so that we don't get uneven line heights with text that uses these. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 5a36f19c5f..87bacd4fbf 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -183,6 +183,11 @@ temporarily blinks with this face." "Face for elements." :version "27.1") +(defface shr-sup + '((t :height 0.8)) + "Face for and elements." + :version "29.1") + (defface shr-h1 '((t :height 1.3 :weight bold)) "Face for

elements." @@ -1464,12 +1469,14 @@ ones, in case fg and bg are nil." (defun shr-tag-sup (dom) (let ((start (point))) (shr-generic dom) - (put-text-property start (point) 'display '(raise 0.2)))) + (put-text-property start (point) 'display '(raise 0.2)) + (add-face-text-property start (point) 'shr-sup))) (defun shr-tag-sub (dom) (let ((start (point))) (shr-generic dom) - (put-text-property start (point) 'display '(raise -0.2)))) + (put-text-property start (point) 'display '(raise -0.2)) + (add-face-text-property start (point) 'shr-sup))) (defun shr-tag-p (dom) (shr-ensure-paragraph) commit 6b0424c102b736686caccdc633b6a7126e26dbc0 Author: Po Lu Date: Sat Nov 20 18:35:45 2021 +0800 Fix a comment in XInput related code * src/xterm.c (x_term_init): Fix comment to say "XInput 2.1" instead of "XInput 1.1". diff --git a/src/xterm.c b/src/xterm.c index ed3921f286..a023a5f9c8 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -14273,7 +14273,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) int minor = 3; #elif defined XI_TouchBegin /* XInput 2.2 */ int minor = 2; -#elif defined XIScrollClass /* XInput 1.1 */ +#elif defined XIScrollClass /* XInput 2.1 */ int minor = 1; #else /* Some old version of XI2 we're not interested in. */ int minor = 0; commit 0c51c1b5ede3521d90a94abdea42dee5078a9432 Author: Po Lu Date: Tue Nov 16 19:39:50 2021 +0800 Expose pixel-wise wheel events to Lisp * doc/lispref/commands.texi (Misc Events): Document changes to wheel events. * src/keyboard.c (make_lispy_event): Handle wheel events with pixel delta data. * src/termhooks.h (WHEEL_EVENT): Document changes to WHEEL_EVENT args. * src/xfns.c (syms_of_xfns): Declare new symbols. * src/xterm.c (handle_one_xevent): Give wheel events pixel delta data. (x_coalesce_scroll_events): New user option. diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index cc9c41623d..5fd7b55a60 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -1994,7 +1994,18 @@ frame has already been made visible, Emacs has no work to do. These kinds of event are generated by moving a mouse wheel. The @var{position} element is a mouse position list (@pxref{Click Events}), specifying the position of the mouse cursor when the event -occurred. +occurred. The event may have additional arguments after +@var{position}. The third argument after @var{position}, if present, +is a pair of the form @w{@code{(@var{x} . @var{y})}}, where @var{x} +and @var{y} are the number of pixels to scroll by in each axis. + +@cindex pixel-resolution wheel events +You can use @var{x} and @var{y} to determine how much the mouse wheel +has actually moved at pixel resolution. + +For example, the pixelwise deltas could be used to scroll the display +at pixel resolution, exactly according to the user's turning the mouse +wheel. @vindex mouse-wheel-up-event @vindex mouse-wheel-down-event diff --git a/src/keyboard.c b/src/keyboard.c index c3bc8307d7..0c48790ce8 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -5980,7 +5980,11 @@ make_lispy_event (struct input_event *event) ASIZE (wheel_syms)); } - if (NUMBERP (event->arg)) + if (CONSP (event->arg)) + return list5 (head, position, make_fixnum (double_click_count), + XCAR (event->arg), Fcons (XCAR (XCDR (event->arg)), + XCAR (XCDR (XCDR (event->arg))))); + else if (NUMBERP (event->arg)) return list4 (head, position, make_fixnum (double_click_count), event->arg); else if (event->modifiers & (double_modifier | triple_modifier)) diff --git a/src/termhooks.h b/src/termhooks.h index e7539bbce2..b274be9e3c 100644 --- a/src/termhooks.h +++ b/src/termhooks.h @@ -119,7 +119,10 @@ enum event_kind .timestamp gives a timestamp (in milliseconds) for the event. .arg may contain the number of - lines to scroll. */ + lines to scroll, or a list of + the form (NUMBER-OF-LINES . (X Y)) where + X and Y are the number of pixels + on each axis to scroll by. */ HORIZ_WHEEL_EVENT, /* A wheel event generated by a second horizontal wheel that is present on some mice. See WHEEL_EVENT. */ diff --git a/src/xfns.c b/src/xfns.c index b33b40b330..0ea43d1330 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -8085,6 +8085,7 @@ eliminated in future versions of Emacs. */); #ifdef HAVE_XINPUT2 DEFSYM (Qxinput2, "xinput2"); + Fprovide (Qxinput2, Qnil); #endif diff --git a/src/xterm.c b/src/xterm.c index 63754a2cb6..ed3921f286 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -556,6 +556,7 @@ xi_reset_scroll_valuators_for_device_id (struct x_display_info *dpyinfo, int id) { valuator = &device->valuators[i]; valuator->invalid_p = true; + valuator->emacs_value = 0.0; } return; @@ -9921,8 +9922,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, #endif goto XI_OTHER; case XI_Motion: - /* First test if there is some kind of scroll event - here! */ states = &xev->valuators; values = states->values; @@ -9932,10 +9931,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, { if (XIMaskIsSet (states->mask, i)) { - block_input (); - struct xi_scroll_valuator_t *val; - double delta; + double delta, scroll_unit; delta = x_get_scroll_valuator_delta (dpyinfo, xev->deviceid, i, *values, &val); @@ -9943,6 +9940,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (delta != DBL_MAX) { f = mouse_or_wdesc_frame (dpyinfo, xev->event); + scroll_unit = pow (FRAME_PIXEL_HEIGHT (f), 2.0 / 3.0); found_valuator = true; if (signbit (delta) != signbit (val->emacs_value)) @@ -9950,15 +9948,16 @@ handle_one_xevent (struct x_display_info *dpyinfo, val->emacs_value += delta; + if (x_coalesce_scroll_events + && (fabs (val->emacs_value) < 1)) + continue; + if (!f) { f = x_any_window_to_frame (dpyinfo, xev->event); if (!f) - { - unblock_input (); - goto XI_OTHER; - } + goto XI_OTHER; } bool s = signbit (val->emacs_value); @@ -9975,13 +9974,26 @@ handle_one_xevent (struct x_display_info *dpyinfo, inev.ie.modifiers |= x_x_to_emacs_modifiers (dpyinfo, xev->mods.effective); - inev.ie.arg = Qnil; + + if (val->horizontal) + { + inev.ie.arg + = list3 (Qnil, + make_float (val->emacs_value + * scroll_unit), + make_float (0)); + } + else + { + inev.ie.arg = list3 (Qnil, make_float (0), + make_float (val->emacs_value + * scroll_unit)); + } kbd_buffer_store_event_hold (&inev.ie, hold_quit); val->emacs_value = 0; } - unblock_input (); values++; } @@ -15048,4 +15060,11 @@ gtk_window_move to set or store frame positions and disables some time consuming frame position adjustments. In newer versions of GTK, Emacs always uses gtk_window_move and ignores the value of this variable. */); x_gtk_use_window_move = true; + + DEFVAR_BOOL ("x-coalesce-scroll-events", x_coalesce_scroll_events, + doc: /* Non-nil means send a wheel event only for scrolling at least one screen line. +Otherwise, a wheel event will be sent every time the mouse wheel is +moved. This option is only effective when Emacs is built with XInput +2. */); + x_coalesce_scroll_events = true; } commit 487ec3cf2a34496866153474507ab741d8dfea63 Author: Po Lu Date: Sat Oct 16 13:15:36 2021 +0800 Add support for event processing via XInput 2 * configure.ac: Add an option to use XInput 2 if available. * src/Makefile.in (XINPUT_LIBS, XINPUT_CFLAGS): New variables. (EMACS_CFLAGS): Add Xinput CFLAGS. (LIBES): Add XInput libs. * src/xmenu.c (popup_activated_flag): Expose flag if XInput 2 is available. * src/xfns.c (x_window): Set XInput 2 event mask. (setup_xi_event_mask): New function. (syms_of_xfns): Provide XInput 2 feature. * src/xterm.c (x_detect_focus_change): Handle XInput 2 GenericEvents. (handle_one_xevent): Handle XInput 2 events. (x_term_init): Ask the server for XInput 2 support and set xkb_desc if available. (x_delete_terminal): Free XKB kb desc if it exists, and free XI2 devices if they exist. (xi_grab_or_ungrab_device) (xi_reset_scroll_valuators_for_device_id) (x_free_xi_devices, x_init_master_valuators): New functions. (x_get_scroll_valuator_delta): New function. (init_xterm): Don't tell GTK to only use Core Input when built with XInput 2 support. * src/xterm.h (struct x_display_info): Add fields for XKB and XI2 support. * src/gtkutil.c (xg_event_is_for_menubar): Handle XIDeviceEvents. (xg_is_menu_window): New function. (xg_event_is_for_scrollbar): Handle XIDeviceEvents. * etc/NEWS: Document changes. * lisp/mwheel.el (mouse-wheel-down-alternate-event) (mouse-wheel-up-alternate-event) (mouse-wheel-left-alternate-event) (mouse-wheel-right-alternate-event): New user options. (mouse-wheel-text-scale) (mwheel-scroll): Test for alternate events. (mouse-wheel--setup-bindings): Set up bindings for alternate buttons. diff --git a/configure.ac b/configure.ac index c231c2ceae..239bf72f71 100644 --- a/configure.ac +++ b/configure.ac @@ -487,6 +487,7 @@ OPTION_DEFAULT_ON([modules],[don't compile with dynamic modules support]) OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support]) OPTION_DEFAULT_OFF([native-compilation],[compile with Emacs Lisp native compiler support]) OPTION_DEFAULT_OFF([cygwin32-native-compilation],[use native compilation on 32-bit Cygwin]) +OPTION_DEFAULT_OFF([xinput2],[use version 2.0 the X Input Extension for input]) AC_ARG_WITH([file-notification],[AS_HELP_STRING([--with-file-notification=LIB], [use a file notification library (LIB one of: yes, inotify, kqueue, gfile, w32, no)])], @@ -4237,6 +4238,26 @@ fi AC_SUBST(XFIXES_CFLAGS) AC_SUBST(XFIXES_LIBS) +## Use XInput 2.0 if available +HAVE_XINPUT2=no +if test "${HAVE_X11}" = "yes" && test "${with_xinput2}" != "no"; then + EMACS_CHECK_MODULES([XINPUT], [xi]) + if test $HAVE_XINPUT = yes; then + # Now check for XInput2.h + AC_CHECK_HEADER(X11/extensions/XInput2.h, + [AC_CHECK_LIB(Xi, XIGrabButton, HAVE_XINPUT2=yes)]) + fi + if test $HAVE_XINPUT2 = yes; then + AC_DEFINE(HAVE_XINPUT2, 1, [Define to 1 if the X Input Extension version 2.0 is present.]) + if test "$USE_GTK_TOOLKIT" = "GTK2"; then + AC_MSG_WARN([You are building Emacs with GTK+ 2 and the X Input Extension version 2. +This might lead to problems if your version of GTK+ is not built with support for XInput 2.]) + fi + fi +fi +AC_SUBST(XINPUT_CFLAGS) +AC_SUBST(XINPUT_LIBS) + ### Use Xdbe (-lXdbe) if available HAVE_XDBE=no if test "${HAVE_X11}" = "yes"; then @@ -6011,6 +6032,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D Does Emacs support legacy unexec dumping? ${with_unexec} Which dumping strategy does Emacs use? ${with_dumping} Does Emacs have native lisp compiler? ${HAVE_NATIVE_COMP} + Does Emacs use version 2 of the the X Input Extension? ${HAVE_XINPUT2} "]) if test -n "${EMACSDATA}"; then diff --git a/etc/NEWS b/etc/NEWS index a5ca8fbb2b..3cceac5584 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -30,6 +30,14 @@ The file is typically installed using a file name akin to If a constant file name is required, the file can be renamed to "emacs.pdmp", and Emacs will find it during startup anyway. +** Emacs now supports use of XInput 2 for input events. +If your X server has support and you have the XInput 2 development headers +installed, you can configure Emacs with the option '--with-xinput2' to enable +this support. + +The named feature `xinput2' can be used to test for the presence of +XInput 2 support from Lisp programs. + * Startup Changes in Emacs 29.1 @@ -224,6 +232,15 @@ The user option 'comint-terminfo-terminal' and variable 'system-uses-terminfo' can now be set as connection-local variables to change the terminal used on a remote host. +** Mwheel + +--- +*** New user options for alternate wheel events. +The options 'mouse-wheel-down-alternate-event', 'mouse-wheel-up-alternate-event', +'mouse-wheel-left-alternate-event', and 'mouse-wheel-right-alternate-event' have +been added to better support systems where two kinds of wheel events can be +received. + * Changes in Specialized Modes and Packages in Emacs 29.1 diff --git a/lisp/mwheel.el b/lisp/mwheel.el index 51410e3ef4..3d0b8f07cb 100644 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@ -63,6 +63,13 @@ :type 'symbol :set 'mouse-wheel-change-button) +(defcustom mouse-wheel-down-alternate-event + (when (featurep 'xinput2) 'wheel-up) + "Alternative wheel down event to consider." + :group 'mouse + :type 'symbol + :set 'mouse-wheel-change-button) + (defcustom mouse-wheel-up-event (if (or (featurep 'w32-win) (featurep 'ns-win)) 'wheel-down @@ -72,6 +79,13 @@ :type 'symbol :set 'mouse-wheel-change-button) +(defcustom mouse-wheel-up-alternate-event + (when (featurep 'xinput2) 'wheel-down) + "Alternative wheel up event to consider." + :group 'mouse + :type 'symbol + :set 'mouse-wheel-change-button) + (defcustom mouse-wheel-click-event 'mouse-2 "Event that should be temporarily inhibited after mouse scrolling. The mouse wheel is typically on the mouse-2 button, so it may easily @@ -226,12 +240,20 @@ Also see `mouse-wheel-tilt-scroll'." 'mouse-6) "Event used for scrolling left.") +(defvar mouse-wheel-left-alternate-event + (when (featurep 'xinput2) 'wheel-left) + "Alternative wheel left event to consider.") + (defvar mouse-wheel-right-event (if (or (featurep 'w32-win) (featurep 'ns-win)) 'wheel-right 'mouse-7) "Event used for scrolling right.") +(defvar mouse-wheel-right-alternate-event + (when (featurep 'xinput2) 'wheel-right) + "Alternative wheel right event to consider.") + (defun mouse-wheel--get-scroll-window (event) "Return window for mouse wheel event EVENT. If `mouse-wheel-follow-mouse' is non-nil, return the window that @@ -296,14 +318,16 @@ value of ARG, and the command uses it in subsequent scrolls." (condition-case nil (unwind-protect (let ((button (mwheel-event-button event))) - (cond ((and (eq amt 'hscroll) (eq button mouse-wheel-down-event)) + (cond ((and (eq amt 'hscroll) (memq button (list mouse-wheel-down-event + mouse-wheel-down-alternate-event))) (when (and (natnump arg) (> arg 0)) (setq mouse-wheel-scroll-amount-horizontal arg)) (funcall (if mouse-wheel-flip-direction mwheel-scroll-left-function mwheel-scroll-right-function) mouse-wheel-scroll-amount-horizontal)) - ((eq button mouse-wheel-down-event) + ((memq button (list mouse-wheel-down-event + mouse-wheel-down-alternate-event)) (condition-case nil (funcall mwheel-scroll-down-function amt) ;; Make sure we do indeed scroll to the beginning of ;; the buffer. @@ -318,23 +342,27 @@ value of ARG, and the command uses it in subsequent scrolls." ;; for a reason that escapes me. This problem seems ;; to only affect scroll-down. --Stef (set-window-start (selected-window) (point-min)))))) - ((and (eq amt 'hscroll) (eq button mouse-wheel-up-event)) + ((and (eq amt 'hscroll) (memq button (list mouse-wheel-up-event + mouse-wheel-up-alternate-event))) (when (and (natnump arg) (> arg 0)) (setq mouse-wheel-scroll-amount-horizontal arg)) (funcall (if mouse-wheel-flip-direction mwheel-scroll-right-function mwheel-scroll-left-function) mouse-wheel-scroll-amount-horizontal)) - ((eq button mouse-wheel-up-event) + ((memq button (list mouse-wheel-up-event + mouse-wheel-up-alternate-event)) (condition-case nil (funcall mwheel-scroll-up-function amt) ;; Make sure we do indeed scroll to the end of the buffer. (end-of-buffer (while t (funcall mwheel-scroll-up-function))))) - ((eq button mouse-wheel-left-event) ; for tilt scroll + ((memq button (list mouse-wheel-left-event + mouse-wheel-left-alternate-event)) ; for tilt scroll (when mouse-wheel-tilt-scroll (funcall (if mouse-wheel-flip-direction mwheel-scroll-right-function mwheel-scroll-left-function) amt))) - ((eq button mouse-wheel-right-event) ; for tilt scroll + ((memq button (list mouse-wheel-right-event + mouse-wheel-right-alternate-event)) ; for tilt scroll (when mouse-wheel-tilt-scroll (funcall (if mouse-wheel-flip-direction mwheel-scroll-left-function @@ -378,9 +406,11 @@ value of ARG, and the command uses it in subsequent scrolls." (button (mwheel-event-button event))) (select-window scroll-window 'mark-for-redisplay) (unwind-protect - (cond ((eq button mouse-wheel-down-event) + (cond ((memq button (list mouse-wheel-down-event + mouse-wheel-down-alternate-event)) (text-scale-increase 1)) - ((eq button mouse-wheel-up-event) + ((eq button (list mouse-wheel-up-event + mouse-wheel-up-alternate-event)) (text-scale-decrease 1))) (select-window selected-window)))) @@ -432,15 +462,23 @@ an event used for scrolling, such as `mouse-wheel-down-event'." (cond ;; Bindings for changing font size. ((and (consp binding) (eq (cdr binding) 'text-scale)) - (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event)) - (mouse-wheel--add-binding `[,(list (caar binding) event)] - 'mouse-wheel-text-scale))) + (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event + mouse-wheel-down-alternate-event + mouse-wheel-up-alternate-event)) + (when event + (mouse-wheel--add-binding `[,(list (caar binding) event)] + 'mouse-wheel-text-scale)))) ;; Bindings for scrolling. (t (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event - mouse-wheel-left-event mouse-wheel-right-event)) - (dolist (key (mouse-wheel--create-scroll-keys binding event)) - (mouse-wheel--add-binding key 'mwheel-scroll))))))) + mouse-wheel-left-event mouse-wheel-right-event + mouse-wheel-down-alternate-event + mouse-wheel-up-alternate-event + mouse-wheel-left-alternate-event + mouse-wheel-right-alternate-event)) + (when event + (dolist (key (mouse-wheel--create-scroll-keys binding event)) + (mouse-wheel--add-binding key 'mwheel-scroll)))))))) (when mouse-wheel-mode (mouse-wheel--setup-bindings)) diff --git a/src/Makefile.in b/src/Makefile.in index 4c5535f8ad..0aaaf91d39 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -258,6 +258,9 @@ XINERAMA_CFLAGS = @XINERAMA_CFLAGS@ XFIXES_LIBS = @XFIXES_LIBS@ XFIXES_CFLAGS = @XFIXES_CFLAGS@ +XINPUT_LIBS = @XINPUT_LIBS@ +XINPUT_CFLAGS = @XINPUT_CFLAGS@ + XDBE_LIBS = @XDBE_LIBS@ XDBE_CFLAGS = @XDBE_CFLAGS@ @@ -374,7 +377,7 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \ $(GNUSTEP_CFLAGS) $(CFLAGS_SOUND) $(RSVG_CFLAGS) $(IMAGEMAGICK_CFLAGS) \ $(PNG_CFLAGS) $(LIBXML2_CFLAGS) $(LIBGCCJIT_CFLAGS) $(DBUS_CFLAGS) \ $(XRANDR_CFLAGS) $(XINERAMA_CFLAGS) $(XFIXES_CFLAGS) $(XDBE_CFLAGS) \ - $(WEBKIT_CFLAGS) $(WEBP_CFLAGS) $(LCMS2_CFLAGS) \ + $(XINPUT_CFLAGS) $(WEBP_CFLAGS) $(WEBKIT_CFLAGS) $(LCMS2_CFLAGS) \ $(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \ $(HARFBUZZ_CFLAGS) $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) \ @@ -524,7 +527,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(HARFBUZZ_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \ $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ - $(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT_LIBS) + $(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT_LIBS) $(XINPUT_LIBS) ## FORCE it so that admin/unidata can decide whether this file is ## up-to-date. Although since charprop depends on bootstrap-emacs, diff --git a/src/gtkutil.c b/src/gtkutil.c index a9eabf47d8..9e676cd025 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -47,6 +47,10 @@ along with GNU Emacs. If not, see . */ #include +#ifdef HAVE_XINPUT2 +#include +#endif + #ifdef HAVE_XFT #include #endif @@ -839,6 +843,23 @@ my_log_handler (const gchar *log_domain, GLogLevelFlags log_level, } #endif +#if defined HAVE_GTK3 && defined HAVE_XINPUT2 +bool +xg_is_menu_window (Display *dpy, Window wdesc) +{ + GtkWidget *gwdesc = xg_win_to_widget (dpy, wdesc); + + if (GTK_IS_WINDOW (gwdesc)) + { + GtkWidget *fw = gtk_bin_get_child (GTK_BIN (gwdesc)); + if (GTK_IS_MENU (fw)) + return true; + } + + return false; +} +#endif + /* Make a geometry string and pass that to GTK. It seems this is the only way to get geometry position right if the user explicitly asked for a position when starting Emacs. @@ -3589,6 +3610,18 @@ xg_event_is_for_menubar (struct frame *f, const XEvent *event) if (! x->menubar_widget) return 0; +#ifdef HAVE_XINPUT2 + XIDeviceEvent *xev = (XIDeviceEvent *) event->xcookie.data; + if (event->type == GenericEvent) /* XI_ButtonPress or XI_ButtonRelease */ + { + if (! (xev->event_x >= 0 + && xev->event_x < FRAME_PIXEL_WIDTH (f) + && xev->event_y >= 0 + && xev->event_y < FRAME_MENUBAR_HEIGHT (f))) + return 0; + } + else +#endif if (! (event->xbutton.x >= 0 && event->xbutton.x < FRAME_PIXEL_WIDTH (f) && event->xbutton.y >= 0 @@ -3597,7 +3630,12 @@ xg_event_is_for_menubar (struct frame *f, const XEvent *event) return 0; gdpy = gdk_x11_lookup_xdisplay (FRAME_X_DISPLAY (f)); - gw = gdk_x11_window_lookup_for_display (gdpy, event->xbutton.window); +#ifdef HAVE_XINPUT2 + if (event->type == GenericEvent) + gw = gdk_x11_window_lookup_for_display (gdpy, xev->event); + else +#endif + gw = gdk_x11_window_lookup_for_display (gdpy, event->xbutton.window); if (! gw) return 0; gevent.any.window = gw; gevent.any.type = GDK_NOTHING; @@ -4244,7 +4282,20 @@ xg_event_is_for_scrollbar (struct frame *f, const XEvent *event) { bool retval = 0; +#ifdef HAVE_XINPUT2 + XIDeviceEvent *xev = (XIDeviceEvent *) event->xcookie.data; + if (f && ((FRAME_DISPLAY_INFO (f)->supports_xi2 + && event->type == GenericEvent + && (event->xgeneric.extension + == FRAME_DISPLAY_INFO (f)->xi2_opcode) + && ((event->xgeneric.evtype == XI_ButtonPress + && xev->detail < 4) + || (event->xgeneric.evtype == XI_Motion))) + || (event->type == ButtonPress + && event->xbutton.button < 4))) +#else if (f && event->type == ButtonPress && event->xbutton.button < 4) +#endif /* HAVE_XINPUT2 */ { /* Check if press occurred outside the edit widget. */ GdkDisplay *gdpy = gdk_x11_lookup_xdisplay (FRAME_X_DISPLAY (f)); @@ -4262,10 +4313,29 @@ xg_event_is_for_scrollbar (struct frame *f, const XEvent *event) gwin = gdk_display_get_window_at_pointer (gdpy, NULL, NULL); #endif retval = gwin != gtk_widget_get_window (f->output_data.x->edit_widget); +#ifdef HAVE_XINPUT2 + GtkWidget *grab = gtk_grab_get_current (); + if (event->type == GenericEvent + && event->xgeneric.evtype == XI_Motion) + retval = retval || (grab && GTK_IS_SCROLLBAR (grab)); +#endif } +#ifdef HAVE_XINPUT2 + else if (f && ((FRAME_DISPLAY_INFO (f)->supports_xi2 + && event->type == GenericEvent + && (event->xgeneric.extension + == FRAME_DISPLAY_INFO (f)->xi2_opcode) + && ((event->xgeneric.evtype == XI_ButtonRelease + && xev->detail < 4) + || (event->xgeneric.evtype == XI_Motion))) + || ((event->type == ButtonRelease + && event->xbutton.button < 4) + || event->type == MotionNotify))) +#else else if (f && ((event->type == ButtonRelease && event->xbutton.button < 4) || event->type == MotionNotify)) +#endif /* HAVE_XINPUT2 */ { /* If we are releasing or moving the scroll bar, it has the grab. */ GtkWidget *w = gtk_grab_get_current (); diff --git a/src/gtkutil.h b/src/gtkutil.h index 31a12cd5d3..95dd75b7fa 100644 --- a/src/gtkutil.h +++ b/src/gtkutil.h @@ -192,6 +192,10 @@ extern Lisp_Object xg_get_page_setup (void); extern void xg_print_frames_dialog (Lisp_Object); #endif +#if defined HAVE_GTK3 && defined HAVE_XINPUT2 +extern bool xg_is_menu_window (Display *dpy, Window); +#endif + /* Mark all callback data that are Lisp_object:s during GC. */ extern void xg_mark_data (void); diff --git a/src/xfns.c b/src/xfns.c index 785ae3baca..b33b40b330 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -57,6 +57,10 @@ along with GNU Emacs. If not, see . */ #include #endif +#ifdef HAVE_XINPUT2 +#include +#endif + #ifdef USE_X_TOOLKIT #include @@ -2912,6 +2916,37 @@ initial_set_up_x_back_buffer (struct frame *f) unblock_input (); } +#if defined HAVE_XINPUT2 && !defined USE_GTK +static void +setup_xi_event_mask (struct frame *f) +{ + XIEventMask mask; + ptrdiff_t l = XIMaskLen (XI_LASTEVENT); + unsigned char *m; + + mask.mask = m = alloca (l); + memset (m, 0, l); + mask.mask_len = l; + mask.deviceid = XIAllMasterDevices; + + XISetMask (m, XI_ButtonPress); + XISetMask (m, XI_ButtonRelease); + XISetMask (m, XI_KeyPress); + XISetMask (m, XI_KeyRelease); + XISetMask (m, XI_Motion); + XISetMask (m, XI_Enter); + XISetMask (m, XI_Leave); + XISetMask (m, XI_FocusIn); + XISetMask (m, XI_FocusOut); + XISetMask (m, XI_PropertyEvent); + XISetMask (m, XI_HierarchyChanged); + XISetMask (m, XI_DeviceChanged); + XISelectEvents (FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), + &mask, 1); +} +#endif + #ifdef USE_X_TOOLKIT /* Create and set up the X widget for frame F. */ @@ -3074,6 +3109,11 @@ x_window (struct frame *f, long window_prompting) class_hints.res_class = SSDATA (Vx_resource_class); XSetClassHint (FRAME_X_DISPLAY (f), XtWindow (shell_widget), &class_hints); +#ifdef HAVE_XINPUT2 + if (FRAME_DISPLAY_INFO (f)->supports_xi2) + setup_xi_event_mask (f); +#endif + #ifdef HAVE_X_I18N FRAME_XIC (f) = NULL; if (use_xim) @@ -3254,6 +3294,11 @@ x_window (struct frame *f) } #endif /* HAVE_X_I18N */ +#ifdef HAVE_XINPUT2 + if (FRAME_DISPLAY_INFO (f)->supports_xi2) + setup_xi_event_mask (f); +#endif + validate_x_resource_name (); class_hints.res_name = SSDATA (Vx_resource_name); @@ -8038,6 +8083,11 @@ eliminated in future versions of Emacs. */); /* Tell Emacs about this window system. */ Fprovide (Qx, Qnil); +#ifdef HAVE_XINPUT2 + DEFSYM (Qxinput2, "xinput2"); + Fprovide (Qxinput2, Qnil); +#endif + #ifdef USE_X_TOOLKIT Fprovide (intern_c_string ("x-toolkit"), Qnil); #ifdef USE_MOTIF diff --git a/src/xmenu.c b/src/xmenu.c index ea2cbab203..07255911f9 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -105,7 +105,11 @@ along with GNU Emacs. If not, see . */ /* Flag which when set indicates a dialog or menu has been posted by Xt on behalf of one of the widget sets. */ +#ifndef HAVE_XINPUT2 static int popup_activated_flag; +#else +int popup_activated_flag; +#endif #ifdef USE_X_TOOLKIT diff --git a/src/xterm.c b/src/xterm.c index 816b6dc5a8..63754a2cb6 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -42,6 +42,10 @@ along with GNU Emacs. If not, see . */ #include #endif +#ifdef HAVE_XINPUT2 +#include +#endif + /* Load sys/types.h if not already loaded. In some systems loading it twice is suicidal. */ #ifndef makedev @@ -223,9 +227,15 @@ static bool x_handle_net_wm_state (struct frame *, const XPropertyEvent *); static void x_check_fullscreen (struct frame *); static void x_check_expected_move (struct frame *, int, int); static void x_sync_with_move (struct frame *, int, int, bool); +#ifndef HAVE_XINPUT2 static int handle_one_xevent (struct x_display_info *, const XEvent *, int *, struct input_event *); +#else +static int handle_one_xevent (struct x_display_info *, + XEvent *, int *, + struct input_event *); +#endif #if ! (defined USE_X_TOOLKIT || defined USE_MOTIF) && defined USE_GTK static int x_dispatch_event (XEvent *, Display *); #endif @@ -335,6 +345,224 @@ x_extension_initialize (struct x_display_info *dpyinfo) dpyinfo->ext_codes = ext_codes; } + +#ifdef HAVE_XINPUT2 + +/* Free all XI2 devices on dpyinfo. */ +static void +x_free_xi_devices (struct x_display_info *dpyinfo) +{ + block_input (); + + if (dpyinfo->num_devices) + { + for (int i = 0; i < dpyinfo->num_devices; ++i) + { + XIUngrabDevice (dpyinfo->display, dpyinfo->devices[i].device_id, + CurrentTime); + xfree (dpyinfo->devices[i].valuators); + } + + xfree (dpyinfo->devices); + dpyinfo->devices = NULL; + dpyinfo->num_devices = 0; + } + + unblock_input (); +} + +/* Setup valuator tracking for XI2 master devices on + DPYINFO->display. */ + +static void +x_init_master_valuators (struct x_display_info *dpyinfo) +{ + int ndevices; + XIDeviceInfo *infos; + + block_input (); + x_free_xi_devices (dpyinfo); + infos = XIQueryDevice (dpyinfo->display, + XIAllMasterDevices, + &ndevices); + + if (!ndevices) + { + XIFreeDeviceInfo (infos); + unblock_input (); + return; + } + + int actual_devices = 0; + dpyinfo->devices = xmalloc (sizeof *dpyinfo->devices * ndevices); + + for (int i = 0; i < ndevices; ++i) + { + XIDeviceInfo *device = &infos[i]; + + if (device->enabled) + { + int actual_valuator_count = 0; + struct xi_device_t *xi_device = &dpyinfo->devices[actual_devices++]; + xi_device->device_id = device->deviceid; + xi_device->grab = 0; + xi_device->valuators = + xmalloc (sizeof *xi_device->valuators * device->num_classes); + + for (int c = 0; c < device->num_classes; ++c) + { + switch (device->classes[c]->type) + { +#ifdef XIScrollClass /* XInput 2.1 */ + case XIScrollClass: + { + XIScrollClassInfo *info = + (XIScrollClassInfo *) device->classes[c]; + struct xi_scroll_valuator_t *valuator = + &xi_device->valuators[actual_valuator_count++]; + + valuator->horizontal + = (info->scroll_type == XIScrollTypeHorizontal); + valuator->invalid_p = true; + valuator->emacs_value = DBL_MIN; + valuator->increment = info->increment; + valuator->number = info->number; + break; + } +#endif + default: + break; + } + } + xi_device->scroll_valuator_count = actual_valuator_count; + } + } + + dpyinfo->num_devices = actual_devices; + XIFreeDeviceInfo (infos); + unblock_input (); +} + +/* Return the delta of the scroll valuator VALUATOR_NUMBER under + DEVICE_ID in the display DPYINFO with VALUE. The valuator's + valuator will be set to VALUE afterwards. In case no scroll + valuator is found, or if device_id is not known to Emacs, DBL_MAX + is returned. Otherwise, the valuator is returned in + VALUATOR_RETURN. */ +static double +x_get_scroll_valuator_delta (struct x_display_info *dpyinfo, int device_id, + int valuator_number, double value, + struct xi_scroll_valuator_t **valuator_return) +{ + block_input (); + + for (int i = 0; i < dpyinfo->num_devices; ++i) + { + struct xi_device_t *device = &dpyinfo->devices[i]; + + if (device->device_id == device_id) + { + for (int j = 0; j < device->scroll_valuator_count; ++j) + { + struct xi_scroll_valuator_t *sv = &device->valuators[j]; + + if (sv->number == valuator_number) + { + if (sv->invalid_p) + { + sv->current_value = value; + sv->invalid_p = false; + *valuator_return = sv; + + unblock_input (); + return 0.0; + } + else + { + double delta = (sv->current_value - value) / sv->increment; + sv->current_value = value; + *valuator_return = sv; + + unblock_input (); + return delta; + } + } + } + + unblock_input (); + return DBL_MAX; + } + } + + unblock_input (); + return DBL_MAX; +} + +static struct xi_device_t * +xi_device_from_id (struct x_display_info *dpyinfo, int deviceid) +{ + for (int i = 0; i < dpyinfo->num_devices; ++i) + { + if (dpyinfo->devices[i].device_id == deviceid) + return &dpyinfo->devices[i]; + } + + return NULL; +} + +static void +xi_grab_or_ungrab_device (struct xi_device_t *device, + struct x_display_info *dpyinfo, + Window window) +{ + XIEventMask mask; + ptrdiff_t l = XIMaskLen (XI_LASTEVENT); + unsigned char *m; + mask.mask = m = alloca (l); + memset (m, 0, l); + mask.mask_len = l; + + XISetMask (m, XI_ButtonPress); + XISetMask (m, XI_ButtonRelease); + XISetMask (m, XI_Motion); + XISetMask (m, XI_Enter); + XISetMask (m, XI_Leave); + + if (device->grab) + { + XIGrabDevice (dpyinfo->display, device->device_id, window, + CurrentTime, None, GrabModeAsync, + GrabModeAsync, True, &mask); + } + else + { + XIUngrabDevice (dpyinfo->display, device->device_id, CurrentTime); + } +} + +static void +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) + return; + + if (!device->scroll_valuator_count) + return; + + for (int i = 0; i < device->scroll_valuator_count; ++i) + { + valuator = &device->valuators[i]; + valuator->invalid_p = true; + } + + return; +} + +#endif + void x_cr_destroy_frame_context (struct frame *f) { @@ -4768,7 +4996,16 @@ static struct frame * x_menubar_window_to_frame (struct x_display_info *dpyinfo, const XEvent *event) { - Window wdesc = event->xany.window; + Window wdesc; +#ifdef HAVE_XINPUT2 + if (event->type == GenericEvent + && dpyinfo->supports_xi2 + && (event->xcookie.evtype == XI_ButtonPress + || event->xcookie.evtype == XI_ButtonRelease)) + wdesc = ((XIDeviceEvent *) event->xcookie.data)->event; + else +#endif + wdesc = event->xany.window; Lisp_Object tail, frame; struct frame *f; struct x_output *x; @@ -4871,6 +5108,29 @@ x_detect_focus_change (struct x_display_info *dpyinfo, struct frame *frame, } break; +#ifdef HAVE_XINPUT2 + case GenericEvent: + { + XIEvent *xi_event = (XIEvent *) event; + + struct frame *focus_frame = dpyinfo->x_focus_event_frame; + int focus_state + = focus_frame ? focus_frame->output_data.x->focus_state : 0; + + if (!((xi_event->evtype == XI_Enter + || xi_event->evtype == XI_Leave) + && (focus_state & FOCUS_EXPLICIT))) + x_focus_changed ((xi_event->evtype == XI_Enter + || xi_event->evtype == XI_FocusIn + ? FocusIn : FocusOut), + (xi_event->evtype == XI_Enter + || xi_event->evtype == XI_Leave + ? FOCUS_IMPLICIT : FOCUS_EXPLICIT), + dpyinfo, frame, bufp); + break; + } +#endif + case FocusIn: case FocusOut: /* Ignore transient focus events from hotkeys, window manager @@ -7975,7 +8235,11 @@ mouse_or_wdesc_frame (struct x_display_info *dpyinfo, int wdesc) static int handle_one_xevent (struct x_display_info *dpyinfo, +#ifndef HAVE_XINPUT2 const XEvent *event, +#else + XEvent *event, +#endif int *finish, struct input_event *hold_quit) { union buffered_input_event inev; @@ -8001,7 +8265,14 @@ handle_one_xevent (struct x_display_info *dpyinfo, inev.ie.kind = NO_EVENT; inev.ie.arg = Qnil; - any = x_any_window_to_frame (dpyinfo, event->xany.window); +#ifdef HAVE_XINPUT2 + if (event->type != GenericEvent) +#endif + any = x_any_window_to_frame (dpyinfo, event->xany.window); +#ifdef HAVE_XINPUT2 + else + any = NULL; +#endif if (any && any->wait_event_type == event->type) any->wait_event_type = 0; /* Indicates we got it. */ @@ -8480,6 +8751,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto OTHER; case MapNotify: +#if defined HAVE_XINPUT2 && defined HAVE_GTK3 + if (xg_is_menu_window (dpyinfo->display, event->xmap.window)) + popup_activated_flag = 1; +#endif /* We use x_top_window_to_frame because map events can come for sub-windows and they don't mean that the frame is visible. */ @@ -9518,6 +9793,785 @@ handle_one_xevent (struct x_display_info *dpyinfo, case DestroyNotify: xft_settings_event (dpyinfo, event); break; +#ifdef HAVE_XINPUT2 + case GenericEvent: + { + if (!dpyinfo->supports_xi2) + goto OTHER; + if (event->xgeneric.extension != dpyinfo->xi2_opcode) + /* Not an XI2 event. */ + goto OTHER; + bool must_free_data = false; + XIEvent *xi_event = (XIEvent *) event->xcookie.data; + /* Sometimes the event is already claimed by GTK, which + will free its data in due course. */ + if (!xi_event && XGetEventData (dpyinfo->display, &event->xcookie)) + { + must_free_data = true; + xi_event = (XIEvent *) event->xcookie.data; + } + + XIDeviceEvent *xev = (XIDeviceEvent *) xi_event; + XILeaveEvent *leave = (XILeaveEvent *) xi_event; + XIEnterEvent *enter = (XIEnterEvent *) xi_event; + XIFocusInEvent *focusin = (XIFocusInEvent *) xi_event; + XIFocusOutEvent *focusout = (XIFocusOutEvent *) xi_event; + XIValuatorState *states; + double *values; + bool found_valuator = false; + + /* A fake XMotionEvent for x_note_mouse_movement. */ + XMotionEvent ev; + /* A fake XButtonEvent for x_construct_mouse_click. */ + XButtonEvent bv; + + if (!xi_event) + { + eassert (!must_free_data); + goto OTHER; + } + + switch (event->xcookie.evtype) + { + case XI_FocusIn: + any = x_any_window_to_frame (dpyinfo, focusin->event); +#ifndef USE_GTK + /* Some WMs (e.g. Mutter in Gnome Shell), don't unmap + minimized/iconified windows; thus, for those WMs we won't get + a MapNotify when unminimizing/deconifying. Check here if we + are deiconizing a window (Bug42655). + + But don't do that on GTK since it may cause a plain invisible + frame get reported as iconified, compare + https://lists.gnu.org/archive/html/emacs-devel/2017-02/msg00133.html. + That is fixed above but bites us here again. */ + f = any; + if (f && FRAME_ICONIFIED_P (f)) + { + SET_FRAME_VISIBLE (f, 1); + SET_FRAME_ICONIFIED (f, false); + f->output_data.x->has_been_visible = true; + inev.ie.kind = DEICONIFY_EVENT; + XSETFRAME (inev.ie.frame_or_window, f); + } +#endif /* USE_GTK */ + x_detect_focus_change (dpyinfo, any, event, &inev.ie); + goto XI_OTHER; + case XI_FocusOut: + any = x_any_window_to_frame (dpyinfo, focusout->event); + x_detect_focus_change (dpyinfo, any, event, &inev.ie); + goto XI_OTHER; + case XI_Enter: + any = x_any_window_to_frame (dpyinfo, enter->event); + ev.x = lrint (enter->event_x); + ev.y = lrint (enter->event_y); + ev.window = leave->event; + + x_display_set_last_user_time (dpyinfo, xi_event->time); + x_detect_focus_change (dpyinfo, any, event, &inev.ie); + xi_reset_scroll_valuators_for_device_id (dpyinfo, enter->deviceid); + f = any; + + if (f && x_mouse_click_focus_ignore_position) + ignore_next_mouse_click_timeout = xi_event->time + 200; + + /* EnterNotify counts as mouse movement, + so update things that depend on mouse position. */ + if (f && !f->output_data.x->hourglass_p) + x_note_mouse_movement (f, &ev); +#ifdef USE_GTK + /* We may get an EnterNotify on the buttons in the toolbar. In that + case we moved out of any highlighted area and need to note this. */ + if (!f && dpyinfo->last_mouse_glyph_frame) + x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev); +#endif + goto XI_OTHER; + case XI_Leave: + ev.x = lrint (leave->event_x); + ev.y = lrint (leave->event_y); + ev.window = leave->event; + any = x_any_window_to_frame (dpyinfo, leave->event); + + x_display_set_last_user_time (dpyinfo, xi_event->time); + x_detect_focus_change (dpyinfo, any, event, &inev.ie); + xi_reset_scroll_valuators_for_device_id (dpyinfo, leave->deviceid); + + f = x_top_window_to_frame (dpyinfo, leave->event); + if (f) + { + if (f == hlinfo->mouse_face_mouse_frame) + { + /* If we move outside the frame, then we're + certainly no longer on any text in the frame. */ + clear_mouse_face (hlinfo); + hlinfo->mouse_face_mouse_frame = 0; + } + + /* Generate a nil HELP_EVENT to cancel a help-echo. + Do it only if there's something to cancel. + Otherwise, the startup message is cleared when + the mouse leaves the frame. */ + if (any_help_event_p) + do_help = -1; + } +#ifdef USE_GTK + /* See comment in EnterNotify above */ + else if (dpyinfo->last_mouse_glyph_frame) + x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev); +#endif + goto XI_OTHER; + case XI_Motion: + /* First test if there is some kind of scroll event + here! */ + states = &xev->valuators; + values = states->values; + + x_display_set_last_user_time (dpyinfo, xi_event->time); + + for (int i = 0; i < states->mask_len * 8; i++) + { + if (XIMaskIsSet (states->mask, i)) + { + block_input (); + + struct xi_scroll_valuator_t *val; + double delta; + + delta = x_get_scroll_valuator_delta (dpyinfo, xev->deviceid, + i, *values, &val); + + if (delta != DBL_MAX) + { + f = mouse_or_wdesc_frame (dpyinfo, xev->event); + found_valuator = true; + + if (signbit (delta) != signbit (val->emacs_value)) + val->emacs_value = 0; + + val->emacs_value += delta; + + if (!f) + { + f = x_any_window_to_frame (dpyinfo, xev->event); + + if (!f) + { + unblock_input (); + goto XI_OTHER; + } + } + + bool s = signbit (val->emacs_value); + inev.ie.kind = (val->horizontal + ? HORIZ_WHEEL_EVENT + : WHEEL_EVENT); + inev.ie.timestamp = xev->time; + + XSETINT (inev.ie.x, lrint (xev->event_x)); + XSETINT (inev.ie.y, lrint (xev->event_y)); + XSETFRAME (inev.ie.frame_or_window, f); + + inev.ie.modifiers = !s ? up_modifier : down_modifier; + inev.ie.modifiers + |= x_x_to_emacs_modifiers (dpyinfo, + xev->mods.effective); + inev.ie.arg = Qnil; + + kbd_buffer_store_event_hold (&inev.ie, hold_quit); + + val->emacs_value = 0; + } + unblock_input (); + values++; + } + + inev.ie.kind = NO_EVENT; + } + + if (found_valuator) + goto XI_OTHER; + + ev.x = lrint (xev->event_x); + ev.y = lrint (xev->event_y); + ev.window = xev->event; + + previous_help_echo_string = help_echo_string; + help_echo_string = Qnil; + + if (hlinfo->mouse_face_hidden) + { + hlinfo->mouse_face_hidden = false; + clear_mouse_face (hlinfo); + } + + f = mouse_or_wdesc_frame (dpyinfo, xev->event); + +#ifdef USE_GTK + if (f && xg_event_is_for_scrollbar (f, event)) + f = 0; +#endif + if (f) + { + /* Maybe generate a SELECT_WINDOW_EVENT for + `mouse-autoselect-window' but don't let popup menus + interfere with this (Bug#1261). */ + if (!NILP (Vmouse_autoselect_window) + && !popup_activated () + /* Don't switch if we're currently in the minibuffer. + This tries to work around problems where the + minibuffer gets unselected unexpectedly, and where + you then have to move your mouse all the way down to + the minibuffer to select it. */ + && !MINI_WINDOW_P (XWINDOW (selected_window)) + /* With `focus-follows-mouse' non-nil create an event + also when the target window is on another frame. */ + && (f == XFRAME (selected_frame) + || !NILP (focus_follows_mouse))) + { + static Lisp_Object last_mouse_window; + Lisp_Object window = window_from_coordinates (f, ev.x, ev.y, 0, false, false); + + /* A window will be autoselected only when it is not + selected now and the last mouse movement event was + not in it. The remainder of the code is a bit vague + wrt what a "window" is. For immediate autoselection, + the window is usually the entire window but for GTK + where the scroll bars don't count. For delayed + autoselection the window is usually the window's text + area including the margins. */ + if (WINDOWP (window) + && !EQ (window, last_mouse_window) + && !EQ (window, selected_window)) + { + inev.ie.kind = SELECT_WINDOW_EVENT; + inev.ie.frame_or_window = window; + } + + /* Remember the last window where we saw the mouse. */ + last_mouse_window = window; + } + + if (!x_note_mouse_movement (f, &ev)) + help_echo_string = previous_help_echo_string; + } + else + { +#ifndef USE_TOOLKIT_SCROLL_BARS + struct scroll_bar *bar + = x_window_to_scroll_bar (xi_event->display, xev->event, 2); + + if (bar) + x_scroll_bar_note_movement (bar, &ev); +#endif /* USE_TOOLKIT_SCROLL_BARS */ + + /* If we move outside the frame, then we're + certainly no longer on any text in the frame. */ + clear_mouse_face (hlinfo); + } + + /* If the contents of the global variable help_echo_string + has changed, generate a HELP_EVENT. */ + if (!NILP (help_echo_string) + || !NILP (previous_help_echo_string)) + do_help = 1; + goto XI_OTHER; + case XI_ButtonRelease: + case XI_ButtonPress: + { + /* If we decide we want to generate an event to be seen + by the rest of Emacs, we put it here. */ + Lisp_Object tab_bar_arg = Qnil; + bool tab_bar_p = false; + bool tool_bar_p = false; + struct xi_device_t *device; + + /* Ignore emulated scroll events when XI2 native + scroll events are present. */ + if (dpyinfo->xi2_version >= 1 && xev->detail >= 4 + && xev->detail <= 8) + goto XI_OTHER; + + device = xi_device_from_id (dpyinfo, xev->deviceid); + + bv.button = xev->detail; + bv.type = xev->evtype == XI_ButtonPress ? ButtonPress : ButtonRelease; + bv.x = lrint (xev->event_x); + bv.y = lrint (xev->event_y); + bv.window = xev->event; + bv.state = xev->mods.base + | xev->mods.effective + | xev->mods.latched + | xev->mods.locked; + + memset (&compose_status, 0, sizeof (compose_status)); + dpyinfo->last_mouse_glyph_frame = NULL; + x_display_set_last_user_time (dpyinfo, xev->time); + + f = mouse_or_wdesc_frame (dpyinfo, xev->event); + + if (f && xev->evtype == XI_ButtonPress + && !popup_activated () + && !x_window_to_scroll_bar (xev->display, xev->event, 2) + && !FRAME_NO_ACCEPT_FOCUS (f)) + { + /* When clicking into a child frame or when clicking + into a parent frame with the child frame selected and + `no-accept-focus' is not set, select the clicked + frame. */ + struct frame *hf = dpyinfo->highlight_frame; + + if (FRAME_PARENT_FRAME (f) || (hf && frame_ancestor_p (f, hf))) + { + block_input (); + XSetInputFocus (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), + RevertToParent, CurrentTime); + if (FRAME_PARENT_FRAME (f)) + XRaiseWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f)); + unblock_input (); + } + } + +#ifdef USE_GTK + if (f && xg_event_is_for_scrollbar (f, event)) + f = 0; +#endif + + if (f) + { + /* Is this in the tab-bar? */ + if (WINDOWP (f->tab_bar_window) + && WINDOW_TOTAL_LINES (XWINDOW (f->tab_bar_window))) + { + Lisp_Object window; + int x = bv.x; + int y = bv.y; + + window = window_from_coordinates (f, x, y, 0, true, true); + tab_bar_p = EQ (window, f->tab_bar_window); + + if (tab_bar_p) + tab_bar_arg = handle_tab_bar_click + (f, x, y, xev->evtype == XI_ButtonPress, + x_x_to_emacs_modifiers (dpyinfo, bv.state)); + } + +#if ! defined (USE_GTK) + /* Is this in the tool-bar? */ + if (WINDOWP (f->tool_bar_window) + && WINDOW_TOTAL_LINES (XWINDOW (f->tool_bar_window))) + { + Lisp_Object window; + int x = bv.x; + int y = bv.y; + + window = window_from_coordinates (f, x, y, 0, true, true); + tool_bar_p = EQ (window, f->tool_bar_window); + + if (tool_bar_p && xev->detail < 4) + handle_tool_bar_click + (f, x, y, xev->evtype == XI_ButtonPress, + x_x_to_emacs_modifiers (dpyinfo, bv.state)); + } +#endif /* !USE_GTK */ + + if (!(tab_bar_p && NILP (tab_bar_arg)) && !tool_bar_p) +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) + if (! popup_activated ()) +#endif + { + if (ignore_next_mouse_click_timeout) + { + if (xev->evtype == XI_ButtonPress + && xev->time > ignore_next_mouse_click_timeout) + { + ignore_next_mouse_click_timeout = 0; + x_construct_mouse_click (&inev.ie, &bv, f); + } + if (xev->evtype == XI_ButtonRelease) + ignore_next_mouse_click_timeout = 0; + } + else + x_construct_mouse_click (&inev.ie, &bv, f); + + if (!NILP (tab_bar_arg)) + inev.ie.arg = tab_bar_arg; + } + if (FRAME_X_EMBEDDED_P (f)) + xembed_send_message (f, xev->time, + XEMBED_REQUEST_FOCUS, 0, 0, 0); + } + + if (xev->evtype == XI_ButtonPress) + { + dpyinfo->grabbed |= (1 << xev->detail); + device->grab |= (1 << xev->detail); + dpyinfo->last_mouse_frame = f; + if (f && !tab_bar_p) + f->last_tab_bar_item = -1; +#if ! defined (USE_GTK) + if (f && !tool_bar_p) + f->last_tool_bar_item = -1; +#endif /* not USE_GTK */ + + } + else + { + dpyinfo->grabbed &= ~(1 << xev->detail); + device->grab &= ~(1 << xev->detail); + } + + xi_grab_or_ungrab_device (device, dpyinfo, xev->event); + + if (f) + f->mouse_moved = false; + +#if defined (USE_GTK) + /* No Xt toolkit currently available has support for XI2. + So the code here assumes use of GTK. */ + f = x_menubar_window_to_frame (dpyinfo, event); + if (f /* Gtk+ menus only react to the first three buttons. */ + && xev->detail < 3) + { + /* What is done with Core Input ButtonPressed is not + possible here, because GenericEvents cannot be saved. */ + bool was_waiting_for_input = waiting_for_input; + /* This hack was adopted from the NS port. Whether + or not it is actually safe is a different story + altogether. */ + if (waiting_for_input) + waiting_for_input = 0; + set_frame_menubar (f, true); + waiting_for_input = was_waiting_for_input; + } +#endif + goto XI_OTHER; + } + case XI_KeyPress: + { + int state = xev->mods.base + | xev->mods.effective + | xev->mods.latched + | xev->mods.locked; + Lisp_Object c; +#ifdef HAVE_XKB + unsigned int mods_rtrn; +#endif + int keycode = xev->detail; + KeySym keysym; + char copy_buffer[81]; + char *copy_bufptr = copy_buffer; + unsigned char *copy_ubufptr; +#ifdef HAVE_XKB + int copy_bufsiz = sizeof (copy_buffer); +#endif + ptrdiff_t i; + int nchars, len; + +#ifdef HAVE_XKB + if (dpyinfo->xkb_desc) + { + if (!XkbTranslateKeyCode (dpyinfo->xkb_desc, keycode, + state, &mods_rtrn, &keysym)) + goto XI_OTHER; + } + else + { +#endif + int keysyms_per_keycode_return; + KeySym *ksms = XGetKeyboardMapping (dpyinfo->display, keycode, 1, + &keysyms_per_keycode_return); + if (!(keysym = ksms[0])) + { + XFree (ksms); + goto XI_OTHER; + } + XFree (ksms); +#ifdef HAVE_XKB + } +#endif + + if (keysym == NoSymbol) + goto XI_OTHER; + + x_display_set_last_user_time (dpyinfo, xev->time); + ignore_next_mouse_click_timeout = 0; + +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) + /* Dispatch XI_KeyPress events when in menu. */ + if (popup_activated ()) + goto XI_OTHER; +#endif + + f = x_any_window_to_frame (dpyinfo, xev->event); + + /* If mouse-highlight is an integer, input clears out + mouse highlighting. */ + if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight) + && (f == 0 +#if ! defined (USE_GTK) + || !EQ (f->tool_bar_window, hlinfo->mouse_face_window) +#endif + || !EQ (f->tab_bar_window, hlinfo->mouse_face_window)) + ) + { + clear_mouse_face (hlinfo); + hlinfo->mouse_face_hidden = true; + } + + if (f != 0) + { +#ifdef USE_GTK + /* Don't pass keys to GTK. A Tab will shift focus to the + tool bar in GTK 2.4. Keys will still go to menus and + dialogs because in that case popup_activated is nonzero + (see above). */ + *finish = X_EVENT_DROP; +#endif + /* If not using XIM/XIC, and a compose sequence is in progress, + we break here. Otherwise, chars_matched is always 0. */ + if (compose_status.chars_matched > 0 && nbytes == 0) + goto XI_OTHER; + + memset (&compose_status, 0, sizeof (compose_status)); + + XSETFRAME (inev.ie.frame_or_window, f); + inev.ie.modifiers + = x_x_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), state); + inev.ie.timestamp = xev->time; + + /* First deal with keysyms which have defined + translations to characters. */ + if (keysym >= 32 && keysym < 128) + /* Avoid explicitly decoding each ASCII character. */ + { + inev.ie.kind = ASCII_KEYSTROKE_EVENT; + inev.ie.code = keysym; + + goto xi_done_keysym; + } + + /* Keysyms directly mapped to Unicode characters. */ + if (keysym >= 0x01000000 && keysym <= 0x0110FFFF) + { + if (keysym < 0x01000080) + inev.ie.kind = ASCII_KEYSTROKE_EVENT; + else + inev.ie.kind = MULTIBYTE_CHAR_KEYSTROKE_EVENT; + inev.ie.code = keysym & 0xFFFFFF; + goto xi_done_keysym; + } + + /* Now non-ASCII. */ + if (HASH_TABLE_P (Vx_keysym_table) + && (c = Fgethash (make_fixnum (keysym), + Vx_keysym_table, + Qnil), + FIXNATP (c))) + { + inev.ie.kind = (SINGLE_BYTE_CHAR_P (XFIXNAT (c)) + ? ASCII_KEYSTROKE_EVENT + : MULTIBYTE_CHAR_KEYSTROKE_EVENT); + inev.ie.code = XFIXNAT (c); + goto xi_done_keysym; + } + + /* Random non-modifier sorts of keysyms. */ + if (((keysym >= XK_BackSpace && keysym <= XK_Escape) + || keysym == XK_Delete +#ifdef XK_ISO_Left_Tab + || (keysym >= XK_ISO_Left_Tab + && keysym <= XK_ISO_Enter) +#endif + || IsCursorKey (keysym) /* 0xff50 <= x < 0xff60 */ + || IsMiscFunctionKey (keysym) /* 0xff60 <= x < VARIES */ +#ifdef HPUX + /* This recognizes the "extended function + keys". It seems there's no cleaner way. + Test IsModifierKey to avoid handling + mode_switch incorrectly. */ + || (XK_Select <= keysym && keysym < XK_KP_Space) +#endif +#ifdef XK_dead_circumflex + || keysym == XK_dead_circumflex +#endif +#ifdef XK_dead_grave + || keysym == XK_dead_grave +#endif +#ifdef XK_dead_tilde + || keysym == XK_dead_tilde +#endif +#ifdef XK_dead_diaeresis + || keysym == XK_dead_diaeresis +#endif +#ifdef XK_dead_macron + || keysym == XK_dead_macron +#endif +#ifdef XK_dead_degree + || keysym == XK_dead_degree +#endif +#ifdef XK_dead_acute + || keysym == XK_dead_acute +#endif +#ifdef XK_dead_cedilla + || keysym == XK_dead_cedilla +#endif +#ifdef XK_dead_breve + || keysym == XK_dead_breve +#endif +#ifdef XK_dead_ogonek + || keysym == XK_dead_ogonek +#endif +#ifdef XK_dead_caron + || keysym == XK_dead_caron +#endif +#ifdef XK_dead_doubleacute + || keysym == XK_dead_doubleacute +#endif +#ifdef XK_dead_abovedot + || keysym == XK_dead_abovedot +#endif + || IsKeypadKey (keysym) /* 0xff80 <= x < 0xffbe */ + || IsFunctionKey (keysym) /* 0xffbe <= x < 0xffe1 */ + /* Any "vendor-specific" key is ok. */ + || (keysym & (1 << 28)) + || (keysym != NoSymbol && nbytes == 0)) + && ! (IsModifierKey (keysym) + /* The symbols from XK_ISO_Lock + to XK_ISO_Last_Group_Lock + don't have real modifiers but + should be treated similarly to + Mode_switch by Emacs. */ +#if defined XK_ISO_Lock && defined XK_ISO_Last_Group_Lock + || (XK_ISO_Lock <= keysym + && keysym <= XK_ISO_Last_Group_Lock) +#endif + )) + { + STORE_KEYSYM_FOR_DEBUG (keysym); + /* make_lispy_event will convert this to a symbolic + key. */ + inev.ie.kind = NON_ASCII_KEYSTROKE_EVENT; + inev.ie.code = keysym; + goto xi_done_keysym; + } + +#ifdef HAVE_XKB + int overflow = 0; + KeySym sym = keysym; + + if (dpyinfo->xkb_desc) + { + if (!(nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, + state & ~mods_rtrn, copy_bufptr, + copy_bufsiz, &overflow))) + goto XI_OTHER; + } + else +#else + { + block_input (); + char *str = XKeysymToString (keysym); + if (!str) + { + unblock_input (); + goto XI_OTHER; + } + nbytes = strlen (str) + 1; + copy_bufptr = alloca (nbytes); + strcpy (copy_bufptr, str); + unblock_input (); + } +#endif +#ifdef HAVE_XKB + if (overflow) + { + overflow = 0; + copy_bufptr = alloca (copy_bufsiz + overflow); + keysym = sym; + if (!(nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, + state & ~mods_rtrn, copy_bufptr, + copy_bufsiz + overflow, &overflow))) + goto XI_OTHER; + + if (overflow) + goto XI_OTHER; + } +#endif + + for (i = 0, nchars = 0; i < nbytes; i++) + { + if (ASCII_CHAR_P (copy_bufptr[i])) + nchars++; + STORE_KEYSYM_FOR_DEBUG (copy_bufptr[i]); + } + + if (nchars < nbytes) + { + /* Decode the input data. */ + + setup_coding_system (Vlocale_coding_system, &coding); + coding.src_multibyte = false; + coding.dst_multibyte = true; + /* The input is converted to events, thus we can't + handle composition. Anyway, there's no XIM that + gives us composition information. */ + coding.common_flags &= ~CODING_ANNOTATION_MASK; + + SAFE_NALLOCA (coding.destination, MAX_MULTIBYTE_LENGTH, + nbytes); + coding.dst_bytes = MAX_MULTIBYTE_LENGTH * nbytes; + coding.mode |= CODING_MODE_LAST_BLOCK; + decode_coding_c_string (&coding, (unsigned char *) copy_bufptr, + nbytes, Qnil); + nbytes = coding.produced; + nchars = coding.produced_char; + copy_bufptr = (char *) coding.destination; + } + + copy_ubufptr = (unsigned char *) copy_bufptr; + + /* Convert the input data to a sequence of + character events. */ + for (i = 0; i < nbytes; i += len) + { + int ch; + if (nchars == nbytes) + ch = copy_ubufptr[i], len = 1; + else + ch = string_char_and_length (copy_ubufptr + i, &len); + inev.ie.kind = (SINGLE_BYTE_CHAR_P (ch) + ? ASCII_KEYSTROKE_EVENT + : MULTIBYTE_CHAR_KEYSTROKE_EVENT); + inev.ie.code = ch; + kbd_buffer_store_buffered_event (&inev, hold_quit); + } + + inev.ie.kind = NO_EVENT; + goto xi_done_keysym; + } + goto XI_OTHER; + } + case XI_KeyRelease: + x_display_set_last_user_time (dpyinfo, xev->time); + goto XI_OTHER; + case XI_PropertyEvent: + case XI_HierarchyChanged: + case XI_DeviceChanged: + x_init_master_valuators (dpyinfo); + goto XI_OTHER; + default: + goto XI_OTHER; + } + xi_done_keysym: + if (must_free_data) + XFreeEventData (dpyinfo->display, &event->xcookie); + goto done_keysym; + XI_OTHER: + if (must_free_data) + XFreeEventData (dpyinfo->display, &event->xcookie); + goto OTHER; + } +#endif default: OTHER: @@ -13199,6 +14253,40 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) dpyinfo->supports_xdbe = true; #endif +#ifdef HAVE_XINPUT2 + dpyinfo->supports_xi2 = false; + int rc; + int major = 2; +#ifdef XI_BarrierHit /* XInput 2.3 */ + int minor = 3; +#elif defined XI_TouchBegin /* XInput 2.2 */ + int minor = 2; +#elif defined XIScrollClass /* XInput 1.1 */ + int minor = 1; +#else /* Some old version of XI2 we're not interested in. */ + int minor = 0; +#endif + int fer, fee; + + if (XQueryExtension (dpyinfo->display, "XInputExtension", + &dpyinfo->xi2_opcode, &fer, &fee)) + { + rc = XIQueryVersion (dpyinfo->display, &major, &minor); + if (rc == Success) + { + dpyinfo->supports_xi2 = true; + x_init_master_valuators (dpyinfo); + } + } + dpyinfo->xi2_version = minor; +#endif + +#ifdef HAVE_XKB + dpyinfo->xkb_desc = XkbGetMap (dpyinfo->display, + XkbAllComponentsMask, + XkbUseCoreKbd); +#endif + #if defined USE_CAIRO || defined HAVE_XFT { /* If we are using Xft, the following precautions should be made: @@ -13631,6 +14719,14 @@ x_delete_terminal (struct terminal *terminal) XrmDestroyDatabase (dpyinfo->rdb); #endif +#ifdef HAVE_XKB + 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 @@ -13790,9 +14886,12 @@ x_initialize (void) void init_xterm (void) { - /* Emacs can handle only core input events, so make sure - Gtk doesn't use Xinput or Xinput2 extensions. */ +#ifndef HAVE_XINPUT2 + /* Emacs can handle only core input events when built without XI2 + support, so make sure Gtk doesn't use Xinput or Xinput2 + extensions. */ xputenv ("GDK_CORE_DEVICE_EVENTS=1"); +#endif } #endif diff --git a/src/xterm.h b/src/xterm.h index 9d9534dd62..7abe168bc6 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -88,6 +88,10 @@ typedef GtkWidget *xt_or_gtk_widget; #include #endif +#ifdef HAVE_XKB +#include +#endif + #include "dispextern.h" #include "termhooks.h" @@ -163,6 +167,28 @@ struct color_name_cache_entry char *name; }; +#ifdef HAVE_XINPUT2 +struct xi_scroll_valuator_t +{ + bool invalid_p; + double current_value; + double emacs_value; + double increment; + + int number; + int horizontal; +}; + +struct xi_device_t +{ + int device_id; + int scroll_valuator_count; + int grab; + + struct xi_scroll_valuator_t *valuators; +}; +#endif + Status x_parse_color (struct frame *f, const char *color_name, XColor *color); @@ -474,6 +500,19 @@ struct x_display_info #ifdef HAVE_XDBE bool supports_xdbe; #endif + +#ifdef HAVE_XINPUT2 + bool supports_xi2; + int xi2_version; + int xi2_opcode; + + int num_devices; + struct xi_device_t *devices; +#endif + +#ifdef HAVE_XKB + XkbDescPtr xkb_desc; +#endif }; #ifdef HAVE_X_I18N @@ -481,6 +520,11 @@ struct x_display_info extern bool use_xim; #endif +#ifdef HAVE_XINPUT2 +/* Defined in xmenu.c. */ +extern int popup_activated_flag; +#endif + /* This is a chain of structures for all the X displays currently in use. */ extern struct x_display_info *x_display_list; commit fbf361f593df52ff414a4483f105e2e4c1a921e2 Author: Po Lu Date: Sat Nov 20 18:23:02 2021 +0800 Allow terminating page loading operations in webkit xwidgets * doc/lispref/display.texi (Xwidgets): Document new function. * etc/NEWS: Announce `xwidget-webkit-stop-loading'. * src/xwidget.c (Fxwidget_webkit_stop_loading): New function. (syms_of_xwidget): Define new subr. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 08426032e0..c093901ea1 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -7025,6 +7025,12 @@ If this function is not called at least once on @var{xwidget} or a related widget, @var{xwidget} will not store cookies on disk at all. @end defun +@defun xwidget-webkit-stop-loading xwidget +Terminate any data transfer still in progress in the WebKit widget +@var{xwidget} as part of a page-loading operation. If a page is not +being loaded, this function does nothing. +@end defun + @node Buttons @section Buttons @cindex buttons in buffers diff --git a/etc/NEWS b/etc/NEWS index 70ba5341d8..a5ca8fbb2b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -873,6 +873,11 @@ WebKit xwidget. This function is used to obtain the estimated progress of page loading in a given WebKit xwidget. ++++ +*** New function 'xwidget-webkit-stop-loading'. +This function is used to terminate all data transfer during page loads +in a given WebKit xwidget. + +++ *** 'load-changed' xwidget events are now more detailed. In particular, they can now have different arguments based on the diff --git a/src/xwidget.c b/src/xwidget.c index 8cad2fbc2c..b1bf291a16 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -2615,6 +2615,30 @@ store cookies in FILE and load them from there. */) return Qnil; } +DEFUN ("xwidget-webkit-stop-loading", Fxwidget_webkit_stop_loading, + Sxwidget_webkit_stop_loading, + 1, 1, 0, doc: /* Stop loading data in the WebKit widget XWIDGET. +This will stop any data transfer that may still be in progress inside +XWIDGET as part of loading a page. */) + (Lisp_Object xwidget) +{ +#ifdef USE_GTK + struct xwidget *xw; + WebKitWebView *webview; + + CHECK_LIVE_XWIDGET (xwidget); + xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); + + block_input (); + webview = WEBKIT_WEB_VIEW (xw->widget_osr); + webkit_web_view_stop_loading (webview); + unblock_input (); +#endif + + return Qnil; +} + void syms_of_xwidget (void) { @@ -2656,6 +2680,7 @@ syms_of_xwidget (void) defsubr (&Sxwidget_webkit_previous_result); defsubr (&Sset_xwidget_buffer); defsubr (&Sxwidget_webkit_set_cookie_storage_file); + defsubr (&Sxwidget_webkit_stop_loading); #ifdef USE_GTK defsubr (&Sxwidget_webkit_load_html); defsubr (&Sxwidget_webkit_back_forward_list); commit c22c988b1f3d9ae5d3f504100bf8e1cb79fab334 Author: martin rudalics Date: Sat Nov 20 10:56:13 2021 +0100 Fix mouse events on tab bar or tool bar when 'track-mouse' is t * lisp/mouse.el (mouse-drag-track): * lisp/mouse-drag.el (mouse-drag-drag): Set 'track-mouse' to some value neither t nor nil. * src/keyboard.c (make_lispy_position): If track_mouse is Qt, report event on tool or tab bar (Bug#51794). diff --git a/lisp/mouse-drag.el b/lisp/mouse-drag.el index ecfb359b36..0cdba6b4d0 100644 --- a/lisp/mouse-drag.el +++ b/lisp/mouse-drag.el @@ -282,6 +282,8 @@ To test this function, evaluate: (setq window-last-row (- (window-height) 2) window-last-col (- (window-width) 2)) (track-mouse + ;; Set 'track-mouse' to something neither nil nor t (Bug#51794). + (setq track-mouse 'drag-dragging) (while (progn (setq event (read--potential-mouse-event) end (event-end event) diff --git a/lisp/mouse.el b/lisp/mouse.el index 0a4ab2878a..5c645a4b89 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -1618,7 +1618,11 @@ The region will be defined with mark and point." (goto-char (nth 1 range))) (setf (terminal-parameter nil 'mouse-drag-start) start-event) - (setq track-mouse t) + ;; Set 'track-mouse' to something neither nil nor t, so that mouse + ;; events are not reported to have happened on the tool bar or the + ;; tab bar, as that breaks drag events that originate on the window + ;; body below these bars; see make_lispy_position and bug#51794. + (setq track-mouse 'drag-tracking) (setq auto-hscroll-mode nil) (set-transient-map diff --git a/src/keyboard.c b/src/keyboard.c index c608c072f0..1d8d98c941 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -5124,19 +5124,20 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, #endif ) { - /* FIXME: While track_mouse is non-nil, we do not report this + /* While 'track-mouse' is neither nil nor t, do not report this event as something that happened on the tool or tab bar since - that would break mouse dragging operations that originate from - an ordinary window beneath and expect the window to auto-scroll - as soon as the mouse cursor appears above or beneath it - (Bug#50993). Since this "fix" might break track_mouse based - operations originating from the tool or tab bar itself, such - operations should set track_mouse to some special value that - would be recognized by the following check. - - This issue should be properly handled by 'mouse-drag-track' and - friends, so the below is only a temporary workaround. */ - if (NILP (track_mouse)) + that would break mouse drag operations that originate from an + ordinary window beneath that bar and expect the window to + auto-scroll as soon as the mouse cursor appears above or + beneath it (Bug#50993). We do allow reports for t, because + applications may have set 'track-mouse' to t and still expect a + click on the tool or tab bar to get through (Bug#51794). + + FIXME: This is a preliminary fix for the bugs cited above and + awaits a solution that includes a convention for all special + values of 'track-mouse' and their documentation in the Elisp + manual. */ + if (NILP (track_mouse) || EQ (track_mouse, Qt)) posn = EQ (window_or_frame, f->tab_bar_window) ? Qtab_bar : Qtool_bar; /* Kludge alert: for mouse events on the tab bar and tool bar, keyboard.c wants the frame, not the special-purpose window commit 2ba7d1e84e76fa4d08fd8ed5a915793d4bf881cd Author: Gregory Heytings Date: Sat Nov 20 10:37:20 2021 +0100 Implement the buttonForeground resource * lwlib/xlwmenu.c (draw_shadow_rectangle, draw_shadow_rhombus): Use the buttonForeground resource color (bug#51988). diff --git a/lwlib/xlwmenu.c b/lwlib/xlwmenu.c index 702fad49ba..5f8832bb36 100644 --- a/lwlib/xlwmenu.c +++ b/lwlib/xlwmenu.c @@ -641,6 +641,21 @@ draw_shadow_rectangle (XlwMenuWidget mw, int thickness = !x && !y ? mw->menu.border_thickness : mw->menu.shadow_thickness; XPoint points [4]; + if (!erase_p && width == height && width == toggle_button_width (mw)) + { + points [0].x = x; + points [0].y = y; + points [1].x = x + width; + points [1].y = y; + points [2].x = x + width; + points [2].y = y + height; + points [3].x = x; + points [3].y = y + height; + XFillPolygon (dpy, window, + down_p ? mw->menu.button_gc : mw->menu.inactive_button_gc, + points, 4, Convex, CoordModeOrigin); + } + if (!erase_p && down_p) { GC temp; @@ -704,6 +719,21 @@ draw_shadow_rhombus (XlwMenuWidget mw, int thickness = mw->menu.shadow_thickness; XPoint points [4]; + if (!erase_p && width == height && width == radio_button_width (mw)) + { + points [0].x = x; + points [0].y = y + width / 2; + points [1].x = x + height / 2; + points [1].y = y + width; + points [2].x = x + height; + points [2].y = y + width / 2; + points [3].x = x + height / 2; + points [3].y = y; + XFillPolygon (dpy, window, + down_p ? mw->menu.button_gc : mw->menu.inactive_button_gc, + points, 4, Convex, CoordModeOrigin); + } + if (!erase_p && down_p) { GC temp; commit bc99604c7ac2c6673615d0ecac4d233bf6a4ff16 Author: Lars Ingebrigtsen Date: Sat Nov 20 10:20:43 2021 +0100 Fix another narrow-to-defun problem in js-mode * lisp/progmodes/js.el (js--function-prologue-beginning): Fix typo in looking-back form (bug#51926). diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index e5e83beff6..9303f1ecb9 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -1247,7 +1247,7 @@ LIMIT defaults to point." (save-excursion (goto-char orig-match-start) (when (looking-back "\\_[ \t\n]+" - (- (point) 3)) + (- (point) 30)) (setq orig-match-start (match-beginning 0)))) (make-js--pitem :paren-depth orig-depth commit 9f06977782ef58fa40bed69368ab92a080f035ec Author: Michael Albinus Date: Sat Nov 20 10:07:48 2021 +0100 Continue adaptions of emba files * test/infra/default-gitlab-ci.yml: New file, derived from gitlab-ci.yml. * test/infra/gitlab-ci.yml (top, test-jobs-pipeline): Include default-gitlab-ci.yml. (stages): Remove normal. * test/infra/test-jobs-generator.sh: Generate also stages entry. diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 3138f4184e..402c17ddb8 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -15,7 +15,7 @@ # You should have received a copy of the GNU General Public License # along with GNU Emacs. If not, see . -# GNU Emacs support for the GitLab protocol for CI +# GNU Emacs support for the GitLab protocol for CI. # The presence of this file does not imply any FSF/GNU endorsement of # any particular service that uses that protocol. Also, it is intended for diff --git a/test/infra/default-gitlab-ci.yml b/test/infra/default-gitlab-ci.yml new file mode 100644 index 0000000000..f6fadee27f --- /dev/null +++ b/test/infra/default-gitlab-ci.yml @@ -0,0 +1,216 @@ +# Copyright (C) 2017-2021 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 . + +# GNU Emacs support for the GitLab protocol for CI. + +# The presence of this file does not imply any FSF/GNU endorsement of +# any particular service that uses that protocol. Also, it is intended for +# evaluation purposes, thus possibly temporary. + +# Maintainer: Ted Zlatanov +# URL: https://emba.gnu.org/emacs/emacs + +# Never run merge request pipelines, they usually duplicate push pipelines +# see https://docs.gitlab.com/ee/ci/yaml/README.html#common-if-clauses-for-rules + +# Rules: always run tags and branches named master*, emacs*, feature*, fix* +# Test that it triggers by pushing a tag: `git tag mytag; git push origin mytag` +# Test that it triggers by pushing to: feature/emba, feature1, master, master-2, fix/emba, emacs-299, fix-2 +# Test that it doesn't trigger by pushing to: scratch-2, scratch/emba, oldbranch, dev +workflow: + rules: + - if: '$CI_PIPELINE_SOURCE == "merge_request_event"' + when: never + - if: '$CI_COMMIT_TAG' + when: always + - if: '$CI_COMMIT_BRANCH !~ /^(master|emacs|feature|fix)/' + when: never + - when: always + +variables: + GIT_STRATEGY: fetch + EMACS_EMBA_CI: 1 + # Three hours, see below. + EMACS_TEST_TIMEOUT: 10800 + EMACS_TEST_VERBOSE: 1 + # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled + # DOCKER_HOST: tcp://docker:2376 + # DOCKER_TLS_CERTDIR: "/certs" + # Put the configuration for each run in a separate directory to + # avoid conflicts. + DOCKER_CONFIG: "/.docker-config-${CI_COMMIT_SHA}" + DOCKER_BUILDKIT: 1 + # We don't use ${CI_COMMIT_SHA} to be able to do one bootstrap + # across multiple builds. + BUILD_TAG: ${CI_COMMIT_REF_SLUG} + # Disable if you don't need it, it can be a security risk. + CI_DEBUG_TRACE: "true" + +default: + image: docker:19.03.12 + timeout: 3 hours + before_script: + - docker info + - echo "docker registry is ${CI_REGISTRY}" + - docker login -u ${CI_REGISTRY_USER} -p ${CI_REGISTRY_PASSWORD} ${CI_REGISTRY} + +.job-template: + variables: + test_name: ${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA} + rules: + - changes: + - "**Makefile.in" + - .gitlab-ci.yml + - aclocal.m4 + - autogen.sh + - configure.ac + - lib/*.{h,c} + - lisp/**.el + - src/*.{h,c} + - test/infra/* + - test/lib-src/*.el + - test/lisp/**.el + - test/misc/*.el + - test/src/*.el + - changes: + # gfilemonitor, kqueue + - src/gfilenotify.c + - src/kqueue.c + # MS Windows + - "**w32*" + # GNUstep + - lisp/term/ns-win.el + - src/ns*.{h,m} + - src/macfont.{h,m} + when: never + # These will be cached across builds. + cache: + key: ${CI_COMMIT_SHA} + paths: [] + policy: pull-push + # These will be saved for followup builds. + artifacts: + expire_in: 24 hrs + paths: [] + # Using the variables for each job. + script: + - docker pull ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} + # TODO: with make -j4 several of the tests were failing, for + # example shadowfile-tests, but passed without it. + - 'export PWD=$(pwd)' + - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} -e EMACS_TEST_TIMEOUT=${EMACS_TEST_TIMEOUT} -e EMACS_TEST_VERBOSE=${EMACS_TEST_VERBOSE} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' + after_script: + # - docker ps -a + # - printenv + # - test -n "$(docker ps -aq -f name=${test_name})" && ( docker export ${test_name} | tar -tvf - ) + - test -n "$(docker ps -aq -f name=${test_name})" && docker cp ${test_name}:checkout/test ${test_name} + - test -n "$(docker ps -aq -f name=${test_name})" && docker rm ${test_name} + # - ls -alR ${test_name} + +.build-template: + needs: [] + rules: + - if: '$CI_PIPELINE_SOURCE == "web"' + when: always + - changes: + - "**Makefile.in" + - .gitlab-ci.yml + - aclocal.m4 + - autogen.sh + - configure.ac + - lib/*.{h,c} + - lisp/emacs-lisp/*.el + - src/*.{h,c} + - test/infra/* + - changes: + # gfilemonitor, kqueue + - src/gfilenotify.c + - src/kqueue.c + # MS Windows + - "**w32*" + # GNUstep + - lisp/term/ns-win.el + - src/ns*.{h,m} + - src/macfont.{h,m} + when: never + script: + - docker build --pull --target ${target} -t ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} -f test/infra/Dockerfile.emba . + - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} + +.test-template: + # Do not run fast and normal test jobs when scheduled. + rules: + - if: '$CI_JOB_STAGE =~ "fast|normal" && $CI_PIPELINE_SOURCE == "schedule"' + when: never + - when: always + artifacts: + name: ${test_name} + public: true + expire_in: 1 week + paths: + - ${test_name}/**/*.log + - ${test_name}/**/core + - ${test_name}/core + when: always + +.gnustep-template: + rules: + - if: '$CI_PIPELINE_SOURCE == "web"' + - if: '$CI_PIPELINE_SOURCE == "schedule"' + changes: + - "**Makefile.in" + - .gitlab-ci.yml + - configure.ac + - src/ns*.{h,m} + - src/macfont.{h,m} + - lisp/term/ns-win.el + - nextstep/** + - test/infra/* + +.filenotify-gio-template: + rules: + - if: '$CI_PIPELINE_SOURCE == "web"' + - if: '$CI_PIPELINE_SOURCE == "schedule"' + changes: + - "**Makefile.in" + - .gitlab-ci.yml + - lisp/autorevert.el + - lisp/filenotify.el + - lisp/net/tramp-sh.el + - src/gfilenotify.c + - test/infra/* + - test/lisp/autorevert-tests.el + - test/lisp/filenotify-tests.el + +.native-comp-template: + rules: + - if: '$CI_PIPELINE_SOURCE == "web"' + - if: '$CI_PIPELINE_SOURCE == "schedule"' + changes: + - "**Makefile.in" + - .gitlab-ci.yml + - lisp/emacs-lisp/comp.el + - lisp/emacs-lisp/comp-cstr.el + - src/comp.{h,m} + - test/infra/* + - test/src/comp-resources/*.el + - test/src/comp-tests.el + timeout: 8 hours + +# Local Variables: +# add-log-current-defun-header-regexp: "^\\([-_.[:alnum:]]+\\)[ \t]*:" +# End: diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index abc7bddbf7..738e709c6b 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -15,7 +15,7 @@ # You should have received a copy of the GNU General Public License # along with GNU Emacs. If not, see . -# GNU Emacs support for the GitLab protocol for CI +# GNU Emacs support for the GitLab protocol for CI. # The presence of this file does not imply any FSF/GNU endorsement of # any particular service that uses that protocol. Also, it is intended for @@ -24,199 +24,15 @@ # Maintainer: Ted Zlatanov # URL: https://emba.gnu.org/emacs/emacs -# Never run merge request pipelines, they usually duplicate push pipelines -# see https://docs.gitlab.com/ee/ci/yaml/README.html#common-if-clauses-for-rules - -# Rules: always run tags and branches named master*, emacs*, feature*, fix* -# Test that it triggers by pushing a tag: `git tag mytag; git push origin mytag` -# Test that it triggers by pushing to: feature/emba, feature1, master, master-2, fix/emba, emacs-299, fix-2 -# Test that it doesn't trigger by pushing to: scratch-2, scratch/emba, oldbranch, dev -workflow: - rules: - - if: '$CI_PIPELINE_SOURCE == "merge_request_event"' - when: never - - if: '$CI_COMMIT_TAG' - when: always - - if: '$CI_COMMIT_BRANCH !~ /^(master|emacs|feature|fix)/' - when: never - - when: always - -variables: - GIT_STRATEGY: fetch - EMACS_EMBA_CI: 1 - # Three hours, see below. - EMACS_TEST_TIMEOUT: 10800 - EMACS_TEST_VERBOSE: 1 - # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled - # DOCKER_HOST: tcp://docker:2376 - # DOCKER_TLS_CERTDIR: "/certs" - # Put the configuration for each run in a separate directory to - # avoid conflicts. - DOCKER_CONFIG: "/.docker-config-${CI_COMMIT_SHA}" - DOCKER_BUILDKIT: 1 - # We don't use ${CI_COMMIT_SHA} to be able to do one bootstrap - # across multiple builds. - BUILD_TAG: ${CI_COMMIT_REF_SLUG} - # Disable if you don't need it, it can be a security risk. - CI_DEBUG_TRACE: "true" - -default: - image: docker:19.03.12 - timeout: 3 hours - before_script: - - docker info - - echo "docker registry is ${CI_REGISTRY}" - - docker login -u ${CI_REGISTRY_USER} -p ${CI_REGISTRY_PASSWORD} ${CI_REGISTRY} - -.job-template: - variables: - test_name: ${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA} - rules: - - changes: - - "**Makefile.in" - - .gitlab-ci.yml - - aclocal.m4 - - autogen.sh - - configure.ac - - lib/*.{h,c} - - lisp/**.el - - src/*.{h,c} - - test/infra/* - - test/lib-src/*.el - - test/lisp/**.el - - test/misc/*.el - - test/src/*.el - - changes: - # gfilemonitor, kqueue - - src/gfilenotify.c - - src/kqueue.c - # MS Windows - - "**w32*" - # GNUstep - - lisp/term/ns-win.el - - src/ns*.{h,m} - - src/macfont.{h,m} - when: never - # These will be cached across builds. - cache: - key: ${CI_COMMIT_SHA} - paths: [] - policy: pull-push - # These will be saved for followup builds. - artifacts: - expire_in: 24 hrs - paths: [] - # Using the variables for each job. - script: - - docker pull ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} - # TODO: with make -j4 several of the tests were failing, for - # example shadowfile-tests, but passed without it. - - 'export PWD=$(pwd)' - - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} -e EMACS_TEST_TIMEOUT=${EMACS_TEST_TIMEOUT} -e EMACS_TEST_VERBOSE=${EMACS_TEST_VERBOSE} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' - after_script: - # - docker ps -a - # - printenv - # - test -n "$(docker ps -aq -f name=${test_name})" && ( docker export ${test_name} | tar -tvf - ) - - test -n "$(docker ps -aq -f name=${test_name})" && docker cp ${test_name}:checkout/test ${test_name} - - test -n "$(docker ps -aq -f name=${test_name})" && docker rm ${test_name} - # - ls -alR ${test_name} - -.build-template: - needs: [] - rules: - - if: '$CI_PIPELINE_SOURCE == "web"' - when: always - - changes: - - "**Makefile.in" - - .gitlab-ci.yml - - aclocal.m4 - - autogen.sh - - configure.ac - - lib/*.{h,c} - - lisp/emacs-lisp/*.el - - src/*.{h,c} - - test/infra/* - - changes: - # gfilemonitor, kqueue - - src/gfilenotify.c - - src/kqueue.c - # MS Windows - - "**w32*" - # GNUstep - - lisp/term/ns-win.el - - src/ns*.{h,m} - - src/macfont.{h,m} - when: never - script: - - docker build --pull --target ${target} -t ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} -f test/infra/Dockerfile.emba . - - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} - -.test-template: - # Do not run fast and normal test jobs when scheduled. - rules: - - if: '$CI_JOB_STAGE =~ "fast|normal" && $CI_PIPELINE_SOURCE == "schedule"' - when: never - - when: always - artifacts: - name: ${test_name} - public: true - expire_in: 1 week - paths: - - ${test_name}/**/*.log - - ${test_name}/**/core - - ${test_name}/core - when: always - -.gnustep-template: - rules: - - if: '$CI_PIPELINE_SOURCE == "web"' - - if: '$CI_PIPELINE_SOURCE == "schedule"' - changes: - - "**Makefile.in" - - .gitlab-ci.yml - - configure.ac - - src/ns*.{h,m} - - src/macfont.{h,m} - - lisp/term/ns-win.el - - nextstep/** - - test/infra/* - -.filenotify-gio-template: - rules: - - if: '$CI_PIPELINE_SOURCE == "web"' - - if: '$CI_PIPELINE_SOURCE == "schedule"' - changes: - - "**Makefile.in" - - .gitlab-ci.yml - - lisp/autorevert.el - - lisp/filenotify.el - - lisp/net/tramp-sh.el - - src/gfilenotify.c - - test/infra/* - - test/lisp/autorevert-tests.el - - test/lisp/filenotify-tests.el - -.native-comp-template: - rules: - - if: '$CI_PIPELINE_SOURCE == "web"' - - if: '$CI_PIPELINE_SOURCE == "schedule"' - changes: - - "**Makefile.in" - - .gitlab-ci.yml - - lisp/emacs-lisp/comp.el - - lisp/emacs-lisp/comp-cstr.el - - src/comp.{h,m} - - test/infra/* - - test/src/comp-resources/*.el - - test/src/comp-tests.el - timeout: 8 hours +# Include defaults. +include: '/test/infra/default-gitlab-ci.yml' stages: - build-images - generator - trigger # - fast - - normal +# - normal - platform-images - platforms - native-comp-images @@ -239,7 +55,6 @@ build-image-inotify: test-jobs-generator: stage: generator script: - - pwd - test/infra/test-jobs-generator.sh > test-jobs.yml artifacts: paths: @@ -249,6 +64,7 @@ test-jobs-pipeline: stage: trigger trigger: include: + - local: '/test/infra/default-gitlab-ci.yml' - artifact: test-jobs.yml job: test-jobs-generator strategy: depend diff --git a/test/infra/test-jobs-generator.sh b/test/infra/test-jobs-generator.sh index 96b61be966..49f491ea66 100755 --- a/test/infra/test-jobs-generator.sh +++ b/test/infra/test-jobs-generator.sh @@ -20,7 +20,7 @@ # GNU Emacs support for the gitlab-ci.yml template generation. # The presence of this file does not imply any FSF/GNU endorsement of -# GitLab or any other particular tool. Also, it is intended for +# any particular service that uses that protocol. Also, it is intended for # evaluation purposes, thus possibly temporary. # Maintainer: Michael Albinus @@ -52,10 +52,16 @@ for subdir in $SUBDIRS; do ;; esac + cat < Date: Sat Nov 20 15:56:08 2021 +0800 Fix `browse-url-interactive-arg' for certain kinds of events * lisp/net/browse-url.el (browse-url-interactive-arg): Don't call `mouse-set-point' unless event is actually a mouse event. diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 3af37e412d..50d11b4b72 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -730,7 +730,8 @@ position clicked before acting. This function returns a list (URL NEW-WINDOW-FLAG) for use in `interactive'." (let ((event (elt (this-command-keys) 0))) - (and (listp event) (mouse-set-point event))) + (when (mouse-event-p event) + (mouse-set-point event))) (list (read-string prompt (or (and transient-mark-mode mark-active ;; rfc2396 Appendix E. (replace-regexp-in-string commit 88458f7354e904a50ed1389869266437ba084533 Author: Po Lu Date: Sat Nov 20 14:57:22 2021 +0800 Make xwidget-events special and document xwidget callbacks Users have always been supposed to use callbacks for handling xwidget events, but for some reason this has not been documented until now. * doc/lispref/commands.texi (Xwidget Events): Document xwidget callbacks and the special status of `xwidget-event's. * doc/lispref/display.texi (Xwidgets): Add xwidget property list functions to the concept index. * lisp/xwidget.el: Make xwidget events special. diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index 1509c200e0..cc9c41623d 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -1886,6 +1886,15 @@ This event is sent whenever some kind of update occurs in @var{xwidget}. There are several types of updates, identified by their @var{kind}. +@cindex xwidget callbacks +It is a special event (@pxref{Special Events}), which should be +handled by adding a callback to an xwidget that is called whenever an +xwidget event for @var{xwidget} is received. + +You can add a callback by setting the @code{callback} of an xwidget's +property list, which should be a function that accepts @var{xwidget} +and @var{kind} as arguments. + @table @code @cindex @code{load-changed} xwidget event @item load-changed diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 12257fda54..08426032e0 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -6828,6 +6828,7 @@ This function kills @var{xwidget}, by removing it from its buffer and releasing window system resources it holds. @end defun +@cindex xwidget property list @defun xwidget-plist xwidget This function returns the property list of @var{xwidget}. @end defun diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 91580efa49..5b465dad3d 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -372,10 +372,13 @@ If N is omitted or nil, scroll backwards by one char." (xwidget-webkit-current-session) "window.scrollTo(pageXOffset, window.document.body.scrollHeight);")) -;; The xwidget event needs to go into a higher level handler -;; since the xwidget can generate an event even if it's offscreen. -;; TODO this needs to use callbacks and consider different xwidget event types. -(define-key (current-global-map) [xwidget-event] #'xwidget-event-handler) +;; The xwidget event needs to go in the special map. To receive +;; xwidget events, you should place a callback in the property list of +;; the xwidget, instead of handling these events manually. +;; +;; See `xwidget-webkit-new-session' for an example of how to do this. +(define-key special-event-map [xwidget-event] #'xwidget-event-handler) + (defun xwidget-log (&rest msg) "Log MSG to a buffer." (let ((buf (get-buffer-create " *xwidget-log*"))) commit da508cf4bd437f8fd9a06fce33f6e62590e1e4d9 Author: Po Lu Date: Sat Nov 20 14:30:12 2021 +0800 Use `xwidget-live-p' inside `xwidget-at'. It should no longer be possible for Lisp code to abuse internal xwidget state, or cause crashes with killed xwidgets and such, so the pedantic checking done in this function is no longer necessary. (In fact, it is even wrong, as it won't catch killed xwidgets.) * lisp/xwidget.el (xwidget-at): Use `xwidget-live-p'. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 89f81bb816..91580efa49 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -58,6 +58,7 @@ (declare-function xwidget-webkit-back-forward-list "xwidget.c" (xwidget &optional limit)) (declare-function xwidget-webkit-estimated-load-progress "xwidget.c" (xwidget)) (declare-function xwidget-webkit-set-cookie-storage-file "xwidget.c" (xwidget file)) +(declare-function xwidget-live-p "xwidget.c" (xwidget)) (defgroup xwidget nil "Displaying native widgets in Emacs buffers." @@ -77,12 +78,9 @@ This returns the result of `make-xwidget'." (defun xwidget-at (pos) "Return xwidget at POS." - ;; TODO this function is a bit tedious because the C layer isn't well - ;; protected yet and xwidgetp apparently doesn't work yet. (let* ((disp (get-text-property pos 'display)) - (xw (car (cdr (cdr disp))))) - ;;(if (xwidgetp xw) xw nil) - (if (equal 'xwidget (car disp)) xw))) + (xw (car (cdr (cdr disp))))) + (when (xwidget-live-p xw) xw))) commit 8331916c85016ae1c457b274031475e5aa5ae041 Author: Po Lu Date: Sat Nov 20 14:17:27 2021 +0800 Remove nonsensical command in xwidget-webkit-mode-map * lisp/xwidget.el (xwidget-webkit-mode-map): Remove nonsensical command binding. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index df9625b264..89f81bb816 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -200,7 +200,6 @@ for the actual events that will be sent." (define-key map "b" 'xwidget-webkit-back) (define-key map "f" 'xwidget-webkit-forward) (define-key map "r" 'xwidget-webkit-reload) - (define-key map "t" (lambda () (interactive) (message "o"))) ;FIXME: ?!? (define-key map "\C-m" 'xwidget-webkit-insert-string) (define-key map "w" 'xwidget-webkit-current-url) (define-key map "+" 'xwidget-webkit-zoom-in) commit 991e304cf1c87e94e0162ab30792437a3706123e Merge: 824f0de836 c1eea85be1 Author: Stefan Kangas Date: Sat Nov 20 07:19:43 2021 +0100 Merge from origin/emacs-28 c1eea85be1 * test/lisp/net/tramp-tests.el (tramp-get-remote-gid): Rem... commit 824f0de83626cb3ac2c07b161d3d1e8ee3d93b33 Merge: 0a3b55aca3 9b08846faa Author: Stefan Kangas Date: Sat Nov 20 07:19:43 2021 +0100 ; Merge from origin/emacs-28 The following commit was skipped: 9b08846faa Add upward compatibility entry in Tramp (don't merge) commit 0a3b55aca336088ab3c5e77e1b442da2960c23e4 Author: Po Lu Date: Sat Nov 20 14:15:46 2021 +0800 Fix option type of `xwidget-webkit-cookie-file' again * lisp/xwidget.el (xwidget-webkit-cookie-file): Revert changes caused by rebase. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 3cccfb6bcf..df9625b264 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -113,7 +113,7 @@ It can use the following special constructs: They will be stored as plain text in Mozilla \"cookies.txt\" format. If nil, do not store cookies. You must kill all xwidget-webkit buffers for this setting to take effect after setting it to nil." - :type 'string + :type '(choice (const :tag "Do not store cookies" nil) file) :version "29.1") ;;;###autoload commit 35de4774caaa5d0879ae814f62a889def317601b Author: Po Lu Date: Sat Nov 20 14:11:13 2021 +0800 Clarify doc string in xwidget-webkit * lisp/xwidget.el (xwidget-webkit-buffer-name-format): Update doc string. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 33b6c16a1d..3cccfb6bcf 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -111,8 +111,9 @@ It can use the following special constructs: (defcustom xwidget-webkit-cookie-file nil "The name of the file where `xwidget-webkit-browse-url' will store cookies. They will be stored as plain text in Mozilla \"cookies.txt\" -format. If nil, do not store cookies." - :type '(choice (const :tag "Do not store cookies" nil) file) +format. If nil, do not store cookies. You must kill all xwidget-webkit +buffers for this setting to take effect after setting it to nil." + :type 'string :version "29.1") ;;;###autoload commit 3817ced7ba4c053d6d39b26cc193f122d42f05fb Author: Glenn Morris Date: Fri Nov 19 18:36:03 2021 -0800 * lisp/xwidget.el (xwidget-webkit-cookie-file): Fix type. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index e9a0507bbf..33b6c16a1d 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -112,7 +112,7 @@ It can use the following special constructs: "The name of the file where `xwidget-webkit-browse-url' will store cookies. They will be stored as plain text in Mozilla \"cookies.txt\" format. If nil, do not store cookies." - :type 'string + :type '(choice (const :tag "Do not store cookies" nil) file) :version "29.1") ;;;###autoload commit 956f21b6b916f8d87a7b872e02f668883c17b8ba Author: Po Lu Date: Sat Nov 20 08:38:04 2021 +0800 Make xwidget-webkit default to not storing cookies * etc/NEWS: Update to reflect change. * lisp/xwidget.el (xwidget-webkit-cookie-file): Set default value to nil. diff --git a/etc/NEWS b/etc/NEWS index c38e1aa5eb..70ba5341d8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -497,8 +497,6 @@ named. *** New user option 'xwidget-webkit-cookie-file'. Using this option you can control whether the xwidget-webkit buffers save cookies set by web pages, and if so, in which file to save them. -the default is the file 'xwidget-webkit-cookies.txt' under -'~/.emacs.d' directory. +++ *** New minor mode 'xwidget-webkit-edit-mode'. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index a1f992e659..e9a0507bbf 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -108,9 +108,7 @@ It can use the following special constructs: :type 'string :version "29.1") -(defcustom xwidget-webkit-cookie-file - (file-name-concat user-emacs-directory - "xwidget-webkit-cookies.txt") +(defcustom xwidget-webkit-cookie-file nil "The name of the file where `xwidget-webkit-browse-url' will store cookies. They will be stored as plain text in Mozilla \"cookies.txt\" format. If nil, do not store cookies." commit 54b2bd1be6715cbc6bc87e2a6e65ffa04aff256b Author: Michael Albinus Date: Fri Nov 19 21:24:08 2021 +0100 ; * test/infra/test-jobs-generator.sh: Still fixes. diff --git a/test/infra/test-jobs-generator.sh b/test/infra/test-jobs-generator.sh index d5171acbf2..96b61be966 100755 --- a/test/infra/test-jobs-generator.sh +++ b/test/infra/test-jobs-generator.sh @@ -17,19 +17,19 @@ # You should have received a copy of the GNU General Public License # along with GNU Emacs. If not, see . -# GNU Emacs support for the GitLab-specific build of Docker images. +# GNU Emacs support for the gitlab-ci.yml template generation. # The presence of this file does not imply any FSF/GNU endorsement of -# Docker or any other particular tool. Also, it is intended for +# GitLab or any other particular tool. Also, it is intended for # evaluation purposes, thus possibly temporary. # Maintainer: Michael Albinus # URL: https://emba.gnu.org/emacs/emacs -SUBDIRS=$(cd test && \ - (find lib-src lisp misc src -type d \ - ! \( -path "*resources*" -o -path "*auto-save-list" \) \ - -print | sort -)) +cd test +SUBDIRS=\ +$(find lib-src lisp misc src -type d \ + ! \( -path "*resources*" -o -path "*auto-save-list" \) -print | sort -) for subdir in $SUBDIRS; do target=check-$(echo $subdir | tr '/' '-') @@ -55,7 +55,7 @@ for subdir in $SUBDIRS; do cat < Date: Fri Nov 19 20:32:29 2021 +0100 Fix Tramp test * test/lisp/net/tramp-tests.el (tramp-test07-abbreviate-file-name): Skip Ange FTP test. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 98269d5fa3..5f2241c5f7 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2293,6 +2293,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check that Tramp abbreviates file names correctly." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-emacs29-p)) + (skip-unless (tramp--test-ange-ftp-p)) (let* ((remote-host (file-remote-p tramp-test-temporary-file-directory)) ;; Not all methods can expand "~". commit 0d9aa424f7de151627ed3efcf06162e968bf96f4 Author: Michael Albinus Date: Fri Nov 19 20:20:31 2021 +0100 ; Fix emba scripts diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index ac3989a5e4..abc7bddbf7 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -239,7 +239,8 @@ build-image-inotify: test-jobs-generator: stage: generator script: - - ./test-jobs-generator.sh > test-jobs.yml + - pwd + - test/infra/test-jobs-generator.sh > test-jobs.yml artifacts: paths: - test-jobs.yml diff --git a/test/infra/test-jobs-generator.sh b/test/infra/test-jobs-generator.sh index 97346785ea..d5171acbf2 100755 --- a/test/infra/test-jobs-generator.sh +++ b/test/infra/test-jobs-generator.sh @@ -26,52 +26,29 @@ # Maintainer: Michael Albinus # URL: https://emba.gnu.org/emacs/emacs -for target in $(cd ..; make -s subdir-targets); do +SUBDIRS=$(cd test && \ + (find lib-src lisp misc src -type d \ + ! \( -path "*resources*" -o -path "*auto-save-list" \) \ + -print | sort -)) + +for subdir in $SUBDIRS; do + target=check-$(echo $subdir | tr '/' '-') + case $target in - check-lib-src) - changes=" - - lib-src/*.{h,c} - - test/lib-src/*.el" - ;; - check-lisp-emacs-lisp) - changes=" - - lisp/emacs-lisp/*.el - - test/lisp/emacs-lisp/*.el" - ;; - check-lisp-emacs-lisp-eieio-tests) - changes=" - - lisp/emacs-lisp/eieio-tests/*.el - - test/lisp/emacs-lisp/eieio-tests/*.el" - ;; - check-lisp-emacs-lisp-faceup-tests) - changes=" - - lisp/emacs-lisp/faceup-tests/*.el - - test/lisp/emacs-lisp/faceup-tests/*.el" - ;; - check-lisp-mh-e) + check*-src) changes=" - - lisp/mh-e/*.el - - test/lisp/mh-e/*.el" - ;; - check-lisp-so-long-tests) - changes=" - - lisp/so-long-tests/*.el - - test/lisp/so-long-tests/*.el" + - $subdir/*.{h,c} + - test/$subdir/*.el" ;; check-misc) changes=" - admin/*.el - - test/misc/*.el" - ;; - check-src) - changes=" - - src/*.{h,c} - - test/src/*.el" + - test/$subdir/*.el" ;; *) changes=" - - $(echo -n ${target##check-}/*.el | tr '-' '/') - - $(echo -n test${target##check}/*.el | tr '-' '/')" + - $subdir/*.el + - test/$subdir/*.el" ;; esac commit c1eea85be12df8f874dea61f6b7856ef23ddf689 Author: Michael Albinus Date: Fri Nov 19 18:58:01 2021 +0100 * test/lisp/net/tramp-tests.el (tramp-get-remote-gid): Remove declaration. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 47ef46f8ec..1fa8fbea17 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -55,7 +55,6 @@ (declare-function tramp-check-remote-uname "tramp-sh") (declare-function tramp-find-executable "tramp-sh") (declare-function tramp-get-remote-chmod-h "tramp-sh") -(declare-function tramp-get-remote-gid "tramp-sh") (declare-function tramp-get-remote-path "tramp-sh") (declare-function tramp-get-remote-perl "tramp-sh") (declare-function tramp-get-remote-stat "tramp-sh") commit 9b08846faa55b1d47cd6403e6dd8c53c6ae310b8 Author: Michael Albinus Date: Fri Nov 19 18:57:47 2021 +0100 Add upward compatibility entry in Tramp (don't merge) * lisp/net/tramp.el (tramp-file-name-for-operation): Add `abbreviate-file-name'. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index b152584c1f..740cb23ebe 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2493,6 +2493,8 @@ Must be handled by the callers." file-system-info ;; Emacs 28+ only. file-locked-p lock-file make-lock-file-name unlock-file + ;; Emacs 29+ only. + abbreviate-file-name ;; Tramp internal magic file name function. tramp-set-file-uid-gid)) (if (file-name-absolute-p (nth 0 args)) commit b11e4320856f88ebf4c3671806a2ffe99ee34803 Author: Michael Albinus Date: Fri Nov 19 17:54:59 2021 +0100 ; Still gitlab-ci.yml fixes * test/infra/gitlab-ci.yml (variables): Add CI_DEBUG_TRACE. (build-image-inotify): Remove timeout. (generator, test-jobs-pipeline): New jobs. (test-lisp-inotify, test-lisp-net-inotify): Comment. diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 8937bb7242..ac3989a5e4 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -213,6 +213,8 @@ default: stages: - build-images + - generator + - trigger # - fast - normal - platform-images @@ -235,7 +237,7 @@ build-image-inotify: # make_params: "-C test check" test-jobs-generator: - stage: .pre + stage: generator script: - ./test-jobs-generator.sh > test-jobs.yml artifacts: @@ -243,7 +245,7 @@ test-jobs-generator: - test-jobs.yml test-jobs-pipeline: - stage: .pre + stage: trigger trigger: include: - artifact: test-jobs.yml commit 408577b402a9e1d288b5d214e397eea22fb8fedc Author: Michael Albinus Date: Fri Nov 19 17:46:40 2021 +0100 ; Further fixes in gitlab-ci.yml diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index b5222f884a..8937bb7242 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -234,7 +234,7 @@ build-image-inotify: # target: emacs-inotify # make_params: "-C test check" -generator: +test-jobs-generator: stage: .pre script: - ./test-jobs-generator.sh > test-jobs.yml @@ -243,11 +243,11 @@ generator: - test-jobs.yml test-jobs-pipeline: - stage: trigger + stage: .pre trigger: include: - artifact: test-jobs.yml - job: generator + job: test-jobs-generator strategy: depend # test-lisp-inotify: commit 3e53047fc5e411a55fa5007c087f74b316fdfa68 Author: Michael Albinus Date: Fri Nov 19 17:33:12 2021 +0100 Fix stage in gitlab-ci.yml diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index c14af0e301..b5222f884a 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -235,7 +235,7 @@ build-image-inotify: # make_params: "-C test check" generator: - stage: generate + stage: .pre script: - ./test-jobs-generator.sh > test-jobs.yml artifacts: commit cb612c51d6c428aa7d8fd01f1b3fde13284c1c16 Author: Michael Albinus Date: Fri Nov 19 16:50:03 2021 +0100 Add more test jobs for emba * test/Makefile.in (SUBDIRS): Suppress "*auto-save-list". (SUBDIR_TARGETS): New variable. (subdir_template): Set it. (subdir-targets): New target. * test/infra/gitlab-ci.yml (variables): Add CI_DEBUG_TRACE. (build-image-inotify): Remove timeout. (generator, test-jobs-pipeline): New jobs. (test-lisp-inotify, test-lisp-net-inotify): Comment. * test/infra/test-jobs-generator.sh: New script. diff --git a/test/Makefile.in b/test/Makefile.in index 7bef1c3660..39d7b1d4e4 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -31,7 +31,7 @@ SHELL = @SHELL@ srcdir = @srcdir@ -abs_top_srcdir=@abs_top_srcdir@ +abs_top_srcdir = @abs_top_srcdir@ top_builddir = @top_builddir@ VPATH = $(srcdir) @@ -67,7 +67,7 @@ elpa_opts = $(foreach el,$(elpa_els),$(and $(wildcard $(el)),-L $(dir $(el)) -l # directory, we can use emacs --chdir. EMACS = ../src/emacs -EMACS_EXTRAOPT= +EMACS_EXTRAOPT = # Command line flags for Emacs. # Apparently MSYS bash would convert "-L :" to "-L ;" anyway, @@ -252,9 +252,12 @@ endef $(foreach test,${TESTS},$(eval $(call test_template,${test}))) ## Get the tests for only a specific directory. -SUBDIRS = $(sort $(shell cd ${srcdir} && find lib-src lisp misc src -type d ! -path "*resources*" -print)) +SUBDIRS = $(sort $(shell cd ${srcdir} && find lib-src lisp misc src -type d \ + ! \( -path "*resources*" -o -path "*auto-save-list" \) -print)) +SUBDIR_TARGETS = define subdir_template + SUBDIR_TARGETS += check-$(subst /,-,$(1)) .PHONY: check-$(subst /,-,$(1)) check-$(subst /,-,$(1)): @${MAKE} check LOGFILES="$(patsubst %.el,%.log, \ @@ -367,3 +370,8 @@ maintainer-clean: distclean bootstrap-clean check-declare: $(emacs) -l check-declare \ --eval '(check-declare-directory "$(srcdir)")' + +.PHONY: subdir-targets + +subdir-targets: + @echo $(SUBDIR_TARGETS) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 096a293b30..c14af0e301 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -47,7 +47,7 @@ variables: # Three hours, see below. EMACS_TEST_TIMEOUT: 10800 EMACS_TEST_VERBOSE: 1 - # # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled + # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled # DOCKER_HOST: tcp://docker:2376 # DOCKER_TLS_CERTDIR: "/certs" # Put the configuration for each run in a separate directory to @@ -57,6 +57,8 @@ variables: # We don't use ${CI_COMMIT_SHA} to be able to do one bootstrap # across multiple builds. BUILD_TAG: ${CI_COMMIT_REF_SLUG} + # Disable if you don't need it, it can be a security risk. + CI_DEBUG_TRACE: "true" default: image: docker:19.03.12 @@ -224,8 +226,6 @@ build-image-inotify: extends: [.job-template, .build-template] variables: target: emacs-inotify -# Temporarily. - timeout: 8 hours # test-fast-inotify: # stage: fast @@ -234,19 +234,35 @@ build-image-inotify: # target: emacs-inotify # make_params: "-C test check" -test-lisp-inotify: - stage: normal - extends: [.job-template, .test-template] - variables: - target: emacs-inotify - make_params: "-C test check-lisp" +generator: + stage: generate + script: + - ./test-jobs-generator.sh > test-jobs.yml + artifacts: + paths: + - test-jobs.yml -test-lisp-net-inotify: - stage: normal - extends: [.job-template, .test-template] - variables: - target: emacs-inotify - make_params: "-C test check-lisp-net" +test-jobs-pipeline: + stage: trigger + trigger: + include: + - artifact: test-jobs.yml + job: generator + strategy: depend + +# test-lisp-inotify: +# stage: normal +# extends: [.job-template, .test-template] +# variables: +# target: emacs-inotify +# make_params: "-C test check-lisp" + +# test-lisp-net-inotify: +# stage: normal +# extends: [.job-template, .test-template] +# variables: +# target: emacs-inotify +# make_params: "-C test check-lisp-net" build-image-filenotify-gio: stage: platform-images diff --git a/test/infra/test-jobs-generator.sh b/test/infra/test-jobs-generator.sh new file mode 100755 index 0000000000..97346785ea --- /dev/null +++ b/test/infra/test-jobs-generator.sh @@ -0,0 +1,89 @@ +#!/bin/sh + +# Copyright (C) 2021 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 . + +# GNU Emacs support for the GitLab-specific build of Docker images. + +# The presence of this file does not imply any FSF/GNU endorsement of +# Docker or any other particular tool. Also, it is intended for +# evaluation purposes, thus possibly temporary. + +# Maintainer: Michael Albinus +# URL: https://emba.gnu.org/emacs/emacs + +for target in $(cd ..; make -s subdir-targets); do + case $target in + check-lib-src) + changes=" + - lib-src/*.{h,c} + - test/lib-src/*.el" + ;; + check-lisp-emacs-lisp) + changes=" + - lisp/emacs-lisp/*.el + - test/lisp/emacs-lisp/*.el" + ;; + check-lisp-emacs-lisp-eieio-tests) + changes=" + - lisp/emacs-lisp/eieio-tests/*.el + - test/lisp/emacs-lisp/eieio-tests/*.el" + ;; + check-lisp-emacs-lisp-faceup-tests) + changes=" + - lisp/emacs-lisp/faceup-tests/*.el + - test/lisp/emacs-lisp/faceup-tests/*.el" + ;; + check-lisp-mh-e) + changes=" + - lisp/mh-e/*.el + - test/lisp/mh-e/*.el" + ;; + check-lisp-so-long-tests) + changes=" + - lisp/so-long-tests/*.el + - test/lisp/so-long-tests/*.el" + ;; + check-misc) + changes=" + - admin/*.el + - test/misc/*.el" + ;; + check-src) + changes=" + - src/*.{h,c} + - test/src/*.el" + ;; + *) + changes=" + - $(echo -n ${target##check-}/*.el | tr '-' '/') + - $(echo -n test${target##check}/*.el | tr '-' '/')" + ;; + esac + + cat < Date: Fri Nov 19 17:23:35 2021 +0200 Fix doc strings in ucs-normalize.el * lisp/international/ucs-normalize.el (ucs-normalize-NFD-region) (ucs-normalize-NFD-string, string-glyph-compose) (string-glyph-decompose, ucs-normalize-NFC-string) (ucs-normalize-NFKD-region, ucs-normalize-NFKD-string) (ucs-normalize-NFKC-region, ucs-normalize-NFKC-string) (ucs-normalize-HFS-NFD-region, ucs-normalize-HFS-NFC-region): Fix wording and typos. diff --git a/lisp/international/ucs-normalize.el b/lisp/international/ucs-normalize.el index 0c85b490c2..3da47e701a 100644 --- a/lisp/international/ucs-normalize.el +++ b/lisp/international/ucs-normalize.el @@ -537,8 +537,9 @@ COMPOSITION-PREDICATE will be used to compose region." (buffer-string))) (defun ucs-normalize-NFD-region (from to) - "Decompose the current region according to the Unicode NFD. -This is the canonical decomposed form." + "Decompose the region between FROM and TO according to the Unicode NFD. +This replaces the text between FROM and TO with its canonical decomposition, +a.k.a. the \"Unicode Normalization Form D\"." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfd-quick-check-regexp @@ -546,14 +547,17 @@ This is the canonical decomposed form." (defun ucs-normalize-NFD-string (str) "Decompose the string STR according to the Unicode NFD. -This is the canonical decomposed form. For instance: +This returns a new string that is the canonical decomposition of STR, +a.k.a. the \"Unicode Normalization Form D\" of STR. For instance: (ucs-normalize-NFD-string \"Å\") => \"Å\"" (ucs-normalize-string ucs-normalize-NFD-region)) (defun ucs-normalize-NFC-region (from to) - "Compose the current region according to the Unicode NFC. -This is the canonical composed form." + "Compose the region between FROM and TO according to the Unicode NFC. +This replaces the text between FROM and TO with the result of its +canonical decomposition (see `ucs-normalize-NFD-region') followed by +canonical composition, a.k.a. the \"Unicode Normalization Form C\"." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfc-quick-check-regexp @@ -561,30 +565,38 @@ This is the canonical composed form." ;;;###autoload (defun string-glyph-compose (string) - "Compose the string STR according to the Unicode NFC. -This is the canonical composed form. For instance: + "Compose STRING according to the Unicode NFC. +This returns a new string obtained by canonical decomposition +of STRING (see `ucs-normalize-NFC-string') followed by canonical +composition, a.k.a. the \"Unicode Normalization Form C\" of STRING. +For instance: (string-glyph-compose \"Å\") => \"Å\"" (ucs-normalize-NFC-string string)) ;;;###autoload (defun string-glyph-decompose (string) - "Decompose the string STR according to the Unicode NFD. -This is the canonical decomposed form. For instance: + "Decompose STRING according to the Unicode NFD. +This returns a new string that is the canonical decomposition of STRING, +a.k.a. the \"Unicode Normalization Form D\" of STRING. For instance: - (string-glyph-decompose \"Å\") => \"Å\"" + (ucs-normalize-NFD-string \"Å\") => \"Å\"" (ucs-normalize-NFD-string string)) (defun ucs-normalize-NFC-string (str) - "Compose the string STR by according to the Unicode NFC. -This is the canonical composed form. For instance: + "Compose STR according to the Unicode NFC. +This returns a new string obtained by canonical decomposition +of STR (see `ucs-normalize-NFC-string') followed by canonical +composition, a.k.a. the \"Unicode Normalization Form C\" of STR. +For instance: - (ucs-normalize-NFC-string \"Å\") => \"Å\"" + (string-glyph-compose \"Å\") => \"Å\"" (ucs-normalize-string ucs-normalize-NFC-region)) (defun ucs-normalize-NFKD-region (from to) - "Decompose the current region according to the Unicode NFKD. -This is the compatibility decomposed form." + "Decompose the region between FROM and TO according to the Unicode NFKD. +This replaces the text between FROM and TO with its compatibility +decomposition, a.k.a. \"Unicode Normalization Form KD\"." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfkd-quick-check-regexp @@ -592,34 +604,39 @@ This is the compatibility decomposed form." (defun ucs-normalize-NFKD-string (str) "Decompose the string STR according to the Unicode NFKD. -This is the compatibility decomposed form. This is much like the -NFD (canonical decomposed) form, but mainly differs in glyphs -with formatting distinctions. For instance: +This returns a new string obtained by compatibility decomposition +of STR. This is much like the NFD (canonical decomposition) form, +see `ucs-normalize-NFD-string', but mainly differs for precomposed +characters. For instance: (ucs-normalize-NFD-string \"fi\") => \"fi\" (ucs-normalize-NFKD-string \"fi\") = \"fi\"" (ucs-normalize-string ucs-normalize-NFKD-region)) (defun ucs-normalize-NFKC-region (from to) - "Compose the current region according to the Unicode NFKC. -The is the compatibility composed form." + "Compose the region between FROM and TO according to the Unicode NFKC. +This replaces the text between FROM and TO with the result of its +compatibility decomposition (see `ucs-normalize-NFC-region') followed by +canonical composition, a.k.a. the \"Unicode Normalization Form KC\"." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfkc-quick-check-regexp 'ucs-normalize-nfkd-table t)) (defun ucs-normalize-NFKC-string (str) - "Compose the string STR according to the Unicode NFKC. -This is the compatibility composed form. This is much like the -NFC (canonical composed) form, but mainly differs in glyphs -with formatting distinctions. For instance: + "Compose STR according to the Unicode NFC. +This returns a new string obtained by compatibility decomposition +of STR (see `ucs-normalize-NFKD-string') followed by canonical +composition, a.k.a. the \"Unicode Normalization Form KC\" of STR. +This is much like the NFC (canonical composition) form, but mainly +differs for precomposed characters. For instance: (ucs-normalize-NFC-string \"fi\") => \"fi\" (ucs-normalize-NFKC-string \"fi\") = \"fi\"" (ucs-normalize-string ucs-normalize-NFKC-region)) (defun ucs-normalize-HFS-NFD-region (from to) - "Normalize the current region by the Unicode NFD and Mac OS's HFS Plus." + "Normalize region between FROM and TO by Unicode NFD and Mac OS's HFS Plus." (interactive "r") (ucs-normalize-region from to ucs-normalize-hfs-nfd-quick-check-regexp @@ -631,7 +648,7 @@ with formatting distinctions. For instance: (ucs-normalize-string ucs-normalize-HFS-NFD-region)) (defun ucs-normalize-HFS-NFC-region (from to) - "Normalize the current region by the Unicode NFC and Mac OS's HFS Plus." + "Normalize region between FROM and TO by Unicode NFC and Mac OS's HFS Plus." (interactive "r") (ucs-normalize-region from to ucs-normalize-hfs-nfc-quick-check-regexp commit eb86c33c46d4bd1af06abcec5d9d97c705c0ce0d Author: Eli Zaretskii Date: Fri Nov 19 15:41:48 2021 +0200 Fix documentation of last commit * lisp/xwidget.el (xwidget-webkit-cookie-file): Don't use "path" for file names in the doc string. Improve wording and markup of the doc string. * src/xwidget.c (Fxwidget_webkit_set_cookie_storage_file): * doc/lispref/display.texi (Xwidgets): Don't use "path" for file names. * etc/NEWS: Improve the wording of the entry about 'xwidget-webkit-cookie-file'. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index a90be5079e..12257fda54 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -7015,8 +7015,8 @@ The value returned is a float ranging between 0.0 and 1.0. @defun xwidget-webkit-set-cookie-storage-file xwidget file Make the WebKit widget @var{xwidget} store cookies in @var{file}. -@var{file} must be an absolute file path. The new setting will also -take effect on any xwidget that was created with @var{xwidget} as the +@var{file} must be an absolute file name. The new setting will also +affect any xwidget that was created with @var{xwidget} as the @code{related} argument to @code{make-xwidget}, and widgets related to those as well. diff --git a/etc/NEWS b/etc/NEWS index 2d3f9dae5b..c38e1aa5eb 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -495,8 +495,10 @@ named. --- *** New user option 'xwidget-webkit-cookie-file'. -Using this option you can set where and if the xwidget-webkit buffers -save cookies set by web pages. +Using this option you can control whether the xwidget-webkit buffers +save cookies set by web pages, and if so, in which file to save them. +the default is the file 'xwidget-webkit-cookies.txt' under +'~/.emacs.d' directory. +++ *** New minor mode 'xwidget-webkit-edit-mode'. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 056315a4db..a1f992e659 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -111,9 +111,9 @@ It can use the following special constructs: (defcustom xwidget-webkit-cookie-file (file-name-concat user-emacs-directory "xwidget-webkit-cookies.txt") - "A path to the file where xwidget-webkit-browse-url will store cookies. -They will be stored as plain text in Mozilla `cookies.txt' -format. If nil, cookies will not be stored." + "The name of the file where `xwidget-webkit-browse-url' will store cookies. +They will be stored as plain text in Mozilla \"cookies.txt\" +format. If nil, do not store cookies." :type 'string :version "29.1") diff --git a/src/xwidget.c b/src/xwidget.c index 4e84d43b2a..8cad2fbc2c 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -2587,8 +2587,8 @@ DEFUN ("xwidget-webkit-set-cookie-storage-file", 2, 2, 0, doc: /* Make the WebKit widget XWIDGET load and store cookies in FILE. Cookies will be stored as plain text in FILE, which must be an -absolute file path. All xwidgets related to XWIDGET will also be -changed to store and load cookies in FILE. */) +absolute file name. All xwidgets related to XWIDGET will also +store cookies in FILE and load them from there. */) (Lisp_Object xwidget, Lisp_Object file) { #ifdef USE_GTK commit b4f0c4c694e1c00b4025fe16039b8940d97c66aa Author: Po Lu Date: Fri Nov 19 20:04:08 2021 +0800 Allow controlling where xwidget-webkit stores cookies * doc/lispref/display.texi (Xwidgets): Document new function. * etc/NEWS: Announce `xwidget-webkit-cookie-file' and `xwidget-webkit-set-cookie-storage-file'. * lisp/xwidget.el (xwidget-webkit-cookie-file): New user option. (xwidget-webkit-new-session): Set cookie storage file. * src/xwidget.c (Fmake_xwidget): Create new context for each unrelated widget. (Fxwidget_webkit_set_cookie_storage_file): New function. (syms_of_xwidget): Define new subr. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index e9b50707de..a90be5079e 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -7012,6 +7012,18 @@ loaded. The value returned is a float ranging between 0.0 and 1.0. @end defun +@defun xwidget-webkit-set-cookie-storage-file xwidget file +Make the WebKit widget @var{xwidget} store cookies in @var{file}. + +@var{file} must be an absolute file path. The new setting will also +take effect on any xwidget that was created with @var{xwidget} as the +@code{related} argument to @code{make-xwidget}, and widgets related to +those as well. + +If this function is not called at least once on @var{xwidget} or a +related widget, @var{xwidget} will not store cookies on disk at all. +@end defun + @node Buttons @section Buttons @cindex buttons in buffers diff --git a/etc/NEWS b/etc/NEWS index ad31b23271..2d3f9dae5b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -493,6 +493,11 @@ This is a convenience function to extract the field data from Using this option you can control how the xwidget-webkit buffers are named. +--- +*** New user option 'xwidget-webkit-cookie-file'. +Using this option you can set where and if the xwidget-webkit buffers +save cookies set by web pages. + +++ *** New minor mode 'xwidget-webkit-edit-mode'. When this mode is enabled, self-inserting characters and other common @@ -882,6 +887,11 @@ These events are sent whenever an xwidget requests that Emacs display another xwidget. The only argument to this event is the xwidget that should be displayed. ++++ +*** New function 'xwidget-webkit-set-cookie-storage-file'. +This function is used to control where and if an xwidget stores +cookies set by web pages on disk. + * Changes in Emacs 29.1 on Non-Free Operating Systems diff --git a/lisp/xwidget.el b/lisp/xwidget.el index b74e332edf..056315a4db 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -57,6 +57,7 @@ (declare-function xwidget-query-on-exit-flag "xwidget.c" (xwidget)) (declare-function xwidget-webkit-back-forward-list "xwidget.c" (xwidget &optional limit)) (declare-function xwidget-webkit-estimated-load-progress "xwidget.c" (xwidget)) +(declare-function xwidget-webkit-set-cookie-storage-file "xwidget.c" (xwidget file)) (defgroup xwidget nil "Displaying native widgets in Emacs buffers." @@ -107,6 +108,15 @@ It can use the following special constructs: :type 'string :version "29.1") +(defcustom xwidget-webkit-cookie-file + (file-name-concat user-emacs-directory + "xwidget-webkit-cookies.txt") + "A path to the file where xwidget-webkit-browse-url will store cookies. +They will be stored as plain text in Mozilla `cookies.txt' +format. If nil, cookies will not be stored." + :type 'string + :version "29.1") + ;;;###autoload (defun xwidget-webkit-browse-url (url &optional new-session) "Ask xwidget-webkit to browse URL. @@ -794,6 +804,9 @@ For example, use this to display an anchor." (xwidget-window-inside-pixel-width (selected-window)) (xwidget-window-inside-pixel-height (selected-window)) nil current-session))) + (when xwidget-webkit-cookie-file + (xwidget-webkit-set-cookie-storage-file + xw (expand-file-name xwidget-webkit-cookie-file))) (xwidget-put xw 'callback callback) (xwidget-webkit-mode) (xwidget-webkit-goto-uri (xwidget-webkit-last-session) url))) diff --git a/src/xwidget.c b/src/xwidget.c index 2f930dcbe7..4e84d43b2a 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -188,7 +188,9 @@ fails. */) || !XWIDGETP (related) || !EQ (XXWIDGET (related)->type, Qwebkit)) { - xw->widget_osr = webkit_web_view_new (); + WebKitWebContext *ctx = webkit_web_context_new (); + xw->widget_osr = webkit_web_view_new_with_context (ctx); + g_object_unref (ctx); webkit_web_view_load_uri (WEBKIT_WEB_VIEW (xw->widget_osr), "about:blank"); @@ -2580,6 +2582,39 @@ is to completely loading its page. */) } #endif +DEFUN ("xwidget-webkit-set-cookie-storage-file", + Fxwidget_webkit_set_cookie_storage_file, Sxwidget_webkit_set_cookie_storage_file, + 2, 2, 0, doc: /* Make the WebKit widget XWIDGET load and store cookies in FILE. + +Cookies will be stored as plain text in FILE, which must be an +absolute file path. All xwidgets related to XWIDGET will also be +changed to store and load cookies in FILE. */) + (Lisp_Object xwidget, Lisp_Object file) +{ +#ifdef USE_GTK + struct xwidget *xw; + WebKitWebView *webview; + WebKitWebContext *context; + WebKitCookieManager *manager; + + CHECK_LIVE_XWIDGET (xwidget); + xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); + CHECK_STRING (file); + + block_input (); + webview = WEBKIT_WEB_VIEW (xw->widget_osr); + context = webkit_web_view_get_context (webview); + manager = webkit_web_context_get_cookie_manager (context); + webkit_cookie_manager_set_persistent_storage (manager, + SSDATA (ENCODE_UTF_8 (file)), + WEBKIT_COOKIE_PERSISTENT_STORAGE_TEXT); + unblock_input (); +#endif + + return Qnil; +} + void syms_of_xwidget (void) { @@ -2620,6 +2655,7 @@ syms_of_xwidget (void) defsubr (&Sxwidget_webkit_next_result); defsubr (&Sxwidget_webkit_previous_result); defsubr (&Sset_xwidget_buffer); + defsubr (&Sxwidget_webkit_set_cookie_storage_file); #ifdef USE_GTK defsubr (&Sxwidget_webkit_load_html); defsubr (&Sxwidget_webkit_back_forward_list); commit 24c67435ea5f15aa858f4a12b00055ed92baa1d9 Author: Po Lu Date: Fri Nov 19 19:18:48 2021 +0800 Use CHECK_LIVE_XWIDGET in xwidget-webkit-estimated-load-progress * src/xwidget.c (Fxwidget_webkit_estimated_load_progress): Check for live xwidgets instead. diff --git a/src/xwidget.c b/src/xwidget.c index 62b01b741c..2f930dcbe7 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -2567,7 +2567,7 @@ is to completely loading its page. */) WebKitWebView *webview; double value; - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); xw = XXWIDGET (xwidget); CHECK_WEBKIT_WIDGET (xw); commit a5e1f8bbddc0cdf3166f3dbdc8760aa0a093db92 Author: Po Lu Date: Fri Nov 19 18:41:53 2021 +0800 Display page loading progress in xwidget webkit * lisp/xwidget.el (xwidget-webkit--title): Remove internal variable. (xwidget-webkit--loading-p) (xwidget-webkit--progress-update-timer): New variables. (xwidget-webkit--update-progress-timer-function): New function. (xwidget-webkit-callback): Set up progress update timer during page loads. (xwidget-webkit-mode): Add page load progress to header line format. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 37cf2e5816..b74e332edf 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -56,6 +56,7 @@ (declare-function get-buffer-xwidgets "xwidget.c" (buffer)) (declare-function xwidget-query-on-exit-flag "xwidget.c" (xwidget)) (declare-function xwidget-webkit-back-forward-list "xwidget.c" (xwidget &optional limit)) +(declare-function xwidget-webkit-estimated-load-progress "xwidget.c" (xwidget)) (defgroup xwidget nil "Displaying native widgets in Emacs buffers." @@ -106,9 +107,6 @@ It can use the following special constructs: :type 'string :version "29.1") -(defvar-local xwidget-webkit--title "" - "The title of the WebKit widget, used for the header line.") - ;;;###autoload (defun xwidget-webkit-browse-url (url &optional new-session) "Ask xwidget-webkit to browse URL. @@ -150,6 +148,12 @@ in `split-window-right' with a new xwidget webkit session." (defvar xwidget-webkit--input-method-events nil "Internal variable used to store input method events.") +(defvar-local xwidget-webkit--loading-p nil + "Whether or not a page is being loaded.") + +(defvar-local xwidget-webkit--progress-update-timer nil + "Timer that updates the display of page load progress in the header line.") + (defun xwidget-webkit-pass-command-event-with-input-method () "Handle a `with-input-method' event." (interactive) @@ -384,6 +388,11 @@ If N is omitted or nil, scroll backwards by one char." (when xwidget-callback (funcall xwidget-callback xwidget xwidget-event-type)))) +(defun xwidget-webkit--update-progress-timer-function (xwidget) + "Force an update of the header line of XWIDGET's buffer." + (with-current-buffer (xwidget-buffer xwidget) + (force-mode-line-update))) + (defun xwidget-webkit-callback (xwidget xwidget-event-type) "Callback for xwidgets. XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." @@ -396,6 +405,17 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." (when-let ((buffer (get-buffer "*Xwidget WebKit History*"))) (with-current-buffer buffer (revert-buffer))) + (with-current-buffer (xwidget-buffer xwidget) + (if (string-equal (nth 3 last-input-event) + "load-finished") + (progn + (setq xwidget-webkit--loading-p nil) + (cancel-timer xwidget-webkit--progress-update-timer)) + (unless xwidget-webkit--loading-p + (setq xwidget-webkit--loading-p t + xwidget-webkit--progress-update-timer + (run-at-time 0.5 0.5 #'xwidget-webkit--update-progress-timer-function + xwidget))))) ;; This funciton will be called multi times, so only ;; change buffer name when the load actually completes ;; this can limit buffer-name flicker in mode-line. @@ -403,7 +423,6 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." "load-finished") (> (length title) 0)) (with-current-buffer (xwidget-buffer xwidget) - (setq xwidget-webkit--title title) (force-mode-line-update) (xwidget-log "webkit finished loading: %s" title) ;; Do not adjust webkit size to window here, the @@ -447,7 +466,17 @@ If non-nil, plugins are enabled. Otherwise, disabled." (setq-local tool-bar-map xwidget-webkit-tool-bar-map) (setq-local bookmark-make-record-function #'xwidget-webkit-bookmark-make-record) - (setq-local header-line-format 'xwidget-webkit--title) + (setq-local header-line-format + (list "WebKit: " + '(:eval + (xwidget-webkit-title (xwidget-webkit-current-session))) + '(:eval + (when xwidget-webkit--loading-p + (let ((session (xwidget-webkit-current-session))) + (format " [%d%%%%]" + (* 100 + (xwidget-webkit-estimated-load-progress + session)))))))) ;; Keep track of [vh]scroll when switching buffers (image-mode-setup-winprops)) commit 9f2f69803275e3baa24c717be6c0586812c3aa7c Author: Stefan Kangas Date: Fri Nov 19 11:34:28 2021 +0100 Improve doc-view-mode menus * lisp/doc-view.el (doc-view-menu): Extend menu. (doc-view-minor-mode-menu): New menu. diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 32e2ec1688..7e113e4f34 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -493,24 +493,69 @@ Typically \"page-%s.png\".") (easy-menu-define doc-view-menu doc-view-mode-map "Menu for Doc View mode." '("DocView" - ["Toggle display" doc-view-toggle-display] - ("Continuous" + ["Next page" doc-view-next-page + :help "Go to the next page"] + ["Previous page" doc-view-previous-page + :help "Go to the previous page"] + ("Other Navigation" + ["Go to page..." doc-view-goto-page + :help "Go to specific page"] + "---" + ["First page" doc-view-first-page + :help "View the first page"] + ["Last page" doc-view-last-page + :help "View the last page"] + "---" + ["Move forward" doc-view-scroll-up-or-next-page + :help "Scroll page up or go to next page"] + ["Move backward" doc-view-scroll-down-or-previous-page + :help "Scroll page down or go to previous page"]) + ("Continuous Scrolling" ["Off" (setq doc-view-continuous nil) - :style radio :selected (eq doc-view-continuous nil)] + :style radio :selected (eq doc-view-continuous nil) + :help "Scrolling stops at page beginning and end"] ["On" (setq doc-view-continuous t) - :style radio :selected (eq doc-view-continuous t)] + :style radio :selected (eq doc-view-continuous t) + :help "Scrolling continues to next or previous page"] "---" - ["Save as Default" - (customize-save-variable 'doc-view-continuous doc-view-continuous) t] + ["Save as Default" (customize-save-variable 'doc-view-continuous doc-view-continuous) + :help "Save current continuous scrolling option as default"] ) "---" - ["Set Slice" doc-view-set-slice-using-mouse] - ["Set Slice (BoundingBox)" doc-view-set-slice-from-bounding-box] - ["Set Slice (manual)" doc-view-set-slice] - ["Reset Slice" doc-view-reset-slice] + ("Toggle edit/display" + ["Edit document" doc-view-toggle-display + :style radio :selected (eq major-mode 'doc-view--text-view-mode)] + ["Display document" (lambda ()) ; ignore but show no keybinding + :style radio :selected (eq major-mode 'doc-view-mode)]) + ("Adjust Display" + ["Fit to window" doc-view-fit-page-to-window + :help "Fit the image to the window"] + ["Fit width" doc-view-fit-width-to-window + :help "Fit the image width to the window width"] + ["Fit height" doc-view-fit-height-to-window + :help "Fit the image height to the window height"] + "---" + ["Enlarge" doc-view-enlarge + :help "Enlarge the document"] + ["Shrink" doc-view-shrink + :help "Shrink the document"] + "---" + ["Set Slice" doc-view-set-slice-using-mouse + :help "Set the slice of the images that should be displayed"] + ["Set Slice (BoundingBox)" doc-view-set-slice-from-bounding-box + :help "Set the slice from the document's BoundingBox information"] + ["Set Slice (manual)" doc-view-set-slice + :help "Set the slice of the images that should be displayed"] + ["Reset Slice" doc-view-reset-slice + :help "Reset the current slice" + :enabled (image-mode-window-get 'slice)]) "---" - ["Search" doc-view-search] - ["Search Backwards" doc-view-search-backward] + ["New Search" (doc-view-search t) + :help "Initiate a new search"] + ["Search Forward" doc-view-search + :help "Jump to the next match or initiate a new search"] + ["Search Backward" doc-view-search-backward + :help "Jump to the previous match or initiate a new search"] )) (defvar doc-view-minor-mode-map @@ -520,6 +565,16 @@ Typically \"page-%s.png\".") map) "Keymap used by `doc-view-minor-mode'.") +(easy-menu-define doc-view-minor-mode-menu doc-view-minor-mode-map + "Menu for Doc View minor mode." + '("DocView (edit)" + ("Toggle edit/display" + ["Edit document" (lambda ()) ; ignore but show no keybinding + :style radio :selected (eq major-mode 'doc-view--text-view-mode)] + ["Display document" doc-view-toggle-display + :style radio :selected (eq major-mode 'doc-view-mode)]) + ["Exit DocView Mode" doc-view-minor-mode])) + ;;;; Navigation Commands ;; FIXME: The doc-view-current-* definitions below are macros because they commit 3ec1ab609e0e7d359ca72777aefae80c3c8ec39d Author: Robert Pluim Date: Fri Nov 19 11:05:25 2021 +0100 ; * lisp/international/ucs-normalize.el: Fix typo. diff --git a/lisp/international/ucs-normalize.el b/lisp/international/ucs-normalize.el index c6a562e3f5..0c85b490c2 100644 --- a/lisp/international/ucs-normalize.el +++ b/lisp/international/ucs-normalize.el @@ -561,7 +561,7 @@ This is the canonical composed form." ;;;###autoload (defun string-glyph-compose (string) - "Compose the string STR by according to the Unicode NFC. + "Compose the string STR according to the Unicode NFC. This is the canonical composed form. For instance: (string-glyph-compose \"Å\") => \"Å\"" commit 5bab11348602b7f5281d3dd76cc7f93f48b18696 Author: Po Lu Date: Fri Nov 19 17:45:03 2021 +0800 Add `xwidget-webkit-estimated-load-progress' * doc/lispref/display.texi (Xwidgets): Document new function. * etc/NEWS: Announce new function. * src/xwidget.c (Fxwidget_webkit_estimated_load_progress): New function. (syms_of_xwidget): Define new subr. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 8decff6fa8..e9b50707de 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -7004,6 +7004,14 @@ manually to reach a specific history item. Instead, @var{idx} should be passed as an index to @code{xwidget-webkit-goto-history}. @end defun +@defun xwidget-webkit-estimated-load-progress xwidget +Return an estimate of how much data is remaining to be transferred +before the page displayed by the WebKit widget @var{xwidget} is fully +loaded. + +The value returned is a float ranging between 0.0 and 1.0. +@end defun + @node Buttons @section Buttons @cindex buttons in buffers diff --git a/etc/NEWS b/etc/NEWS index cee2844be3..ad31b23271 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -863,6 +863,11 @@ for performing searches on WebKit xwidgets. This function is used to obtain the history of page-loads in a given WebKit xwidget. ++++ +*** New function 'xwidget-webkit-estimated-load-progress'. +This function is used to obtain the estimated progress of page loading +in a given WebKit xwidget. + +++ *** 'load-changed' xwidget events are now more detailed. In particular, they can now have different arguments based on the diff --git a/src/xwidget.c b/src/xwidget.c index e1bf40ea43..62b01b741c 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -2555,6 +2555,29 @@ LIMIT is not specified or nil, it is treated as `50'. */) return list3 (back, here, forward); } + +DEFUN ("xwidget-webkit-estimated-load-progress", + Fxwidget_webkit_estimated_load_progress, Sxwidget_webkit_estimated_load_progress, + 1, 1, 0, doc: /* Get the estimated load progress of XWIDGET, a WebKit widget. +Return a value ranging from 0.0 to 1.0, based on how close XWIDGET +is to completely loading its page. */) + (Lisp_Object xwidget) +{ + struct xwidget *xw; + WebKitWebView *webview; + double value; + + CHECK_XWIDGET (xwidget); + xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); + + block_input (); + webview = WEBKIT_WEB_VIEW (xw->widget_osr); + value = webkit_web_view_get_estimated_load_progress (webview); + unblock_input (); + + return make_float (value); +} #endif void @@ -2600,6 +2623,7 @@ syms_of_xwidget (void) #ifdef USE_GTK defsubr (&Sxwidget_webkit_load_html); defsubr (&Sxwidget_webkit_back_forward_list); + defsubr (&Sxwidget_webkit_estimated_load_progress); #endif defsubr (&Skill_xwidget); commit 023dc2ac8fb004c16748fa98223a1fb88cfa2186 Author: Lars Ingebrigtsen Date: Fri Nov 19 07:42:55 2021 +0100 Make puny-encode-string normalize first * lisp/net/puny.el (puny-encode-string): Normalize before encoding (bug#51954). diff --git a/lisp/net/puny.el b/lisp/net/puny.el index 42a7e79679..c1833ffdb0 100644 --- a/lisp/net/puny.el +++ b/lisp/net/puny.el @@ -43,6 +43,7 @@ For instance, \"fśf.org\" => \"xn--ff-2sa.org\"." "Encode STRING according to the IDNA/punycode algorithm. This is used to encode non-ASCII domain names. For instance, \"bücher\" => \"xn--bcher-kva\"." + (setq string (downcase (string-glyph-compose string))) (let ((ascii (seq-filter (lambda (char) (< char 128)) string))) diff --git a/test/lisp/net/puny-tests.el b/test/lisp/net/puny-tests.el index 28c0d49cbe..9119084209 100644 --- a/test/lisp/net/puny-tests.el +++ b/test/lisp/net/puny-tests.el @@ -61,4 +61,11 @@ ;; Only allowed in unrestricted. (should-not (puny-highly-restrictive-domain-p "I♥NY.org"))) +(ert-deftest puny-normalize () + (should (equal (puny-encode-string (string-glyph-compose "Bä.com")) + "xn--b.com-gra")) + (should (equal (puny-encode-string "Bä.com") + "xn--b.com-gra")) + (should (equal (puny-encode-string "Bä.com") "xn--b.com-gra"))) + ;;; puny-tests.el ends here commit 19e78601a03c96731f4c01c38a0966b5e27e57f3 Author: Lars Ingebrigtsen Date: Fri Nov 19 07:42:25 2021 +0100 Regenerate ldefs-boot diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 2eae134e3d..613d9734ae 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -1,4 +1,5 @@ ;;; loaddefs.el --- automatically extracted autoloads -*- lexical-binding: t -*- +;; This file will be copied to ldefs-boot.el and checked in periodically. ;; ;;; Code: @@ -2381,12 +2382,7 @@ a reflection. (define-key ctl-x-r-map "M" 'bookmark-set-no-overwrite) (define-key ctl-x-r-map "l" 'bookmark-bmenu-list) -(defvar bookmark-map (let ((map (make-sparse-keymap))) (define-key map "x" 'bookmark-set) (define-key map "m" 'bookmark-set) (define-key map "M" 'bookmark-set-no-overwrite) (define-key map "j" 'bookmark-jump) (define-key map "g" 'bookmark-jump) (define-key map "o" 'bookmark-jump-other-window) (define-key map "5" 'bookmark-jump-other-frame) (define-key map "i" 'bookmark-insert) (define-key map "e" 'edit-bookmarks) (define-key map "f" 'bookmark-insert-location) (define-key map "r" 'bookmark-rename) (define-key map "d" 'bookmark-delete) (define-key map "D" 'bookmark-delete-all) (define-key map "l" 'bookmark-load) (define-key map "w" 'bookmark-write) (define-key map "s" 'bookmark-save) map) "\ -Keymap containing bindings to bookmark functions. -It is not bound to any key by default: to bind it -so that you have a bookmark prefix, just use `global-set-key' and bind a -key of your choice to variable `bookmark-map'. All interactive bookmark -functions have a binding in this keymap.") +(defvar-keymap bookmark-map :doc "Keymap containing bindings to bookmark functions.\nIt is not bound to any key by default: to bind it\nso that you have a bookmark prefix, just use `global-set-key' and bind a\nkey of your choice to variable `bookmark-map'. All interactive bookmark\nfunctions have a binding in this keymap." "x" #'bookmark-set "m" #'bookmark-set "M" #'bookmark-set-no-overwrite "j" #'bookmark-jump "g" #'bookmark-jump "o" #'bookmark-jump-other-window "5" #'bookmark-jump-other-frame "i" #'bookmark-insert "e" #'edit-bookmarks "f" #'bookmark-insert-location "r" #'bookmark-rename "d" #'bookmark-delete "D" #'bookmark-delete-all "l" #'bookmark-load "w" #'bookmark-write "s" #'bookmark-save) (fset 'bookmark-map bookmark-map) (autoload 'bookmark-set "bookmark" "\ @@ -4772,6 +4768,14 @@ space at the end of each line. \(fn &optional NO-ERROR)" t nil) +(autoload 'checkdoc-dired "checkdoc" "\ +In Dired, run `checkdoc' on marked files. +Skip anything that doesn't have the Emacs Lisp library file +extension (\".el\"). +When called from Lisp, FILES is a list of filenames. + +\(fn FILES)" '(dired-mode) nil) + (autoload 'checkdoc-ispell "checkdoc" "\ Check the style and spelling of everything interactively. Calls `checkdoc' with spell-checking turned on. @@ -6755,7 +6759,7 @@ You can set this option through Custom, if you carefully read the last paragraph below. However, usually it is simpler to write something like the following in your init file: -\(setq custom-file \"~/.emacs-custom.el\") +\(setq custom-file \"~/.config/emacs-custom.el\") \(load custom-file) Note that both lines are necessary: the first line tells Custom to @@ -11135,6 +11139,9 @@ Macros in BODY are expanded when the test is defined, not when it is run. If a macro (possibly with side effects) is to be tested, it has to be wrapped in `(eval (quote ...))'. +If NAME is already defined as a test and Emacs is running +in batch mode, an error is signalled. + \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] BODY...)" nil t) (function-put 'ert-deftest 'doc-string-elt '3) @@ -11167,11 +11174,8 @@ the tests). Run the tests specified by SELECTOR and display the results in a buffer. SELECTOR works as described in `ert-select-tests'. -OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they -are used for automated self-tests and specify which buffer to use -and how to display message. -\(fn SELECTOR &optional OUTPUT-BUFFER-NAME MESSAGE-FN)" t nil) +\(fn SELECTOR)" t nil) (defalias 'ert #'ert-run-tests-interactively) @@ -13301,7 +13305,7 @@ retrieval with `flymake-diagnostic-data'. If LOCUS is a buffer BEG and END should be buffer positions inside it. If LOCUS designates a file, BEG and END should be a cons (LINE . COL) indicating a file position. In this second -case, END may be ommited in which case the region is computed +case, END may be omitted in which case the region is computed using `flymake-diag-region' if the diagnostic is appended to an actual buffer. @@ -30412,6 +30416,29 @@ only these files will be asked to be saved. \(fn ARG)" nil nil) +(autoload 'server-stop-automatically "server" "\ +Automatically stop server as specified by ARG. + +If ARG is the symbol `empty', stop the server when it has no +remaining clients, no remaining unsaved file-visiting buffers, +and no running processes with a `query-on-exit' flag. + +If ARG is the symbol `delete-frame', ask the user when the last +frame is deleted whether each unsaved file-visiting buffer must +be saved and each running process with a `query-on-exit' flag +can be stopped, and if so, stop the server itself. + +If ARG is the symbol `kill-terminal', ask the user when the +terminal is killed with \\[save-buffers-kill-terminal] whether each unsaved file-visiting +buffer must be saved and each running process with a `query-on-exit' +flag can be stopped, and if so, stop the server itself. + +Any other value of ARG will cause this function to signal an error. + +This function is meant to be called from the user init file. + +\(fn ARG)" nil nil) + (register-definition-prefixes "server" '("server-")) ;;;*** @@ -30748,7 +30775,7 @@ If FUNCTION is non-nil, place point on the entry for FUNCTION (if any). \(fn GROUP &optional FUNCTION)" t nil) -(register-definition-prefixes "shortdoc" '("alist" "buffer" "define-short-documentation-group" "file" "hash-table" "list" "number" "overlay" "process" "regexp" "sequence" "shortdoc-" "string" "text-properties" "vector")) +(register-definition-prefixes "shortdoc" '("alist" "buffer" "define-short-documentation-group" "file" "hash-table" "keymaps" "list" "number" "overlay" "process" "regexp" "sequence" "shortdoc-" "string" "text-properties" "vector")) ;;;*** @@ -35146,7 +35173,7 @@ Add archive file name handler to `file-name-handler-alist'." (when tramp-archive ;;;;;; 0)) ;;; Generated autoloads from net/tramp-compat.el -(register-definition-prefixes "tramp-compat" '("tramp-")) +(register-definition-prefixes "tramp-compat" '("tramp-compat-")) ;;;*** @@ -35232,7 +35259,7 @@ Add archive file name handler to `file-name-handler-alist'." (when tramp-archive ;;;### (autoloads nil "trampver" "net/trampver.el" (0 0 0 0)) ;;; Generated autoloads from net/trampver.el -(push (purecopy '(tramp 2 5 2 -1)) package--builtin-versions) +(push (purecopy '(tramp 2 6 0 -1)) package--builtin-versions) (register-definition-prefixes "trampver" '("tramp-")) @@ -35555,65 +35582,21 @@ You might need to set `uce-mail-reader' before using this. ;;;;;; (0 0 0 0)) ;;; Generated autoloads from international/ucs-normalize.el -(autoload 'ucs-normalize-NFD-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFD. - -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-NFD-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFD. - -\(fn STR)" nil nil) - -(autoload 'ucs-normalize-NFC-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFC. - -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-NFC-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFC. - -\(fn STR)" nil nil) +(autoload 'string-glyph-compose "ucs-normalize" "\ +Compose the string STR by according to the Unicode NFC. +This is the canonical composed form. For instance: -(autoload 'ucs-normalize-NFKD-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFKD. + (ucs-normalize-NFC-string \"Å\") => \"Å\" -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-NFKD-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFKD. - -\(fn STR)" nil nil) - -(autoload 'ucs-normalize-NFKC-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFKC. - -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-NFKC-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFKC. - -\(fn STR)" nil nil) - -(autoload 'ucs-normalize-HFS-NFD-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFD and Mac OS's HFS Plus. - -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-HFS-NFD-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFD and Mac OS's HFS Plus. - -\(fn STR)" nil nil) - -(autoload 'ucs-normalize-HFS-NFC-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFC and Mac OS's HFS Plus. +\(fn STRING)" nil nil) -\(fn FROM TO)" t nil) +(autoload 'string-glyph-decompose "ucs-normalize" "\ +Decompose the string STR according to the Unicode NFD. +This is the canonical decomposed form. For instance: -(autoload 'ucs-normalize-HFS-NFC-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFC and Mac OS's HFS Plus. + (ucs-normalize-NFD-string \"Å\") => \"Å\" -\(fn STR)" nil nil) +\(fn STRING)" nil nil) (register-definition-prefixes "ucs-normalize" '("ucs-normalize-" "utf-8-hfs")) @@ -39738,7 +39721,7 @@ Zone out, completely." t nil) ;;;;;; "international/uni-special-lowercase.el" "international/uni-special-titlecase.el" ;;;;;; "international/uni-special-uppercase.el" "international/uni-titlecase.el" ;;;;;; "international/uni-uppercase.el" "isearch.el" "jit-lock.el" -;;;;;; "jka-cmpr-hook.el" "language/burmese.el" "language/cham.el" +;;;;;; "jka-cmpr-hook.el" "keymap.el" "language/burmese.el" "language/cham.el" ;;;;;; "language/chinese.el" "language/cyrillic.el" "language/czech.el" ;;;;;; "language/english.el" "language/ethiopic.el" "language/european.el" ;;;;;; "language/georgian.el" "language/greek.el" "language/hebrew.el" commit 3f096eb3405b2fce7c35366eb2dcf025dda55783 Author: Lars Ingebrigtsen Date: Fri Nov 19 07:42:12 2021 +0100 Make UCS compose/decompose functions more understandable * lisp/international/ucs-normalize.el () (ucs-normalize-NFD-region, ucs-normalize-NFD-string) (ucs-normalize-NFC-region, ucs-normalize-NFC-string) (ucs-normalize-NFKD-region, ucs-normalize-NFKD-string) (ucs-normalize-NFKC-region, ucs-normalize-NFKC-string): Make the doc strings say what they actually do. diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 157209fcf7..ba08e68af5 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -159,8 +159,6 @@ There can be any number of :example/:result elements." :eval (split-string-and-unquote "foo \"bar zot\"")) (split-string-shell-command :eval (split-string-shell-command "ls /tmp/'foo bar'")) - (string-glyph-split - :eval (string-glyph-split "Hello, 👼🏻🧑🏼‍🤝‍🧑🏻")) (string-lines :eval (string-lines "foo\n\nbar") :eval (string-lines "foo\n\nbar" t)) @@ -198,6 +196,13 @@ There can be any number of :example/:result elements." :eval (substring-no-properties (propertize "foobar" 'face 'bold) 0 3)) (try-completion :eval (try-completion "foo" '("foobar" "foozot" "gazonk"))) + "Unicode Strings" + (string-glyph-split + :eval (string-glyph-split "Hello, 👼🏻🧑🏼‍🤝‍🧑🏻")) + (string-glyph-compose + :eval (string-glyph-compose "Å")) + (string-glyph-decompose + :eval (string-glyph-decompose "Å")) "Predicates for Strings" (string-equal :eval (string-equal "foo" "foo")) diff --git a/lisp/international/ucs-normalize.el b/lisp/international/ucs-normalize.el index 0f8dedfc09..c6a562e3f5 100644 --- a/lisp/international/ucs-normalize.el +++ b/lisp/international/ucs-normalize.el @@ -536,55 +536,88 @@ COMPOSITION-PREDICATE will be used to compose region." (,ucs-normalize-region (point-min) (point-max)) (buffer-string))) -;;;###autoload (defun ucs-normalize-NFD-region (from to) - "Normalize the current region by the Unicode NFD." + "Decompose the current region according to the Unicode NFD. +This is the canonical decomposed form." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfd-quick-check-regexp 'ucs-normalize-nfd-table nil)) -;;;###autoload + (defun ucs-normalize-NFD-string (str) - "Normalize the string STR by the Unicode NFD." + "Decompose the string STR according to the Unicode NFD. +This is the canonical decomposed form. For instance: + + (ucs-normalize-NFD-string \"Å\") => \"Å\"" (ucs-normalize-string ucs-normalize-NFD-region)) -;;;###autoload (defun ucs-normalize-NFC-region (from to) - "Normalize the current region by the Unicode NFC." + "Compose the current region according to the Unicode NFC. +This is the canonical composed form." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfc-quick-check-regexp 'ucs-normalize-nfd-table t)) + +;;;###autoload +(defun string-glyph-compose (string) + "Compose the string STR by according to the Unicode NFC. +This is the canonical composed form. For instance: + + (string-glyph-compose \"Å\") => \"Å\"" + (ucs-normalize-NFC-string string)) + ;;;###autoload +(defun string-glyph-decompose (string) + "Decompose the string STR according to the Unicode NFD. +This is the canonical decomposed form. For instance: + + (string-glyph-decompose \"Å\") => \"Å\"" + (ucs-normalize-NFD-string string)) + (defun ucs-normalize-NFC-string (str) - "Normalize the string STR by the Unicode NFC." + "Compose the string STR by according to the Unicode NFC. +This is the canonical composed form. For instance: + + (ucs-normalize-NFC-string \"Å\") => \"Å\"" (ucs-normalize-string ucs-normalize-NFC-region)) -;;;###autoload (defun ucs-normalize-NFKD-region (from to) - "Normalize the current region by the Unicode NFKD." + "Decompose the current region according to the Unicode NFKD. +This is the compatibility decomposed form." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfkd-quick-check-regexp 'ucs-normalize-nfkd-table nil)) -;;;###autoload + (defun ucs-normalize-NFKD-string (str) - "Normalize the string STR by the Unicode NFKD." + "Decompose the string STR according to the Unicode NFKD. +This is the compatibility decomposed form. This is much like the +NFD (canonical decomposed) form, but mainly differs in glyphs +with formatting distinctions. For instance: + + (ucs-normalize-NFD-string \"fi\") => \"fi\" + (ucs-normalize-NFKD-string \"fi\") = \"fi\"" (ucs-normalize-string ucs-normalize-NFKD-region)) -;;;###autoload (defun ucs-normalize-NFKC-region (from to) - "Normalize the current region by the Unicode NFKC." + "Compose the current region according to the Unicode NFKC. +The is the compatibility composed form." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfkc-quick-check-regexp 'ucs-normalize-nfkd-table t)) -;;;###autoload + (defun ucs-normalize-NFKC-string (str) - "Normalize the string STR by the Unicode NFKC." + "Compose the string STR according to the Unicode NFKC. +This is the compatibility composed form. This is much like the +NFC (canonical composed) form, but mainly differs in glyphs +with formatting distinctions. For instance: + + (ucs-normalize-NFC-string \"fi\") => \"fi\" + (ucs-normalize-NFKC-string \"fi\") = \"fi\"" (ucs-normalize-string ucs-normalize-NFKC-region)) -;;;###autoload (defun ucs-normalize-HFS-NFD-region (from to) "Normalize the current region by the Unicode NFD and Mac OS's HFS Plus." (interactive "r") @@ -592,18 +625,18 @@ COMPOSITION-PREDICATE will be used to compose region." ucs-normalize-hfs-nfd-quick-check-regexp 'ucs-normalize-hfs-nfd-table 'ucs-normalize-hfs-nfd-comp-p)) -;;;###autoload + (defun ucs-normalize-HFS-NFD-string (str) "Normalize the string STR by the Unicode NFD and Mac OS's HFS Plus." (ucs-normalize-string ucs-normalize-HFS-NFD-region)) -;;;###autoload + (defun ucs-normalize-HFS-NFC-region (from to) "Normalize the current region by the Unicode NFC and Mac OS's HFS Plus." (interactive "r") (ucs-normalize-region from to ucs-normalize-hfs-nfc-quick-check-regexp 'ucs-normalize-hfs-nfd-table t)) -;;;###autoload + (defun ucs-normalize-HFS-NFC-string (str) "Normalize the string STR by the Unicode NFC and Mac OS's HFS Plus." (ucs-normalize-string ucs-normalize-HFS-NFC-region)) commit c6d5fccc92fca76bf81dcfdca37ac9b0f96c1d81 Merge: 7138e69fdc 02853edba7 Author: Stefan Kangas Date: Fri Nov 19 07:00:24 2021 +0100 Merge from origin/emacs-28 02853edba7 Fix sorting of menus in `context-menu-local' (bug#50067). 14271d050a Fix flyspell-correct-word selected from context menu opene... bf824843f4 * lisp/repeat.el (describe-repeat-maps): Print all bound k... 6fc94fb99e * lisp/tab-bar.el: Use 'mouse-1' for history buttons like ... 5eeaf85767 Improve documentation of window hooks 7404f4b4e0 Improve doc string of 'highlight-nonselected-windows' commit 7138e69fdcf2d9f8cfe6bebf750f7f04b6ee6286 Author: Po Lu Date: Fri Nov 19 12:26:08 2021 +0800 Fix documentation on xwidgets * doc/lispref/display.texi (Xwidgets): Refer to correct function. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index dd2c6e003f..8decff6fa8 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -6807,7 +6807,7 @@ subprocesses with. The xwidget that is returned will be killed alongside its buffer (@pxref{Killing Buffers}). You can also kill it using -@code{xwidget-kill}. Once it is killed, the xwidget may continue to +@code{kill-xwidget}. Once it is killed, the xwidget may continue to exist as a Lisp object and act as a @code{display} property until all references to it are gone, but most actions that can be performed on live xwidgets will no longer be available. commit 64497fb8cc62c9c8302a20d54fc52e3113b0983e Author: Stefan Monnier Date: Thu Nov 18 22:06:50 2021 -0500 * lisp/files.el (file-has-changed-p): Index the cache with absolute file names diff --git a/lisp/files.el b/lisp/files.el index 49bf06bfc1..1979f1bbe3 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -6224,8 +6224,7 @@ of `file-has-changed-p' always returns non-nil when FILE exists. The optional argument TAG, which must be a symbol, can be used to limit the comparison to invocations with identical tags; it can be the symbol of the calling function, for example." - (let* (;; FIXME: Shall we use `file-truename'? - (file (directory-file-name file)) + (let* ((file (directory-file-name (expand-file-name file))) (remote-file-name-inhibit-cache t) (fileattr (file-attributes file 'integer)) (attr (and fileattr commit d7a2af593984820763f8597c2ed378d4da869aaa Author: Stefan Monnier Date: Thu Nov 18 22:02:43 2021 -0500 * lisp/net/mailcap.el (mailcap-parse-mailcaps): Fix $MAILCAPS case diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index 2c68755718..14d49251f5 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -55,7 +55,7 @@ you have an entry for \"image/*\" in your ~/.mailcap file." "A syntax table for parsing SGML attributes.") (defvar mailcap-print-command - (mapconcat 'identity + (mapconcat #'identity (cons (if (boundp 'lpr-command) lpr-command "lpr") @@ -116,8 +116,7 @@ is consulted." (regexp :tag "MIME Type") (sexp :tag "Test (optional)"))) :get #'mailcap--get-user-mime-data - :set #'mailcap--set-user-mime-data - :group 'mailcap) + :set #'mailcap--set-user-mime-data) ;; Postpone using defcustom for this as it's so big and we essentially ;; have to have two copies of the data around then. Perhaps just @@ -344,8 +343,7 @@ Same format as `mailcap-mime-data'.") "Directory to which `mailcap-save-binary-file' downloads files by default. nil means your home directory." :type '(choice (const :tag "Home directory" nil) - directory) - :group 'mailcap) + directory)) (defvar mailcap-poor-system-types '(ms-dos windows-nt) @@ -439,6 +437,8 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus ("/etc/mailcap" system) ("/usr/etc/mailcap" system) ("/usr/local/etc/mailcap" system))))) + (when (stringp path) + (setq path (mapcar #'list (split-string path path-separator t)))) (when (seq-some (lambda (f) (file-has-changed-p (car f) 'mail-parse-mailcaps)) path) @@ -451,14 +451,9 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus do (cl-loop for (minor . entry) in minors do (mailcap-add-mailcap-entry major minor entry))) ;; The ~/.mailcap entries will end up first in the resulting data. - (dolist (spec (reverse - (if (stringp path) - (split-string path path-separator t) - path))) - (let ((source (and (consp spec) (cadr spec))) - (file-name (if (stringp spec) - spec - (car spec)))) + (dolist (spec (reverse path)) + (let ((source (cadr spec)) + (file-name (car spec))) (when (and (file-readable-p file-name) (file-regular-p file-name)) (mailcap-parse-mailcap file-name source))))) @@ -639,7 +634,7 @@ the test clause will be unchanged." ((and (listp test) (symbolp (car test))) test) ((or (stringp test) (and (listp test) (stringp (car test)) - (setq test (mapconcat 'identity test " ")))) + (setq test (mapconcat #'identity test " ")))) (with-temp-buffer (insert test) (goto-char (point-min)) @@ -710,12 +705,12 @@ to supply to the test." (symbol-value test)) ((and (listp test) ; List to be eval'd (symbolp (car test))) - (eval test)) + (eval test t)) (t (setq test (mailcap-unescape-mime-test test type-info) test (list shell-file-name nil nil nil shell-command-switch test) - status (apply 'call-process test)) + status (apply #'call-process test)) (eq 0 status)))) (push (list otest result) mailcap-viewer-test-cache) result)))) @@ -840,7 +835,7 @@ If NO-DECODE is non-nil, don't decode STRING." (dolist (entry viewers) (when (mailcap-viewer-passes-test entry info) (push entry passed))) - (setq passed (sort (nreverse passed) 'mailcap-viewer-lessp)) + (setq passed (sort (nreverse passed) #'mailcap-viewer-lessp)) ;; When we want to prefer entries from the user's ;; ~/.mailcap file, then we filter out the system entries ;; and see whether we have anything left. @@ -1070,7 +1065,7 @@ For instance, \"foo.png\" will result in \"image/png\"." ;;;###autoload (defun mailcap-mime-type-to-extension (mime-type) - "Return a file name extension based on a mime type. + "Return a file name extension based on a MIME-TYPE. For instance, `image/png' will result in `png'." (intern (cadr (split-string (if (symbolp mime-type) (symbol-name mime-type) @@ -1082,7 +1077,7 @@ For instance, `image/png' will result in `png'." (mailcap-parse-mimetypes) (delete-dups (nconc - (mapcar 'cdr mailcap-mime-extensions) + (mapcar #'cdr mailcap-mime-extensions) (let (res type) (dolist (data mailcap--computed-mime-data) (dolist (info (cdr data)) commit 69f1bc43c026049ed2aab6a6368e2e9a5406b779 Author: Mattias Engdegård Date: Thu Nov 18 20:14:02 2021 +0100 Turn mistaken functions into tests (bug#51941) * test/lisp/calendar/icalendar-tests.el (icalendar-tests--decode-isodatetime): * test/src/eval-tests.el (eval-tests-19790-backquote-comma-dot-substitution): Change `defun` into `ert-deftest` where this seems to have been the original intention. diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index 9e8a8e7b47..10b684aacb 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -1633,7 +1633,7 @@ SUMMARY:NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30 (let ((time (icalendar--decode-isodatetime string day zone))) (format-time-string "%FT%T%z" (encode-time time) 0))) -(defun icalendar-tests--decode-isodatetime (_ical-string) +(ert-deftest icalendar-tests--decode-isodatetime () "Test `icalendar--decode-isodatetime'." (should (equal (icalendar-test--format "20040917T050910-0200") "2004-09-17T03:09:10+0000")) diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el index 3c3e703341..4f05d99136 100644 --- a/test/src/eval-tests.el +++ b/test/src/eval-tests.el @@ -179,7 +179,7 @@ are found on the stack and therefore not garbage collected." "Remove the Lisp reference to the byte-compiled object." (setf (symbol-function #'eval-tests-33014-func) nil)) -(defun eval-tests-19790-backquote-comma-dot-substitution () +(ert-deftest eval-tests-19790-backquote-comma-dot-substitution () "Regression test for Bug#19790. Don't handle destructive splicing in backquote expressions (like in Common Lisp). Instead, make sure substitution in backquote commit 09a5dd862832ffe82914baeab0ba7d4a0ab5fb62 Author: Mattias Engdegård Date: Thu Nov 18 15:05:47 2021 +0100 String backslash corrections * lisp/net/shr.el (shr-tag-video): Remove ineffective backslash. * test/lisp/emacs-lisp/package-tests.el (package-test-macro-compilation-gz): Make dot literal as intended. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index b9e8a18e25..5a36f19c5f 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1697,7 +1697,7 @@ The preference is a float determined from `shr-prefer-media-type'." (xwidget-webkit-execute-script widget (format "document.body.innerHTML = %S;" (format - "
" + "
" url))))) ;; No xwidgets. (if (> (length image) 0) diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 3b12f57e5c..efa9f83411 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -383,7 +383,7 @@ but with a different end of line convention (bug#48137)." (mapc #'delete-file (directory-files-recursively dir "\\`[^\\.].*\\.elc\\'")) (mapc (lambda (f) (call-process "gunzip" nil nil nil f)) - (directory-files-recursively dir "\\`[^\\.].*\\.el.gz\\'")))))) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\.gz\\'")))))) (ert-deftest package-test-install-two-dependencies () "Install a package which includes a dependency." commit 02853edba795b0d47201977d3b500e8a46ed5e0f Author: Juri Linkov Date: Thu Nov 18 20:36:55 2021 +0200 Fix sorting of menus in `context-menu-local' (bug#50067). * lisp/menu-bar.el (menu-bar-keymap): Don't use `lookup-key' on the `keymap' arg. * lisp/mouse.el (context-menu-global): Use `lookup-key global-map' for the `keymap' arg of `menu-bar-keymap'. (context-menu-local): Use `menu-bar-keymap' to sort `keymap'. diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index f19dc9e7c9..da79aae529 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -2715,7 +2715,7 @@ could provide `global-map' where items are limited to the global map only." ;; sorting. (push (cons pos menu-item) menu-end) (push menu-item menu-bar)))) - (lookup-key (or keymap (menu-bar-current-active-maps)) [menu-bar])) + (or keymap (lookup-key (menu-bar-current-active-maps) [menu-bar]))) `(keymap ,@(nreverse menu-bar) ,@(mapcar #'cdr (sort menu-end (lambda (a b) diff --git a/lisp/mouse.el b/lisp/mouse.el index b6448a13f3..0a4ab2878a 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -364,7 +364,7 @@ Some context functions add menu items below the separator." (when (consp binding) (define-key-after menu (vector key) (copy-sequence binding)))) - (menu-bar-keymap global-map)) + (menu-bar-keymap (lookup-key global-map [menu-bar]))) menu) (defun context-menu-local (menu _click) @@ -377,7 +377,7 @@ Some context functions add menu items below the separator." (when (consp binding) (define-key-after menu (vector key) (copy-sequence binding)))) - keymap))) + (menu-bar-keymap keymap)))) menu) (defun context-menu-minor (menu _click) commit 03fba4da8fc689dabc65e693631cd17d819b5135 Author: Michael Albinus Date: Thu Nov 18 19:35:13 2021 +0100 Do not exclude emacs-module-tests.el on emba * test/infra/gitlab-ci.yml (test-native-comp-speed0) (test-all-inotify): Do not exclude emacs-module-tests.el. * test/src/emacs-module-tests.el (module--test-assertions--load-non-live-object) (module--test-assertions--load-non-live-object-with-global-copy) (module--test-assertions--call-emacs-from-gc) (module--test-assertions--globref-invalid-free): Tag them as :unstable on emba. (Bug#50902) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 001c779572..096a293b30 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -302,9 +302,7 @@ test-native-comp-speed0: extends: [.job-template, .test-template, .native-comp-template] variables: target: emacs-native-comp-speed0 - make_params: >- - -C test check EXCLUDE_TESTS=%emacs-module-tests.el - SELECTOR='(not (tag :unstable))' + make_params: "-C test check SELECTOR='(not (tag :unstable))'" test-all-inotify: # This tests also file monitor libraries inotify and inotifywatch. @@ -317,7 +315,7 @@ test-all-inotify: - if: '$CI_PIPELINE_SOURCE == "schedule"' variables: target: emacs-inotify - make_params: check-expensive EXCLUDE_TESTS=%emacs-module-tests.el + make_params: check-expensive # Two hours. EMACS_TEST_TIMEOUT: 7200 diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index 442bca5fac..988b311f5b 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -247,6 +247,7 @@ must evaluate to a regular expression string." (ert-deftest module--test-assertions--load-non-live-object () "Check that -module-assertions verify that non-live objects aren't accessed." + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) @@ -265,6 +266,7 @@ must evaluate to a regular expression string." This differs from `module--test-assertions-load-non-live-object' in that it stows away a global reference. The module assertions should nevertheless detect the invalid load." + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) @@ -281,6 +283,7 @@ should nevertheless detect the invalid load." (ert-deftest module--test-assertions--call-emacs-from-gc () "Check that -module-assertions prevents calling Emacs functions during garbage collection." + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) @@ -292,7 +295,8 @@ during garbage collection." (ert-deftest module--test-assertions--globref-invalid-free () "Check that -module-assertions detects invalid freeing of a local reference." - (skip-unless (or (file-executable-p mod-test-emacs) + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) + (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) (module--test-assertion commit 14271d050a30b8121358361ba671ba29493e03dd Author: Juri Linkov Date: Thu Nov 18 20:23:58 2021 +0200 Fix flyspell-correct-word selected from context menu opened with the keyboard * lisp/mouse.el (context-menu-open): Call interactively a command returned by `context-menu-map' such as `flyspell-correct-word' (bug#50067). * lisp/textmodes/flyspell.el (flyspell-correct-word): Handle the case when it's called by a key bound to `context-menu-open'. Then it should work the same way as `C-c $' typed on misspelled word where the arg `event' of `flyspell-correct-word-before-point' is nil. diff --git a/lisp/mouse.el b/lisp/mouse.el index 091383bf11..b6448a13f3 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -541,8 +541,11 @@ activates the menu whose contents depends on its surrounding context." "Start key navigation of the context menu. This is the keyboard interface to \\[context-menu-map]." (interactive) - (let ((inhibit-mouse-event-check t)) - (popup-menu (context-menu-map) (point)))) + (let ((inhibit-mouse-event-check t) + (map (context-menu-map))) + (if (commandp map) + (call-interactively map) + (popup-menu map (point))))) (global-set-key [S-f10] 'context-menu-open) diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 1d450b5001..258e5fde67 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -2160,7 +2160,7 @@ The word checked is the word at the mouse position." (interactive "e") (let ((save (point))) (mouse-set-point event) - (flyspell-correct-word-before-point event save))) + (flyspell-correct-word-before-point (and (consp event) event) save))) (defun flyspell-correct-word-before-point (&optional event opoint) "Pop up a menu of possible corrections for misspelled word before point. commit bf824843f40a8235e2cdfc6d84d67ea2e2e96acb Author: Robert Pluim Date: Thu Nov 18 19:42:44 2021 +0200 * lisp/repeat.el (describe-repeat-maps): Print all bound keys (bug#49265). diff --git a/lisp/repeat.el b/lisp/repeat.el index 45201ad1aa..4dcd353e34 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -533,10 +533,12 @@ Used in `repeat-mode'." (dolist (command (sort (cdr keymap) 'string-lessp)) (let* ((info (help-fns--analyze-function command)) (map (list (symbol-value (car keymap)))) - (desc (key-description - (or (where-is-internal command map t) - (where-is-internal (nth 3 info) map t))))) - (princ (format-message " `%s' (bound to '%s')\n" command desc)))) + (desc (mapconcat (lambda (key) + (format-message "`%s'" (key-description key))) + (or (where-is-internal command map) + (where-is-internal (nth 3 info) map)) + ", "))) + (princ (format-message " `%s' (bound to %s)\n" command desc)))) (princ "\n")))))) (provide 'repeat) commit 6fc94fb99e38960a24ee3a3dc441f85f786a654e Author: Juri Linkov Date: Thu Nov 18 19:36:42 2021 +0200 * lisp/tab-bar.el: Use 'mouse-1' for history buttons like for 'add-tab' button * lisp/tab-bar.el (tab-bar-mouse-down-1, tab-bar-mouse-1): Handle clicks for 'history-back' and 'history-forward' the same way as 'add-tab' clicks. diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 871ed1c981..ca1087e827 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -284,7 +284,8 @@ existing tab." (setq tab-bar--dragging-in-progress t) ;; Don't close the tab when clicked on the close button. Also ;; don't add new tab on down-mouse. Let `tab-bar-mouse-1' do this. - (unless (or (eq (car item) 'add-tab) (nth 2 item)) + (unless (or (memq (car item) '(add-tab history-back history-forward)) + (nth 2 item)) (if (functionp (nth 1 item)) (call-interactively (nth 1 item)) (unless (eq tab-number t) @@ -298,7 +299,8 @@ regardless of where you click on it. Also add a new tab." (let* ((item (tab-bar--event-to-item (event-start event))) (tab-number (tab-bar--key-to-number (nth 0 item)))) (cond - ((and (eq (car item) 'add-tab) (functionp (nth 1 item))) + ((and (memq (car item) '(add-tab history-back history-forward)) + (functionp (nth 1 item))) (call-interactively (nth 1 item))) ((and (nth 2 item) (not (eq tab-number t))) (tab-bar-close-tab tab-number))))) commit a4e789c2e32dd16898529ece30bd2a90cef40c10 Author: Juri Linkov Date: Thu Nov 18 19:27:46 2021 +0200 * lisp/tab-bar.el: Optimize data usage for nil tab-bar-history-mode. * lisp/tab-bar.el (tab-bar--tab): Add wc-history-back and wc-history-forward only when tab-bar-history-mode is non-nil. (tab-bar-select-tab): Use wc-history-back and wc-history-forward only when tab-bar-history-mode is non-nil. (tab-bar-new-tab-to): Reset tab-bar-history-back and tab-bar-history-forward to nil. diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 9e554f718f..c2bf3021b0 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -980,10 +980,11 @@ on the tab bar instead." (wc-point . ,(point-marker)) (wc-bl . ,bl) (wc-bbl . ,bbl) - (wc-history-back . ,(gethash (or frame (selected-frame)) - tab-bar-history-back)) - (wc-history-forward . ,(gethash (or frame (selected-frame)) - tab-bar-history-forward)) + ,@(when tab-bar-history-mode + `((wc-history-back . ,(gethash (or frame (selected-frame)) + tab-bar-history-back)) + (wc-history-forward . ,(gethash (or frame (selected-frame)) + tab-bar-history-forward)))) ;; Copy other possible parameters ,@(mapcan (lambda (param) (unless (memq (car param) @@ -1124,19 +1125,21 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar." (when wc-bl (set-frame-parameter nil 'buffer-list wc-bl)) (when wc-bbl (set-frame-parameter nil 'buried-buffer-list wc-bbl)) - (puthash (selected-frame) - (and (window-configuration-p (alist-get 'wc (car wc-history-back))) - wc-history-back) - tab-bar-history-back) - (puthash (selected-frame) - (and (window-configuration-p (alist-get 'wc (car wc-history-forward))) - wc-history-forward) - tab-bar-history-forward))) + (when tab-bar-history-mode + (puthash (selected-frame) + (and (window-configuration-p (alist-get 'wc (car wc-history-back))) + wc-history-back) + tab-bar-history-back) + (puthash (selected-frame) + (and (window-configuration-p (alist-get 'wc (car wc-history-forward))) + wc-history-forward) + tab-bar-history-forward)))) (ws (window-state-put ws nil 'safe))) - (setq tab-bar-history-omit t) + (when tab-bar-history-mode + (setq tab-bar-history-omit t)) (when from-index (setf (nth from-index tabs) from-tab)) @@ -1386,6 +1389,11 @@ After the tab is created, the hooks in ;; `pushnew' handles the head of tabs but not frame-parameter (tab-bar-tabs-set tabs)) + (when tab-bar-history-mode + (puthash (selected-frame) nil tab-bar-history-back) + (puthash (selected-frame) nil tab-bar-history-forward) + (setq tab-bar-history-omit t)) + (run-hook-with-args 'tab-bar-tab-post-open-functions (nth to-index tabs))) commit 5c8c3d59ead75df199f31b892f17f8a0a101a62c Author: Juri Linkov Date: Thu Nov 18 19:24:35 2021 +0200 * lisp/tab-bar.el: Avoid micro-steps in tab-bar-history-back/forward. * lisp/tab-bar.el (tab-bar-history-pre-command) (tab-bar-history-done-command): New variables. (tab-bar--history-pre-change): Set 'tab-bar-history-omit' and 'tab-bar-history-pre-command'. (tab-bar--history-change): Use 'tab-bar-history-done-command' and 'tab-bar-history-pre-command' (bug#51370). diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 871ed1c981..9e554f718f 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -1802,10 +1802,19 @@ Interactively, prompt for GROUP-NAME." (defvar tab-bar-history-old nil "Window configuration before the current command.") +(defvar tab-bar-history-pre-command nil + "Command set to `this-command' by `pre-command-hook'.") + +(defvar tab-bar-history-done-command nil + "Command handled by `window-configuration-change-hook'.") + (defvar tab-bar-history-old-minibuffer-depth 0 "Minibuffer depth before the current command.") (defun tab-bar--history-pre-change () + ;; Reset before the command could set it + (setq tab-bar-history-omit nil) + (setq tab-bar-history-pre-command this-command) (setq tab-bar-history-old-minibuffer-depth (minibuffer-depth)) ;; Store window-configuration before possibly entering the minibuffer. (when (zerop tab-bar-history-old-minibuffer-depth) @@ -1814,8 +1823,10 @@ Interactively, prompt for GROUP-NAME." (wc-point . ,(point-marker)))))) (defun tab-bar--history-change () - (when (and (not tab-bar-history-omit) - tab-bar-history-old + (when (and (not tab-bar-history-omit) tab-bar-history-old + ;; Don't register changes performed by the same command + ;; repeated in sequence, such as incremental window resizing. + (not (eq tab-bar-history-done-command tab-bar-history-pre-command)) ;; Store window-configuration before possibly entering ;; the minibuffer. (zerop tab-bar-history-old-minibuffer-depth)) @@ -1824,8 +1835,8 @@ Interactively, prompt for GROUP-NAME." (gethash (selected-frame) tab-bar-history-back)) tab-bar-history-limit) tab-bar-history-back)) - (when tab-bar-history-omit - (setq tab-bar-history-omit nil))) + (setq tab-bar-history-old nil) + (setq tab-bar-history-done-command tab-bar-history-pre-command)) (defun tab-bar-history-back () "Restore a previous window configuration used in the current tab. commit 4da785ec9826edd0d7effb46309a8593133896f2 Author: Eli Zaretskii Date: Thu Nov 18 19:17:52 2021 +0200 ; Minor fixes of doc strings in xdisp.c * src/xdisp.c (syms_of_xdisp) : Doc fix. diff --git a/src/xdisp.c b/src/xdisp.c index d7ad548917..ef49297e0f 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -35934,11 +35934,13 @@ message displayed by its counterpart function specified by Vclear_message_function = Qnil; DEFVAR_LISP ("redisplay--all-windows-cause", Vredisplay__all_windows_cause, - doc: /* */); + doc: /* Code of the cause for redisplaying all windows. +Internal use only. */); Vredisplay__all_windows_cause = Fmake_hash_table (0, NULL); DEFVAR_LISP ("redisplay--mode-lines-cause", Vredisplay__mode_lines_cause, - doc: /* */); + doc: /* Code of the cause for redisplaying mode lines. +Internal use only. */); Vredisplay__mode_lines_cause = Fmake_hash_table (0, NULL); DEFVAR_BOOL ("redisplay--inhibit-bidi", redisplay__inhibit_bidi, @@ -35964,10 +35966,11 @@ mouse stays within the extent of a single glyph (except for images). */); tab_bar__dragging_in_progress = false; DEFVAR_BOOL ("redisplay-skip-initial-frame", redisplay_skip_initial_frame, - doc: /* Non-nil to skip redisplay in initial frame. -The initial frame is not displayed anywhere, so skipping it is -best except in special circumstances such as running redisplay tests -in batch mode. */); + doc: /* Non-nil means skip redisplay of the initial frame. +The initial frame is the text-mode frame used by Emacs internally during +the early stages of startup. That frame is not displayed anywhere, so +skipping it is best except in special circumstances such as running +redisplay tests in batch mode. */); redisplay_skip_initial_frame = true; DEFVAR_BOOL ("redisplay-skip-fontification-on-input", commit 71f237d668044d613546cb3cbf82a8c66c2cf4db Author: Juri Linkov Date: Thu Nov 18 19:13:48 2021 +0200 * lisp/vc/diff-mode.el (diff-minor-mode-prefix): Fix typo from 44faf54659 diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 1cffd88a56..8f83aa580e 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -264,7 +264,7 @@ and hunk-based syntax highlighting otherwise as a fallback." :help "Go to the next count'th file"] )) -(defcustom diff-minor-mode-prefix "\C-c ==" +(defcustom diff-minor-mode-prefix "\C-c=" "Prefix key for `diff-minor-mode' commands." :type '(choice (string "ESC") (string "\C-c=") string)) commit ce33ad8bae71b29d2561904e0c3ed68ff410c427 Author: Protesilaos Stavrou Date: Thu Nov 18 13:24:30 2021 +0200 Update modus-themes to version 1.7.0 * doc/misc/modus-themes.org (File): Use new version and add release date. (How do the themes look like, Learn about the latest changes): Update link to new URL. (Enable and load): Update text of internal reference. (Sample configuration for use-package): Add sample configuration without the 'use-package' infrastructure. (Differences between loading and enabling): Minor rewordings. (Customization Options): Update sample code to cover latest changes. (Option for inhibiting theme reload) (Option for color-coding success state (deuteranopia)) (Option for more bold constructs) (Option for more italic constructs) (Option for syntax highlighting) (Option for links) (Option for command prompt styles) (Option for mode line presentation) (Option for accented background in tab interfaces) (Option for completion framework aesthetics) (Option for mail citations) (Option for fringe visibility) (Option for language checkers) (Option for line highlighting (hl-line-mode)) (Option for line numbers (display-line-numbers-mode)) (Option for parenthesis matching (show-paren-mode)) (Option for active region) (Option for diff buffer looks) (Option for org-mode block styles) (Option for Org agenda constructs) (Option for scaled headings) (Control the scale of headings) (Option for variable-pitch font in UI elements) (Option for variable-pitch font in headings): Write brief description, document the type of the user option, and make any other relevant adjustments. (Option for font mixing): Document new 'modus-themes-mixed-fonts' user option, which supersedes the old 'modus-themes-no-mixed-fonts'. (Option for mode line padding): Document new user option 'modus-themes-mode-line-padding'. (Option for language checkers): Include new available property for the user option 'modus-themes-lang-checkers'. Reword the rest of the entry. (Option for intense markup in Org and others): Describe new boolean option 'modus-themes-intense-markup'. (Option for Org agenda constructs): Include new available property for the 'event' key in the alist 'modus-themes-org-agenda'. (Option for the headings' overall style): Describe the new style of explicitly specifying an optional font weight other than the implied bold. (Font configurations for Org and others (DIY)) (Configure bold and italic faces (DIY)): Reword and clarify some statements. (Decrease mode line height (DIY)): Add new Do-It-Yourself section on tweaking the mode line's :box attribute. (Full support for packages or face groups): Include new packages. (Acknowledgements): Update list of contributors to code, user feedback, etc. Does not affect the status of copyright assignment. (Meta): Update URLs to protesilaos.com (my website). * etc/themes/modus-themes.el (modus-themes-variable-pitch) (modus-themes-fixed-pitch, modus-themes-no-mixed-fonts): Reference the new 'modus-themes-mixed-fonts' user option. (modus-themes--headings-choice): Include new font weight styles. (modus-themes-headings): Document the new feature of accepting an explicit font weight. (modus-themes-org-agenda): Document the refinements to the 'event' key of the alist and the new 'varied' property it accepts. (modus-themes-lang-checkers): Describe the new 'faint' property. (modus-themes-mode-line-padding): Include new user option. (modus-themes-intense-hl-line): Remove old-deprecated user option. (modus-themes-intense-markup): Add new option. (modus-themes-success-deuteranopia): Update doc string. (modus-themes--fixed-pitch): Work with 'modus-themes-mixed-fonts'. (modus-themes--lang-check): Update internal function to add the 'faint' property of 'modus-themes-lang-checkers'. (modus-themes--markup): Add helper function. (modus-themes--heading-weights): Private variable with available font weights. (modus-themes--heading-weight): New helper function to pick the desired font weight. (modus-themes--heading): Update helper function to implement the aforementioned change to 'modus-themes-headings'. (modus-themes--agenda-event): Update helper function to apply the new styles of 'modus-themes-org-agenda'. (modus-themes--mode-line-padding): Add helper function for 'modus-themes-mode-line-padding'. (modus-themes--mode-line-attrs): Minor refinements. (modus-themes-load-operandi, modus-themes-load-vivendi): Make these functions interactive. (modus-themes-faces): Update faces. * etc/themes/modus-operandi-theme.el: Bump version number. * etc/themes/modus-vivendi-theme.el: Same. * * * A detailed change log entry is available here: . diff --git a/doc/misc/modus-themes.org b/doc/misc/modus-themes.org index 675144d517..f3c2e37b7d 100644 --- a/doc/misc/modus-themes.org +++ b/doc/misc/modus-themes.org @@ -5,9 +5,9 @@ #+options: ':t toc:nil author:t email:t num:t #+startup: content -#+macro: stable-version 1.6.0 -#+macro: release-date 2021-09-29 -#+macro: development-version 1.7.0-dev +#+macro: stable-version 1.7.0 +#+macro: release-date 2021-11-18 +#+macro: development-version 1.8.0-dev #+macro: file @@texinfo:@file{@@$1@@texinfo:}@@ #+macro: space @@texinfo:@: @@ #+macro: kbd @@texinfo:@kbd{@@$1@@texinfo:}@@ @@ -95,7 +95,7 @@ Emacs. :end: #+cindex: Screenshots -Check the web page with [[https://protesilaos.com/modus-themes-pictures/][the screen shots]]. There are lots of scenarios +Check the web page with [[https://protesilaos.com/emacs/modus-themes-pictures/][the screen shots]]. There are lots of scenarios on display that draw attention to details and important aspects in the design of the themes. They also showcase the numerous customization options. @@ -108,7 +108,7 @@ options. :end: #+cindex: Changelog -Please refer to the [[https://protesilaos.com/modus-themes-changelog][web page with the change log]]. It is comprehensive +Please refer to the [[https://protesilaos.com/emacs/modus-themes-changelog][web page with the change log]]. It is comprehensive and covers everything that goes into every tagged release of the themes. * Installation @@ -268,7 +268,7 @@ could look like: (define-key global-map (kbd "") #'modus-themes-toggle) #+end_src -[[#h:e979734c-a9e1-4373-9365-0f2cd36107b8][Sample configuration for use-package]]. +[[#h:e979734c-a9e1-4373-9365-0f2cd36107b8][Sample configuration with and without use-package]]. With those granted, bear in mind a couple of technical points on ~modus-themes-load-operandi~ and ~modus-themes-load-vivendi~, as well as @@ -283,11 +283,12 @@ With those granted, bear in mind a couple of technical points on wish to rely on such a hook and the functions that run it: they may prefer a custom solution ([[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]]). -** Sample configuration for use-package +** Sample configuration with and without use-package :properties: :custom_id: h:e979734c-a9e1-4373-9365-0f2cd36107b8 :end: #+cindex: use-package configuration +#+cindex: sample configuration It is common for Emacs users to rely on ~use-package~ for declaring package configurations in their setup. We use this as an example: @@ -309,6 +310,25 @@ package configurations in their setup. We use this as an example: :bind ("" . modus-themes-toggle)) #+end_src +The same without ~use-package~: + +#+begin_src emacs-lisp +(require 'modus-themes) + +;; Add all your customizations prior to loading the themes +(setq modus-themes-italic-constructs t + modus-themes-bold-constructs nil + modus-themes-region '(bg-only no-extend)) + +;; Load the theme files before enabling a theme +(modus-themes-load-themes) + +;; Load the theme of your choice: +(modus-themes-load-operandi) ;; OR (modus-themes-load-vivendi) + +(define-key global-map (kbd "") #'modus-themes-toggle) +#+end_src + [[#h:e68560b3-7fb0-42bc-a151-e015948f8a35][Differences between loading and enabling]]. Note: make sure not to customize the variable ~custom-theme-load-path~ @@ -325,7 +345,7 @@ package declaration of the themes. The reason we recommend ~load-theme~ instead of the other option of ~enable-theme~ is that the former does a kind of "reset" on the face -specs. It quite literally loads (or re-loads) the theme. Whereas the +specs. It quite literally loads (or reloads) the theme. Whereas the latter simply puts an already loaded theme at the top of the list of enabled items, re-using whatever state was last loaded. @@ -352,7 +372,7 @@ session, are better off using something like this: (enable-theme 'modus-operandi) ;; OR (enable-theme 'modus-vivendi) #+end_src -[[#h:e979734c-a9e1-4373-9365-0f2cd36107b8][Sample configuration for use-package]]. +[[#h:e979734c-a9e1-4373-9365-0f2cd36107b8][Sample configuration with and without use-package]]. With the above granted, other sections of the manual discuss how to configure custom faces, where ~load-theme~ is expected, though @@ -372,7 +392,8 @@ without any further tweaks. By default, all customization options are set to nil, unless otherwise noted in this manual. Remember that all customization options must be evaluated before loading -a theme ([[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]). +a theme ([[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]). If the theme is already active, it must be +reloaded for changes in user options to come into force. Below is a summary of what you will learn in the subsequent sections of this manual. @@ -380,8 +401,9 @@ this manual. #+begin_src emacs-lisp (setq modus-themes-italic-constructs t modus-themes-bold-constructs nil - modus-themes-no-mixed-fonts nil + modus-themes-mixed-fonts nil modus-themes-subtle-line-numbers nil + modus-themes-intense-markup t modus-themes-success-deuteranopia t modus-themes-tabs-accented t modus-themes-inhibit-reload t ; only applies to `customize-set-variable' and related @@ -391,7 +413,7 @@ this manual. ;; Options for `modus-themes-lang-checkers' are either nil (the ;; default), or a list of properties that may include any of those ;; symbols: `straight-underline', `text-also', `background', - ;; `intense' + ;; `intense' OR `faint'. modus-themes-lang-checkers nil ;; Options for `modus-themes-mode-line' are either nil, or a list @@ -399,6 +421,10 @@ this manual. ;; `accented', `padded'. modus-themes-mode-line '(padded accented borderless) + ;; This one only works when `modus-themes-mode-line' (above) has + ;; the `padded' property. It takes a positive integer. + modus-themes-mode-line-padding 3 + ;; Options for `modus-themes-syntax' are either nil (the default), ;; or a list of properties that may include any of those symbols: ;; `faint', `yellow-comments', `green-strings', `alt-syntax' @@ -450,7 +476,7 @@ this manual. modus-themes-headings ; this is an alist: read the manual or its doc string '((1 . (overline background)) (2 . (rainbow overline)) - (t . (no-bold))) + (t . (semibold))) modus-themes-variable-pitch-ui nil modus-themes-variable-pitch-headings t @@ -470,7 +496,10 @@ this manual. :end: #+vindex: modus-themes-inhibit-reload -Symbol: ~modus-themes-inhibit-reload~ +Brief: Toggle reloading of the active theme when an option is changed +through the Customize UI. + +Symbol: ~modus-themes-inhibit-reload~ (=boolean= type) Possible values: @@ -483,6 +512,9 @@ currently active Modus theme. Enable this behaviour by setting this variable to ~nil~. +Regardless of this option, the active theme must be reloaded for changes +to user options to take effect ([[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]). + ** Option for color-coding success state (deuteranopia) :properties: :alt_title: Success' color-code @@ -491,25 +523,27 @@ Enable this behaviour by setting this variable to ~nil~. :end: #+vindex: modus-themes-success-deuteranopia -Symbol: ~modus-themes-success-deuteranopia~ +Brief: Toggle the use of blue instead of green in places which +color-code green as "success" and red as "failure". + +Symbol: ~modus-themes-success-deuteranopia~ (=boolean= type) Possible values: 1. ~nil~ (default) 2. ~t~ -The default is to colorise all faces that denote "success", "done", or -similar with a variant of green. +The default is to colorise a passing state in a green hue. This affects +all faces that denote "success", "done", marking a selection as opposed +to marking for deletion, the current search match in contrast to lazily +highlighted ones, and the like. With a non-nil value (~t~), use variants of blue instead of green. This is meant to empower users with red-green color deficiency. -The present customization option should apply to all contexts where -there can be a color-coded distinction between success and failure, -to-do and done, and so on. - -Diffs, which have a red/green dichotomy by default, can also be -configured to conform with deuteranopia. +Diffs, which rely on a red/green dichotomy by default, can also be +configured to meet the needs of users with deuteranopia via the option +~modus-themes-diffs~. [[#h:ea7ac54f-5827-49bd-b09f-62424b3b6427][Option for diff buffer looks]]. @@ -521,7 +555,9 @@ configured to conform with deuteranopia. :end: #+vindex: modus-themes-bold-constructs -Symbol: ~modus-themes-bold-constructs~ +Brief: Use bold for code syntax highlighting and related. + +Symbol: ~modus-themes-bold-constructs~ (=boolean= type) Possible values: @@ -549,7 +585,9 @@ Advanced users may also want to configure the exact attributes of the :end: #+vindex: modus-themes-italic-constructs -Symbol: ~modus-themes-italic-constructs~ +Brief: Use italics for code syntax highlighting and related. + +Symbol: ~modus-themes-italic-constructs~ (=boolean= type) Possible values: @@ -575,7 +613,9 @@ Advanced users may also want to configure the exact attributes of the :end: #+vindex: modus-themes-syntax -Symbol: ~modus-themes-syntax~ +Brief: Set the overall style of code syntax highlighting. + +Symbol: ~modus-themes-syntax~ (=choice= type, list of properties) Possible values are expressed as a list of properties (default is ~nil~ or an empty list). The list can include any of the following symbols: @@ -629,36 +669,41 @@ weight or italic text: ~modus-themes-bold-constructs~ and [[#h:977c900d-0d6d-4dbb-82d9-c2aae69543d6][Option for more italic constructs]]. -** Option for no font mixing +** Option for font mixing :properties: -:alt_title: No mixed fonts +:alt_title: Mixed fonts :description: Toggle mixing of font families :custom_id: h:115e6c23-ee35-4a16-8cef-e2fcbb08e28b :end: -#+vindex: modus-themes-no-mixed-fonts +#+vindex: modus-themes-mixed-fonts -Symbol: ~modus-themes-no-mixed-fonts~ +Brief: Toggle the use of monospaced fonts for spacing-sensitive +constructs (affects font families). + +Symbol: ~modus-themes-mixed-fonts~ (=boolean= type) Possible values: 1. ~nil~ (default) 2. ~t~ -By default, the themes configure some spacing-sensitive faces like Org +When set to non-nil (~t~), configure some spacing-sensitive faces like Org tables and code blocks to always inherit from the ~fixed-pitch~ face. -This is to ensure that those constructs remain monospaced even when -users opt for a mode that remaps typeface families, such as the built-in -{{{kbd(M-x variable-pitch-mode)}}}. Otherwise the layout would appear -broken, due to how spacing is done. To disable this behaviour, set the -option to ~t~. +This is to ensure that certain constructs like code blocks and tables +remain monospaced even when users opt for a mode that remaps typeface +families, such as the built-in {{{kbd(M-x variable-pitch-mode)}}}. Otherwise +the layout would appear broken, due to how spacing is done. -Users may prefer to use another package for handling mixed typeface -configurations, rather than letting the theme do it, perhaps because a -purpose-specific package has extra functionality. Two possible options -are ~org-variable-pitch~ and ~mixed-pitch~. +For a consistent experience, user may need to specify the font family of +the ~fixed-pitch~ face. [[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and others]]. +Furthermore, users may prefer to use another package for handling mixed +typeface configurations, rather than letting the theme do it, perhaps +because a purpose-specific package has extra functionality. Two +possible options are ~org-variable-pitch~ and ~mixed-pitch~. + ** Option for links :properties: :alt_title: Link styles @@ -667,7 +712,9 @@ are ~org-variable-pitch~ and ~mixed-pitch~. :end: #+vindex: modus-themes-links -Symbol: ~modus-themes-links~ +Brief: Control the style of links to web pages, files, buffers... + +Symbol: ~modus-themes-links~ (=choice= type, list of properties) Possible values are expressed as a list of properties (default is ~nil~ or an empty list). The list can include any of the following symbols: @@ -738,7 +785,10 @@ their documentation strings. :end: #+vindex: modus-themes-prompts -Symbol: ~modus-themes-prompts~ +Brief: Control the style of command prompts (e.g. minibuffer, shell, IRC +clients). + +Symbol: ~modus-themes-prompts~ (=choice= type, list of properties) Possible values are expressed as a list of properties (default is ~nil~ or an empty list). The list can include any of the following symbols: @@ -794,7 +844,9 @@ In user configuration files the form may look like this: :end: #+vindex: modus-themes-mode-line -Symbol: ~modus-themes-mode-line~ +Brief: Control the style of the mode lines. + +Symbol: ~modus-themes-mode-line~ (=choice= type, list of properties) Possible values, which can be expressed as a list of combinations of box effect, color, and border visibility: @@ -836,7 +888,10 @@ This is done by applying box effects and combining them with an underline and overline. To ensure that the underline is placed at the bottom, set ~x-underline-at-descent-line~ to non-nil. The ~padded~ property has no effect when the ~moody~ property is also used, because Moody -already applies its own padding. +already applies its own padding. The exact value of the padding is +controlled by the variable ~modus-themes-mode-line-padding~. + +[[#h:a12b4d3c-e66b-42ed-99ab-4ea039b69e2e][Option for mode line padding]]. Combinations of any of those properties are expressed as a list, like in these examples: @@ -877,6 +932,28 @@ Furthermore, because Moody expects an underline and overline instead of a box style, it is advised to set ~x-underline-at-descent-line~ to a non-nil value. +Finally, note that various packages which heavily modify the mode line, +such as =doom-modeline=, =nano-modeline=, =powerline=, =spaceline= may not look +as intended with all possible combinations of this user option. + +*** Option for mode line padding +:properties: +:custom_id: h:a12b4d3c-e66b-42ed-99ab-4ea039b69e2e +:end: +#+vindex: modus-themes-mode-line-padding + +Brief: Set the padding of the mode lines. + +Symbol: ~modus-themes-mode-line-padding~ (=natnum= type) + +Controls the exact width of the mode line's padding. Possible values +are positive integers. The default value is =6=. + +This customization option applies only when ~modus-themes-mode-line~ is +configured with the ~padded~ property. + +[[#h:27943af6-d950-42d0-bc23-106e43f50a24][Option for mode line presentation]]. + ** Option for accented background in tab interfaces :properties: :alt_title: Tab style @@ -885,7 +962,9 @@ non-nil value. :end: #+vindex: modus-themes-tabs-accented -Symbol: ~modus-themes-tabs-accented~ +Brief: Toggle accent colors for tabbed interfaces. + +Symbol: ~modus-themes-tabs-accented~ (=boolean= type) Possible values: @@ -906,7 +985,9 @@ Centaur tabs package. :end: #+vindex: modus-themes-completions -Symbol: ~modus-themes-completions~ +Brief: Set the overall style of completion framework interfaces. + +Symbol: ~modus-themes-completions~ (=choice= type) Possible values: @@ -951,7 +1032,10 @@ possibilities. :end: #+vindex: modus-themes-mail-citations -Symbol: ~modus-themes-mail-citations~ +Brief: Set the overall style of citations/quotes when composing +emails. + +Symbol: ~modus-themes-mail-citations~ (=choice= type) Possible values: @@ -980,7 +1064,9 @@ not touch. :end: #+vindex: modus-themes-fringes -Symbol: ~modus-themes-fringes~ +Brief: Control the overall coloration of the fringes. + +Symbol: ~modus-themes-fringes~ (=choice= type) Possible values: @@ -1004,7 +1090,10 @@ names imply. :end: #+vindex: modus-themes-lang-checkers -Symbol: ~modus-themes-lang-checkers~ +Brief: Control the style of in-buffer warnings and errors produced by +spell checkers, code linters, and the like. + +Symbol: ~modus-themes-lang-checkers~ (=choice= type, list of properties) Possible values are expressed as a list of properties (default is ~nil~ or an empty list). The list can include any of the following symbols: @@ -1012,7 +1101,9 @@ an empty list). The list can include any of the following symbols: + ~straight-underline~ + ~text-also~ + ~background~ -+ ~intense~ ++ Overall coloration: + - ~intense~ + - ~faint~ The default (a ~nil~ value or an empty list) applies a color-coded underline to the affected text, while it leaves the original foreground @@ -1028,15 +1119,15 @@ affected text. The property ~background~ adds a color-coded background. The property ~intense~ amplifies the applicable colors if ~background~ -and/or ~text-only~ are set. If ~intense~ is set on its own, then it implies -~text-only~. +and/or ~text-also~ are set. If ~intense~ is set on its own, then it implies +~text-also~. -To disable fringe indicators for Flymake or Flycheck, refer to variables -~flymake-fringe-indicator-position~ and ~flycheck-indication-mode~, -respectively. +The property ~faint~ uses nuanced colors for the underline and for the +foreground when ~text-also~ is included. If both ~faint~ and ~intense~ are +specified, the former takes precedence. -Combinations of any of those properties can be expressed in a -list, as in those examples: +Combinations of any of those properties can be expressed in a list, as +in those examples: #+begin_src emacs-lisp (background) @@ -1056,6 +1147,10 @@ NOTE: The placement of the straight underline, though not the wave style, is controlled by the built-in variables ~underline-minimum-offset~, ~x-underline-at-descent-line~, ~x-use-underline-position-properties~. +To disable fringe indicators for Flymake or Flycheck, refer to variables +~flymake-fringe-indicator-position~ and ~flycheck-indication-mode~, +respectively. + ** Option for line highlighting (hl-line-mode) :properties: :alt_title: Line highlighting @@ -1064,7 +1159,9 @@ style, is controlled by the built-in variables ~underline-minimum-offset~, :end: #+vindex: modus-themes-hl-line -Symbol: ~modus-themes-hl-line~ +Brief: Control the style of the current line of ~hl-line-mode~. + +Symbol: ~modus-themes-hl-line~ (=choice= type, list of properties) Possible values are expressed as a list of properties (default is ~nil~ or an empty list). The list can include any of the following symbols: @@ -1116,7 +1213,9 @@ This style affects several packages that enable ~hl-line-mode~, such as :end: #+vindex: modus-themes-subtle-line-numbers -Symbol: ~modus-themes-subtle-line-numbers~ +Brief: Toggle subtle line numbers. + +Symbol: ~modus-themes-subtle-line-numbers~ (=boolean= type) Possible value: @@ -1137,6 +1236,30 @@ Instead they retain the primary background of the theme, blending with the rest of the buffer. Foreground values for all relevant faces are updated to accommodate this aesthetic. +** Option for intense markup in Org and others +:properties: +:alt_title: Intense markup +:description: Toggle intense style for markup in Org and others +:custom_id: h:9d9a4e64-99ac-4018-8f66-3051b9c43fd7 +:end: +#+vindex: modus-themes-intense-markup + +Brief: Toggle intense style for inline code and related markup. + +Symbol: ~modus-themes-intense-markup~ (=boolean= type) + +Possible value: + +1. ~nil~ (default) +2. ~t~ + +The default style for certain markup types like inline code and verbatim +constructs in Org and related major modes is a subtle foreground color +combined with a subtle background. + +With a non-nil value (~t~), these constructs will use a more prominent +background and foreground color combination instead. + ** Option for parenthesis matching (show-paren-mode) :properties: :alt_title: Matching parentheses @@ -1145,7 +1268,10 @@ updated to accommodate this aesthetic. :end: #+vindex: modus-themes-paren-match -Symbol: ~modus-themes-paren-match~ +Brief: Control the style of matching delimiters produced by +~show-paren-mode~. + +Symbol: ~modus-themes-paren-match~ (=choice= type, list of properties) Possible values are expressed as a list of properties (default is ~nil~ or an empty list). The list can include any of the following symbols: @@ -1192,7 +1318,9 @@ This customization variable affects the built-in ~show-paren-mode~ and the :end: #+vindex: modus-themes-region -Symbol: ~modus-themes-region~ +Brief: Control the style of the region. + +Symbol: ~modus-themes-region~ (=choice= type, list of properties) Possible values are expressed as a list of properties (default is ~nil~ or an empty list). The list can include any of the following symbols: @@ -1238,7 +1366,9 @@ In user configuration files the form may look like this: :end: #+vindex: modus-themes-diffs -Symbol: ~modus-themes-diffs~ +Bried: Set the overall style of diffs. + +Symbol: ~modus-themes-diffs~ (=choice= type) Possible values: @@ -1284,7 +1414,9 @@ interest of backward compatibility. :end: #+vindex: modus-themes-org-blocks -Symbol: ~modus-themes-org-blocks~ +Brief: Set the overall style of Org code blocks, quotes, and the like. + +Symbol: ~modus-themes-org-blocks~ (=choice= type) Possible values: @@ -1325,7 +1457,10 @@ and ~rainbow~. Those will continue to work as they are aliases for :end: #+vindex: modus-themes-org-agenda -Symbol: ~modus-themes-org-agenda~ +Brief: Control the style of the Org agenda. Multiple parameters are +available, each with its own options. + +Symbol: ~modus-themes-org-agenda~ (=alist= type, multiple styles) This is an alist that accepts a =(key . value)= combination. Some values are specified as a list. Here is a sample, followed by a description of @@ -1335,7 +1470,7 @@ all possible combinations: (setq modus-themes-org-agenda '((header-block . (variable-pitch scale-title)) (header-date . (grayscale workaholic bold-today)) - (event . (accented scale-small)) + (event . (accented italic varied)) (scheduled . uniform) (habit . traffic-light))) #+end_src @@ -1394,28 +1529,41 @@ For example: (header-date . (grayscale workaholic bold-today scale-heading)) #+end_src -An ~event~ key covers events from the diary and other entries that derive -from a symbolic expression or sexp (e.g. phases of the moon, holidays). -This key accepts a list of values. By default (a nil value or an empty -list) those have a gray foreground, while sexp events are additionally -presented using slanted text (italics). The properties that can form a -list of possible values are: - -- ~scale-small~ reduces the height of the entries to the value of the user - option ~modus-themes-scale-small~ (0.9 the height of the main font size - by default). -- ~accented~ applies an accent value to the event's foreground, replacing - the original gray. +An ~event~ key covers (i) headings with a plain time stamp that are +shown on the agenda, also known as events, (ii) entries imported from +the diary, and (iii) other items that derive from a symbolic expression +or sexp (phases of the moon, holidays, etc.). By default all those look +the same and have a subtle foreground color (the default is a nil value +or an empty list). This key accepts a list of properties. Those are: + +- ~scale-small~ reduces the height of the entries to the value of + the user option ~modus-themes-scale-small~ (0.9 the height of + the main font size by default). This work best when the + relevant entries have no tags associated with them and when the + user is interested in reducing their presence in the agenda + view. +- ~accented~ applies an accent value to the event's foreground, + replacing the original gray. It makes all entries stand out more. - ~italic~ adds a slant to the font's forms (italic or oblique forms, depending on the typeface). +- ~varied~ differentiates between events with a plain time stamp and + entries that are generated from either the diary or a symbolic + expression. It generally puts more emphasis on events. When ~varied~ + is combined with ~accented~, it makes only events use an accent color, + while diary/sexp entries retain their original subtle foreground. + When ~varied~ is used in tandem with ~italic~, it applies a slant only + to diary and sexp entries, not events. And when ~varied~ is the sole + property passed to the ~event~ key, it has the same meaning as the + list (italic varied). The combination of ~varied~, ~accented~, + ~italic~ covers all of the aforementioned cases. For example: #+begin_src emacs-lisp (event . nil) -(event . (scale-small)) -(event . (scale-small accented)) -(event . (scale-small accented italic)) +(event . (italic)) +(event . (accented italic)) +(event . (accented italic varied)) #+end_src A ~scheduled~ key applies to tasks with a scheduled date. By default (a @@ -1498,7 +1646,10 @@ Putting it all together, the alist can look like this: :end: #+vindex: modus-themes-headings -Symbol: ~modus-themes-headings~ +Brief: Control the style of headings. This can be particularised for +each level of heading (e.g. Org has eight levels). + +Symbol: ~modus-themes-headings~ (=alist= type, multiple properties) This is an alist that accepts a =(key . list-of-values)= combination. The key is either a number, representing the heading's level or ~t~, which @@ -1518,8 +1669,21 @@ Properties: + ~rainbow~ + ~overline~ + ~background~ -+ ~no-bold~ + ~monochrome~ ++ A font weight, which must be supported by the underlying typeface: + - ~thin~ + - ~ultralight~ + - ~extralight~ + - ~light~ + - ~semilight~ + - ~regular~ + - ~medium~ + - ~semibold~ + - ~bold~ + - ~heavy~ + - ~extrabold~ + - ~ultrabold~ ++ ~no-bold~ By default (a ~nil~ value for this variable), all headings have a bold typographic weight and use a desaturated text color. @@ -1531,20 +1695,27 @@ An ~overline~ property draws a line above the area of the heading. A ~background~ property adds a subtle tinted color to the background of the heading. -A ~no-bold~ property removes the bold weight from the heading's text. - A ~monochrome~ property makes all headings the same base color, which is that of the default for the active theme (black/white). When ~background~ is also set, ~monochrome~ changes its color to gray. If both ~monochrome~ and ~rainbow~ are set, the former takes precedence. +The symbol of a weight attribute adjusts the font of the heading +accordingly, such as ~light~, ~semibold~, etc. Valid symbols are defined in +the internal variable ~modus-themes--heading-weights~. The absence of a +weight means that bold will be used by virtue of inheriting the ~bold~ +face. For backward compatibility, the ~no-bold~ value is accepted, though +users are encouraged to specify a ~regular~ weight instead. + +[[#h:2793a224-2109-4f61-a106-721c57c01375][Configure bold and italic faces]]. + Combinations of any of those properties are expressed as a list, like in these examples: #+begin_src emacs-lisp -(no-bold) +(semibold) (rainbow background) -(overline monochrome no-bold) +(overline monochrome semibold) #+end_src The order in which the properties are set is not significant. @@ -1555,7 +1726,7 @@ In user configuration files the form may look like this: (setq modus-themes-headings '((1 . (background overline rainbow)) (2 . (background overline)) - (t . (overline no-bold)))) + (t . (overline semibold)))) #+end_src When defining the styles per heading level, it is possible to pass a @@ -1570,7 +1741,7 @@ original aesthetic for that level. For example: (setq modus-themes-headings '((1 . (background overline)) - (2 . (rainbow no-bold)) + (2 . (rainbow semibold)) (t . t))) ; default style for all other levels #+end_src @@ -1591,7 +1762,9 @@ others, such as ~org-fontify-done-headline~. :end: #+vindex: modus-themes-scale-headings -Symbol: ~modus-themes-scale-headings~ +Brief: Toggle the scaling of headings. + +Symbol: ~modus-themes-scale-headings~ (=boolean= type) Possible values: @@ -1610,6 +1783,17 @@ main text. This is noticeable in modes like Org, Markdown, and Info. :custom_id: h:6868baa1-beba-45ed-baa5-5fd68322ccb3 :end: +Brief: Specify the height for individual heading scales. + +Symbols (all are =number= type): + ++ ~modus-themes-scale-1~ ++ ~modus-themes-scale-2~ ++ ~modus-themes-scale-3~ ++ ~modus-themes-scale-4~ ++ ~modus-themes-scale-title~ ++ ~modus-themes-scale-small~ + In addition to the toggle for enabling scaled headings, users can also specify a number of their own. @@ -1681,7 +1865,10 @@ size of the heading, but not of keywords that were added to it, like :end: #+vindex: modus-themes-variable-pitch-ui -Symbol: ~modus-themes-variable-pitch-ui~ +Brief: Toggle the use of proportionately spaced (~variable-pitch~) fonts +in the User Interface. + +Symbol: ~modus-themes-variable-pitch-ui~ (=boolean= type) Possible values: @@ -1708,7 +1895,10 @@ is done by assigning the ~variable-pitch~ face to the relevant items. :end: #+vindex: modus-themes-variable-pitch-headings -Symbol: ~modus-themes-variable-pitch-headings~ +Brief: Toggle the use of proportionately spaced (~variable-pitch~) fonts +in headings. + +Symbol: ~modus-themes-variable-pitch-headings~ (=boolean= type) Possible values: @@ -2460,17 +2650,16 @@ inspiration from the ~modus-themes-toggle~ we already provide: :end: #+cindex: Font configurations -The themes are designed to cope well with mixed font configurations. - -[[#h:115e6c23-ee35-4a16-8cef-e2fcbb08e28b][Option for no font mixing]]. +The themes are designed to optionally cope well with mixed font +configurations. This mostly concerns ~org-mode~ and ~markdown-mode~, though +expect to find it elsewhere like in ~Info-mode~. -This mostly concerns ~org-mode~ and ~markdown-mode~, though expect to find -it elsewhere like in ~Info-mode~. +[[#h:115e6c23-ee35-4a16-8cef-e2fcbb08e28b][Option for font mixing]]. In practice it means that the user can safely opt for a more prose-friendly proportionately spaced typeface as their default, while -letting spacing-sensitive elements like tables and inline code always -use a monospaced font, by inheriting from the ~fixed-pitch~ face. +spacing-sensitive elements like tables and inline code always use a +monospaced font, by inheriting from the ~fixed-pitch~ face. Users can try the built-in {{{kbd(M-x variable-pitch-mode)}}} to see the effect in action. @@ -2491,7 +2680,14 @@ reading the doc string of ~set-face-attribute~): (set-face-attribute 'variable-pitch nil :family "DejaVu Serif" :height 1.0) ;; Monospaced typeface -(set-face-attribute 'fixed-pitch nil :family "DejaVu Sans Mono" :height 1.0) +(set-face-attribute 'fixed-pitch nil :family "DejaVu Sans Mono" :height 1.5) +#+end_src + +Or employ the ~face-attribute~ function to read an existing value, such as +if you want to make ~fixed-pitch~ use the font family of the ~default~ face: + +#+begin_src emacs-lisp +(set-face-attribute 'fixed-pitch nil :family (face-attribute 'default :family)) #+end_src The next section shows how to make those work in a more elaborate setup @@ -2504,12 +2700,13 @@ specify an absolute value, which is the point size × 10. So if you want to use a font at point size =11=, you set the height to =110=.[fn:: ~:height~ values do not need to be rounded to multiples of ten: the likes of =115= are perfectly valid—some typefaces will change to account for those -finer increments.] Whereas every other face must have a value that is -relative to the default, represented as a floating point (if you use an -integer, then that means an absolute height). This is of paramount -importance: it ensures that all fonts can scale gracefully when using -something like the ~text-scale-adjust~ command which only operates on the -base font size (i.e. the ~default~ face's absolute height). +finer increments.] Whereas every other face must either not specify a +height or have a value that is relative to the default, represented as a +floating point. If you use an integer, then that means an absolute +height. This is of paramount importance: it ensures that all fonts can +scale gracefully when using something like the ~text-scale-adjust~ command +which only operates on the base font size (i.e. the ~default~ face's +absolute height). [[#h:e6c5451f-6763-4be7-8fdb-b4706a422a4c][Note for EWW and Elfeed fonts (SHR fonts)]]. @@ -2545,7 +2742,7 @@ it means for a construct to be bold/italic, by tweaking the ~bold~ and To achieve those effects, one must first be sure that the fonts they use have support for those features. It then is a matter of following the -instructions for all face tweaks. +instructions for all typeface tweaks. [[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and others]]. @@ -2573,19 +2770,20 @@ To reset the font family, one can use this: To ensure that the effects persist after switching between the Modus themes (such as with {{{kbd(M-x modus-themes-toggle)}}}), the user needs to -write their configurations to a function and hook it up to the -~modus-themes-after-load-theme-hook~. This is necessary because the -themes set the default styles of faces (otherwise changing themes would -not be possible). +write their configurations to a function and pass it to the +~modus-themes-after-load-theme-hook~. This is necessary because themes +set the styles of faces upon activation, overriding prior values where +conflicts occur between the previous and the current states (otherwise +changing themes would not be possible). [[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]]. This is a minimal setup to preserve font configurations across theme -load phases. For a more permanent setup, it is better to employ the +load phases. For a more permanent setup, it is better to rely on the ~custom-set-faces~ function: ~set-face-attribute~ works just fine, though it -is more convenient for quick previews or for smaller scale operations -(~custom-set-faces~ follows the format used in the source code of the -themes). +probably is better suited for quick previews or for smaller scale +operations (~custom-set-faces~ follows the format used in the source code +of the themes, which can make it easier to redefine faces in bulk). #+begin_src emacs-lisp ;; our generic function @@ -2605,6 +2803,8 @@ themes). (add-hook 'modus-themes-after-load-theme-hook #'my-modes-themes-bold-italic-faces) #+end_src +[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]]. + ** Custom Org user faces (DIY) :properties: :custom_id: h:89f0678d-c5c3-4a57-a526-668b2bb2d7ad @@ -2897,6 +3097,101 @@ With those in place, PDFs have a distinct backdrop for their page, while they automatically switch to their dark mode when ~modus-themes-toggle~ is called from inside a buffer whose major-mode is ~pdf-view-mode~. +** Decrease mode line height (DIY) +:properties: +:custom_id: h:03be4438-dae1-4961-9596-60a307c070b5 +:end: +#+cindex: Decrease mode line height + +By default, the mode line of the Modus themes is set to 1 pixel width +for its =:box= attribute. In contrast, the mode line of stock Emacs is -1 +pixel. This small difference is considered necessary for the purposes +of accessibility as our out-of-the-box design has a prominent color +around the mode line (a border) to make its boundaries clear. With a +negative width the border and the text on the mode line can feel a bit +more difficult to read under certain scenaria. + +Furthermore, the user option ~modus-themes-mode-line~ ([[#h:27943af6-d950-42d0-bc23-106e43f50a24][Mode line]]) does not +allow for such a negative value because there are many edge cases that +simply make for a counter-intuitive set of possibilities, such as a =0= +value not being acceptable by the underlying face infrastructure, and +negative values greater than =-2= not being particularly usable. + +For these reasons, users who wish to decrease the overall height of the +mode line must handle things on their own by implementing the methods +for face customization documented herein. + +[[#h:1487c631-f4fe-490d-8d58-d72ffa3bd474][Basic face customization]]. + +One such method is to create a function that configures the desired +faces and hook it to ~modus-themes-after-load-theme-hook~ so that it +persists while switching between the Modus themes with the command +~modus-themes-toggle~. + +This one simply disables the box altogether, which will reduce the +height of the mode lines, but also remove their border: + +#+begin_src emacs-lisp +(defun my-modus-themes-custom-faces () + (set-face-attribute 'mode-line nil :box nil) + (set-face-attribute 'mode-line-inactive nil :box nil)) + +(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces) +#+end_src + +The above relies on the ~set-face-attribute~ function, though users who +plan to re-use colors from the theme and do so at scale are better off +with the more streamlined combination of the ~modus-themes-with-colors~ +macro and ~custom-set-faces~. + +[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face customization at scale]]. + +As explained before in this document, this approach has a syntax that is +consistent with the source code of the themes, so it probably is easier +to re-use parts of the design. + +The following emulates the stock Emacs style, while still using the +colors of the Modus themes (whichever attribute is not explicitly stated +is inherited from the underlying theme): + +#+begin_src emacs-lisp +(defun my-modus-themes-custom-faces () + (modus-themes-with-colors + (custom-set-faces + `(mode-line ((,class :box (:line-width -1 :style released-button)))) + `(mode-line-inactive ((,class :box (:line-width -1 :color ,bg-region))))))) + +(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces) +#+end_src + +And this one is like the out-of-the-box style of the Modus themes, but +with the -1 height instead of 1: + +#+begin_src emacs-lisp +(defun my-modus-themes-custom-faces () + (modus-themes-with-colors + (custom-set-faces + `(mode-line ((,class :box (:line-width -1 :color ,fg-alt)))) + `(mode-line-inactive ((,class :box (:line-width -1 :color ,bg-region))))))) + +(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces) +#+end_src + +Finally, to also change the background color of the active mode line, +such as that it looks like the "accented" variant which is possible via +the user option ~modus-themes-mode-line~, the =:background= attribute needs +to be specified as well: + +#+begin_src emacs-lisp +(defun my-modus-themes-custom-faces () + (modus-themes-with-colors + (custom-set-faces + `(mode-line ((,class :box (:line-width -1 :color ,fg-alt) :background ,bg-active-accent))) + `(mode-line-inactive ((,class :box (:line-width -1 :color ,bg-region))))))) + +(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces) +#+end_src + ** A theme-agnostic hook for theme loading (DIY) :properties: :custom_id: h:86f6906b-f090-46cc-9816-1fe8aeb38776 @@ -3121,6 +3416,7 @@ have lots of extensions, so the "full support" may not be 100% true… + ido-mode + iedit + iflipb ++ image-dired + imenu-list + indium + info @@ -3162,6 +3458,7 @@ have lots of extensions, so the "full support" may not be 100% true… + mu4e + mu4e-conversation + multiple-cursors ++ nano-modeline + neotree + no-emoji + notmuch @@ -3263,6 +3560,7 @@ have lots of extensions, so the "full support" may not be 100% true… + vc-annotate (the output of {{{kbd(C-x v g)}}}) + vdiff + vertico ++ vertico-quick + vimish-fold + visible-mark + visual-regexp @@ -3314,7 +3612,6 @@ supported by the themes. + tide + vertico-indexed + vertico-mouse -+ vertico-quick * Notes on individual packages :properties: @@ -4219,7 +4516,7 @@ The source code of the themes is [[https://gitlab.com/protesilaos/modus-themes/] being. A [[https://github.com/protesilaos/modus-themes/][mirror on Github]] is also on offer. An HTML version of this manual is provided as an extension of the -[[https://protesilaos.com/modus-themes/][author's personal website]] (does not rely on any non-free code). +[[https://protesilaos.com/emacs/modus-themes/][author's personal website]] (does not rely on any non-free code). ** Issues you can help with :properties: @@ -4323,11 +4620,11 @@ The Modus themes are a collective effort. Every bit of work matters. + Author/maintainer :: Protesilaos Stavrou. + Contributions to code or documentation :: Anders Johansson, Basil - L.{{{space()}}} Contovounesios, Carlo Zancanaro, Eli Zaretskii, Fritz Grabo, - Kévin Le Gouguec, Kostadin Ninev, Madhavan Krishnan, Markus Beppler, - Matthew Stevenson, Mauro Aranda, Nicolas De Jaeghere, Philip - Kaludercic, Rudolf Adamkovič, Stephen Gildea, Shreyas Ragavan, Stefan - Kangas, Vincent Murphy, Xinglu Chen. + L.{{{space()}}} Contovounesios, Carlo Zancanaro, Christian Tietze, Daniel + Mendler, Eli Zaretskii, Fritz Grabo, Kévin Le Gouguec, Kostadin Ninev, + Madhavan Krishnan, Markus Beppler, Matthew Stevenson, Mauro Aranda, + Nicolas De Jaeghere, Philip Kaludercic, Rudolf Adamkovič, Stephen + Gildea, Shreyas Ragavan, Stefan Kangas, Vincent Murphy, Xinglu Chen. + Ideas and user feedback :: Aaron Jensen, Adam Porter, Adam Spiers, Adrian Manea, Alex Griffin, Alex Peitsinis, Alexey Shmalko, Alok @@ -4336,19 +4633,20 @@ The Modus themes are a collective effort. Every bit of work matters. Dimech, Damien Cassou, Daniel Mendler, Dario Gjorgjevski, David Edmondson, Davor Rotim, Divan Santana, Eliraz Kedmi, Emanuele Michele Alberto Monterosso, Farasha Euker, Feng Shu, Gautier Ponsinet, Gerry - Agbobada, Gianluca Recchia, Gustavo Barros, Hörmetjan Yiltiz, Ilja - Kocken, Iris Garcia, Jeremy Friesen, Jerry Zhang, John Haman, Joshua - O'Connor, Kevin Fleming, Kévin Le Gouguec, Kostadin Ninev, Len Trigg, - Manuel Uberti, Mark Burton, Markus Beppler, Mauro Aranda, Michael - Goldenberg, Morgan Smith, Murilo Pereira, Nicky van Foreest, Nicolas - De Jaeghere, Paul Poloskov, Pengji Zhang, Pete Kazmier, Peter Wu, - Philip Kaludercic, Pierre Téchoueyres, Roman Rudakov, Ryan Phillips, - Rudolf Adamkovič, Sam Kleinman, Shreyas Ragavan, Simon Pugnet, Tassilo - Horn, Thibaut Verron, Thomas Heartman, Trey Merkley, Togan Muftuoglu, - Toon Claes, Uri Sharf, Utkarsh Singh, Vincent Foley. As well as - users: Ben, CsBigDataHub1, Emacs Contrib, Eugene, Fourchaux, Fredrik, - Moesasji, Nick, TheBlob42, Trey, bepolymathe, doolio, fleimgruber, - iSeeU, jixiuf, okamsn, pRot0ta1p. + Agbobada, Gianluca Recchia, Guilherme Semente, Gustavo Barros, + Hörmetjan Yiltiz, Ilja Kocken, Iris Garcia, Jeremy Friesen, Jerry + Zhang, Johannes Grødem, John Haman, Joshua O'Connor, Kevin Fleming, + Kévin Le Gouguec, Kostadin Ninev, Len Trigg, Manuel Uberti, Mark + Burton, Markus Beppler, Mauro Aranda, Michael Goldenberg, Morgan + Smith, Murilo Pereira, Nicky van Foreest, Nicolas De Jaeghere, Paul + Poloskov, Pengji Zhang, Pete Kazmier, Peter Wu, Philip Kaludercic, + Pierre Téchoueyres, Roman Rudakov, Ryan Phillips, Rudolf Adamkovič, + Sam Kleinman, Shreyas Ragavan, Simon Pugnet, Tassilo Horn, Thibaut + Verron, Thomas Heartman, Trey Merkley, Togan Muftuoglu, Toon Claes, + Uri Sharf, Utkarsh Singh, Vincent Foley. As well as users: Ben, + CsBigDataHub1, Emacs Contrib, Eugene, Fourchaux, Fredrik, Moesasji, + Nick, TheBlob42, Trey, bepolymathe, doolio, fleimgruber, iSeeU, + jixiuf, okamsn, pRot0ta1p. + Packaging :: Basil L.{{{space()}}} Contovounesios, Eli Zaretskii, Glenn Morris, Mauro Aranda, Richard Stallman, Stefan Kangas (core Emacs), @@ -4358,9 +4656,10 @@ The Modus themes are a collective effort. Every bit of work matters. + Inspiration for certain features :: Bozhidar Batsov (zenburn-theme), Fabrice Niessen (leuven-theme). -Special thanks, in no particular order, to Manuel Uberti, Gustavo -Barros, and Omar Antolín Camarena for their long time contributions and -insightful commentary. +Special thanks (from A-Z) to Gustavo Barros, Manuel Uberti, Nicolas De +Jaeghere, and Omar Antolín Camarena for their long time contributions +and insightful commentary on key aspects of the themes' design and/or +aspects of their functionality. * Meta :properties: @@ -4388,9 +4687,9 @@ of this sort): And here are the canonical sources of this project's documentation: -+ Manual :: -+ Change Log :: -+ Screenshots :: ++ Manual :: ++ Change Log :: ++ Screenshots :: * GNU Free Documentation License :properties: diff --git a/etc/themes/modus-operandi-theme.el b/etc/themes/modus-operandi-theme.el index 350524779d..5a73e655f3 100644 --- a/etc/themes/modus-operandi-theme.el +++ b/etc/themes/modus-operandi-theme.el @@ -4,8 +4,8 @@ ;; Author: Protesilaos Stavrou ;; URL: https://gitlab.com/protesilaos/modus-themes -;; Version: 1.6.0 -;; Package-Requires: ((emacs "26.1")) +;; Version: 1.7.0 +;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility ;; This file is part of GNU Emacs. diff --git a/etc/themes/modus-themes.el b/etc/themes/modus-themes.el index 7ab985c077..f7d38ac2de 100644 --- a/etc/themes/modus-themes.el +++ b/etc/themes/modus-themes.el @@ -4,8 +4,8 @@ ;; Author: Protesilaos Stavrou ;; URL: https://gitlab.com/protesilaos/modus-themes -;; Version: 1.6.0 -;; Last-Modified: <2021-09-29 08:47:03 +0300> +;; Version: 1.7.0 +;; Last-Modified: <2021-11-18 12:28:22 +0200> ;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility @@ -31,7 +31,7 @@ ;; This file contains all customization variables, helper functions, ;; interactive commands, and face specifications. Please refer to the ;; official Info manual for further documentation (distributed with the -;; themes, or available at: ). +;; themes, or available at: ). ;; ;; The themes share the following customization variables: ;; @@ -39,8 +39,9 @@ ;; modus-themes-org-agenda (alist) ;; modus-themes-bold-constructs (boolean) ;; modus-themes-inhibit-reload (boolean) +;; modus-themes-intense-markup (boolean) ;; modus-themes-italic-constructs (boolean) -;; modus-themes-no-mixed-fonts (boolean) +;; modus-themes-mixed-fonts (boolean) ;; modus-themes-scale-headings (boolean) ;; modus-themes-subtle-line-numbers (boolean) ;; modus-themes-success-deuteranopia (boolean) @@ -59,6 +60,7 @@ ;; modus-themes-prompts (choice) ;; modus-themes-region (choice) ;; modus-themes-syntax (choice) +;; modus-themes-mode-line-padding (natnum) ;; ;; The default scale for headings is as follows (it can be customized as ;; well---remember, no scaling takes place by default): @@ -238,6 +240,7 @@ ;; ido-mode ;; iedit ;; iflipb +;; image-dired ;; imenu-list ;; indium ;; info @@ -278,6 +281,7 @@ ;; mu4e ;; mu4e-conversation ;; multiple-cursors +;; nano-modeline ;; neotree ;; no-emoji ;; notmuch @@ -378,6 +382,7 @@ ;; vc-annotate (C-x v g) ;; vdiff ;; vertico +;; vertico-quick ;; vimish-fold ;; visible-mark ;; visual-regexp @@ -1475,7 +1480,7 @@ The actual styling of the face is done by `modus-themes-faces'." (defface modus-themes-variable-pitch nil "Generic face for applying a conditional `variable-pitch'. -This behaves in accordance with `modus-themes-no-mixed-fonts', +This behaves in accordance with `modus-themes-mixed-fonts', `modus-themes-variable-pitch-headings' for all heading levels, and `modus-themes-variable-pitch-ui'. @@ -1484,7 +1489,7 @@ The actual styling of the face is done by `modus-themes-faces'." (defface modus-themes-fixed-pitch nil "Generic face for applying a conditional `fixed-pitch'. -This behaves in accordance with `modus-themes-no-mixed-fonts'. +This behaves in accordance with `modus-themes-mixed-fonts'. The actual styling of the face is done by `modus-themes-faces'." :group 'modus-theme-faces) @@ -1782,30 +1787,43 @@ This includes the mode line, header line, tab bar, and tab line." :initialize #'custom-initialize-default :link '(info-link "(modus-themes) UI typeface")) -(defcustom modus-themes-no-mixed-fonts nil - "Disable inheritance from `fixed-pitch' in some faces. - -This is done by default to allow spacing-sensitive constructs, -such as Org tables and code blocks, to remain monospaced when -users opt for something like the command `variable-pitch-mode'. -The downside with the default is that users need to explicitly -configure the font family of `fixed-pitch' in order to get a -consistent experience. That may be something they do not want to -do. Hence this option to disable any kind of technique for -mixing fonts." +(define-obsolete-variable-alias + 'modus-themes-no-mixed-fonts + 'modus-themes-mixed-fonts "On 2021-10-02 for version 1.7.0") + +(defcustom modus-themes-mixed-fonts nil + "Non-nil to enable inheritance from `fixed-pitch' in some faces. + +This is done to allow spacing-sensitive constructs, such as Org +tables and code blocks, to remain monospaced when users opt for +something like the command `variable-pitch-mode'. + +Users may need to explicitly configure the font family of +`fixed-pitch' in order to get a consistent experience." :group 'modus-themes - :package-version '(modus-themes . "1.0.0") - :version "28.1" + :package-version '(modus-themes . "1.7.0") + :version "29.1" :type 'boolean :set #'modus-themes--set-option :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) No mixed fonts")) + :link '(info-link "(modus-themes) Mixed fonts")) (defconst modus-themes--headings-choice '(set :tag "Properties" :greedy t (const :tag "Background color" background) (const :tag "Overline" overline) - (const :tag "No bold weight" no-bold) + (choice :tag "Font weight (must be supported by the typeface)" + (const :tag "Bold (default)" nil) + (const :tag "Thin" thin) + (const :tag "Ultra-light" ultralight) + (const :tag "Extra-light" extralight) + (const :tag "Light" light) + (const :tag "Semi-light" semilight) + (const :tag "Regular" regular) + (const :tag "Medium" medium) + (const :tag "Semi-bold" semibold) + (const :tag "Extra-bold" extrabold) + (const :tag "Ultra-bold" ultrabold)) (choice :tag "Colors" (const :tag "Subtle colors" nil) (const :tag "Rainbow colors" rainbow) @@ -1839,21 +1857,27 @@ heading. A `background' property adds a subtle tinted color to the background of the heading. -A `no-bold' property removes the bold weight from the heading's -text. - A `monochrome' property makes all headings the same base color, which is that of the default for the active theme (black/white). When `background' is also set, `monochrome' changes its color to gray. If both `monochrome' and `rainbow' are set, the former takes precedence. +The symbol of a weight attribute adjusts the font of the heading +accordingly, such as `light', `semibold', etc. Valid symbols are +defined in the internal variable `modus-themes--heading-weights'. +The absence of a weight means that bold will be used by virtue of +inheriting the `bold' face (check the manual for tweaking bold +and italic faces). For backward compatibility, the `no-bold' +value is accepted, though users are encouraged to specify a +`regular' weight instead. + Combinations of any of those properties are expressed as a list, like in these examples: - (no-bold) + (semibold) (rainbow background) - (overline monochrome no-bold) + (overline monochrome semibold) The order in which the properties are set is not significant. @@ -1862,7 +1886,7 @@ In user configuration files the form may look like this: (setq modus-themes-headings '((1 . (background overline rainbow)) (2 . (background overline)) - (t . (overline no-bold)))) + (t . (overline semibold)))) When defining the styles per heading level, it is possible to pass a non-nil value (t) instead of a list of properties. This @@ -1875,7 +1899,7 @@ will retain the original aesthetic for that level. For example: (setq modus-themes-headings '((1 . (background overline)) - (2 . (rainbow no-bold)) + (2 . (rainbow semibold)) (t . t))) ; default style for all other levels For Org users, the extent of the heading depends on the variable @@ -1887,8 +1911,8 @@ Also read `modus-themes-scale-headings' to change the height of headings and `modus-themes-variable-pitch-headings' to make them use a proportionately spaced font." :group 'modus-themes - :package-version '(modus-themes . "1.5.0") - :version "28.1" + :package-version '(modus-themes . "1.7.0") + :version "29.1" :type `(alist :options ,(mapcar (lambda (el) (list el modus-themes--headings-choice)) @@ -1909,7 +1933,7 @@ combinations: (setq modus-themes-org-agenda '((header-block . (variable-pitch scale-title)) (header-date . (grayscale workaholic bold-today)) - (event . (accented scale-small)) + (event . (accented italic varied)) (scheduled . uniform) (habit . traffic-light))) @@ -1963,26 +1987,42 @@ For example: (header-date . (grayscale workaholic bold-today)) (header-date . (grayscale workaholic bold-today scale-heading)) -An `event' key covers events from the diary and other entries -that derive from a symbolic expression or sexp (e.g. phases of -the moon, holidays). By default those have a gray -foreground (the default is a nil value or an empty list). This -key accepts a list of properties. Those are: +An `event' key covers (i) headings with a plain time stamp that +are shown on the agenda, also known as events, (ii) entries +imported from the diary, and (iii) other items that derive from a +symbolic expression or sexp (phases of the moon, holidays, etc.). +By default all those look the same and have a subtle foreground +color (the default is a nil value or an empty list). This key +accepts a list of properties. Those are: - `scale-small' reduces the height of the entries to the value of the user option `modus-themes-scale-small' (0.9 the height of - the main font size by default). + the main font size by default). This work best when the + relevant entries have no tags associated with them and when the + user is interested in reducing their presence in the agenda + view. - `accented' applies an accent value to the event's foreground, - replacing the original gray. + replacing the original gray. It makes all entries stand out more. - `italic' adds a slant to the font's forms (italic or oblique - forms, depending on the typeface) + forms, depending on the typeface). +- `varied' differentiates between events with a plain time stamp + and entries that are generated from either the diary or a + symbolic expression. It generally puts more emphasis on + events. When `varied' is combined with `accented', it makes + only events use an accent color, while diary/sexp entries + retain their original subtle foreground. When `varied' is used + in tandem with `italic', it applies a slant only to diary and + sexp entries, not events. And when `varied' is the sole + property passed to the `event' key, it has the same meaning as + the list (italic varied). The combination of `varied', + `accented', `italic' covers all of the aforementioned cases. For example: (event . nil) - (event . (scale-small)) - (event . (scale-small accented)) - (event . (scale-small accented italic)) + (event . (italic)) + (event . (accented italic)) + (event . (accented italic varied)) A `scheduled' key applies to tasks with a scheduled date. By default (a nil value), these use varying shades of yellow to @@ -2038,8 +2078,8 @@ For example: (habit . simplified) (habit . traffic-light)" :group 'modus-themes - :package-version '(modus-themes . "1.6.0") - :version "28.1" + :package-version '(modus-themes . "1.7.0") + :version "29.1" :type '(set (cons :tag "Block header" (const header-block) @@ -2065,7 +2105,8 @@ For example: (set :tag "Text presentation" :greedy t (const :tag "Use smaller font size (`modus-themes-scale-small')" scale-small) (const :tag "Apply an accent color" accented) - (const :tag "Italic font slant (oblique forms)" italic))) + (const :tag "Italic font slant (oblique forms)" italic) + (const :tag "Differentiate events from diary/sexp entries" varied))) (cons :tag "Scheduled tasks" (const scheduled) (choice (const :tag "Yellow colors to distinguish current and future tasks (default)" nil) @@ -2289,12 +2330,12 @@ to the affected text. The property `background' adds a color-coded background. The property `intense' amplifies the applicable colors if -`background' and/or `text-only' are set. If `intense' is set on -its own, then it implies `text-only'. +`background' and/or `text-also' are set. If `intense' is set on +its own, then it implies `text-also'. -To disable fringe indicators for Flymake or Flycheck, refer to -variables `flymake-fringe-indicator-position' and -`flycheck-indication-mode', respectively. +The property `faint' uses nuanced colors for the underline and +for the foreground when `text-also' is included. If both `faint' +and `intense' are specified, the former takes precedence. Combinations of any of those properties can be expressed in a list, as in those examples: @@ -2312,15 +2353,21 @@ In user configuration files the form may look like this: NOTE: The placement of the straight underline, though not the wave style, is controlled by the built-in variables `underline-minimum-offset', `x-underline-at-descent-line', -`x-use-underline-position-properties'." +`x-use-underline-position-properties'. + +To disable fringe indicators for Flymake or Flycheck, refer to +variables `flymake-fringe-indicator-position' and +`flycheck-indication-mode', respectively." :group 'modus-themes - :package-version '(modus-themes . "1.5.0") - :version "28.1" + :package-version '(modus-themes . "1.7.0") + :version "29.1" :type '(set :tag "Properties" :greedy t (const :tag "Straight underline" straight-underline) (const :tag "Colorise text as well" text-also) - (const :tag "Increase color intensity" intense) - (const :tag "With background" background)) + (const :tag "With background" background) + (choice :tag "Overall coloration" + (const :tag "Intense colors" intense) + (const :tag "Faint colors" faint))) :set #'modus-themes--set-option :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Language checkers")) @@ -2502,6 +2549,17 @@ instead of a box style, it is advised to set :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Mode line")) +(defcustom modus-themes-mode-line-padding 6 + "Padding for `modus-themes-mode-line'. +The value is expressed as a positive integer." + :group 'modus-themes + :package-version '(modus-themes . "1.7.0") + :version "29.1" + :type 'natnum + :set #'modus-themes--set-option + :initialize #'custom-initialize-default + :link '(info-link "(modus-themes) Mode line")) + (defcustom modus-themes-diffs nil "Adjust the overall style of diffs. @@ -2643,16 +2701,6 @@ In user configuration files the form may look like this: :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Command prompts")) -(defcustom modus-themes-intense-hl-line nil - "Use a more prominent background for command `hl-line-mode'." - :group 'modus-themes - :package-version '(modus-themes . "1.0.0") - :version "28.1" - :type 'boolean - :set #'modus-themes--set-option - :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Line highlighting")) - (make-obsolete 'modus-themes-intense-hl-line 'modus-themes-hl-line "1.3.0") (defcustom modus-themes-hl-line nil @@ -2708,6 +2756,22 @@ results with underlines." :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Line numbers")) +(defcustom modus-themes-intense-markup nil + "Use more intense markup in Org, Markdown, and related. +The default style for certain markup types like inline code and +verbatim constructs in Org and related major modes is a subtle +foreground color combined with a subtle background. + +With a non-nil value (t), these constructs will use a more +prominent background and foreground color combination instead." + :group 'modus-themes + :package-version '(modus-themes . "1.7.0") + :version "29.1" + :type 'boolean + :set #'modus-themes--set-option + :initialize #'custom-initialize-default + :link '(info-link "(modus-themes) Intense markup")) + (defcustom modus-themes-paren-match nil "Control the style of matching parentheses or delimiters. @@ -2913,12 +2977,14 @@ In user configuration files the form may look like this: This is to account for red-green color deficiency. -The present customization option should apply to all contexts where -there can be a color-coded distinction between success and failure, -to-do and done, and so on. +The present customization option applies to all contexts where +there can be a color-coded distinction between success or +failure, to-do or done, mark for selection or deletion (e.g. in +Dired), current and lazily highlighted search matches, and so on. -Diffs, which have a red/green dichotomy by default, can also be -configured to conform with deuteranopia: `modus-themes-diffs'." +Diffs, which rely on a red/green dichotomy by default, can also +be configured to meet the needs of users with deuteranopia via +the option `modus-themes-diffs'." :group 'modus-themes :package-version '(modus-themes . "1.4.0") :version "28.1" @@ -3024,7 +3090,7 @@ Those are stored in `modus-themes-faces' and (defun modus-themes--fixed-pitch () "Conditional application of `fixed-pitch' inheritance." - (unless modus-themes-no-mixed-fonts + (when modus-themes-mixed-fonts (list :inherit 'fixed-pitch))) (defun modus-themes--variable-pitch () @@ -3054,14 +3120,23 @@ combines with the theme's primary background (white/black)." (list :background (or altbg 'unspecified) :foreground altfg) (list :background mainbg :foreground mainfg))) -(defun modus-themes--lang-check (underline subtlefg intensefg intensefg-alt subtlebg intensebg) +(defun modus-themes--markup (mainfg intensefg &optional mainbg intensebg) + "Conditional use of colors for markup in Org and others. +MAINBG is the default background. MAINFG is the default +foreground. INTENSEBG and INTENSEFG must be more colorful +variants." + (if modus-themes-intense-markup + (list :background (or intensebg 'unspecified) :foreground intensefg) + (list :background (or mainbg 'unspecified) :foreground mainfg))) + +(defun modus-themes--lang-check (underline subtlefg intensefg intensefg-alt subtlebg intensebg faintfg) "Conditional use of foreground colors for language checkers. UNDERLINE is a color-code value for the affected text's underline property. SUBTLEFG and INTENSEFG follow the same color-coding pattern and represent a value that is faint or vibrant respectively. INTENSEFG-ALT is used when the intensity is high. SUBTLEBG and INTENSEBG are color-coded background colors that -differ in overall intensity." +differ in overall intensity. FAINTFG is a nuanced color." (let ((modus-themes-lang-checkers (if (listp modus-themes-lang-checkers) modus-themes-lang-checkers @@ -3074,12 +3149,16 @@ differ in overall intensity." ('straight-underline '(straight-underline)))))) (list :underline (list :color - underline + (if (memq 'faint modus-themes-lang-checkers) + faintfg underline) :style (if (memq 'straight-underline modus-themes-lang-checkers) 'line 'wave)) :background (cond + ((and (memq 'background modus-themes-lang-checkers) + (memq 'faint modus-themes-lang-checkers)) + subtlebg) ((and (memq 'background modus-themes-lang-checkers) (memq 'intense modus-themes-lang-checkers)) intensebg) @@ -3087,6 +3166,9 @@ differ in overall intensity." subtlebg)) :foreground (cond + ((and (memq 'faint modus-themes-lang-checkers) + (memq 'text-also modus-themes-lang-checkers)) + faintfg) ((and (memq 'background modus-themes-lang-checkers) (memq 'intense modus-themes-lang-checkers)) intensefg-alt) @@ -3312,6 +3394,18 @@ an alternative to the default value." "Get cdr of KEY in ALIST." (cdr (assoc key alist))) +(defvar modus-themes--heading-weights + '( thin ultralight extralight light semilight regular medium + semibold bold heavy extrabold ultrabold) + "List of font weights used by `modus-themes--heading'.") + +(defun modus-themes--heading-weight (list) + "Search for `modus-themes--heading' weight in LIST." + (catch 'found + (dolist (elt list) + (when (memq elt modus-themes--heading-weights) + (throw 'found elt))))) + (defun modus-themes--heading (level fg fg-alt bg bg-gray border) "Conditional styles for `modus-themes-headings'. @@ -3323,8 +3417,9 @@ values. BG-GRAY is a gray background. BORDER is a color value that combines well with the background and foreground." (let* ((key (modus-themes--key-cdr level modus-themes-headings)) (style (or key (modus-themes--key-cdr t modus-themes-headings))) + (style-listp (listp style)) (modus-themes-headings - (if (listp style) + (if style-listp style ;; translation layer for legacy values (pcase style @@ -3345,15 +3440,16 @@ that combines well with the background and foreground." ('rainbow-section-no-bold '(no-bold rainbow background overline)) ('section '(background overline)) ('section-no-bold '(background overline no-bold))))) - (var (if modus-themes-variable-pitch-headings - 'variable-pitch - 'unspecified)) + (var (when modus-themes-variable-pitch-headings 'variable-pitch)) (varbold (if var (append (list 'bold) (list var)) - 'bold))) + 'bold)) + (weight (when style-listp (modus-themes--heading-weight style)))) (list :inherit (cond - ((memq 'no-bold modus-themes-headings) + ;; `no-bold' is for backward compatibility because we cannot + ;; deprecate a variable's value. + ((or weight (memq 'no-bold modus-themes-headings)) var) (varbold)) :background @@ -3371,6 +3467,8 @@ that combines well with the background and foreground." ((memq 'rainbow modus-themes-headings) fg-alt) (fg)) + :weight + (or weight 'unspecified) :overline (if (memq 'overline modus-themes-headings) border @@ -3430,24 +3528,42 @@ weight. Optional UL applies an underline." t 'unspecified)))) -(defun modus-themes--agenda-event (fg) +(defun modus-themes--agenda-event (fg-accent &optional varied) "Control the style of the Org agenda events. -FG is the accent color to use." +FG-ACCENT is the accent color to use. Optional VARIED is a +toggle to behave in accordance with the semantics of the `varied' +property that the `event' key accepts in +`modus-themes-org-agenda'." (let ((properties (modus-themes--key-cdr 'event modus-themes-org-agenda))) (list :height (if (memq 'scale-small properties) modus-themes-scale-small 'unspecified) :foreground - (if (memq 'accented properties) - fg + (cond + ((or (and (memq 'varied properties) varied) + (and (memq 'accented properties) + (memq 'varied properties) + varied)) 'unspecified) + ((memq 'accented properties) + fg-accent) + ('unspecified)) :inherit (cond + ((and (memq 'italic properties) + (memq 'varied properties) + varied) + '(shadow italic)) ((and (memq 'accented properties) - (memq 'italic properties)) - 'italic) - ((memq 'italic properties) + (memq 'varied properties) + varied) + 'shadow) + ((or (and (memq 'varied properties) varied) + (and (memq 'italic properties) varied)) + '(shadow italic)) + ((and (memq 'italic properties) + (not (memq 'varied properties))) '(shadow italic)) ('shadow))))) @@ -3512,6 +3628,13 @@ set to `rainbow'." ('rainbow (list :background bgaccent :foreground fgaccent)) (_ (list :background bg :foreground fg)))) +(defun modus-themes--mode-line-padding () + "Determine mode line padding value. +See `modus-themes--mode-line-attrs'." + (if (natnump modus-themes-mode-line-padding) + modus-themes-mode-line-padding + 6)) ; the default value + (defun modus-themes--mode-line-attrs (fg bg fg-alt bg-alt fg-accent bg-accent border border-3d &optional alt-style fg-distant) "Color combinations for `modus-themes-mode-line'. @@ -3528,7 +3651,8 @@ line's box property. Optional FG-DISTANT should be close to the main background values. It is intended to be used as a distant-foreground property." - (let ((modus-themes-mode-line + (let ((padding (modus-themes--mode-line-padding)) + (modus-themes-mode-line (if (listp modus-themes-mode-line) modus-themes-mode-line ;; translation layer for legacy values @@ -3552,10 +3676,10 @@ property." (cons fg-alt bg-alt)) ((cons fg bg)))) (box (cond ((memq 'moody modus-themes-mode-line) - nil) + 'unspecified) ((and (memq '3d modus-themes-mode-line) (memq 'padded modus-themes-mode-line)) - (list :line-width 4 + (list :line-width padding :color (cond ((and (memq 'accented modus-themes-mode-line) (memq 'borderless modus-themes-mode-line)) @@ -3567,9 +3691,9 @@ property." :style (when alt-style 'released-button))) ((and (memq 'accented modus-themes-mode-line) (memq 'padded modus-themes-mode-line)) - (list :line-width 6 :color bg-accent)) + (list :line-width padding :color bg-accent)) ((memq 'padded modus-themes-mode-line) - (list :line-width 6 :color bg)) + (list :line-width padding :color bg)) ((memq '3d modus-themes-mode-line) (list :line-width 1 :color @@ -3579,14 +3703,17 @@ property." ((memq 'borderless modus-themes-mode-line) bg) (border-3d)) :style (when alt-style 'released-button))) + ((and (memq 'accented modus-themes-mode-line) + (memq 'borderless modus-themes-mode-line)) + bg-accent) ((memq 'borderless modus-themes-mode-line) bg) ((memq 'padded modus-themes-mode-line) - (list :line-width 6 :color bg)) + (list :line-width padding :color bg)) (border))) (line (cond ((not (or (memq 'moody modus-themes-mode-line) (memq 'padded modus-themes-mode-line))) - nil) + 'unspecified) ((and (memq 'borderless modus-themes-mode-line) (memq 'accented modus-themes-mode-line)) bg-accent) @@ -4007,6 +4134,7 @@ as when they are declared in the `:config' phase)." (defun modus-themes-load-operandi () "Load `modus-operandi' and disable `modus-vivendi'. Also run `modus-themes-after-load-theme-hook'." + (interactive) (disable-theme 'modus-vivendi) (load-theme 'modus-operandi t) (run-hooks 'modus-themes-after-load-theme-hook)) @@ -4015,6 +4143,7 @@ Also run `modus-themes-after-load-theme-hook'." (defun modus-themes-load-vivendi () "Load `modus-vivendi' and disable `modus-operandi'. Also run `modus-themes-after-load-theme-hook'." + (interactive) (disable-theme 'modus-operandi) (load-theme 'modus-vivendi t) (run-hooks 'modus-themes-after-load-theme-hook)) @@ -4169,7 +4298,11 @@ by virtue of calling either of `modus-themes-load-operandi' and `(modus-themes-pseudo-header ((,class :inherit bold :foreground ,fg-main))) `(modus-themes-mark-alt ((,class :inherit bold :background ,bg-mark-alt :foreground ,fg-mark-alt))) `(modus-themes-mark-del ((,class :inherit bold :background ,bg-mark-del :foreground ,fg-mark-del))) - `(modus-themes-mark-sel ((,class :inherit bold :background ,bg-mark-sel :foreground ,fg-mark-sel))) + `(modus-themes-mark-sel ((,class :inherit bold + :background ,@(modus-themes--success-deuteran + cyan-refine-bg + bg-mark-sel) + :foreground ,fg-mark-sel))) `(modus-themes-mark-symbol ((,class :inherit bold :foreground ,blue-alt))) ;;;;; heading levels ;; styles for regular headings used in Org, Markdown, Info, etc. @@ -4225,13 +4358,13 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; language checkers `(modus-themes-lang-error ((,class ,@(modus-themes--lang-check fg-lang-underline-error fg-lang-error - red red-refine-fg red-nuanced-bg red-refine-bg)))) + red red-refine-fg red-nuanced-bg red-refine-bg red-faint)))) `(modus-themes-lang-note ((,class ,@(modus-themes--lang-check fg-lang-underline-note fg-lang-note - blue-alt blue-refine-fg blue-nuanced-bg blue-refine-bg)))) + blue-alt blue-refine-fg blue-nuanced-bg blue-refine-bg blue-faint)))) `(modus-themes-lang-warning ((,class ,@(modus-themes--lang-check fg-lang-underline-warning fg-lang-warning - yellow yellow-refine-fg yellow-nuanced-bg yellow-refine-bg)))) + yellow yellow-refine-fg yellow-nuanced-bg yellow-refine-bg yellow-faint)))) ;;;;; other custom faces `(modus-themes-bold ((,class ,@(modus-themes--bold-weight)))) `(modus-themes-hl-line ((,class ,@(modus-themes--hl-line @@ -4276,15 +4409,16 @@ by virtue of calling either of `modus-themes-load-operandi' and `(buffer-menu-buffer ((,class :inherit bold))) `(comint-highlight-input ((,class :inherit bold))) `(comint-highlight-prompt ((,class :inherit modus-themes-prompt))) + `(confusingly-reordered ((,class :inherit modus-themes-lang-error))) `(error ((,class :inherit bold :foreground ,red))) `(escape-glyph ((,class :foreground ,fg-escape-char-construct))) - `(file-name-shadow ((,class :foreground ,fg-unfocused))) + `(file-name-shadow ((,class :inherit (shadow italic)))) `(header-line ((,class ,@(modus-themes--variable-pitch-ui) :background ,bg-header :foreground ,fg-header))) `(header-line-highlight ((,class :inherit modus-themes-active-blue))) `(help-argument-name ((,class :inherit modus-themes-slant :foreground ,cyan))) - `(help-key-binding ((,class :box (:line-width (1 . -1) :color ,bg-region) ; NOTE: box syntax is for Emacs28 - :background ,bg-inactive))) + `(help-key-binding ((,class :box (:line-width (-1 . -1) :color ,bg-active) ; NOTE: box syntax is for Emacs28 + :background ,bg-alt))) `(homoglyph ((,class :foreground ,red-alt-faint))) `(ibuffer-locked-buffer ((,class :foreground ,yellow-alt-other-faint))) `(italic ((,class :slant italic))) @@ -4316,7 +4450,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(widget-button-pressed ((,class :inherit widget-button :foreground ,magenta))) `(widget-documentation ((,class :foreground ,green))) `(widget-field ((,class :background ,bg-alt :foreground ,fg-dim))) - `(widget-inactive ((,class :foreground ,fg-alt))) + `(widget-inactive ((,class :inherit shadow :background ,bg-dim))) `(widget-single-line-field ((,class :inherit widget-field))) ;;;;; ag `(ag-hit-face ((,class :foreground ,fg-special-cold))) @@ -4505,7 +4639,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(bongo-marked-track ((,class :foreground ,fg-mark-alt))) `(bongo-marked-track-line ((,class :background ,bg-mark-alt))) `(bongo-played-track ((,class :foreground ,fg-unfocused :strike-through t))) - `(bongo-track-length ((,class :foreground ,fg-alt))) + `(bongo-track-length ((,class :inherit shadow))) `(bongo-track-title ((,class :foreground ,blue-active))) `(bongo-unfilled-seek-bar ((,class :background ,bg-special-cold :foreground ,fg-main))) ;;;;; boon @@ -4569,7 +4703,7 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; cfrs `(cfrs-border-color ((,class :background ,fg-window-divider-inner))) ;;;;; change-log and log-view (`vc-print-log' and `vc-print-root-log') - `(change-log-acknowledgment ((,class :foreground ,fg-alt))) + `(change-log-acknowledgment ((,class :inherit shadow))) `(change-log-conditionals ((,class :foreground ,yellow))) `(change-log-date ((,class :foreground ,cyan))) `(change-log-email ((,class :foreground ,cyan-alt-other))) @@ -4609,7 +4743,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(cider-stacktrace-filter-active-face ((,class :foreground ,cyan-alt :underline t))) `(cider-stacktrace-filter-inactive-face ((,class :foreground ,cyan-alt))) `(cider-stacktrace-fn-face ((,class :inherit bold :foreground ,fg-main))) - `(cider-stacktrace-ns-face ((,class :inherit italic :foreground ,fg-alt))) + `(cider-stacktrace-ns-face ((,class :inherit (shadow italic)))) `(cider-stacktrace-promoted-button-face ((,class :box (:line-width 3 :color ,fg-alt :style released-button) :foreground ,red))) `(cider-stacktrace-suppressed-button-face ((,class :box (:line-width 3 :color ,fg-alt :style pressed-button) :background ,bg-alt :foreground ,fg-alt))) @@ -4658,6 +4792,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(company-tooltip-annotation-selection ((,class :inherit bold :foreground ,fg-main))) `(company-tooltip-common ((,class :inherit bold :foreground ,blue-alt))) `(company-tooltip-common-selection ((,class :foreground ,fg-main))) + `(company-tooltip-deprecated ((,class :inherit company-tooltip :strike-through t))) `(company-tooltip-mouse ((,class :inherit modus-themes-intense-blue))) `(company-tooltip-search ((,class :inherit (modus-themes-search-success-lazy bold)))) `(company-tooltip-search-selection ((,class :inherit (modus-themes-search-success bold) :underline t))) @@ -4698,10 +4833,10 @@ by virtue of calling either of `modus-themes-load-operandi' and `(consult-preview-error ((,class :inherit modus-themes-intense-red))) `(consult-preview-line ((,class :background ,bg-hl-alt-intense))) ;;;;; corfu - `(corfu-background ((,class :background ,bg-alt))) `(corfu-current ((,class :inherit bold :background ,cyan-subtle-bg))) `(corfu-bar ((,class :background ,fg-alt))) `(corfu-border ((,class :background ,bg-active))) + `(corfu-default ((,class :background ,bg-alt))) ;;;;; counsel `(counsel-active-mode ((,class :foreground ,magenta-alt-other))) `(counsel-application-name ((,class :foreground ,red-alt-other))) @@ -4758,7 +4893,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(custom-comment ((,class :inherit shadow))) `(custom-comment-tag ((,class :background ,bg-alt :foreground ,yellow-alt-other))) `(custom-face-tag ((,class :inherit bold :foreground ,blue-intense))) - `(custom-group-tag ((,class :inherit bold :foreground ,green-intense))) + `(custom-group-tag ((,class :inherit modus-themes-pseudo-header :foreground ,magenta-alt))) `(custom-group-tag-1 ((,class :inherit modus-themes-special-warm))) `(custom-invalid ((,class :inherit (modus-themes-intense-red bold)))) `(custom-modified ((,class :inherit modus-themes-subtle-cyan))) @@ -4814,7 +4949,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(deft-filter-string-face ((,class :foreground ,green-intense))) `(deft-header-face ((,class :inherit bold :foreground ,fg-special-warm))) `(deft-separator-face ((,class :inherit shadow))) - `(deft-summary-face ((,class :inherit modus-themes-slant :foreground ,fg-alt))) + `(deft-summary-face ((,class :inherit (shadow modus-themes-slant)))) `(deft-time-face ((,class :foreground ,fg-special-cold))) `(deft-title-face ((,class :inherit bold :foreground ,fg-main))) ;;;;; dictionary @@ -4862,7 +4997,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(dir-treeview-audio-icon-face ((,class :inherit dir-treeview-default-icon-face :foreground ,magenta-alt))) `(dir-treeview-control-face ((,class :inherit shadow))) `(dir-treeview-control-mouse-face ((,class :inherit highlight))) - `(dir-treeview-default-icon-face ((,class :inherit bold :family "Font Awesome" :foreground ,fg-alt))) + `(dir-treeview-default-icon-face ((,class :inherit (shadow bold) :family "Font Awesome"))) `(dir-treeview-default-filename-face ((,class :foreground ,fg-main))) `(dir-treeview-directory-face ((,class :foreground ,blue))) `(dir-treeview-directory-icon-face ((,class :inherit dir-treeview-default-icon-face :foreground ,blue-alt))) @@ -5484,8 +5619,8 @@ by virtue of calling either of `modus-themes-load-operandi' and `(git-gutter-fr:modified ((,class :inherit modus-themes-fringe-yellow))) ;;;;; git-{gutter,fringe}+ `(git-gutter+-added ((,class :inherit ,@(modus-themes--diff-deuteran - 'modus-themes-fringe-blue - 'modus-themes-fringe-green)))) + 'modus-themes-fringe-blue + 'modus-themes-fringe-green)))) `(git-gutter+-deleted ((,class :inherit modus-themes-fringe-red))) `(git-gutter+-modified ((,class :inherit modus-themes-fringe-yellow))) `(git-gutter+-separator ((,class :inherit modus-themes-fringe-cyan))) @@ -5851,6 +5986,11 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; iflipb `(iflipb-current-buffer-face ((,class :inherit bold :foreground ,cyan-alt))) `(iflipb-other-buffer-face ((,class :inherit shadow))) +;;;;; image-dired + `(image-dired-thumb-flagged ((,class :background ,red-intense-bg))) + `(image-dired-thumb-mark ((,class :background ,@(modus-themes--success-deuteran + cyan-intense-bg + green-intense-bg)))) ;;;;; imenu-list `(imenu-list-entry-face-0 ((,class :foreground ,cyan))) `(imenu-list-entry-face-1 ((,class :foreground ,blue))) @@ -5862,7 +6002,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(imenu-list-entry-subalist-face-3 ((,class :inherit bold :foreground ,red-alt-other :underline t))) ;;;;; indium `(indium-breakpoint-face ((,class :foreground ,red-active))) - `(indium-frame-url-face ((,class :inherit button :foreground ,fg-alt))) + `(indium-frame-url-face ((,class :inherit (shadow button)))) `(indium-keyword-face ((,class :inherit font-lock-keyword-face))) `(indium-litable-face ((,class :inherit modus-themes-slant :foreground ,fg-special-warm))) `(indium-repl-error-face ((,class :inherit error))) @@ -5870,8 +6010,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(indium-repl-stdout-face ((,class :foreground ,fg-main))) ;;;;; info `(Info-quoted ((,class :inherit modus-themes-fixed-pitch ; the capitalization is canonical - :background ,bg-alt :foreground ,fg-special-calm))) - `(info-header-node ((,class :inherit bold :foreground ,fg-alt))) + ,@(modus-themes--markup fg-special-calm magenta-alt + bg-alt magenta-nuanced-bg)))) + `(info-header-node ((,class :inherit (shadow bold)))) `(info-header-xref ((,class :foreground ,blue-active))) `(info-index-match ((,class :inherit match))) `(info-menu-header ((,class :inherit modus-themes-heading-3))) @@ -5882,7 +6023,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(info-title-3 ((,class :inherit modus-themes-heading-3))) `(info-title-4 ((,class :inherit modus-themes-heading-4))) ;;;;; info-colors - `(info-colors-lisp-code-block ((,class :inherit fixed-pitch))) + `(info-colors-lisp-code-block ((,class :inherit modus-themes-fixed-pitch))) `(info-colors-ref-item-command ((,class :inherit font-lock-function-name-face))) `(info-colors-ref-item-constant ((,class :inherit font-lock-constant-face))) `(info-colors-ref-item-function ((,class :inherit font-lock-function-name-face))) @@ -6089,7 +6230,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(lsp-face-semhl-variable ((,class :foreground ,cyan))) `(lsp-face-semhl-variable-local ((,class :foreground ,cyan))) `(lsp-face-semhl-variable-parameter ((,class :foreground ,cyan-alt-other))) - `(lsp-lens-face ((,class :height 0.8 :foreground ,fg-alt))) + `(lsp-lens-face ((,class :inherit shadow :height 0.8))) `(lsp-lens-mouse-face ((,class :height 0.8 :foreground ,blue-alt-other :underline t))) `(lsp-ui-doc-background ((,class :background ,bg-alt))) `(lsp-ui-doc-header ((,class :background ,bg-header :foreground ,fg-header))) @@ -6309,13 +6450,14 @@ by virtue of calling either of `modus-themes-load-operandi' and `(markdown-html-tag-name-face ((,class :inherit modus-themes-fixed-pitch :foreground ,magenta-alt))) `(markdown-inline-code-face ((,class :inherit modus-themes-fixed-pitch - :background ,bg-alt :foreground ,fg-special-calm))) + ,@(modus-themes--markup fg-special-calm magenta-alt + bg-alt magenta-nuanced-bg)))) `(markdown-italic-face ((,class :inherit italic))) `(markdown-language-info-face ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-special-cold))) `(markdown-language-keyword-face ((,class :inherit modus-themes-fixed-pitch - :background ,bg-alt - :foreground ,fg-alt))) + ,@(modus-themes--markup fg-alt red-alt + bg-alt red-nuanced-bg)))) `(markdown-line-break-face ((,class :inherit modus-themes-refine-cyan :underline t))) `(markdown-link-face ((,class :inherit button))) `(markdown-link-title-face ((,class :inherit modus-themes-slant :foreground ,fg-special-cold))) @@ -6349,7 +6491,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(markup-meta-face ((,class :inherit shadow))) `(markup-meta-hide-face ((,class :foreground "gray50"))) `(markup-reference-face ((,class :foreground ,blue-alt :underline ,bg-region))) - `(markup-replacement-face ((,class :inherit fixed-pitch :foreground ,red-alt))) + `(markup-replacement-face ((,class :inherit modus-themes-fixed-pitch :foreground ,red-alt))) `(markup-secondary-text-face ((,class :height 0.9 :foreground ,cyan-alt-other))) `(markup-small-face ((,class :inherit markup-gen-face :height 0.9))) `(markup-strong-face ((,class :inherit markup-bold-face))) @@ -6479,7 +6621,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(mu4e-title-face ((,class :foreground ,fg-main))) `(mu4e-trashed-face ((,class :foreground ,red))) `(mu4e-unread-face ((,class :inherit bold))) - `(mu4e-url-number-face ((,class :foreground ,fg-alt))) + `(mu4e-url-number-face ((,class :inherit shadow))) `(mu4e-view-body-face ((,class :foreground ,fg-main))) `(mu4e-warning-face ((,class :inherit warning))) ;;;;; mu4e-conversation @@ -6498,6 +6640,17 @@ by virtue of calling either of `modus-themes-load-operandi' and `(mc/cursor-bar-face ((,class :height 1 :background ,fg-main))) `(mc/cursor-face ((,class :inverse-video t))) `(mc/region-face ((,class :inherit region))) +;;;;; nano-modeline + `(nano-modeline-active-primary ((,class :inherit mode-line :foreground ,fg-special-mild))) + `(nano-modeline-active-secondary ((,class :inherit mode-line :foreground ,fg-special-cold))) + `(nano-modeline-active-status-** ((,class :inherit mode-line :background ,yellow-subtle-bg))) + `(nano-modeline-active-status-RO ((,class :inherit mode-line :background ,red-subtle-bg))) + `(nano-modeline-active-status-RW ((,class :inherit mode-line :background ,cyan-subtle-bg))) + `(nano-modeline-inactive-primary ((,class :inherit mode-line-inactive :foreground ,fg-inactive))) + `(nano-modeline-inactive-secondary ((,class :inherit mode-line-inactive :foreground ,fg-inactive))) + `(nano-modeline-inactive-status-** ((,class :inherit mode-line-inactive :foreground ,yellow-active))) + `(nano-modeline-inactive-status-RO ((,class :inherit mode-line-inactive :foreground ,red-active))) + `(nano-modeline-inactive-status-RW ((,class :inherit mode-line-inactive :foreground ,cyan-active))) ;;;;; neotree `(neo-banner-face ((,class :foreground ,magenta))) `(neo-button-face ((,class :inherit button))) @@ -6507,7 +6660,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(neo-header-face ((,class :inherit bold :foreground ,fg-main))) `(neo-root-dir-face ((,class :inherit bold :foreground ,cyan-alt))) `(neo-vc-added-face ((,class :foreground ,@(modus-themes--diff-deuteran blue green)))) - `(neo-vc-conflict-face ((,class :inherit bold :foreground ,red))) + `(neo-vc-conflict-face ((,class :inherit error))) `(neo-vc-default-face ((,class :foreground ,fg-main))) `(neo-vc-edited-face ((,class :foreground ,yellow))) `(neo-vc-ignored-face ((,class :foreground ,fg-inactive))) @@ -6601,17 +6754,20 @@ by virtue of calling either of `modus-themes-load-operandi' and yellow-refine-bg yellow-refine-fg)))) ;;;;; org `(org-agenda-calendar-event ((,class ,@(modus-themes--agenda-event blue-alt)))) - `(org-agenda-calendar-sexp ((,class :inherit org-agenda-calendar-event))) + `(org-agenda-calendar-sexp ((,class ,@(modus-themes--agenda-event blue-alt t)))) `(org-agenda-clocking ((,class :inherit modus-themes-special-cold :extend t))) `(org-agenda-column-dateline ((,class :background ,bg-alt))) `(org-agenda-current-time ((,class :foreground ,blue-alt-other-faint))) `(org-agenda-date ((,class ,@(modus-themes--agenda-date cyan fg-main)))) - `(org-agenda-date-today ((,class ,@(modus-themes--agenda-date blue-active fg-main - cyan-active fg-main - bg-active t t)))) - `(org-agenda-date-weekend ((,class ,@(modus-themes--agenda-date cyan-alt-other fg-alt + `(org-agenda-date-today ((,class ,@(modus-themes--agenda-date cyan fg-main + nil nil + bg-inactive t t)))) + `(org-agenda-date-weekend ((,class ,@(modus-themes--agenda-date cyan-alt-other-faint fg-alt cyan fg-main)))) - `(org-agenda-diary ((,class :inherit org-agenda-calendar-event))) + `(org-agenda-date-weekend-today ((,class ,@(modus-themes--agenda-date cyan-alt-other-faint fg-alt + cyan fg-main + bg-inactive t t)))) + `(org-agenda-diary ((,class :inherit org-agenda-calendar-sexp))) `(org-agenda-dimmed-todo-face ((,class :inherit shadow))) `(org-agenda-done ((,class :foreground ,@(modus-themes--success-deuteran blue-nuanced-fg @@ -6622,6 +6778,8 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-agenda-filter-tags ((,class :inherit bold :foreground ,cyan-active))) `(org-agenda-restriction-lock ((,class :background ,bg-dim :foreground ,fg-dim))) `(org-agenda-structure ((,class ,@(modus-themes--agenda-structure blue-alt)))) + `(org-agenda-structure-filter ((,class :inherit org-agenda-structure :foreground ,yellow))) + `(org-agenda-structure-secondary ((,class :foreground ,cyan))) `(org-archived ((,class :background ,bg-alt :foreground ,fg-alt))) `(org-block ((,class :inherit modus-themes-fixed-pitch ,@(modus-themes--org-block bg-dim fg-main)))) @@ -6636,23 +6794,24 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-checkbox-statistics-todo ((,class :inherit org-todo))) `(org-clock-overlay ((,class :inherit modus-themes-special-cold))) `(org-code ((,class :inherit modus-themes-fixed-pitch - :background ,bg-alt :foreground ,fg-special-mild + ,@(modus-themes--markup fg-special-mild green-alt-other + bg-alt green-nuanced-bg) :extend t))) `(org-column ((,class :background ,bg-alt))) `(org-column-title ((,class :inherit bold :underline t :background ,bg-alt))) - `(org-date ((,class :inherit ,(if modus-themes-no-mixed-fonts - 'button - '(button fixed-pitch)) + `(org-date ((,class :inherit ,(if modus-themes-mixed-fonts + '(button fixed-pitch) + 'button) ,@(modus-themes--link-color cyan cyan-faint)))) `(org-date-selected ((,class :inherit bold :foreground ,blue-alt :inverse-video t))) `(org-dispatcher-highlight ((,class :inherit (bold modus-themes-mark-alt)))) `(org-document-info ((,class :foreground ,fg-special-cold))) - `(org-document-info-keyword ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-alt))) + `(org-document-info-keyword ((,class :inherit (shadow modus-themes-fixed-pitch)))) `(org-document-title ((,class :inherit (bold modus-themes-variable-pitch) :foreground ,fg-special-cold ,@(modus-themes--scale modus-themes-scale-title)))) `(org-done ((,class :foreground ,@(modus-themes--success-deuteran blue green)))) - `(org-drawer ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-alt))) + `(org-drawer ((,class :inherit (shadow modus-themes-fixed-pitch)))) `(org-ellipsis (())) ; inherits from the heading's color `(org-footnote ((,class :inherit button ,@(modus-themes--link-color @@ -6701,6 +6860,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-headline-todo ((,class :inherit modus-themes-variable-pitch :foreground ,red-nuanced-fg))) `(org-hide ((,class :foreground ,bg-main))) `(org-indent ((,class :inherit (fixed-pitch org-hide)))) + `(org-imminent-deadline ((,class :foreground ,red-intense))) `(org-latex-and-related ((,class :foreground ,magenta-refine-fg))) `(org-level-1 ((,class :inherit modus-themes-heading-1))) `(org-level-2 ((,class :inherit modus-themes-heading-2))) @@ -6713,8 +6873,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-link ((,class :inherit button))) `(org-list-dt ((,class :inherit bold))) `(org-macro ((,class :inherit modus-themes-fixed-pitch - :background ,cyan-nuanced-bg :foreground ,cyan-nuanced-fg))) - `(org-meta-line ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-alt))) + ,@(modus-themes--markup cyan-nuanced-fg cyan + cyan-nuanced-bg cyan-nuanced-bg)))) + `(org-meta-line ((,class :inherit (shadow modus-themes-fixed-pitch)))) `(org-mode-line-clock ((,class :foreground ,fg-main))) `(org-mode-line-clock-overrun ((,class :inherit bold :foreground ,red-active))) `(org-priority ((,class :foreground ,magenta))) @@ -6724,18 +6885,19 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-scheduled-previously ((,class ,@(modus-themes--agenda-scheduled yellow fg-special-warm yellow-alt-other)))) `(org-scheduled-today ((,class ,@(modus-themes--agenda-scheduled yellow fg-special-warm magenta-alt-other)))) `(org-sexp-date ((,class :inherit org-date))) - `(org-special-keyword ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-alt))) + `(org-special-keyword ((,class :inherit (shadow modus-themes-fixed-pitch)))) `(org-table ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-special-cold))) `(org-table-header ((,class :inherit (fixed-pitch modus-themes-intense-neutral)))) `(org-tag ((,class :foreground ,magenta-nuanced-fg))) `(org-tag-group ((,class :inherit bold :foreground ,cyan-nuanced-fg))) `(org-target ((,class :underline t))) - `(org-time-grid ((,class :foreground ,fg-unfocused))) + `(org-time-grid ((,class :inherit shadow))) `(org-todo ((,class :foreground ,red))) `(org-upcoming-deadline ((,class :foreground ,red-alt-other))) `(org-upcoming-distant-deadline ((,class :foreground ,red-faint))) `(org-verbatim ((,class :inherit modus-themes-fixed-pitch - :background ,bg-alt :foreground ,fg-special-calm))) + ,@(modus-themes--markup fg-special-calm magenta-alt + bg-alt magenta-nuanced-bg)))) `(org-verse ((,class :inherit org-quote))) `(org-warning ((,class :inherit bold :foreground ,red-alt-other))) ;;;;; org-journal @@ -6764,7 +6926,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-roam-link-shielded ((,class :inherit button ,@(modus-themes--link-color yellow yellow-faint)))) - `(org-roam-tag ((,class :inherit italic :foreground ,fg-alt))) + `(org-roam-tag ((,class :inherit (shadow italic)))) ;;;;; org-superstar `(org-superstar-item ((,class :foreground ,fg-main))) `(org-superstar-leading ((,class :foreground ,fg-whitespace))) @@ -6863,7 +7025,7 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; pomidor `(pomidor-break-face ((,class :foreground ,blue-alt-other))) `(pomidor-overwork-face ((,class :foreground ,red-alt-other))) - `(pomidor-skip-face ((,class :inherit modus-themes-slant :foreground ,fg-alt))) + `(pomidor-skip-face ((,class :inherit (shadow modus-themes-slant)))) `(pomidor-work-face ((,class :foreground ,@(modus-themes--success-deuteran blue-alt green-alt-other)))) @@ -6914,7 +7076,7 @@ by virtue of calling either of `modus-themes-load-operandi' and :foreground ,green))) `(racket-here-string-face ((,class :foreground ,blue-alt))) `(racket-keyword-argument-face ((,class :foreground ,red-alt))) - `(racket-logger-config-face ((,class :inherit modus-themes-slant :foreground ,fg-alt))) + `(racket-logger-config-face ((,class :inherit (shadow modus-themes-slant)))) `(racket-logger-debug-face ((,class :foreground ,blue-alt-other))) `(racket-logger-info-face ((,class :foreground ,fg-lang-note))) `(racket-logger-topic-face ((,class :inherit modus-themes-slant :foreground ,magenta))) @@ -7208,7 +7370,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(spray-base-face ((,class :inherit default :foreground ,fg-special-cold))) ;;;;; stripes `(stripes ((,class :background ,bg-alt))) -;;;;; success +;;;;; suggest `(suggest-heading ((,class :inherit bold :foreground ,yellow-alt-other))) ;;;;; switch-window `(switch-window-background ((,class :background ,bg-dim))) @@ -7255,7 +7417,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(sx-question-mode-score-downvoted ((,class :foreground ,yellow))) `(sx-question-mode-score-upvoted ((,class :inherit bold :foreground ,magenta))) `(sx-question-mode-title ((,class :inherit bold :foreground ,fg-main))) - `(sx-question-mode-title-comments ((,class :inherit bold :foreground ,fg-alt))) + `(sx-question-mode-title-comments ((,class :inherit (shadow bold)))) `(sx-tag ((,class :foreground ,magenta-alt))) `(sx-user-name ((,class :foreground ,blue-alt))) `(sx-user-reputation ((,class :inherit shadow))) @@ -7318,9 +7480,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(telega-button-active ((,class :box ,blue-intense-bg :background ,blue-intense-bg :foreground ,fg-main))) `(telega-button-highlight ((,class :inherit modus-themes-subtle-magenta))) `(telega-chat-prompt ((,class :inherit bold))) - `(telega-entity-type-code ((,class :inherit fixed-pitch))) + `(telega-entity-type-code ((,class :inherit modus-themes-fixed-pitch))) `(telega-entity-type-mention ((,class :foreground ,cyan))) - `(telega-entity-type-pre ((,class :inherit fixed-pitch))) + `(telega-entity-type-pre ((,class :inherit modus-themes-fixed-pitch))) `(telega-msg-heading ((,class :background ,bg-alt))) `(telega-msg-self-title ((,class :inherit bold))) `(telega-root-heading ((,class :inherit modus-themes-subtle-neutral))) @@ -7329,9 +7491,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(telega-user-online-status ((,class :foreground ,cyan-active))) `(telega-username ((,class :foreground ,cyan-alt-other))) `(telega-webpage-chat-link ((,class :background ,bg-alt))) - `(telega-webpage-fixed ((,class :inherit fixed-pitch :height 0.85))) + `(telega-webpage-fixed ((,class :inherit modus-themes-fixed-pitch :height 0.85))) `(telega-webpage-header ((,class :inherit modus-themes-variable-pitch :height 1.3))) - `(telega-webpage-preformatted ((,class :inherit fixed-pitch :background ,bg-alt))) + `(telega-webpage-preformatted ((,class :inherit modus-themes-fixed-pitch :background ,bg-alt))) `(telega-webpage-subheader ((,class :inherit modus-themes-variable-pitch :height 1.15))) ;;;;; telephone-line `(telephone-line-accent-active ((,class :background ,fg-inactive :foreground ,bg-inactive))) @@ -7383,10 +7545,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(transient-heading ((,class :inherit bold :foreground ,fg-main))) `(transient-inactive-argument ((,class :inherit shadow))) `(transient-inactive-value ((,class :inherit shadow))) - ;; FIXME 2021-08-28: using `modus-themes-key-binding' leads to - ;; misalignments because of the added box property. - ;; `(transient-key ((,class :inherit modus-themes-key-binding))) - `(transient-key ((,class :inherit bold :foreground ,blue-alt-other))) + `(transient-key ((,class :inherit modus-themes-key-binding))) `(transient-mismatched-key ((,class :underline t))) `(transient-nonstandard-key ((,class :underline t))) `(transient-pink ((,class :inherit bold :foreground ,magenta-alt-faint))) @@ -7473,10 +7632,10 @@ by virtue of calling either of `modus-themes-load-operandi' and `(vc-dir-header-value ((,class :foreground ,magenta-alt-other))) `(vc-dir-mark-indicator ((,class :foreground ,blue-alt-other))) `(vc-dir-status-edited ((,class :foreground ,yellow))) - `(vc-dir-status-ignored ((,class :foreground ,fg-unfocused))) + `(vc-dir-status-ignored ((,class :inherit shadow))) `(vc-dir-status-up-to-date ((,class :foreground ,cyan))) - `(vc-dir-status-warning ((,class :foreground ,red))) - `(vc-conflict-state ((,class :inherit modus-themes-slant :foreground ,red-active))) + `(vc-dir-status-warning ((,class :inherit error))) + `(vc-conflict-state ((,class :inherit bold :foreground ,red-active))) `(vc-edited-state ((,class :foreground ,yellow-active))) `(vc-locally-added-state ((,class :foreground ,cyan-active))) `(vc-locked-state ((,class :foreground ,blue-active))) @@ -7498,6 +7657,9 @@ by virtue of calling either of `modus-themes-load-operandi' and :background ,@(pcase modus-themes-completions ('opinionated (list bg-active)) (_ (list bg-inactive)))))) +;;;;; vertico-quick + `(vertico-quick1 ((,class :inherit (modus-themes-intense-magenta bold)))) + `(vertico-quick2 ((,class :inherit (modus-themes-refine-cyan bold)))) ;;;;; vimish-fold `(vimish-fold-fringe ((,class :foreground ,cyan-active))) `(vimish-fold-mouse-face ((,class :inherit modus-themes-intense-blue))) diff --git a/etc/themes/modus-vivendi-theme.el b/etc/themes/modus-vivendi-theme.el index 919009278b..6dffbf07e9 100644 --- a/etc/themes/modus-vivendi-theme.el +++ b/etc/themes/modus-vivendi-theme.el @@ -4,8 +4,8 @@ ;; Author: Protesilaos Stavrou ;; URL: https://gitlab.com/protesilaos/modus-themes -;; Version: 1.6.0 -;; Package-Requires: ((emacs "26.1")) +;; Version: 1.7.0 +;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility ;; This file is part of GNU Emacs. commit 6c1190c74936f132cb4173335cb037de89ef8aa7 Author: Michael Albinus Date: Thu Nov 18 15:06:26 2021 +0100 Extend abbreviate-file-name for further Tramp methods. * lisp/net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist): Add 'abbreviate-file-name'. (tramp-gvfs-handle-expand-file-name): * lisp/net/tramp.el (tramp-handle-expand-file-name): Handle case that tilde cannot be expanded. * test/lisp/net/tramp-tests.el (tramp-test07-abbreviate-file-name): Extend test. diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index a4a7bacd8a..ab71c9cd13 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -744,7 +744,7 @@ It has been changed in GVFS 1.14.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-gvfs-file-name-handler-alist - '(;; `abbreviate-file-name' performed by default handler. + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) (access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. @@ -1149,15 +1149,12 @@ file names." (make-tramp-file-name :method method :user user :domain domain :host host :port port :localname "/" :hop hop))) - (setq localname - (replace-match - (tramp-get-connection-property v "default-location" "~") - nil t localname 1))) - ;; Tilde expansion is not possible. - (when (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) - (tramp-error - v 'file-error - "Cannot expand tilde in file `%s'" name)) + (unless (string-empty-p + (tramp-get-connection-property v "default-location" "")) + (setq localname + (replace-match + (tramp-get-connection-property v "default-location" "~") + nil t localname 1)))) (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) ;; We do not pass "/..". @@ -1172,10 +1169,12 @@ file names." ;; Do not keep "/..". (when (string-match-p "^/\\.\\.?$" localname) (setq localname "/")) - ;; No tilde characters in file name, do normal - ;; `expand-file-name' (this does "/./" and "/../"). + ;; Do normal `expand-file-name' (this does "/./" and "/../"), + ;; unless there are tilde characters in file name. (tramp-make-tramp-file-name - v (tramp-run-real-handler #'expand-file-name (list localname)))))) + v (if (string-match-p "\\`~" localname) + localname + (tramp-run-real-handler #'expand-file-name (list localname))))))) (defun tramp-gvfs-get-directory-attributes (directory) "Return GVFS attributes association list of all files in DIRECTORY." diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 7927ddd107..f43c1d84b8 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3454,13 +3454,16 @@ User is always nil." ;; Do not keep "/..". (when (string-match-p "^/\\.\\.?$" localname) (setq localname "/")) - ;; Do normal `expand-file-name' (this does "/./" and "/../"). + ;; Do normal `expand-file-name' (this does "/./" and "/../"), + ;; unless there are tilde characters in file name. ;; `default-directory' is bound, because on Windows there would ;; be problems with UNC shares or Cygwin mounts. (let ((default-directory tramp-compat-temporary-file-directory)) (tramp-make-tramp-file-name - v (tramp-drop-volume-letter - (tramp-run-real-handler #'expand-file-name (list localname)))))))) + v (if (string-match-p "\\`~" localname) + localname + (tramp-drop-volume-letter + (tramp-run-real-handler #'expand-file-name (list localname))))))))) (defun tramp-handle-file-accessible-directory-p (filename) "Like `file-accessible-directory-p' for Tramp files." diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 482d3ff554..98269d5fa3 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2295,7 +2295,10 @@ This checks also `file-name-as-directory', `file-name-directory', (skip-unless (tramp--test-emacs29-p)) (let* ((remote-host (file-remote-p tramp-test-temporary-file-directory)) - (home-dir (expand-file-name (concat remote-host "~")))) + ;; Not all methods can expand "~". + (home-dir (ignore-errors (expand-file-name (concat remote-host "~"))))) + (skip-unless home-dir) + ;; Check home-dir abbreviation. (unless (string-suffix-p "~" home-dir) (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) commit f8478dc133839fc9e2b395bef0c8e8f1d7d18b35 Author: Filipp Gunbin Date: Thu Nov 18 17:03:43 2021 +0300 Fixup for bug#51037 * lisp/emacs-lisp/ert.el (ert-batch-backtrace-line-length): Fix docstring. (ert-run-tests-batch): Remove redundand let-binding. (ert-run-tests-interactively): Fix interactive spec. diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index dc9cbc4745..946193e40d 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -101,12 +101,10 @@ produce extremely long lines in backtraces and lengthy delays in forming them. This variable governs the target maximum line length by manipulating these two variables while printing stack traces. Setting this variable to t will re-use the value of -`backtrace-line-length' while print stack traces in ERT batch -mode. A value of nil will short-circuit this mechanism; line -lengths will be completely determined by `ert-batch-line-length' -and `ert-batch-line-level'. Any other value will be temporarily -bound to `backtrace-line-length' when producing stack traces -in batch mode.") +`backtrace-line-length' while printing stack traces in ERT batch +mode. Any other value will be temporarily bound to +`backtrace-line-length' when producing stack traces in batch +mode.") (defface ert-test-result-expected '((((class color) (background light)) :background "green1") @@ -1451,13 +1449,9 @@ Returns the stats object." (message "Test %S backtrace:" (ert-test-name test)) (with-temp-buffer (let ((backtrace-line-length - (cond - ((eq ert-batch-backtrace-line-length t) - backtrace-line-length) - ((eq ert-batch-backtrace-line-length nil) - nil) - (t - ert-batch-backtrace-line-length))) + (if (eq ert-batch-backtrace-line-length t) + backtrace-line-length + ert-batch-backtrace-line-length)) (print-level ert-batch-print-level) (print-length ert-batch-print-length)) (insert (backtrace-to-string @@ -2062,8 +2056,7 @@ SELECTOR works as described in `ert-select-tests'." (read (completing-read (format-prompt "Run tests" default) obarray #'ert-test-boundp nil nil - 'ert--selector-history default nil))) - nil)) + 'ert--selector-history default nil))))) (let (buffer listener) (setq listener (lambda (event-type &rest event-args) commit 7a1e5ac8b29b731e89cc9d5b498e31bd90840b9b Author: Mattias Engdegård Date: Thu Nov 18 12:47:35 2021 +0100 Eliminate ERT test name clashes (bug#51941) * test/lisp/electric-tests.el (js-mode-braces-with-layout-and-indent): * test/lisp/emacs-lisp/cl-lib-tests.el (cl-lib-test-fifth): * test/lisp/thingatpt-tests.el (test-symbol-thing-2): Remove duplicated tests. * test/lisp/emacs-lisp/generator-tests.el (cps-loop): * test/lisp/emacs-lisp/ring-tests.el (ring-tests-insert): * test/lisp/help-tests.el (help-tests-substitute-command-keys/no-change): * test/lisp/net/netrc-tests.el (test-netrc-credentials): * test/lisp/progmodes/elisp-mode-tests.el (elisp-completes-functions-after-let-bindings): * test/lisp/thingatpt-tests.el (test-symbol-thing-3): * test/src/buffer-tests.el (deftest-overlayp-1, buffer-tests--*): * test/src/buffer-tests.el (test-buffer-swap-text-1): * test/src/data-tests.el (binding-test-set-constant-nil) (data-tests-logcount): Rename clashing tests. diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el index 1e32dbfb60..feeae2b82a 100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@ -550,16 +550,6 @@ baz\"\"" (electric-indent-mode 1) (electric-layout-mode 1))) -(define-electric-pair-test js-mode-braces-with-layout-and-indent - "" "{" :expected-string "{\n \n}" :expected-point 7 - :modes '(js-mode) - :test-in-comments nil - :test-in-strings nil - :fixture-fn (lambda () - (electric-pair-mode 1) - (electric-indent-mode 1) - (electric-layout-mode 1))) - ;;; Backspacing ;;; TODO: better tests diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index a132d73638..854e371b32 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -353,13 +353,6 @@ (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) (should-error (cl-fifth "12345") :type 'wrong-type-argument)) -(ert-deftest cl-lib-test-fifth () - (should (null (cl-fifth '()))) - (should (null (cl-fifth '(1 2 3 4)))) - (should (= 5 (cl-fifth '(1 2 3 4 5)))) - (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) - (should-error (cl-fifth "12345") :type 'wrong-type-argument)) - (ert-deftest cl-lib-test-sixth () (should (null (cl-sixth '()))) (should (null (cl-sixth '(1 2 3 4 5)))) diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index c81d3d09e7..50b8cc53a2 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -219,7 +219,7 @@ identical output." (should (eql (iter-next it -1) 42)) (should (eql (iter-next it -1) -1)))) -(ert-deftest cps-loop () +(ert-deftest cps-loop-2 () (should (equal (cl-loop for x iter-by (mygenerator 42) collect x) diff --git a/test/lisp/emacs-lisp/ring-tests.el b/test/lisp/emacs-lisp/ring-tests.el index 55df4f3668..3ec20a1e8e 100644 --- a/test/lisp/emacs-lisp/ring-tests.el +++ b/test/lisp/emacs-lisp/ring-tests.el @@ -199,7 +199,7 @@ (should (= (ring-size ring) 3)) (should (equal (ring-elements ring) '(5 4 3))))) -(ert-deftest ring-tests-insert () +(ert-deftest ring-tests-insert-2 () (let ((ring (make-ring 2))) (ring-insert+extend ring :a) (ring-insert+extend ring :b) diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el index a331ec440a..982750f479 100644 --- a/test/lisp/help-tests.el +++ b/test/lisp/help-tests.el @@ -174,7 +174,7 @@ M-g M-c switch-to-completions (let ((text-quoting-style 'grave)) (test "\\=`x\\='" "`x'")))) -(ert-deftest help-tests-substitute-command-keys/no-change () +(ert-deftest help-tests-substitute-command-keys/no-change-2 () (with-substitute-command-keys-test (test "\\[foobar" "\\[foobar") (test "\\=" "\\="))) diff --git a/test/lisp/net/netrc-tests.el b/test/lisp/net/netrc-tests.el index f75328a59f..2f68b9bbb2 100644 --- a/test/lisp/net/netrc-tests.el +++ b/test/lisp/net/netrc-tests.el @@ -48,7 +48,7 @@ (should (equal (netrc-credentials "ftp.example.org") '("jrh" "*baz*"))))) -(ert-deftest test-netrc-credentials () +(ert-deftest test-netrc-credentials-2 () (let ((netrc-file (ert-resource-file "netrc-folding"))) (should (equal (netrc-parse netrc-file) diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index 7f1cd6795e..b91f7331a8 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -109,7 +109,7 @@ (should (member "backup-inhibited" comps)) (should-not (member "backup-buffer" comps)))))) -(ert-deftest elisp-completes-functions-after-let-bindings () +(ert-deftest elisp-completes-functions-after-let-bindings-2 () (with-temp-buffer (emacs-lisp-mode) (insert "(let ((bar 1) (baz 2)) (ba") diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index 2a32dc57b1..f2031fa79a 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -170,21 +170,13 @@ position to retrieve THING.") (forward-char -1) (should (eq (symbol-at-point) 'bar)))) -(ert-deftest test-symbol-thing-2 () - (with-temp-buffer - (insert " bar ") - (goto-char (point-max)) - (should (eq (symbol-at-point) nil)) - (forward-char -1) - (should (eq (symbol-at-point) 'bar)))) - (ert-deftest test-symbol-thing-3 () (with-temp-buffer (insert "bar") (goto-char 2) (should (eq (symbol-at-point) 'bar)))) -(ert-deftest test-symbol-thing-3 () +(ert-deftest test-symbol-thing-4 () (with-temp-buffer (insert "`[[`(") (goto-char 2) diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 7943ac2ec2..9b7023d18b 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -147,7 +147,7 @@ with parameters from the *Messages* buffer modification." (defmacro deftest-overlayp-1 (id arg-expr should-expr) (declare (indent 1)) - `(ert-deftest ,(buffer-tests--make-test-name 'overlay-buffer 1 id) () + `(ert-deftest ,(buffer-tests--make-test-name 'overlayp 1 id) () (with-temp-buffer (should (equal ,should-expr (overlayp ,arg-expr)))))) @@ -436,14 +436,14 @@ with parameters from the *Messages* buffer modification." (deftest-next-overlay-change-1 I 10 (point-max) (10 10)) (deftest-next-overlay-change-1 J 20 (point-max) (10 10)) ;; 2 non-empty, non-intersecting -(deftest-next-overlay-change-1 D 10 20 (20 30) (40 50)) -(deftest-next-overlay-change-1 E 35 40 (20 30) (40 50)) -(deftest-next-overlay-change-1 F 60 (point-max) (20 30) (40 50)) -(deftest-next-overlay-change-1 G 30 40 (20 30) (40 50)) -(deftest-next-overlay-change-1 H 50 (point-max) (20 30) (40 50)) +(deftest-next-overlay-change-1 D2 10 20 (20 30) (40 50)) +(deftest-next-overlay-change-1 E2 35 40 (20 30) (40 50)) +(deftest-next-overlay-change-1 F2 60 (point-max) (20 30) (40 50)) +(deftest-next-overlay-change-1 G2 30 40 (20 30) (40 50)) +(deftest-next-overlay-change-1 H2 50 (point-max) (20 30) (40 50)) ;; 2 non-empty, intersecting -(deftest-next-overlay-change-1 I 10 20 (20 30) (25 35)) -(deftest-next-overlay-change-1 J 20 25 (20 30) (25 35)) +(deftest-next-overlay-change-1 I2 10 20 (20 30) (25 35)) +(deftest-next-overlay-change-1 J2 20 25 (20 30) (25 35)) (deftest-next-overlay-change-1 K 23 25 (20 30) (25 35)) (deftest-next-overlay-change-1 L 25 30 (20 30) (25 35)) (deftest-next-overlay-change-1 M 28 30 (20 30) (25 35)) @@ -473,11 +473,11 @@ with parameters from the *Messages* buffer modification." (deftest-next-overlay-change-1 k 30 (point-max) (20 20) (20 30)) (deftest-next-overlay-change-1 l 40 (point-max) (20 20) (20 30)) ;; 1 empty, 1 non-empty, intersecting at end -(deftest-next-overlay-change-1 h 10 20 (30 30) (20 30)) -(deftest-next-overlay-change-1 i 20 30 (30 30) (20 30)) -(deftest-next-overlay-change-1 j 25 30 (30 30) (20 30)) -(deftest-next-overlay-change-1 k 30 (point-max) (20 20) (20 30)) -(deftest-next-overlay-change-1 l 40 (point-max) (20 20) (20 30)) +(deftest-next-overlay-change-1 h2 10 20 (30 30) (20 30)) +(deftest-next-overlay-change-1 i2 20 30 (30 30) (20 30)) +(deftest-next-overlay-change-1 j2 25 30 (30 30) (20 30)) +(deftest-next-overlay-change-1 k2 30 (point-max) (20 20) (20 30)) +(deftest-next-overlay-change-1 l2 40 (point-max) (20 20) (20 30)) ;; 1 empty, 1 non-empty, intersecting in the middle (deftest-next-overlay-change-1 m 10 20 (25 25) (20 30)) (deftest-next-overlay-change-1 n 20 25 (25 25) (20 30)) @@ -524,14 +524,14 @@ with parameters from the *Messages* buffer modification." (deftest-previous-overlay-change-1 I 10 1 (10 10)) (deftest-previous-overlay-change-1 J 20 10 (10 10)) ;; 2 non-empty, non-intersecting -(deftest-previous-overlay-change-1 D 10 1 (20 30) (40 50)) -(deftest-previous-overlay-change-1 E 35 30 (20 30) (40 50)) -(deftest-previous-overlay-change-1 F 60 50 (20 30) (40 50)) -(deftest-previous-overlay-change-1 G 30 20 (20 30) (40 50)) -(deftest-previous-overlay-change-1 H 50 40 (20 30) (40 50)) +(deftest-previous-overlay-change-1 D2 10 1 (20 30) (40 50)) +(deftest-previous-overlay-change-1 E2 35 30 (20 30) (40 50)) +(deftest-previous-overlay-change-1 F2 60 50 (20 30) (40 50)) +(deftest-previous-overlay-change-1 G2 30 20 (20 30) (40 50)) +(deftest-previous-overlay-change-1 H2 50 40 (20 30) (40 50)) ;; 2 non-empty, intersecting -(deftest-previous-overlay-change-1 I 10 1 (20 30) (25 35)) -(deftest-previous-overlay-change-1 J 20 1 (20 30) (25 35)) +(deftest-previous-overlay-change-1 I2 10 1 (20 30) (25 35)) +(deftest-previous-overlay-change-1 J2 20 1 (20 30) (25 35)) (deftest-previous-overlay-change-1 K 23 20 (20 30) (25 35)) (deftest-previous-overlay-change-1 L 25 20 (20 30) (25 35)) (deftest-previous-overlay-change-1 M 28 25 (20 30) (25 35)) @@ -621,28 +621,28 @@ with parameters from the *Messages* buffer modification." (deftest-overlays-at-1 P 50 () (a 10 20) (b 30 40)) ;; 2 non-empty overlays intersecting -(deftest-overlays-at-1 G 1 () (a 10 30) (b 20 40)) -(deftest-overlays-at-1 H 10 (a) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 I 15 (a) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 K 20 (a b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 L 25 (a b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 M 30 (b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 N 35 (b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 O 40 () (a 10 30) (b 20 40)) -(deftest-overlays-at-1 P 50 () (a 10 30) (b 20 40)) +(deftest-overlays-at-1 G2 1 () (a 10 30) (b 20 40)) +(deftest-overlays-at-1 H2 10 (a) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 I2 15 (a) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 K2 20 (a b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 L2 25 (a b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 M2 30 (b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 N2 35 (b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 O2 40 () (a 10 30) (b 20 40)) +(deftest-overlays-at-1 P2 50 () (a 10 30) (b 20 40)) ;; 2 non-empty overlays continuous -(deftest-overlays-at-1 G 1 () (a 10 20) (b 20 30)) -(deftest-overlays-at-1 H 10 (a) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 I 15 (a) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 K 20 (b) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 L 25 (b) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 M 30 () (a 10 20) (b 20 30)) +(deftest-overlays-at-1 G3 1 () (a 10 20) (b 20 30)) +(deftest-overlays-at-1 H3 10 (a) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 I3 15 (a) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 K3 20 (b) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 L3 25 (b) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 M3 30 () (a 10 20) (b 20 30)) ;; overlays-at never returns empty overlays. -(deftest-overlays-at-1 N 1 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) -(deftest-overlays-at-1 O 20 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) -(deftest-overlays-at-1 P 30 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) +(deftest-overlays-at-1 N3 1 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) +(deftest-overlays-at-1 O3 20 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) +(deftest-overlays-at-1 P3 30 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) (deftest-overlays-at-1 Q 40 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) (deftest-overlays-at-1 R 50 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) (deftest-overlays-at-1 S 60 () (a 1 60) (c 1 1) (b 30 30) (d 50 50)) @@ -1109,7 +1109,7 @@ with parameters from the *Messages* buffer modification." (should (eq ov (car (overlays-in 1 1))))))))) ;; properties -(ert-deftest test-buffer-swap-text-1 () +(ert-deftest test-buffer-swap-text-2 () (buffer-tests--with-temp-buffers (buffer other) (with-current-buffer other (overlay-put (make-overlay 1 1) 'buffer 'other)) diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 756c41b6ff..dfc12735bd 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -419,7 +419,7 @@ comparing the subr with a much slower Lisp implementation." "Test setting a keyword constant." (with-no-warnings (should-error (setq :keyword 'bob) :type 'setting-constant))) -(ert-deftest binding-test-set-constant-nil () +(ert-deftest binding-test-set-constant-itself () "Test setting a keyword to itself." (with-no-warnings (should (setq :keyword :keyword)))) @@ -690,7 +690,7 @@ comparing the subr with a much slower Lisp implementation." (let ((n (* 2 most-negative-fixnum))) (should (= (logand -1 n) n)))) -(ert-deftest data-tests-logcount () +(ert-deftest data-tests-logcount-2 () (should (= (logcount (read "#xffffffffffffffffffffffffffffffff")) 128))) (ert-deftest data-tests-logior () commit 67ffcc5c7f5e1adcc6f662b01c7904f977dd4f51 Author: Mattias Engdegård Date: Thu Nov 18 12:18:24 2021 +0100 Signal an error for duplicated ERT tests (bug#51941) Make `ert-deftest` fail with an error (in batch mode only) if an existing test is redefined, because that is an easy mistake to make and which leads to a test being discarded silently. lisp/emacs-lisp/ert.el (ert-set-test, ert-deftest): Add check. etc/NEWS: Announce. diff --git a/etc/NEWS b/etc/NEWS index 80be6c0e49..cee2844be3 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -64,6 +64,13 @@ the 'COLORTERM' environment variable is set to the value "truecolor". These variables will override 'print-length' and 'print-level' when printing Lisp values in ERT batch test results. +--- +** Redefining an ERT test in batch mode now signals an error +Executing 'ert-deftest' with the same name as an existing test causes +the previous definition to be discarded, which was probably not +intended when this occurs in batch mode. To remedy the error, rename +tests so that they all have unique names. + ** Emacs now supports Unicode Standard version 14.0. ** Emoji diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 36b4408dc8..dc9cbc4745 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -151,6 +151,10 @@ in batch mode.") ;; Note that nil is still a valid value for the `name' slot in ;; ert-test objects. It designates an anonymous test. (error "Attempt to define a test named nil")) + (when (and noninteractive (get symbol 'ert--test)) + ;; Make sure duplicated tests are discovered since the older test would + ;; be ignored silently otherwise. + (error "Test `%s' redefined" symbol)) (define-symbol-prop symbol 'ert--test definition) definition) @@ -206,6 +210,9 @@ Macros in BODY are expanded when the test is defined, not when it is run. If a macro (possibly with side effects) is to be tested, it has to be wrapped in `(eval (quote ...))'. +If NAME is already defined as a test and Emacs is running +in batch mode, an error is signalled. + \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ [:tags \\='(TAG...)] BODY...)" (declare (debug (&define [&name "test@" symbolp] commit f41c6a70e7ce100b13ff0b662a054f6a0cd11cb2 Author: Mattias Engdegård Date: Thu Nov 18 11:26:21 2021 +0100 Avoid adding duplicates to Xref history * lisp/progmodes/xref.el (xref--push-backward, xref--push-forward): New functions. (xref-push-marker-stack, xref-go-back, xref-go-forward): Use them. diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index edb98aa5fe..ca3594d253 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -414,19 +414,29 @@ or earlier: it can break `dired-do-find-regexp-and-replace'." :version "28.1" :package-version '(xref . "1.2.0")) -(defvar xref--history (cons nil nil) - "(BACKWARD-STACK . FORWARD-STACK) of markers to visited Xref locations.") - (make-obsolete-variable 'xref-marker-ring nil "29.1") (defun xref-set-marker-ring-length (_var _val) (declare (obsolete nil "29.1")) nil) +(defvar xref--history (cons nil nil) + "(BACKWARD-STACK . FORWARD-STACK) of markers to visited Xref locations.") + +(defun xref--push-backward (m) + "Push marker M onto the backward history stack." + (unless (equal m (caar xref--history)) + (push m (car xref--history)))) + +(defun xref--push-forward (m) + "Push marker M onto the forward history stack." + (unless (equal m (cadr xref--history)) + (push m (cdr xref--history)))) + (defun xref-push-marker-stack (&optional m) "Add point M (defaults to `point-marker') to the marker stack. The future stack is erased." - (push (or m (point-marker)) (car xref--history)) + (xref--push-backward (or m (point-marker))) (dolist (mk (cdr xref--history)) (set-marker mk nil nil)) (setcdr xref--history nil)) @@ -442,7 +452,7 @@ To undo, use \\[xref-go-forward]." (if (null (car xref--history)) (user-error "At start of xref history") (let ((marker (pop (car xref--history)))) - (push (point-marker) (cdr xref--history)) + (xref--push-forward (point-marker)) (switch-to-buffer (or (marker-buffer marker) (user-error "The marked buffer has been deleted"))) (goto-char (marker-position marker)) @@ -456,7 +466,7 @@ To undo, use \\[xref-go-forward]." (if (null (cdr xref--history)) (user-error "At end of xref history") (let ((marker (pop (cdr xref--history)))) - (push (point-marker) (car xref--history)) + (xref--push-backward (point-marker)) (switch-to-buffer (or (marker-buffer marker) (user-error "The marked buffer has been deleted"))) (goto-char (marker-position marker)) commit 44faf546592a0c063d5044322f11bb0f006e613c Author: Lars Ingebrigtsen Date: Thu Nov 18 12:11:35 2021 +0100 Revert VC-related prefix user options to previous values * lisp/vc/smerge-mode.el (smerge-command-prefix): * lisp/vc/pcvs.el (cvs-minor-mode-prefix): * lisp/vc/diff-mode.el (diff-minor-mode-prefix): Revert to previous values, as external packages rely on those values. diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 87d30666da..1cffd88a56 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -264,15 +264,14 @@ and hunk-based syntax highlighting otherwise as a fallback." :help "Go to the next count'th file"] )) -(defcustom diff-minor-mode-prefix "C-c =" +(defcustom diff-minor-mode-prefix "\C-c ==" "Prefix key for `diff-minor-mode' commands." :type '(choice (string "ESC") - (string "C-c =") string) - :version "29.1") + (string "\C-c=") string)) (defvar-keymap diff-minor-mode-map :doc "Keymap for `diff-minor-mode'. See also `diff-mode-shared-map'." - diff-minor-mode-prefix diff-mode-shared-map) + (key-description diff-minor-mode-prefix) diff-mode-shared-map) (define-minor-mode diff-auto-refine-mode "Toggle automatic diff hunk finer highlighting (Diff Auto Refine mode). diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el index fa28d074a9..2d7b8cb2ef 100644 --- a/lisp/vc/pcvs.el +++ b/lisp/vc/pcvs.el @@ -266,14 +266,13 @@ ;;;; CVS-Minor mode ;;;; -(defcustom cvs-minor-mode-prefix "C-x c" +(defcustom cvs-minor-mode-prefix "\C-xc" "Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'." :type 'string - :version "29.1" - :group 'pcl-cvs) + :group 'pcl-cvs) (defvar-keymap cvs-minor-mode-map - cvs-minor-mode-prefix 'cvs-mode-map + (key-description cvs-minor-mode-prefix) 'cvs-mode-map "e" '(menu-item nil cvs-mode-edit-log :filter (lambda (x) (and (derived-mode-p 'log-view-mode) x)))) diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index ee6ddf1588..6c1b8cc95b 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -162,16 +162,15 @@ Used in `smerge-diff-base-upper' and related functions." ">" (cons "base-lower" #'smerge-diff-base-lower) "=" (cons "upper-lower" #'smerge-diff-upper-lower))) -(defcustom smerge-command-prefix "C-c ^" +(defcustom smerge-command-prefix "\C-c^" "Prefix for `smerge-mode' commands." - :version "29.1" :type '(choice (const :tag "ESC" "\e") - (const :tag "C-c ^" "C-c ^") + (const :tag "C-c ^" "\C-c^") (const :tag "none" "") string)) (defvar-keymap smerge-mode-map - smerge-command-prefix smerge-basic-map) + (key-description smerge-command-prefix) smerge-basic-map) (defvar-local smerge-check-cache nil) (defun smerge-check (n) commit 6cad3dc75e19669ba43bdc69a617ad14dec5643f Author: Lars Ingebrigtsen Date: Thu Nov 18 11:25:18 2021 +0100 Fix `narrow-to-defun' in "async function" in js-mode * lisp/progmodes/js.el (js--plain-method-re): (js--function-prologue-beginning): (js--ensure-cache): Allow "async" before "function" (bug#51926). This makes `narrow-to-defun' work as expected. diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index f11995127d..e5e83beff6 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -91,7 +91,7 @@ name.") (defconst js--plain-method-re (concat "^\\s-*?\\(" js--dotted-name-re "\\)\\.prototype" - "\\.\\(" js--name-re "\\)\\s-*?=\\s-*?\\(function\\)\\_>") + "\\.\\(" js--name-re "\\)\\s-*?=\\s-*?\\(\\(:?async[ \t\n]+\\)function\\)\\_>") "Regexp matching an explicit JavaScript prototype \"method\" declaration. Group 1 is a (possibly-dotted) class name, group 2 is a method name, and group 3 is the `function' keyword.") @@ -914,9 +914,10 @@ This puts point at the `function' keyword. If this is a syntactically-correct non-expression function, return the name of the function, or t if the name could not be determined. Otherwise, return nil." - (cl-assert (looking-at "\\_")) + (unless (looking-at "\\(\\_[ \t\n]+\\)?\\_") + (error "Invalid position")) (let ((name t)) - (forward-word-strictly) + (goto-char (match-end 0)) (forward-comment most-positive-fixnum) (when (eq (char-after) ?*) (forward-char) @@ -952,14 +953,17 @@ If POS is not in a function prologue, return nil." (goto-char (match-end 0)))) (skip-syntax-backward "w_") - (and (or (looking-at "\\_") - (js--re-search-backward "\\_" nil t)) - - (save-match-data (goto-char (match-beginning 0)) - (js--forward-function-decl)) - - (<= pos (point)) - (or prologue-begin (match-beginning 0)))))) + (let ((start nil)) + (and (or (looking-at "\\_") + (js--re-search-backward "\\_" nil t)) + (progn + (setq start (match-beginning 0)) + (goto-char start) + (when (looking-back "\\_[ \t\n]+" (- (point) 30)) + (setq start (match-beginning 0))) + (js--forward-function-decl)) + (<= pos (point)) + (or prologue-begin start)))))) (defun js--beginning-of-defun-raw () "Helper function for `js-beginning-of-defun'. @@ -1229,7 +1233,6 @@ LIMIT defaults to point." ;; Regular function declaration ((and (looking-at "\\_") (setq name (js--forward-function-decl))) - (when (eq name t) (setq name (js--guess-function-name orig-match-end)) (if name @@ -1241,6 +1244,11 @@ LIMIT defaults to point." (cl-assert (eq (char-after) ?{)) (forward-char) + (save-excursion + (goto-char orig-match-start) + (when (looking-back "\\_[ \t\n]+" + (- (point) 3)) + (setq orig-match-start (match-beginning 0)))) (make-js--pitem :paren-depth orig-depth :h-begin orig-match-start commit 1625123e4ceb8d23eef00f3944341ecf0a75dc77 Author: Greg Minshall Date: Thu Nov 18 10:32:34 2021 +0100 Fix eldoc usage of newly introduced variable * lisp/emacs-lisp/eldoc.el (eldoc-display-message-no-interference-p): Make this function work in older Emacs versions again (bug#51939). diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index b30d3fc30f..cd0e7dca7c 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -385,7 +385,8 @@ Also store it in `eldoc-last-message' and return that value." ;; The following configuration shows "Matches..." in the ;; echo area when point is after a closing bracket, which ;; conflicts with eldoc. - (and show-paren-context-when-offscreen + (and (boundp 'show-paren-context-when-offscreen) + show-paren-context-when-offscreen (not (pos-visible-in-window-p (overlay-end show-paren--overlay))))))) commit d7f52c64666cbd0b91ece1231c235b5c74acd0a5 Author: Mattias Engdegård Date: Thu Nov 18 10:01:17 2021 +0100 ; * src/macfont.m: fix typing errors diff --git a/src/macfont.m b/src/macfont.m index 1426cae6dc..ce7a5ec8cd 100644 --- a/src/macfont.m +++ b/src/macfont.m @@ -2928,7 +2928,7 @@ So we use CTFontDescriptorCreateMatchingFontDescriptor (no { if (s->hl == DRAW_CURSOR) { - CGColorRef *colorref = get_cgcolor_from_nscolor (FRAME_CURSOR_COLOR (f), f); + CGColorRef colorref = get_cgcolor_from_nscolor (FRAME_CURSOR_COLOR (f), f); CGContextSetFillColorWithColor (context, colorref); CGColorRelease (colorref); } @@ -2944,7 +2944,7 @@ So we use CTFontDescriptorCreateMatchingFontDescriptor (no CGContextScaleCTM (context, 1, -1); if (s->hl == DRAW_CURSOR) { - CGColorRef *colorref = get_cgcolor_from_nscolor (FRAME_BACKGROUND_COLOR (f), f); + CGColorRef colorref = get_cgcolor_from_nscolor (FRAME_BACKGROUND_COLOR (f), f); CGContextSetFillColorWithColor (context, colorref); CGColorRelease (colorref); } commit 5eeaf857678d617560efa6a99bb6fd54c0ceddec Author: Eli Zaretskii Date: Thu Nov 18 10:25:58 2021 +0200 Improve documentation of window hooks * doc/lispref/windows.texi (Window Hooks): Clarify "buffer-local functions". (Bug#51930) diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index 57cd2274d4..a3a37bc60d 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -6375,7 +6375,9 @@ changed. @xref{Other Font Lock Variables}. during redisplay provided a significant, non-scrolling change of a window has been detected. For simplicity, these hooks and the functions they call will be collectively referred to as @dfn{window -change functions}. +change functions}. As any hook, these hooks can be set either +globally of buffer-locally via the @var{local} argument of +@code{add-hook} (@pxref{Setting Hooks}) when the hook is installed. @cindex window buffer change The first of these hooks is run after a @dfn{window buffer change} is commit ce2f7335f1f4ec8d276e47de79b3c9bd9797233d Author: Lars Ingebrigtsen Date: Wed Nov 17 09:29:06 2021 +0100 Make the optional describe-map-tree parameters optional * lisp/help.el (describe-map-tree): Make the optional parameters optional. This makes testing easier. diff --git a/lisp/help.el b/lisp/help.el index 68b6d930c9..bc3d4773da 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1226,8 +1226,8 @@ Otherwise, return a new string." (buffer-string))))) (defvar help--keymaps-seen nil) -(defun describe-map-tree (startmap partial shadow prefix title no-menu - transl always-title mention-shadow) +(defun describe-map-tree (startmap &optional partial shadow prefix title + no-menu transl always-title mention-shadow) "Insert a description of the key bindings in STARTMAP. This is followed by the key bindings of all maps reachable through STARTMAP. commit f596f0db82c0b1ff3fe8e8f1d8b07d2fe7504ab6 Author: Miha Rihtaršič Date: Wed Nov 17 09:12:21 2021 +0100 Don't ignore restriction in indent-region-line-by-line * lisp/indent.el (indent-according-to-mode): Don't widen if the new optional argument is non-nil. (indent-region): Explicitly widen before calling indent-region-line-by-line. (indent-region-line-by-line): Don't widen (bug#51892). Emacs convention is that low-level functions should respect restriction so that their callers can set restriction according to their needs. For example, 'c-indent-region' is a lower-level function which respects the current restriction and 'indent-region' is a higher-level user command which sets the restriction for lower-level functions, it calls "(widen)". 'indent-region-line-by-line' is a low-level function on a similar level as 'c-indent-region'. This patch makes it respect the current restriction instead of having it call "(widen)". diff --git a/lisp/indent.el b/lisp/indent.el index aa6b8d17c4..ec01733d12 100644 --- a/lisp/indent.el +++ b/lisp/indent.el @@ -88,16 +88,20 @@ This variable has no effect unless `tab-always-indent' is `complete'." indent-relative-first-indent-point) "Values that are ignored by `indent-according-to-mode'.") -(defun indent-according-to-mode () +(defun indent-according-to-mode (&optional inhibit-widen) "Indent line in proper way for current major mode. Normally, this is done by calling the function specified by the variable `indent-line-function'. However, if the value of that variable is present in the `indent-line-ignored-functions' variable, handle it specially (since those functions are used for tabbing); -in that case, indent by aligning to the previous non-blank line." +in that case, indent by aligning to the previous non-blank line. + +Ignore restriction, unless the optional argument INHIBIT-WIDEN is +non-nil." (interactive) (save-restriction - (widen) + (unless inhibit-widen + (widen)) (syntax-propertize (line-end-position)) (if (memq indent-line-function indent-line-ignored-functions) ;; These functions are used for tabbing, but can't be used for @@ -601,7 +605,10 @@ column to indent to; if it is nil, use one of the three methods above." (funcall indent-region-function start end))) ;; Else, use a default implementation that calls indent-line-function on ;; each line. - (t (indent-region-line-by-line start end))) + (t + (save-restriction + (widen) + (indent-region-line-by-line start end)))) ;; In most cases, reindenting modifies the buffer, but it may also ;; leave it unmodified, in which case we have to deactivate the mark ;; by hand. @@ -615,7 +622,7 @@ column to indent to; if it is nil, use one of the three methods above." (make-progress-reporter "Indenting region..." (point) end)))) (while (< (point) end) (or (and (bolp) (eolp)) - (indent-according-to-mode)) + (indent-according-to-mode t)) (forward-line 1) (and pr (progress-reporter-update pr (point)))) (and pr (progress-reporter-done pr)) commit 7404f4b4e0bf472d5f161957ff23e30df0e8b96d Author: Eli Zaretskii Date: Thu Nov 18 08:46:17 2021 +0200 Improve doc string of 'highlight-nonselected-windows' * src/xdisp.c (syms_of_xdisp) : Clarify the doc string. (Bug#51927) diff --git a/src/xdisp.c b/src/xdisp.c index c05e7edbc9..0316408d92 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -35205,7 +35205,9 @@ line number may be omitted from the mode line. */); line_number_display_limit_width = 200; DEFVAR_BOOL ("highlight-nonselected-windows", highlight_nonselected_windows, - doc: /* Non-nil means highlight region even in nonselected windows. */); + doc: /* Non-nil means highlight active region even in nonselected windows. +When nil (the default), the active region is only highlighted when +the window is selected. */); highlight_nonselected_windows = false; DEFVAR_BOOL ("multiple-frames", multiple_frames, commit b48cbaf5c7e47c002fd274aea21554245075bfe8 Author: Mike Kupfer Date: Wed Nov 17 20:25:50 2021 -0800 Fix two failing tests in mh-utils-tests * test/lisp/mh-e/mh-utils-tests.el (mh-test-utils-mock-call-process): Add mock for root folders. (mh-folder-completion-function-08-plus-slash) (mh-folder-completion-function-09-plus-slash-tmp): Skip these tests with Mailutils, which doesn't handle root folders. (Bug#51902) diff --git a/test/lisp/mh-e/mh-utils-tests.el b/test/lisp/mh-e/mh-utils-tests.el index 3a03d817f5..0066c00b5b 100644 --- a/test/lisp/mh-e/mh-utils-tests.el +++ b/test/lisp/mh-e/mh-utils-tests.el @@ -211,6 +211,10 @@ The tests use this method if no configured MH variant is found." "/abso-folder/bar has no messages." "/abso-folder/foo has no messages." "/abso-folder/food has no messages.")) + (("folders" "-noheader" "-norecurse" "-nototal" "+/") . + ("/+ has no messages ; (others)." + "//abso-folder has no messages ; (others)." + "//tmp has no messages ; (others).")) )) (arglist (cons (file-name-base program) args))) (let ((response-list-cons (assoc arglist argument-responses))) @@ -437,7 +441,10 @@ and the `should' macro requires idempotent evaluation anyway." (ert-deftest mh-folder-completion-function-08-plus-slash () "Test `mh-folder-completion-function' with `+/'." - :tags '(:unstable) + ;; This test fails with Mailutils 3.5, 3.7, and 3.13. + (with-mh-test-env + (skip-unless (not (and (stringp mh-variant-in-use) + (string-search "GNU Mailutils" mh-variant-in-use))))) (mh-test-folder-completion-1 "+/" "+/" "tmp/" t) ;; case "bb" (with-mh-test-env @@ -447,7 +454,10 @@ and the `should' macro requires idempotent evaluation anyway." (ert-deftest mh-folder-completion-function-09-plus-slash-tmp () "Test `mh-folder-completion-function' with `+/tmp'." - :tags '(:unstable) + ;; This test fails with Mailutils 3.5, 3.7, and 3.13. + (with-mh-test-env + (skip-unless (not (and (stringp mh-variant-in-use) + (string-search "GNU Mailutils" mh-variant-in-use))))) (mh-test-folder-completion-1 "+/tmp" "+/tmp/" "tmp/" t)) (ert-deftest mh-folder-completion-function-10-plus-slash-abs-folder () commit 38322419e4d32ff9f3d5505360f2714c31aa2e8d Author: Stefan Kangas Date: Thu Nov 18 00:58:26 2021 +0100 Revert "* lisp/image-dired.el: Remove unnecessary 'declare-function'." This reverts commit e0261d4a0cf2a23d32b51b84870a3a75f8273c7c. This commit gives warnings on builds --without-x. Problem pointed out by Glenn Morris in: https://lists.gnu.org/r/emacs-devel/2021-11/msg01278.html diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 047be5a215..852ef0f103 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -1739,6 +1739,8 @@ Note that n, p and and will be hijacked and bound to `image-dired-dired-next-line' and `image-dired-dired-previous-line'." :keymap image-dired-minor-mode-map) +(declare-function clear-image-cache "image.c" (&optional filter)) + (defun image-dired-create-thumbs (&optional arg) "Create thumbnail images for all marked files in Dired. With prefix argument ARG, create thumbnails even if they already exist commit bf04c19cdd08baa5e5e90ccdba8aa9c0449c7fab Author: Eli Zaretskii Date: Wed Nov 17 20:33:40 2021 +0200 Fix recent changes related to USABLE_SIGIO * src/process.c (wait_reading_process_output) [WINDOWSNT]: * src/keyboard.c (handle_async_input) [DOS_NT]: Ifdef away the code that is not needed on MS-Windows. (Bug#50403) (Bug#51820) diff --git a/src/keyboard.c b/src/keyboard.c index 5a43e9a46a..c3bc8307d7 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -7180,6 +7180,7 @@ tty_read_avail_input (struct terminal *terminal, static void handle_async_input (void) { +#ifndef DOS_NT while (1) { int nread = gobble_input (); @@ -7189,6 +7190,7 @@ handle_async_input (void) if (nread <= 0) break; } +#endif } void diff --git a/src/process.c b/src/process.c index 808bf6f1ff..a00426795b 100644 --- a/src/process.c +++ b/src/process.c @@ -5588,7 +5588,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, timeout = make_timespec (0, 0); #endif -#ifndef USABLE_SIGIO +#if !defined USABLE_SIGIO && !defined WINDOWSNT /* If we're polling for input, don't get stuck in select for more than 25 msec. */ struct timespec short_timeout = make_timespec (0, 25000000); commit d4e2915dab13da38ce2b7ab63b5c8b0ffb9b9df8 Author: Ken Brown Date: Wed Nov 17 13:02:44 2021 -0500 Make process_pending_signals useful on systems without SIGIO * src/keyboard.c (handle_async_input): Call gobble_input unconditionally, not just if USABLE_SIGIO is defined. This makes process_pending_signals do something useful on systems that have to poll for input. (Bug#51820) diff --git a/src/keyboard.c b/src/keyboard.c index de9805df32..5a43e9a46a 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -7180,7 +7180,6 @@ tty_read_avail_input (struct terminal *terminal, static void handle_async_input (void) { -#ifdef USABLE_SIGIO while (1) { int nread = gobble_input (); @@ -7190,7 +7189,6 @@ handle_async_input (void) if (nread <= 0) break; } -#endif } void commit 5896ca8925b65d86a392269c0696c96755890b1a Author: Ken Brown Date: Wed Nov 17 11:55:39 2021 -0500 Avoid delays waiting for input on systems without SIGIO * src/process.c (wait_reading_process_output) [!USABLE_SIGIO]: If we're waiting for input, don't use a timeout of more than 25 msec in the call to select. (Bug#50043) diff --git a/src/process.c b/src/process.c index f923aff1cb..808bf6f1ff 100644 --- a/src/process.c +++ b/src/process.c @@ -5588,6 +5588,15 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, timeout = make_timespec (0, 0); #endif +#ifndef USABLE_SIGIO + /* If we're polling for input, don't get stuck in select for + more than 25 msec. */ + struct timespec short_timeout = make_timespec (0, 25000000); + if ((read_kbd || !NILP (wait_for_cell)) + && timespec_cmp (short_timeout, timeout) < 0) + timeout = short_timeout; +#endif + /* Non-macOS HAVE_GLIB builds call thread_select in xgselect.c. */ #if defined HAVE_GLIB && !defined HAVE_NS nfds = xg_select (max_desc + 1, commit 3b2421e6a7218b128c45ec2dd1f65a24d178093a Author: Po Lu Date: Wed Nov 17 21:30:20 2021 +0800 Prevent subprocess hangs in xwidget * src/xwidget.c (Fmake_xwidget, Fxwidget_webkit_goto_url): Use `catch_child_signal' instead of trying to preserve the previous signal handler. diff --git a/src/xwidget.c b/src/xwidget.c index e1d54d43b7..e1bf40ea43 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -32,6 +32,7 @@ along with GNU Emacs. If not, see . */ #include "sysstdio.h" #include "termhooks.h" #include "window.h" +#include "process.h" /* Include xwidget bottom end headers. */ #ifdef USE_GTK @@ -189,14 +190,12 @@ fails. */) { xw->widget_osr = webkit_web_view_new (); + webkit_web_view_load_uri (WEBKIT_WEB_VIEW (xw->widget_osr), + "about:blank"); /* webkitgtk uses GSubprocess which sets sigaction causing Emacs to not catch SIGCHLD with its usual handle setup in 'catch_child_signal'. This resets the SIGCHLD sigaction. */ - struct sigaction old_action; - sigaction (SIGCHLD, NULL, &old_action); - webkit_web_view_load_uri (WEBKIT_WEB_VIEW (xw->widget_osr), - "about:blank"); - sigaction (SIGCHLD, &old_action, NULL); + catch_child_signal (); } else { @@ -1841,6 +1840,7 @@ DEFUN ("xwidget-webkit-goto-uri", uri = ENCODE_FILE (uri); #ifdef USE_GTK webkit_web_view_load_uri (WEBKIT_WEB_VIEW (xw->widget_osr), SSDATA (uri)); + catch_child_signal (); #elif defined NS_IMPL_COCOA nsxwidget_webkit_goto_uri (xw, SSDATA (uri)); #endif commit 0fbe543bc1a7cc3e9198eb0d8fc4b248ff0701e6 Author: Stefan Kangas Date: Mon Mar 8 10:56:51 2021 +0100 Use substitute-command-keys in some messages * lisp/dired.el (dired-get-file-for-visit): * lisp/doc-view.el (doc-view-buffer-message): * lisp/help.el (help-window-setup): * lisp/ibuf-ext.el (ibuffer-do-kill-lines): * lisp/vc/ediff.el (ediff-documentation): Use 'substitute-command-keys'. diff --git a/lisp/dired.el b/lisp/dired.el index 8650fb9baa..a0fa917891 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -2449,7 +2449,9 @@ directory in another window." file-name (if (file-symlink-p file-name) (error "File is a symlink to a nonexistent target") - (error "File no longer exists; type `g' to update Dired buffer"))))) + (error (substitute-command-keys + (concat "File no longer exists; type \\" + "\\[revert-buffer] to update Dired buffer"))))))) ;; Force C-m keybinding rather than `f' or `e' in the mode doc: (define-obsolete-function-alias 'dired-advertised-find-file diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 088ca5bfea..32e2ec1688 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -1530,16 +1530,16 @@ have the page we want to view." (overlay-put (doc-view-current-overlay) 'display (concat (propertize "Welcome to DocView!" 'face 'bold) "\n" - " + (substitute-command-keys " If you see this buffer it means that the document you want to view is being converted to PNG and the conversion of the first page hasn't finished yet or `doc-view-conversion-refresh-interval' is set to nil. For now these keys are useful: - -`q' : Bury this buffer. Conversion will go on in background. -`k' : Kill the conversion process and this buffer. -`K' : Kill the conversion process.\n")))) +\\ +\\[quit-window] : Bury this buffer. Conversion will go on in background. +\\[image-kill-buffer] : Kill the conversion process and this buffer. +\\[doc-view-kill-proc] : Kill the conversion process.\n"))))) (declare-function tooltip-show "tooltip" (text &optional use-echo-area)) diff --git a/lisp/help.el b/lisp/help.el index 4470e6baaa..68b6d930c9 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1833,13 +1833,13 @@ Return VALUE." (cond ((eq help-setup 'window) ;; ... and is new, ... - "Type \"q\" to delete help window") + "Type \\\\[help-quit] to delete help window") ((eq help-setup 'frame) ;; ... on a new frame, ... - "Type \"q\" to quit the help frame") + "Type \\\\[help-quit] to quit the help frame") ((eq help-setup 'other) ;; ... or displayed some other buffer before. - "Type \"q\" to restore previous buffer")) + "Type \\\\[help-quit] to restore previous buffer")) window t)) ((and (eq (window-frame window) help-window-old-frame) (= (length (window-list nil 'no-mini)) 2)) @@ -1850,7 +1850,7 @@ Return VALUE." ((eq help-setup 'window) "Type \\[delete-other-windows] to delete the help window") ((eq help-setup 'other) - "Type \"q\" in help window to restore its previous buffer")) + "Type \\\\[help-quit] in help window to restore its previous buffer")) window 'other)) (t ;; The help window is not selected ... @@ -1858,10 +1858,10 @@ Return VALUE." (cond ((eq help-setup 'window) ;; ... and is new, ... - "Type \"q\" in help window to delete it") + "Type \\\\[help-quit] in help window to delete it") ((eq help-setup 'other) ;; ... or displayed some other buffer before. - "Type \"q\" in help window to restore previous buffer")) + "Type \\\\[help-quit] in help window to restore previous buffer")) window)))) ;; Return VALUE. value)) diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index 5b69a878e2..2d2365dc34 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -1597,7 +1597,10 @@ to move by. The default is `ibuffer-marked-char'." "Hide all of the currently marked lines." (interactive) (if (= (ibuffer-count-marked-lines) 0) - (message "No buffers marked; use `m' to mark a buffer") + (message (substitute-command-keys + (concat + "No buffers marked; use \\" + "\\[ibuffer-mark-forward] to mark a buffer"))) (let ((count (ibuffer-map-marked-lines (lambda (_buf _mark) diff --git a/lisp/vc/ediff.el b/lisp/vc/ediff.el index 97c84ae5a1..cb4c8d9305 100644 --- a/lisp/vc/ediff.el +++ b/lisp/vc/ediff.el @@ -1558,7 +1558,9 @@ With optional NODE, goes to that node." (info "ediff") (if node (Info-goto-node node) - (message "Type `i' to search for a specific topic")) + (message (substitute-command-keys + (concat "Type \\\\[Info-index] to" + " search for a specific topic")))) (raise-frame)) (error (beep 1) (with-output-to-temp-buffer ediff-msg-buffer commit 9ae741750cc3e96cacb3c496f7c941e5fc3f1052 Author: Po Lu Date: Wed Nov 17 20:31:41 2021 +0800 Don't draw xwidgets that have just been resized This serves to eliminate the huge black bar displayed when the offscreen widget has been resized (and as such the damage event signal is sent), but the X window hasn't. * src/xwidget.c (xv_do_draw): Don't draw xwidgets that have just been resized. (x_draw_xwidget_glyph_string) (xwidget_init_view): Clear just_resized. (Fxwidget_resize): Set just_resized first, then queue allocate. diff --git a/src/xwidget.c b/src/xwidget.c index 650572a889..e1d54d43b7 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -1062,6 +1062,9 @@ xv_do_draw (struct xwidget_view *xw, struct xwidget *w) GtkOffscreenWindow *wnd; cairo_surface_t *surface; + if (xw->just_resized) + return; + if (NILP (w->buffer)) { XClearWindow (xw->dpy, xw->wdesc); @@ -1578,6 +1581,7 @@ xwidget_init_view (struct xwidget *xww, xv->wdesc = None; xv->frame = s->f; xv->cursor = cursor_for_hit (xww->hit_result, s->f); + xv->just_resized = false; #elif defined NS_IMPL_COCOA nsxwidget_init_view (xv, xww, s, x, y); nsxwidget_resize_view(xv, xww->width, xww->height); @@ -1609,6 +1613,8 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) #ifdef USE_GTK if (!xv) xv = xwidget_init_view (xww, s, x, y); + + xv->just_resized = false; #elif defined NS_IMPL_COCOA if (!xv) { @@ -1970,20 +1976,7 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, xw->width = w; xw->height = h; - /* If there is an offscreen widget resize it first. */ -#ifdef USE_GTK - if (xw->widget_osr) - { - gtk_window_resize (GTK_WINDOW (xw->widgetwindow_osr), xw->width, - xw->height); - gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), xw->width, - xw->height); - - gtk_widget_queue_allocate (GTK_WIDGET (xw->widget_osr)); - } -#elif defined NS_IMPL_COCOA - nsxwidget_resize (xw); -#endif + block_input (); for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); tail = XCDR (tail)) @@ -1993,13 +1986,34 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, struct xwidget_view *xv = XXWIDGET_VIEW (XCAR (tail)); if (XXWIDGET (xv->model) == xw) { +#ifdef USE_GTK + xv->just_resized = true; + SET_FRAME_GARBAGED (xv->frame); +#else wset_redisplay (XWINDOW (xv->w)); +#endif } } } redisplay (); + /* If there is an offscreen widget resize it first. */ +#ifdef USE_GTK + if (xw->widget_osr) + { + gtk_window_resize (GTK_WINDOW (xw->widgetwindow_osr), xw->width, + xw->height); + gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), xw->width, + xw->height); + + gtk_widget_queue_allocate (GTK_WIDGET (xw->widget_osr)); + } +#elif defined NS_IMPL_COCOA + nsxwidget_resize (xw); +#endif + unblock_input (); + return Qnil; } diff --git a/src/xwidget.h b/src/xwidget.h index 2f6d0442e2..78fe865dd8 100644 --- a/src/xwidget.h +++ b/src/xwidget.h @@ -114,6 +114,7 @@ struct xwidget_view cairo_surface_t *cr_surface; cairo_t *cr_context; + int just_resized; #elif defined (NS_IMPL_COCOA) # ifdef __OBJC__ XvWindow *xvWindow; commit b6ea007f9dc02f2699d5d772032344fbd189c55d Author: Stefan Kangas Date: Wed Nov 17 12:08:56 2021 +0100 Ignore some externally maintained files in AUTHORS * admin/authors.el (authors-ignored-files): Ignore externally maintained files. diff --git a/admin/authors.el b/admin/authors.el index 23990fee70..1e8bf0364d 100644 --- a/admin/authors.el +++ b/admin/authors.el @@ -360,6 +360,8 @@ Changes to files matching one of the regexps in this list are not listed.") "autogen/missing" "autogen" "autogen/copy_autogen" ; not generated, but trivial and now removed "dir_top" + ;; Imported into Emacs but externally maintained. + "publicsuffix.txt" "SKK-JISYO.L" ;; Only existed briefly, then renamed: "images/icons/allout-widgets-dark-bg" "images/icons/allout-widgets-light-bg" commit e0261d4a0cf2a23d32b51b84870a3a75f8273c7c Author: Stefan Kangas Date: Wed Nov 17 11:46:14 2021 +0100 * lisp/image-dired.el: Remove unnecessary 'declare-function'. diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 852ef0f103..047be5a215 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -1739,8 +1739,6 @@ Note that n, p and and will be hijacked and bound to `image-dired-dired-next-line' and `image-dired-dired-previous-line'." :keymap image-dired-minor-mode-map) -(declare-function clear-image-cache "image.c" (&optional filter)) - (defun image-dired-create-thumbs (&optional arg) "Create thumbnail images for all marked files in Dired. With prefix argument ARG, create thumbnails even if they already exist commit 2caa06eab58753fa9cef14739aa9adfcffe8e5ff Author: Stefan Kangas Date: Wed Nov 17 10:49:19 2021 +0100 ; * admin/MAINTAINERS: Add myself. diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS index 02b8cf39bd..b881e76e25 100644 --- a/admin/MAINTAINERS +++ b/admin/MAINTAINERS @@ -138,6 +138,9 @@ Andrea Corallo lisp/emacs-lisp/comp-cstr.el test/src/comp-*.el +Stefan Kangas + admin/automerge + ============================================================================== 2. Areas that someone is willing to maintain, although he would not necessarily mind if someone else was the official maintainer. commit cde5dcd441b5db79f39b8664221866566c400b05 Author: Lars Ingebrigtsen Date: Wed Nov 17 08:34:32 2021 +0100 Change the call signature to keymap-substitute * lisp/keymap.el (keymap-substitute): Make the keymap the first parameter for symmetry with the other functions. * lisp/emacs-lisp/shortdoc.el (keymaps): * lisp/emacs-lisp/bytecomp.el (lambda): Adjust. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 4078a7314f..3338c38317 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5066,7 +5066,7 @@ binding slots have been popped." (keymap-unset 2) (keymap-global-unset 1) (keymap-local-unset 1) - (keymap-substitute 1 2) + (keymap-substitute 2 3) (keymap-set-after 2) (key-translate 1 2) (keymap-lookup 2) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 228d1e0551..157209fcf7 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -1242,7 +1242,7 @@ There can be any number of :example/:result elements." (keymap-global-unset :no-eval (keymap-global-unset "C-c C-c")) (keymap-substitute - :no-eval (keymap-substitute "C-c C-c" "M-a" map)) + :no-eval (keymap-substitute map "C-c C-c" "M-a")) (keymap-set-after :no-eval (keymap-set-after map "" menu-bar-separator)) "Predicates" diff --git a/lisp/keymap.el b/lisp/keymap.el index b634487ba6..a9331e1604 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -121,7 +121,7 @@ parent keymap to be used." (keymap--check key) (define-key keymap (key-parse key) nil remove)) -(defun keymap-substitute (olddef newdef keymap &optional oldmap prefix) +(defun keymap-substitute (keymap olddef newdef &optional oldmap prefix) "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. In other words, OLDDEF is replaced with NEWDEF wherever it appears. Alternatively, if optional fourth argument OLDMAP is specified, we redefine commit 249095fd6778b9014ff30381ca562f40107d7be4 Merge: 90ac2db9ed fa0b34b716 Author: Stefan Kangas Date: Wed Nov 17 08:20:55 2021 +0100 Merge from origin/emacs-28 fa0b34b716 * admin/authors.el (authors-ignored-files): Ignore some NE... c25be3e7bb * lisp/tab-bar.el (tab-bar-select-tab): Add check for wc-f... 38d905abf9 * lisp/tab-bar.el: Doc fixes for commands bound to modifie... commit 90ac2db9ed9b2bab6f40508f6302996d5b8a725d Author: Lars Ingebrigtsen Date: Wed Nov 17 08:16:58 2021 +0100 Make bookmark-set prompt less confusing * lisp/bookmark.el (bookmark-set): Make the prompt less confusing (bug#51876). diff --git a/lisp/bookmark.el b/lisp/bookmark.el index 89c9125a60..a8fa9ae774 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -916,7 +916,7 @@ it removes only the first instance of a bookmark with that name from the list of bookmarks.)" (interactive (list nil current-prefix-arg)) (let ((prompt - (if no-overwrite "Set bookmark" "Set bookmark unconditionally"))) + (if no-overwrite "Append bookmark named" "Set bookmark named"))) (bookmark-set-internal prompt name (if no-overwrite 'push 'overwrite)))) ;;;###autoload commit 8e67cf41e3a15d81812b4098ce06f5badee74a3f Author: Lars Ingebrigtsen Date: Wed Nov 17 08:14:23 2021 +0100 Fix mh-mime build problem * lisp/mh-e/mh-mime.el (mh-acros): Require to get mh-dlet*. diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el index 3698dd33ec..714bf029bb 100644 --- a/lisp/mh-e/mh-mime.el +++ b/lisp/mh-e/mh-mime.el @@ -39,6 +39,7 @@ ;;; Code: (require 'mh-e) +(require 'mh-acros) (require 'mh-gnus) ;needed because mh-gnus.el not compiled (require 'font-lock) commit fc8c976298e22b50d4c0fb6b06b61271306aa8b2 Author: Stefan Kangas Date: Wed Nov 17 07:59:00 2021 +0100 Temporarily mark two failing tests as unstable * test/lisp/mh-e/mh-utils-tests.el (mh-folder-completion-function-08-plus-slash) (mh-folder-completion-function-09-plus-slash-tmp): Temporarily mark two failing tests as unstable. diff --git a/test/lisp/mh-e/mh-utils-tests.el b/test/lisp/mh-e/mh-utils-tests.el index 0df4d44646..3a03d817f5 100644 --- a/test/lisp/mh-e/mh-utils-tests.el +++ b/test/lisp/mh-e/mh-utils-tests.el @@ -437,15 +437,17 @@ and the `should' macro requires idempotent evaluation anyway." (ert-deftest mh-folder-completion-function-08-plus-slash () "Test `mh-folder-completion-function' with `+/'." + :tags '(:unstable) (mh-test-folder-completion-1 "+/" "+/" "tmp/" t) - ;; case "bb" - (with-mh-test-env - (should (equal nil - (member (format "+%s/" mh-test-rel-folder) - (mh-folder-completion-function "+/" nil t)))))) + ;; case "bb" + (with-mh-test-env + (should (equal nil + (member (format "+%s/" mh-test-rel-folder) + (mh-folder-completion-function "+/" nil t)))))) (ert-deftest mh-folder-completion-function-09-plus-slash-tmp () "Test `mh-folder-completion-function' with `+/tmp'." + :tags '(:unstable) (mh-test-folder-completion-1 "+/tmp" "+/tmp/" "tmp/" t)) (ert-deftest mh-folder-completion-function-10-plus-slash-abs-folder () commit 6f52a1ba2c756ae60609d9c56fa7dc5160b3bcd2 Author: Stefan Kangas Date: Wed Nov 17 07:37:38 2021 +0100 ; * admin/automerge: Maintain. diff --git a/admin/automerge b/admin/automerge index 227a404b7a..81082f7dc6 100755 --- a/admin/automerge +++ b/admin/automerge @@ -4,7 +4,7 @@ ## Copyright (C) 2018-2021 Free Software Foundation, Inc. ## Author: Glenn Morris -## Maintainer: emacs-devel@gnu.org +## Maintainer: Stefan Kangas ## This file is part of GNU Emacs. commit e72061c262226bbacaa11457d3014ef148185bf3 Author: Lars Ingebrigtsen Date: Wed Nov 17 07:04:22 2021 +0100 Fix bookmark-bmenu-mode-map syntax * lisp/bookmark.el (bookmark-bmenu-mode-map): Fix syntax in defvar-keymap. diff --git a/lisp/bookmark.el b/lisp/bookmark.el index 5176d7aa8d..89c9125a60 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -812,7 +812,7 @@ CODING is the symbol of the coding-system in which the file is encoded." (defvar-keymap bookmark-minibuffer-read-name-map :parent minibuffer-local-map - ["C-w"] #'bookmark-yank-word) + "C-w" #'bookmark-yank-word) (defun bookmark-set-internal (prompt name overwrite-or-push) "Set a bookmark using specified NAME or prompting with PROMPT. @@ -990,7 +990,7 @@ It takes one argument, the name of the bookmark, as a string.") (defvar-keymap bookmark-edit-annotation-mode-map :doc "Keymap for editing an annotation of a bookmark." :parent text-mode-map - ["C-c C-c"] #'bookmark-send-edited-annotation) + "C-c C-c" #'bookmark-send-edited-annotation) (defun bookmark-insert-annotation (bookmark-name-or-record) "Insert annotation for BOOKMARK-NAME-OR-RECORD at point." @@ -1702,20 +1702,20 @@ unique numeric suffixes \"<2>\", \"<3>\", etc." "2" #'bookmark-bmenu-2-window "1" #'bookmark-bmenu-1-window "j" #'bookmark-bmenu-this-window - ["C-c C-c"] #'bookmark-bmenu-this-window + "C-c C-c" #'bookmark-bmenu-this-window "f" #'bookmark-bmenu-this-window - ["C-m"] #'bookmark-bmenu-this-window + "C-m" #'bookmark-bmenu-this-window "o" #'bookmark-bmenu-other-window - ["C-o"] #'bookmark-bmenu-switch-other-window + "C-o" #'bookmark-bmenu-switch-other-window "s" #'bookmark-bmenu-save - ["C-x C-s"] #'bookmark-bmenu-save + "C-x C-s" #'bookmark-bmenu-save "k" #'bookmark-bmenu-delete - ["C-d"] #'bookmark-bmenu-delete-backwards + "C-d" #'bookmark-bmenu-delete-backwards "x" #'bookmark-bmenu-execute-deletions "d" #'bookmark-bmenu-delete "D" #'bookmark-bmenu-delete-all - [? ] #'next-line - "\177" #'bookmark-bmenu-backup-unmark + "SPC" #'next-line + "DEL" #'bookmark-bmenu-backup-unmark "u" #'bookmark-bmenu-unmark "U" #'bookmark-bmenu-unmark-all "m" #'bookmark-bmenu-mark @@ -1728,7 +1728,7 @@ unique numeric suffixes \"<2>\", \"<3>\", etc." "A" #'bookmark-bmenu-show-all-annotations "e" #'bookmark-bmenu-edit-annotation "/" #'bookmark-bmenu-search - [mouse-2] #'bookmark-bmenu-other-window-with-mouse) + "" #'bookmark-bmenu-other-window-with-mouse) (easy-menu-define bookmark-menu bookmark-bmenu-mode-map "Menu for `bookmark-bmenu'." commit 9e79575486fb6aeb0deb23e17cb2ce9ec02b5fd7 Author: Stefan Kangas Date: Wed Nov 17 06:25:50 2021 +0100 Remove some references to XEmacs * lisp/emulation/viper-cmd.el (viper-start-R-mode): * lisp/emulation/viper-init.el (viper-window-display-p): * lisp/emulation/viper-mous.el (viper-surrounding-word): * lisp/mail/footnote.el (footnote-mode): * lisp/textmodes/reftex-index.el: Remove some comments referring to XEmacs. diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index 59be3f4846..849ad3d824 100644 --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@ -2311,7 +2311,6 @@ problems." (viper-downgrade-to-insert)) (defun viper-start-R-mode () - ;; Leave arg as 1, not t: XEmacs insists that it must be a pos number (overwrite-mode 1) (add-hook 'viper-post-command-hooks #'viper-R-state-post-command-sentinel t 'local) diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el index e3790b7453..368a5dc40a 100644 --- a/lisp/emulation/viper-init.el +++ b/lisp/emulation/viper-init.el @@ -44,7 +44,6 @@ (define-obsolete-function-alias 'viper-device-type #'window-system "27.1") -;; in XEmacs: device-type is tty on tty and stream in batch. (defun viper-window-display-p () (and window-system (not (memq window-system '(tty stream pc))))) diff --git a/lisp/emulation/viper-mous.el b/lisp/emulation/viper-mous.el index 3d55690bd6..879d8edca6 100644 --- a/lisp/emulation/viper-mous.el +++ b/lisp/emulation/viper-mous.el @@ -198,8 +198,7 @@ is ignored." (setq result (buffer-substring word-beg (point)))) ) ; if - ;; XEmacs doesn't have set-text-properties, but there buffer-substring - ;; doesn't return properties together with the string, so it's not needed. + ;; FIXME: Use `buffer-substring-no-properties' above instead? (set-text-properties 0 (length result) nil result) result)) diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el index 716348a9c1..ef040ca90b 100644 --- a/lisp/mail/footnote.el +++ b/lisp/mail/footnote.el @@ -898,7 +898,7 @@ play around with the following keys: (make-local-variable 'footnote-end-tag) (make-local-variable 'adaptive-fill-function) - ;; Filladapt was an XEmacs package which is now in GNU ELPA. + ;; Filladapt is a GNU ELPA package. (when (boundp 'filladapt-token-table) ;; add tokens to filladapt to match footnotes ;; 1] xxxxxxxxxxx x x x or [1] x x x x x x x diff --git a/lisp/textmodes/reftex-index.el b/lisp/textmodes/reftex-index.el index 9d9eab4d7b..357f7da2f9 100644 --- a/lisp/textmodes/reftex-index.el +++ b/lisp/textmodes/reftex-index.el @@ -29,9 +29,7 @@ (require 'reftex) -;; START remove for XEmacs release (defvar TeX-master) -;; END remove for XEmacs release ;;;###autoload (defun reftex-index-selection-or-word (&optional arg phrase) commit 3be2a6b8b4098e5cf118d196e4cba37054d8292b Author: Stefan Kangas Date: Wed Nov 17 06:05:12 2021 +0100 Make mh-funcall-if-exists obsolete * lisp/mh-e/mh-acros.el (mh-funcall-if-exists): Make obsolete. * lisp/mh-e/mh-alias.el (mh-read-address): * lisp/mh-e/mh-folder.el (mh-folder-mode): * lisp/mh-e/mh-mime.el (mh-mm-display-part): * lisp/mh-e/mh-show.el (mh-defun-show-buffer): * lisp/mh-e/mh-speed.el (mh-speedbar-change-expand-button-char): * lisp/mh-e/mh-tool-bar.el (mh-tool-bar-define): * lisp/mh-e/mh-utils.el (mh-logo-display): * lisp/mh-e/mh-xface.el (mh-face-display-function): Don't use above obsolete macro. diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el index 0669f5bb22..25fff6a8e1 100644 --- a/lisp/mh-e/mh-acros.el +++ b/lisp/mh-e/mh-acros.el @@ -59,7 +59,8 @@ ;;;###mh-autoload (defmacro mh-funcall-if-exists (function &rest args) "Call FUNCTION with ARGS as parameters if it exists." - (declare (debug (symbolp body))) + (declare (obsolete "use `(when (fboundp 'foo) (foo))' instead." "29.1") + (debug (symbolp body))) ;; FIXME: Not clear when this should be used. If the function happens ;; not to exist at compile-time (e.g. because the corresponding package ;; wasn't loaded), then it won't ever be used :-( diff --git a/lisp/mh-e/mh-alias.el b/lisp/mh-e/mh-alias.el index 5761df5297..8087df97c9 100644 --- a/lisp/mh-e/mh-alias.el +++ b/lisp/mh-e/mh-alias.el @@ -258,15 +258,7 @@ Blind aliases or users from /etc/passwd are not expanded." (read-string prompt) (let* ((minibuffer-local-completion-map mh-alias-read-address-map) (completion-ignore-case mh-alias-completion-ignore-case-flag) - (the-answer - (cond ((fboundp 'completing-read-multiple) - (mh-funcall-if-exists - completing-read-multiple prompt mh-alias-alist nil nil)) - ((featurep 'multi-prompt) - (mh-funcall-if-exists - multi-prompt "," nil prompt mh-alias-alist nil nil)) - (t (split-string - (completing-read prompt mh-alias-alist nil nil) ","))))) + (the-answer (completing-read-multiple prompt mh-alias-alist nil nil))) (if (not mh-alias-expand-aliases-flag) (mapconcat #'identity the-answer ", ") ;; Loop over all elements, checking if in passwd alias or blind first diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el index ddf13d193e..132ac33d26 100644 --- a/lisp/mh-e/mh-folder.el +++ b/lisp/mh-e/mh-folder.el @@ -631,7 +631,7 @@ perform the operation on all messages in that region. (add-hook 'write-file-functions #'mh-execute-commands nil t) (make-local-variable 'revert-buffer-function) (make-local-variable 'hl-line-mode) ; avoid pollution - (mh-funcall-if-exists hl-line-mode 1) + (hl-line-mode 1) (setq revert-buffer-function #'mh-undo-folder) (add-to-list 'minor-mode-alist '(mh-showing-mode " Show")) (mh-inc-spool-make) diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el index 0b58d7ba1f..3698dd33ec 100644 --- a/lisp/mh-e/mh-mime.el +++ b/lisp/mh-e/mh-mime.el @@ -700,8 +700,7 @@ buttons for alternative parts that are usually suppressed." ;; Delete the button and displayed part (if any) (let ((region (get-text-property point 'mh-region))) (when region - (mh-funcall-if-exists - remove-images (car region) (cdr region))) + (remove-images (car region) (cdr region))) (mm-display-part handle) (when region (delete-region (car region) (cdr region)))) diff --git a/lisp/mh-e/mh-show.el b/lisp/mh-e/mh-show.el index 0f85cd6f69..16489bf017 100644 --- a/lisp/mh-e/mh-show.el +++ b/lisp/mh-e/mh-show.el @@ -367,7 +367,8 @@ still visible.\n") (setq normal-exit t)) (deactivate-mark) (when (eq major-mode 'mh-folder-mode) - (mh-funcall-if-exists hl-line-highlight)) + (when (fboundp 'hl-line-highlight) + (hl-line-highlight))) (cond ((not normal-exit) (set-window-configuration config)) ,(if dont-return diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el index bf3a9e5774..d9909a034d 100644 --- a/lisp/mh-e/mh-speed.el +++ b/lisp/mh-e/mh-speed.el @@ -535,8 +535,8 @@ be handled next." (insert-char char 1 t) (put-text-property (point) (1- (point)) 'invisible nil) ;; make sure we fix the image on the text here. - (mh-funcall-if-exists - speedbar-insert-image-button-maybe (- (point) 2) 3))))) + (when (fboundp 'speedbar-insert-image-button-maybe) + (speedbar-insert-image-button-maybe (- (point) 2) 3)))))) ;;;###mh-autoload (defun mh-speed-add-folder (folder) diff --git a/lisp/mh-e/mh-tool-bar.el b/lisp/mh-e/mh-tool-bar.el index 0200d232c3..d451ae34d2 100644 --- a/lisp/mh-e/mh-tool-bar.el +++ b/lisp/mh-e/mh-tool-bar.el @@ -182,8 +182,7 @@ where, (add-to-list vector-list `(vector nil ',function t ,full-doc)) (add-to-list setter `(when (member ',name ,list) - (mh-funcall-if-exists - tool-bar-add-item ,icon ',function ',key + (tool-bar-add-item ,icon ',function ',key :help ,doc :enable ',enable-expr))) (add-to-list mbuttons name) (if docs (add-to-list docs doc)))))) diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el index 1c322b8034..992943e304 100644 --- a/lisp/mh-e/mh-utils.el +++ b/lisp/mh-e/mh-utils.el @@ -139,8 +139,7 @@ Ignores case when searching for OLD." 0 2 `(display ,(or mh-logo-cache (setq mh-logo-cache - (mh-funcall-if-exists - find-image '(( :type xpm :ascent center + (find-image '(( :type xpm :ascent center :file "mh-logo.xpm" )))))) (car mode-line-buffer-identification)))) diff --git a/lisp/mh-e/mh-xface.el b/lisp/mh-e/mh-xface.el index 0c1bcdfefd..8350f3d0fb 100644 --- a/lisp/mh-e/mh-xface.el +++ b/lisp/mh-e/mh-xface.el @@ -73,8 +73,7 @@ in this order is used." (when (re-search-forward "^from:" (point-max) t) (if (eq type 'url) (mh-x-image-url-display url) - (mh-funcall-if-exists - insert-image (create-image + (insert-image (create-image raw type t :foreground (face-foreground 'mh-show-xface nil t) commit 0fd79ee039de664bc06b0dbcaee786f88a2b079c Author: Stefan Kangas Date: Wed Nov 17 05:49:05 2021 +0100 Convert keymaps in bookmark.el to defvar-keymap * lisp/bookmark.el (bookmark-map) (bookmark-minibuffer-read-name-map) (bookmark-edit-annotation-mode-map, bookmark-bmenu-mode-map): Convert to defvar-keymap. diff --git a/lisp/bookmark.el b/lisp/bookmark.el index 58fd0021f5..5176d7aa8d 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -214,31 +214,28 @@ A non-nil value may result in truncated bookmark names." ;;;###autoload (define-key ctl-x-r-map "l" 'bookmark-bmenu-list) ;;;###autoload -(defvar bookmark-map - (let ((map (make-sparse-keymap))) - ;; Read the help on all of these functions for details... - (define-key map "x" 'bookmark-set) - (define-key map "m" 'bookmark-set) ;"m"ark - (define-key map "M" 'bookmark-set-no-overwrite) ;"M"aybe mark - (define-key map "j" 'bookmark-jump) - (define-key map "g" 'bookmark-jump) ;"g"o - (define-key map "o" 'bookmark-jump-other-window) - (define-key map "5" 'bookmark-jump-other-frame) - (define-key map "i" 'bookmark-insert) - (define-key map "e" 'edit-bookmarks) - (define-key map "f" 'bookmark-insert-location) ;"f"ind - (define-key map "r" 'bookmark-rename) - (define-key map "d" 'bookmark-delete) - (define-key map "D" 'bookmark-delete-all) - (define-key map "l" 'bookmark-load) - (define-key map "w" 'bookmark-write) - (define-key map "s" 'bookmark-save) - map) - "Keymap containing bindings to bookmark functions. +(defvar-keymap bookmark-map + :doc "Keymap containing bindings to bookmark functions. It is not bound to any key by default: to bind it so that you have a bookmark prefix, just use `global-set-key' and bind a key of your choice to variable `bookmark-map'. All interactive bookmark -functions have a binding in this keymap.") +functions have a binding in this keymap." + "x" #'bookmark-set + "m" #'bookmark-set ;"m"ark + "M" #'bookmark-set-no-overwrite ;"M"aybe mark + "j" #'bookmark-jump + "g" #'bookmark-jump ;"g"o + "o" #'bookmark-jump-other-window + "5" #'bookmark-jump-other-frame + "i" #'bookmark-insert + "e" #'edit-bookmarks + "f" #'bookmark-insert-location ;"f"ind + "r" #'bookmark-rename + "d" #'bookmark-delete + "D" #'bookmark-delete-all + "l" #'bookmark-load + "w" #'bookmark-write + "s" #'bookmark-save) ;;;###autoload (fset 'bookmark-map bookmark-map) @@ -813,11 +810,9 @@ CODING is the symbol of the coding-system in which the file is encoded." (define-obsolete-function-alias 'bookmark-maybe-message 'message "27.1") -(defvar bookmark-minibuffer-read-name-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-map) - (define-key map "\C-w" 'bookmark-yank-word) - map)) +(defvar-keymap bookmark-minibuffer-read-name-map + :parent minibuffer-local-map + ["C-w"] #'bookmark-yank-word) (defun bookmark-set-internal (prompt name overwrite-or-push) "Set a bookmark using specified NAME or prompting with PROMPT. @@ -992,12 +987,10 @@ annotations." "Function to return default text to use for a bookmark annotation. It takes one argument, the name of the bookmark, as a string.") -(defvar bookmark-edit-annotation-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\C-c\C-c" 'bookmark-send-edited-annotation) - map) - "Keymap for editing an annotation of a bookmark.") +(defvar-keymap bookmark-edit-annotation-mode-map + :doc "Keymap for editing an annotation of a bookmark." + :parent text-mode-map + ["C-c C-c"] #'bookmark-send-edited-annotation) (defun bookmark-insert-annotation (bookmark-name-or-record) "Insert annotation for BOOKMARK-NAME-OR-RECORD at point." @@ -1700,44 +1693,42 @@ unique numeric suffixes \"<2>\", \"<3>\", etc." (defvar bookmark-bmenu-hidden-bookmarks ()) - -(defvar bookmark-bmenu-mode-map - (let ((map (make-keymap))) - (set-keymap-parent map tabulated-list-mode-map) - (define-key map "v" 'bookmark-bmenu-select) - (define-key map "w" 'bookmark-bmenu-locate) - (define-key map "5" 'bookmark-bmenu-other-frame) - (define-key map "2" 'bookmark-bmenu-2-window) - (define-key map "1" 'bookmark-bmenu-1-window) - (define-key map "j" 'bookmark-bmenu-this-window) - (define-key map "\C-c\C-c" 'bookmark-bmenu-this-window) - (define-key map "f" 'bookmark-bmenu-this-window) - (define-key map "\C-m" 'bookmark-bmenu-this-window) - (define-key map "o" 'bookmark-bmenu-other-window) - (define-key map "\C-o" 'bookmark-bmenu-switch-other-window) - (define-key map "s" 'bookmark-bmenu-save) - (define-key map "\C-x\C-s" 'bookmark-bmenu-save) - (define-key map "k" 'bookmark-bmenu-delete) - (define-key map "\C-d" 'bookmark-bmenu-delete-backwards) - (define-key map "x" 'bookmark-bmenu-execute-deletions) - (define-key map "d" 'bookmark-bmenu-delete) - (define-key map "D" 'bookmark-bmenu-delete-all) - (define-key map " " 'next-line) - (define-key map "\177" 'bookmark-bmenu-backup-unmark) - (define-key map "u" 'bookmark-bmenu-unmark) - (define-key map "U" 'bookmark-bmenu-unmark-all) - (define-key map "m" 'bookmark-bmenu-mark) - (define-key map "M" 'bookmark-bmenu-mark-all) - (define-key map "l" 'bookmark-bmenu-load) - (define-key map "r" 'bookmark-bmenu-rename) - (define-key map "R" 'bookmark-bmenu-relocate) - (define-key map "t" 'bookmark-bmenu-toggle-filenames) - (define-key map "a" 'bookmark-bmenu-show-annotation) - (define-key map "A" 'bookmark-bmenu-show-all-annotations) - (define-key map "e" 'bookmark-bmenu-edit-annotation) - (define-key map "/" 'bookmark-bmenu-search) - (define-key map [mouse-2] 'bookmark-bmenu-other-window-with-mouse) - map)) +(defvar-keymap bookmark-bmenu-mode-map + :doc "Keymap for `bookmark-bmenu-mode'." + :parent tabulated-list-mode-map + "v" #'bookmark-bmenu-select + "w" #'bookmark-bmenu-locate + "5" #'bookmark-bmenu-other-frame + "2" #'bookmark-bmenu-2-window + "1" #'bookmark-bmenu-1-window + "j" #'bookmark-bmenu-this-window + ["C-c C-c"] #'bookmark-bmenu-this-window + "f" #'bookmark-bmenu-this-window + ["C-m"] #'bookmark-bmenu-this-window + "o" #'bookmark-bmenu-other-window + ["C-o"] #'bookmark-bmenu-switch-other-window + "s" #'bookmark-bmenu-save + ["C-x C-s"] #'bookmark-bmenu-save + "k" #'bookmark-bmenu-delete + ["C-d"] #'bookmark-bmenu-delete-backwards + "x" #'bookmark-bmenu-execute-deletions + "d" #'bookmark-bmenu-delete + "D" #'bookmark-bmenu-delete-all + [? ] #'next-line + "\177" #'bookmark-bmenu-backup-unmark + "u" #'bookmark-bmenu-unmark + "U" #'bookmark-bmenu-unmark-all + "m" #'bookmark-bmenu-mark + "M" #'bookmark-bmenu-mark-all + "l" #'bookmark-bmenu-load + "r" #'bookmark-bmenu-rename + "R" #'bookmark-bmenu-relocate + "t" #'bookmark-bmenu-toggle-filenames + "a" #'bookmark-bmenu-show-annotation + "A" #'bookmark-bmenu-show-all-annotations + "e" #'bookmark-bmenu-edit-annotation + "/" #'bookmark-bmenu-search + [mouse-2] #'bookmark-bmenu-other-window-with-mouse) (easy-menu-define bookmark-menu bookmark-bmenu-mode-map "Menu for `bookmark-bmenu'." commit 1a4f210c246688519f85db72bdc3bea536cb5dbe Author: Stefan Monnier Date: Tue Nov 16 22:48:37 2021 -0500 * lisp/rot13.el (rot13-translate-table): Make it a `translation-table` (rot13-display-table): Use `dotimes`. diff --git a/lisp/rot13.el b/lisp/rot13.el index 4e4e60fea3..e509b22529 100644 --- a/lisp/rot13.el +++ b/lisp/rot13.el @@ -46,29 +46,23 @@ ;;; Code: -(defvar rot13-display-table - (let ((table (make-display-table)) - (i 0)) - (while (< i 26) +(defconst rot13-display-table + (let ((table (make-display-table))) + (dotimes (i 26) (aset table (+ i ?a) (vector (+ (% (+ i 13) 26) ?a))) - (aset table (+ i ?A) (vector (+ (% (+ i 13) 26) ?A))) - (setq i (1+ i))) + (aset table (+ i ?A) (vector (+ (% (+ i 13) 26) ?A)))) table) "Char table for ROT13 display.") -(defvar rot13-translate-table - (let ((str (make-string 127 0)) - (i 0)) - (while (< i 127) - (aset str i i) - (setq i (1+ i))) - (setq i 0) - (while (< i 26) - (aset str (+ i ?a) (+ (% (+ i 13) 26) ?a)) - (aset str (+ i ?A) (+ (% (+ i 13) 26) ?A)) - (setq i (1+ i))) - str) - "String table for ROT13 translation.") +(put 'plain-char-table 'char-table-extra-slots 0) + +(defconst rot13-translate-table + (let ((table (make-char-table 'translation-table))) + (dotimes (i 26) + (aset table (+ i ?a) (+ (% (+ i 13) 26) ?a)) + (aset table (+ i ?A) (+ (% (+ i 13) 26) ?A))) + table) + "Char table for ROT13 translation.") ;;;###autoload (defun rot13 (object &optional start end) commit fa0b34b716ba31a6414d12de67c8f30706caad96 Author: Stefan Kangas Date: Wed Nov 17 04:44:38 2021 +0100 * admin/authors.el (authors-ignored-files): Ignore some NEWS files. diff --git a/admin/authors.el b/admin/authors.el index fd46dabaa3..23990fee70 100644 --- a/admin/authors.el +++ b/admin/authors.el @@ -323,7 +323,8 @@ Changes to files matching one of the regexps in this list are not listed.") "NEWS.unicode" "COPYING.DJ" "Makefile.old" "Makefile.am" "NEWS.1" "OOOOONEWS...OONEWS" "OOOONEWS" "etc/NEWS" "NEWS.1-17" "NEWS.18" "NEWS.19" "NEWS.20" "NEWS.21" "NEWS.22" - "MAINTAINERS" "MH-E-NEWS" + "NEWS.23" "NEWS.24" "NEWS.25" "NEWS.26" "NEWS.27" "NEWS.28" + "MAINTAINERS" "ERC-NEWS" "MH-E-NEWS" "NXML-NEWS" "install.sh" "install-sh" "missing" "mkinstalldirs" "termcap.dat" "termcap.src" "termcap.ucb" "termcap" "ChangeLog.nextstep" "Emacs.clr" "spec.txt" commit 4c467e4aff12e65fa4fa62d7f4bdcbf4a2bcd92c Author: Stefan Kangas Date: Wed Nov 17 04:14:33 2021 +0100 * admin/gitmerge.el (gitmerge-mode-map): Convert to defvar-keymap. diff --git a/admin/gitmerge.el b/admin/gitmerge.el index 67fca87c11..5aae6b40a0 100644 --- a/admin/gitmerge.el +++ b/admin/gitmerge.el @@ -96,16 +96,13 @@ If nil, the function `gitmerge-default-branch' guesses.") (defvar gitmerge-log-regexp "^\\([A-Z ]\\)\\s-*\\([0-9a-f]+\\) \\(.+?\\): \\(.*\\)$") -(defvar gitmerge-mode-map - (let ((map (make-keymap))) - (define-key map [(l)] 'gitmerge-show-log) - (define-key map [(d)] 'gitmerge-show-diff) - (define-key map [(f)] 'gitmerge-show-files) - (define-key map [(s)] 'gitmerge-toggle-skip) - (define-key map [(m)] 'gitmerge-start-merge) - map) - "Keymap for gitmerge major mode.") - +(defvar-keymap gitmerge-mode-map + :doc "Keymap for gitmerge major mode." + "l" #'gitmerge-show-log + "d" #'gitmerge-show-diff + "f" #'gitmerge-show-files + "s" #'gitmerge-toggle-skip + "m" #'gitmerge-start-merge) (defvar gitmerge-mode-font-lock-keywords `((,gitmerge-log-regexp commit 2a99138f1766c23cfdbbc86ea5c277b0fbeed7e2 Author: Po Lu Date: Wed Nov 17 09:10:10 2021 +0800 Update xwidget webkit history buffer more eagerly * lisp/xwidget.el (xwidget-webkit-callback): Update history buffer on each load-changed event. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index c1d0cd66a9..37cf2e5816 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -393,15 +393,15 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." (cond ((eq xwidget-event-type 'load-changed) (let ((title (xwidget-webkit-title xwidget)) (uri (xwidget-webkit-uri xwidget))) + (when-let ((buffer (get-buffer "*Xwidget WebKit History*"))) + (with-current-buffer buffer + (revert-buffer))) ;; This funciton will be called multi times, so only ;; change buffer name when the load actually completes ;; this can limit buffer-name flicker in mode-line. (when (or (string-equal (nth 3 last-input-event) "load-finished") (> (length title) 0)) - (when-let ((buffer (get-buffer "*Xwidget WebKit History*"))) - (with-current-buffer buffer - (revert-buffer))) (with-current-buffer (xwidget-buffer xwidget) (setq xwidget-webkit--title title) (force-mode-line-update) commit 058c012f73d4abe014ace44b46c23babd48aebbc Author: Alan Third Date: Sun Nov 14 15:09:43 2021 +0000 Only set LANG if the ID is valid * src/nsterm.m (ns_init_locale): Check the provided locale identifier is available before trying to use it. diff --git a/src/nsterm.m b/src/nsterm.m index 1f17a30272..e29dda684a 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -535,8 +535,11 @@ - (NSColor *)colorUsingDefaultColorSpace NSTRACE ("ns_init_locale"); - @try + /* If we were run from a terminal then assume an unset LANG variable + is intentional and don't try to "fix" it. */ + if (!isatty (STDIN_FILENO)) { + char *oldLocale = setlocale (LC_ALL, NULL); /* It seems macOS should probably use UTF-8 everywhere. 'localeIdentifier' does not specify the encoding, and I can't find any way to get the OS to tell us which encoding to use, @@ -544,12 +547,12 @@ - (NSColor *)colorUsingDefaultColorSpace NSString *localeID = [NSString stringWithFormat:@"%@.UTF-8", [locale localeIdentifier]]; - /* Set LANG to locale, but not if LANG is already set. */ - setenv("LANG", [localeID UTF8String], 0); - } - @catch (NSException *e) - { - NSLog (@"Locale detection failed: %@: %@", [e name], [e reason]); + /* Check the locale ID is valid and if so set LANG, but not if + it is already set. */ + if (setlocale (LC_ALL, [localeID UTF8String])) + setenv("LANG", [localeID UTF8String], 0); + + setlocale (LC_ALL, oldLocale); } } commit c25be3e7bb91f932a1d620bef08e16872dcf04d5 Author: Juri Linkov Date: Tue Nov 16 22:45:33 2021 +0200 * lisp/tab-bar.el (tab-bar-select-tab): Add check for wc-frame (bug#51883). diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 9fba70f34d..871ed1c981 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -1096,7 +1096,11 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar." ;; its value of window-configuration is unreadable, ;; so restore its saved window-state. (cond - ((window-configuration-p wc) + ((and (window-configuration-p wc) + ;; Check for such cases as cloning a frame with tabs. + ;; When tabs were cloned to another frame, then fall back + ;; to using `window-state-put' below. + (eq (window-configuration-frame wc) (selected-frame))) (let ((wc-point (alist-get 'wc-point to-tab)) (wc-bl (seq-filter #'buffer-live-p (alist-get 'wc-bl to-tab))) (wc-bbl (seq-filter #'buffer-live-p (alist-get 'wc-bbl to-tab))) commit 38d905abf9eecbb1eef33c1d7df184f2f6faeeb3 Author: Juri Linkov Date: Tue Nov 16 22:40:45 2021 +0200 * lisp/tab-bar.el: Doc fixes for commands bound to modifier keys. (tab-bar-select-tab-modifiers) (tab-bar-select-tab, tab-bar-switch-to-last-tab): Doc fixes. diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 10f26875db..9fba70f34d 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -91,9 +91,10 @@ (defcustom tab-bar-select-tab-modifiers '() "List of modifier keys for selecting tab-bar tabs by their numbers. Possible modifier keys are `control', `meta', `shift', `hyper', `super' and -`alt'. Pressing one of the modifiers in the list and a digit selects -the tab whose number equals the digit. Negative numbers count from -the end of the tab bar. The digit 9 selects the last (rightmost) tab. +`alt'. Pressing one of the modifiers in the list and a digit selects the +tab whose number equals the digit (see `tab-bar-select-tab'). +The digit 9 selects the last (rightmost) tab (see `tab-last'). +The digit 0 selects the most recently visited tab (see `tab-recent'). For easier selection of tabs by their numbers, consider customizing `tab-bar-tab-hints', which will show tab numbers alongside the tab name." :type '(set :tag "Tab selection modifier keys" @@ -1060,11 +1061,14 @@ inherits the current tab's `explicit-name' parameter." (defun tab-bar-select-tab (&optional tab-number) "Switch to the tab by its absolute position TAB-NUMBER in the tab bar. -When this command is bound to a numeric key (with a prefix or modifier key +When this command is bound to a numeric key (with a key prefix or modifier key using `tab-bar-select-tab-modifiers'), calling it without an argument will translate its bound numeric key to the numeric argument. -TAB-NUMBER counts from 1. Negative TAB-NUMBER counts tabs from the end of -the tab bar." +Also the prefix argument TAB-NUMBER can be used to override +the numeric key, so it takes precedence over the bound digit key. +For example, `-2' will select the second tab, but `C-u 15 +-2' will select the 15th tab. TAB-NUMBER counts from 1. +Negative TAB-NUMBER counts tabs from the end of the tab bar." (interactive "P") (unless (integerp tab-number) (let ((key (event-basic-type last-command-event))) @@ -1161,7 +1165,8 @@ Interactively, ARG is the prefix numeric argument and defaults to 1." (defun tab-bar-switch-to-last-tab (&optional arg) "Switch to the last tab or ARGth tab from the end of the tab bar. Interactively, ARG is the prefix numeric argument; it defaults to 1, -which means the last tab on the tab bar." +which means the last tab on the tab bar. For example, `C-u 2 +-9' selects the tab before the last tab." (interactive "p") (tab-bar-select-tab (- (length (funcall tab-bar-tabs-function)) (1- (or arg 1))))) commit 97c23204b981d5ad88ea3c8ddff0f726798aff1b Author: Lars Ingebrigtsen Date: Tue Nov 16 19:41:56 2021 +0100 Make keymap-unset work * lisp/keymap.el (keymap-unset): Fix key syntax (bug#51897). diff --git a/lisp/keymap.el b/lisp/keymap.el index 8938197ecf..b634487ba6 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -119,7 +119,7 @@ a key in a child map, it will still shadow the same key in the parent keymap. Removing the binding will allow the key in the parent keymap to be used." (keymap--check key) - (define-key keymap key nil remove)) + (define-key keymap (key-parse key) nil remove)) (defun keymap-substitute (olddef newdef keymap &optional oldmap prefix) "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. commit 4f47f10d9f8f3864fd37685b290e4ca5d339ba35 Author: Eli Zaretskii Date: Tue Nov 16 19:14:04 2021 +0200 Put back documentation of legacy keymap functions * doc/lispref/keymaps.texi (Low-Level Key Binding): Reinstate documentation of legacy commands and functions. diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi index 38e688ab61..d893e22b8b 100644 --- a/doc/lispref/keymaps.texi +++ b/doc/lispref/keymaps.texi @@ -1626,53 +1626,105 @@ return the binding in the parent, and with a nil @var{def}, the lookups will return @code{nil}. @end defun -There's a number of other legacy key definition functions. Below is a -list of them, with the equivalent modern function to use instead. +Here are other legacy key definition functions and commands, with the +equivalent modern function to use instead in new code. -@table @code -@findex global-set-key -@item global-set-key -Use @code{keymap-global-set} instead. - -@findex local-set-key -@item local-set-key -Use @code{keymap-local-set} instead. - -@findex global-unset-key -@item global-unset-key -Use @code{keymap-global-unset} instead. - -@findex local-unset-key -@item local-unset-key -Use @code{keymap-local-unset} instead. - -@findex substitute-key-definition -@item substitute-key-definition -Use @code{keymap-substitute} instead. - -@findex define-key-after -@item define-key-after -Use @code{keymap-set-after} instead. - -@findex keyboard-translate -@item keyboard-translate -Use @code{key-translate} instead. - -@findex lookup-keymap -@findex key-binding -@item lookup-keymap -@itemx key-binding -Use @code{keymap-lookup} instead. - -@findex local-key-binding -@item local-key-binding -Use @code{keymap-local-lookup} instead. - -@findex global-key-binding -@item gobal-key-binding -Use @code{keymap-global-lookup} instead. -@end table +@deffn Command global-set-key key binding +This function sets the binding of @var{key} in the current global map +to @var{binding}. Use @code{keymap-global-set} instead. +@end deffn + +@deffn Command global-unset-key key +This function removes the binding of @var{key} from the current +global map. Use @code{keymap-global-unset} instead. +@end deffn + +@deffn Command local-set-key key binding +This function sets the binding of @var{key} in the current local +keymap to @var{binding}. Use @code{keymap-local-set} instead. +@end deffn + +@deffn Command local-unset-key key +This function removes the binding of @var{key} from the current +local map. Use @code{keymap-local-unset} instead. +@end deffn + +@defun substitute-key-definition olddef newdef keymap &optional oldmap +This function replaces @var{olddef} with @var{newdef} for any keys in +@var{keymap} that were bound to @var{olddef}. In other words, +@var{olddef} is replaced with @var{newdef} wherever it appears. The +function returns @code{nil}. Use @code{keymap-substitute} instead. +@end defun + +@defun define-key-after map key binding &optional after +Define a binding in @var{map} for @var{key}, with value @var{binding}, +just like @code{define-key}, but position the binding in @var{map} after +the binding for the event @var{after}. The argument @var{key} should be +of length one---a vector or string with just one element. But +@var{after} should be a single event type---a symbol or a character, not +a sequence. The new binding goes after the binding for @var{after}. If +@var{after} is @code{t} or is omitted, then the new binding goes last, at +the end of the keymap. However, new bindings are added before any +inherited keymap. Use @code{keymap-set-after} instead of this function. +@end defun + +@defun keyboard-translate from to +This function modifies @code{keyboard-translate-table} to translate +character code @var{from} into character code @var{to}. It creates +the keyboard translate table if necessary. Use @code{key-translate} +instead. +@end defun + +@defun key-binding key &optional accept-defaults no-remap position +This function returns the binding for @var{key} according to the +current active keymaps. The result is @code{nil} if @var{key} is +undefined in the keymaps. The argument @var{accept-defaults} controls +checking for default bindings, as in @code{lookup-key} +(@pxref{Functions for Key Lookup}). If @var{no-remap} is +non-@code{nil}, @code{key-binding} ignores command remappings +(@pxref{Remapping Commands}) and returns the binding directly +specified for @var{key}. The optional argument @var{position} should +be either a buffer position or an event position like the value of +@code{event-start}; it tells the function to consult the maps +determined based on that @var{position}. + +Emacs signals an error if @var{key} is not a string or a vector. + +Use @code{keymap-lookup} instead of this function. +@end defun + +@defun lookup-key keymap key &optional accept-defaults +This function returns the definition of @var{key} in @var{keymap}. If +the string or vector @var{key} is not a valid key sequence according +to the prefix keys specified in @var{keymap}, it must be too long and +have extra events at the end that do not fit into a single key +sequence. Then the value is a number, the number of events at the +front of @var{key} that compose a complete key. + +If @var{accept-defaults} is non-@code{nil}, then @code{lookup-key} +considers default bindings as well as bindings for the specific events +in @var{key}. Otherwise, @code{lookup-key} reports only bindings for +the specific sequence @var{key}, ignoring default bindings except when +you explicitly ask about them. + +Use @code{keymap-lookup} instead of this function. +@end defun + +@defun local-key-binding key &optional accept-defaults +This function returns the binding for @var{key} in the current +local keymap, or @code{nil} if it is undefined there. + +The argument @var{accept-defaults} controls checking for default bindings, +as in @code{lookup-key} (above). +@end defun + +@defun global-key-binding key &optional accept-defaults +This function returns the binding for command @var{key} in the +current global keymap, or @code{nil} if it is undefined there. +The argument @var{accept-defaults} controls checking for default bindings, +as in @code{lookup-key} (above). +@end defun @node Remapping Commands @section Remapping Commands commit 6748c465aba092364465e6309359c3bc8857f34d Merge: 9e2f59132d 6e93cb0954 Author: Eli Zaretskii Date: Tue Nov 16 16:18:30 2021 +0200 Merge branch 'master' of git.savannah.gnu.org:/srv/git/emacs commit 9e2f59132dd0df8338dc315621fa23341857f07c Author: Eli Zaretskii Date: Tue Nov 16 16:17:10 2021 +0200 Minor copyedits of recent documentation changes * doc/lispref/keymaps.texi (Low-Level Key Binding): Minor changes in wording and markup. diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi index 86faba2619..38e688ab61 100644 --- a/doc/lispref/keymaps.texi +++ b/doc/lispref/keymaps.texi @@ -1575,13 +1575,14 @@ Modes}); then its keymap will automatically inherit from @node Low-Level Key Binding @section Low-Level Key Binding +@cindex low-level key bindings Historically, Emacs has supported a number of different syntaxes for defining keys. The documented way to bind a key today is to use the syntax supported by @code{key-valid-p}, which is what all the functions like @code{keymap-set} and @code{keymap-lookup} supports. -This section of the manual documents the old syntax and interface -functions, and should not be used in new code. +This section documents the old-style syntax and interface functions; +they should not be used in new code. @cindex meta character key constants @cindex control character key constants @@ -1595,20 +1596,21 @@ character or function key name). For example, @code{[(control ?a) (meta b)]} is equivalent to @kbd{C-a M-b} and @code{[(hyper control left)]} is equivalent to @kbd{C-H-left}. -@item A string with control and meta characters. +@item A string of characters with modifiers Internally, key sequences are often represented as strings using the -special escape sequences for control and meta characters +special escape sequences for shift, control and meta modifiers (@pxref{String Type}), but this representation can also be used by users when rebinding keys. A string like @code{"\M-x"} is read as containing a single @kbd{M-x}, @code{"\C-f"} is read as containing a single @kbd{C-f}, and @code{"\M-\C-x"} and @code{"\C-\M-x"} are both read as containing a single @kbd{C-M-x}. -@item a vector of characters. -This is the other internal representation of key sequences, and -supports a fuller range of modifiers than the string representation. -One example is @samp{[?\C-\H-x home]}, which represents the @kbd{C-H-x -home} key sequence. @xref{Character Type}. +@item A vector of characters and key symbols +This is the other internal representation of key sequences. It +supports a fuller range of modifiers than the string representation, +and also support function keys. An example is @w{@samp{[?\C-\H-x +home]}}, which represents the @w{@kbd{C-H-x @key{home}}} key sequence. +@xref{Character Type}. @end table @defun define-key keymap key binding &optional remove commit 6e93cb0954285b16054d07e420cf3bdc5d93c1c2 Author: Michael Albinus Date: Tue Nov 16 15:04:27 2021 +0100 Some minor Tramp updates * lisp/net/tramp-crypt.el (tramp-crypt-add-directory): Add comment. * lisp/net/tramp.el (tramp-debug-buffer-command-completion-p) (tramp-setup-debug-buffer): New defuns. (tramp-get-debug-buffer): Call `tramp-setup-debug-buffer. * test/lisp/net/tramp-tests.el (tramp-test07-abbreviate-file-name): Extend test. diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index f60841cf8c..4ff8e6bbf1 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -486,6 +486,7 @@ See `tramp-crypt-do-encrypt-or-decrypt-file'." Files in that directory and all subdirectories will be encrypted before copying to, and decrypted after copying from that directory. File names will be also encrypted." + ;; (declare (completion tramp-crypt-command-completion-p)) (interactive "DRemote directory name: ") (unless tramp-crypt-enabled (tramp-user-error nil "Feature is not enabled.")) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 26425199bf..7927ddd107 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1904,31 +1904,55 @@ The outline level is equal to the verbosity of the Tramp message." (put #'tramp-debug-outline-level 'tramp-suppress-trace t) +;; This function takes action since Emacs 28.1, when +;; `read-extended-command-predicate' is set to +;; `command-completion-default-include-p'. +(defun tramp-debug-buffer-command-completion-p (_symbol buffer) + "A predicate for Tramp interactive commands. +They are completed by \"M-x TAB\" only in Tramp debug buffers." + (with-current-buffer buffer + (string-equal (buffer-substring 1 10) ";; Emacs:"))) + +(put #'tramp-debug-buffer-command-completion-p 'tramp-suppress-trace t) + +(defun tramp-setup-debug-buffer () + "Function to setup debug buffers." + ;; (declare (completion tramp-debug-buffer-command-completion-p)) + (interactive) + (set-buffer-file-coding-system 'utf-8) + (setq buffer-undo-list t) + ;; Activate `outline-mode'. This runs `text-mode-hook' and + ;; `outline-mode-hook'. We must prevent that local processes die. + ;; Yes: I've seen `flyspell-mode', which starts "ispell". + ;; `(custom-declare-variable outline-minor-mode-prefix ...)' raises + ;; on error in `(outline-mode)', we don't want to see it in the + ;; traces. + (let ((default-directory tramp-compat-temporary-file-directory)) + (outline-mode)) + (setq-local outline-level 'tramp-debug-outline-level) + (setq-local font-lock-keywords + ;; FIXME: This `(t FOO . BAR)' representation in + ;; `font-lock-keywords' is supposed to be an internal + ;; implementation "detail". Don't abuse it here! + `(t (eval ,tramp-debug-font-lock-keywords t) + ,(eval tramp-debug-font-lock-keywords t))) + ;; Do not edit the debug buffer. + (use-local-map special-mode-map) + ;; For debugging purposes. + (local-set-key "\M-n" 'clone-buffer) + (add-hook 'clone-buffer-hook #'tramp-setup-debug-buffer nil 'local)) + +(put #'tramp-setup-debug-buffer 'tramp-suppress-trace t) + +(function-put + #'tramp-setup-debug-buffer 'completion-predicate + #'tramp-debug-buffer-command-completion-p) + (defun tramp-get-debug-buffer (vec) "Get the debug buffer for VEC." (with-current-buffer (get-buffer-create (tramp-debug-buffer-name vec)) (when (bobp) - (set-buffer-file-coding-system 'utf-8) - (setq buffer-undo-list t) - ;; Activate `outline-mode'. This runs `text-mode-hook' and - ;; `outline-mode-hook'. We must prevent that local processes - ;; die. Yes: I've seen `flyspell-mode', which starts "ispell". - ;; `(custom-declare-variable outline-minor-mode-prefix ...)' - ;; raises on error in `(outline-mode)', we don't want to see it - ;; in the traces. - (let ((default-directory tramp-compat-temporary-file-directory)) - (outline-mode)) - (setq-local outline-level 'tramp-debug-outline-level) - (setq-local font-lock-keywords - ;; FIXME: This `(t FOO . BAR)' representation in - ;; `font-lock-keywords' is supposed to be an - ;; internal implementation "detail". Don't abuse it here! - `(t (eval ,tramp-debug-font-lock-keywords t) - ,(eval tramp-debug-font-lock-keywords t))) - ;; Do not edit the debug buffer. - (use-local-map special-mode-map) - ;; For debugging purposes. - (define-key (current-local-map) "\M-n" 'clone-buffer)) + (tramp-setup-debug-buffer)) (current-buffer))) (put #'tramp-get-debug-buffer 'tramp-suppress-trace t) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 150ea29838..482d3ff554 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2314,7 +2314,16 @@ This checks also `file-name-as-directory', `file-name-directory', (concat remote-host "~/f/bar"))) (should (equal (abbreviate-file-name (concat remote-host "/nowhere/special")) - (concat remote-host "/nw/special")))))) + (concat remote-host "/nw/special")))) + + ;; Check that home-dir abbreviation doesn't occur when home-dir is just "/". + (setq home-dir (concat remote-host "/")) + ;; The remote home directory is kept in the connection property + ;; "home-directory". We fake this setting. + (tramp-set-connection-property tramp-test-vec "home-directory" home-dir) + (should (equal (concat home-dir "foo/bar") + (abbreviate-file-name (concat home-dir "foo/bar")))) + (tramp-flush-connection-property tramp-test-vec "home-directory"))) (ert-deftest tramp-test07-file-exists-p () "Check `file-exist-p', `write-region' and `delete-file'." commit ee2a5784561431b9bf23efa752523cca9e229e9f Author: Lars Ingebrigtsen Date: Tue Nov 16 14:10:50 2021 +0100 Fix compilation error in previous keymap.c change * src/keymap.c (initial_define_lispy_key, define_as_prefix): Fix --enable-checking error. diff --git a/src/keymap.c b/src/keymap.c index 7993e31ac6..0b882958b9 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -132,7 +132,7 @@ void initial_define_lispy_key (Lisp_Object keymap, const char *keyname, const char *defname) { store_in_keymap (keymap, intern_c_string (keyname), - intern_c_string (defname), Qnil); + intern_c_string (defname), false); } DEFUN ("keymapp", Fkeymapp, Skeymapp, 1, 1, 0, @@ -1441,7 +1441,7 @@ static Lisp_Object define_as_prefix (Lisp_Object keymap, Lisp_Object c) { Lisp_Object cmd = Fmake_sparse_keymap (Qnil); - store_in_keymap (keymap, c, cmd, Qnil); + store_in_keymap (keymap, c, cmd, false); return cmd; } commit 8d0c19fb0c368692f4b17728c0eaf3e16e0c70f7 Author: Po Lu Date: Tue Nov 16 17:51:07 2021 +0800 Lower xwidget views owned by parent when lowering frame * src/xterm.c (x_lower_frame): Lower parent frame's xwidget views as well. * src/xwidget.h (lower_frame_xwidget_views): * src/xwidget.c (lower_frame_xwidget_views): New function. diff --git a/src/xterm.c b/src/xterm.c index 5988d3a15f..816b6dc5a8 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -11723,6 +11723,13 @@ x_lower_frame (struct frame *f) XFlush (FRAME_X_DISPLAY (f)); unblock_input (); } +#ifdef HAVE_XWIDGETS + /* Make sure any X windows owned by xwidget views of the parent + still display below the lowered frame. */ + + if (FRAME_PARENT_FRAME (f)) + lower_frame_xwidget_views (FRAME_PARENT_FRAME (f)); +#endif } static void diff --git a/src/xwidget.c b/src/xwidget.c index 008eb07bca..650572a889 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -2810,6 +2810,20 @@ xwidget_end_redisplay (struct window *w, struct glyph_matrix *matrix) } #ifdef USE_GTK +void +lower_frame_xwidget_views (struct frame *f) +{ + struct xwidget_view *xv; + + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); + tail = XCDR (tail)) + { + xv = XXWIDGET_VIEW (XCAR (tail)); + if (xv->frame == f && xv->wdesc != None) + XLowerWindow (xv->dpy, xv->wdesc); + } +} + void kill_frame_xwidget_views (struct frame *f) { diff --git a/src/xwidget.h b/src/xwidget.h index df55dacffe..2f6d0442e2 100644 --- a/src/xwidget.h +++ b/src/xwidget.h @@ -188,6 +188,7 @@ extern struct xwidget *xwidget_from_id (uint32_t id); #ifdef HAVE_X_WINDOWS struct xwidget_view *xwidget_view_from_window (Window wdesc); void xwidget_expose (struct xwidget_view *xv); +extern void lower_frame_xwidget_views (struct frame *f); extern void kill_frame_xwidget_views (struct frame *f); extern void xwidget_button (struct xwidget_view *, bool, int, int, int, int, Time); commit 1657e0fb177d6a107479306e17ffbb9016a9a40c Author: Po Lu Date: Mon Nov 15 13:12:45 2021 +0800 Add command to browse xwidget history * doc/emacs/misc.texi (Embedded WebKit Widgets) * etc/NEWS: Document `xwidget-webkit-browse-history'. * lisp/xwidget.el (xwidget-webkit-mode-map): Bind "H" to xwidget-webkit-browse-history. (xwidget-webkit-import-widget): Set last session buffer correctly. (xwidget-webkit-browse-history): New command. (xwidget-webkit-history--session): New variable. (xwidget-webkit-history--insert-item) (xwidget-webkit-history-select-item) (xwidget-webkit-history-reload): New functions. (xwidget-webkit-history-mode): New major mode. diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index 3d423d7675..1f2c852fac 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -3011,6 +3011,14 @@ the WebKit widget to display the next search result, while typing To leave incremental search, you can type @kbd{C-g}. +@findex xwidget-webkit-browse-history +@cindex history of webkit buffers + The command @code{xwidget-webkit-browse-history} displays a buffer +containing a list of pages previously loaded by the current WebKit +buffer, and lets you navigate to those pages by hitting @kbd{RET}. + +It is bound to @kbd{H}. + @node Browse-URL @subsection Following URLs @cindex World Wide Web diff --git a/etc/NEWS b/etc/NEWS index ce4c86b0c8..80be6c0e49 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -498,6 +498,11 @@ This mode acts similarly to incremental search, and allows to search the contents of a WebKit widget. In xwidget-webkit mode, it is bound to 'C-s' and 'C-r'. ++++ +*** New command 'xwidget-webkit-browse-history'. +This command displays a buffer containing the page load history of +the current WebKit widget, and allows you to navigate it. + --- *** On X11, the WebKit inspector is now available inside xwidgets. To access the inspector, right click on the widget and select "Inspect diff --git a/lisp/xwidget.el b/lisp/xwidget.el index a587fe85db..c1d0cd66a9 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -55,6 +55,7 @@ (declare-function delete-xwidget-view "xwidget.c" (xwidget-view)) (declare-function get-buffer-xwidgets "xwidget.c" (buffer)) (declare-function xwidget-query-on-exit-flag "xwidget.c" (xwidget)) +(declare-function xwidget-webkit-back-forward-list "xwidget.c" (xwidget &optional limit)) (defgroup xwidget nil "Displaying native widgets in Emacs buffers." @@ -194,6 +195,7 @@ for the actual events that will be sent." (define-key map "e" 'xwidget-webkit-edit-mode) (define-key map "\C-r" 'xwidget-webkit-isearch-mode) (define-key map "\C-s" 'xwidget-webkit-isearch-mode) + (define-key map "H" 'xwidget-webkit-browse-history) ;;similar to image mode bindings (define-key map (kbd "SPC") 'xwidget-webkit-scroll-up) @@ -228,6 +230,7 @@ for the actual events that will be sent." ["Back" xwidget-webkit-back t] ["Forward" xwidget-webkit-forward t] ["Reload" xwidget-webkit-reload t] + ["History" xwidget-webkit-browse-history t] ["Insert String" xwidget-webkit-insert-string :active t :help "Insert a string into the currently active field"] @@ -396,6 +399,9 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." (when (or (string-equal (nth 3 last-input-event) "load-finished") (> (length title) 0)) + (when-let ((buffer (get-buffer "*Xwidget WebKit History*"))) + (with-current-buffer buffer + (revert-buffer))) (with-current-buffer (xwidget-buffer xwidget) (setq xwidget-webkit--title title) (force-mode-line-update) @@ -775,6 +781,7 @@ Return the buffer." (callback #'xwidget-webkit-callback) (buffer (get-buffer-create bufname))) (with-current-buffer buffer + (setq xwidget-webkit-last-session-buffer buffer) (save-excursion (erase-buffer) (insert ".") @@ -821,6 +828,15 @@ Return the buffer." (let ((url (xwidget-webkit-uri (xwidget-webkit-current-session)))) (message "URL: %s" (kill-new (or url ""))))) +(defun xwidget-webkit-browse-history () + "Display a buffer containing the history of page loads." + (interactive) + (setq xwidget-webkit-last-session-buffer (current-buffer)) + (let ((buffer (get-buffer-create "*Xwidget WebKit History*"))) + (with-current-buffer buffer + (xwidget-webkit-history-mode)) + (display-buffer buffer))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun xwidget-webkit-get-selection (proc) "Get the webkit selection and pass it to PROC." @@ -1059,6 +1075,66 @@ Press \\\\[xwidget-webkit-isearch-exit] to exit (concat xwidget-webkit-isearch--string (current-kill 0))) (xwidget-webkit-isearch--update)) + +(defvar-local xwidget-webkit-history--session nil + "The xwidget this history buffer controls.") + +(define-button-type 'xwidget-webkit-history 'action #'xwidget-webkit-history-select-item) + +(defun xwidget-webkit-history--insert-item (item) + "Insert specified ITEM into the current buffer." + (let ((idx (car item)) + (title (cadr item)) + (uri (caddr item))) + (push (list idx (vector (list (number-to-string idx) + :type 'xwidget-webkit-history) + (list title :type 'xwidget-webkit-history) + (list uri :type 'xwidget-webkit-history))) + tabulated-list-entries))) + +(defun xwidget-webkit-history-select-item (pos) + "Navigate to the history item underneath POS." + (interactive "P") + (let ((id (tabulated-list-get-id pos))) + (xwidget-webkit-goto-history xwidget-webkit-history--session id)) + (xwidget-webkit-history-reload)) + +(defun xwidget-webkit-history-reload (&rest ignored) + "Reload the current history buffer." + (interactive) + (setq tabulated-list-entries nil) + (let* ((back-forward-list + (xwidget-webkit-back-forward-list xwidget-webkit-history--session)) + (back-list (car back-forward-list)) + (here (cadr back-forward-list)) + (forward-list (caddr back-forward-list))) + (mapc #'xwidget-webkit-history--insert-item (nreverse forward-list)) + (xwidget-webkit-history--insert-item here) + (mapc #'xwidget-webkit-history--insert-item back-list) + (tabulated-list-print t nil) + (goto-char (point-min)) + (let ((position (line-beginning-position (1+ (length back-list))))) + (goto-char position) + (setq-local overlay-arrow-position (make-marker)) + (set-marker overlay-arrow-position position)))) + +(define-derived-mode xwidget-webkit-history-mode tabulated-list-mode + "Xwidget Webkit History" + "Major mode for browsing the history of an Xwidget Webkit buffer. +Each line describes an entry in history." + (setq truncate-lines t) + (setq buffer-read-only t) + (setq tabulated-list-format [("Index" 10 nil) + ("Title" 50 nil) + ("URL" 100 nil)]) + (setq tabulated-list-entries nil) + (setq xwidget-webkit-history--session (xwidget-webkit-current-session)) + (xwidget-webkit-history-reload) + (setq-local revert-buffer-function #'xwidget-webkit-history-reload) + (tabulated-list-init-header)) + +(define-key xwidget-webkit-history-mode-map (kbd "RET") + #'xwidget-webkit-history-select-item) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar xwidget-view-list) ; xwidget.c commit 24a817ccad7e67bd2bb0f23ea572073f36bdc3d9 Author: Gregory Heytings Date: Tue Nov 16 09:00:24 2021 +0100 New X resource to control the border thickness of menus * lwlib/xlwmenu.h (XtNborderThickness, XtCBorderThickness): New X resource name. * lwlib/xlwmenuP.h (XlwMenuPart): New border_thickness field. * lwlib/xlwmenu.c (xlwMenuResources): Access the new resource. (draw_shadow_rectangle): Use the new resource value. * doc/emacs/xresources.texi (Lucid Resources): Document the new resource (bug#51867). diff --git a/doc/emacs/xresources.texi b/doc/emacs/xresources.texi index 00fa6c0aa3..0e0070829c 100644 --- a/doc/emacs/xresources.texi +++ b/doc/emacs/xresources.texi @@ -406,6 +406,9 @@ the associated text. Default is 10. @item shadowThickness Thickness of shadow lines for 3D buttons, arrows, and other graphical elements. Default is 1. +@item borderThickness +Thickness of the external borders of the menu bars and pop-up menus. +Default is 1. @end ifnottex @item margin Margin of the menu bar, in characters. Default is 1. diff --git a/etc/NEWS b/etc/NEWS index 92ae8ac624..ce4c86b0c8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -46,6 +46,11 @@ time. * Changes in Emacs 29.1 ++++ +** New X resource: "borderThickness". +This controls the thickness of the external borders of the menu bars +and pop-up menus. + ** Terminal Emacs --- diff --git a/lwlib/xlwmenu.c b/lwlib/xlwmenu.c index cc73d9aa49..702fad49ba 100644 --- a/lwlib/xlwmenu.c +++ b/lwlib/xlwmenu.c @@ -157,6 +157,9 @@ xlwMenuResources[] = offset(menu.cursor_shape), XtRString, (XtPointer)"right_ptr"}, {XtNhorizontal, XtCHorizontal, XtRInt, sizeof(int), offset(menu.horizontal), XtRImmediate, (XtPointer)True}, + {XtNborderThickness, XtCBorderThickness, XtRDimension, + sizeof (Dimension), offset (menu.border_thickness), + XtRImmediate, (XtPointer)1} }; #undef offset @@ -635,7 +638,7 @@ draw_shadow_rectangle (XlwMenuWidget mw, Display *dpy = XtDisplay (mw); GC top_gc = !erase_p ? mw->menu.shadow_top_gc : mw->menu.background_gc; GC bottom_gc = !erase_p ? mw->menu.shadow_bottom_gc : mw->menu.background_gc; - int thickness = mw->menu.shadow_thickness; + int thickness = !x && !y ? mw->menu.border_thickness : mw->menu.shadow_thickness; XPoint points [4]; if (!erase_p && down_p) diff --git a/lwlib/xlwmenu.h b/lwlib/xlwmenu.h index 9143edba9a..89e548bc8d 100644 --- a/lwlib/xlwmenu.h +++ b/lwlib/xlwmenu.h @@ -56,6 +56,8 @@ along with GNU Emacs. If not, see . */ #define XtCResizeToPreferred "ResizeToPreferred" #define XtNallowResize "allowResize" #define XtCAllowResize "AllowResize" +#define XtNborderThickness "borderThickness" +#define XtCBorderThickness "BorderThickness" /* Motif-compatible resource names */ #define XmNshadowThickness "shadowThickness" diff --git a/lwlib/xlwmenuP.h b/lwlib/xlwmenuP.h index fc77ec4bfd..bb37b0dee2 100644 --- a/lwlib/xlwmenuP.h +++ b/lwlib/xlwmenuP.h @@ -75,6 +75,7 @@ typedef struct _XlwMenu_part Dimension vertical_spacing; Dimension arrow_spacing; Dimension shadow_thickness; + Dimension border_thickness; Pixel top_shadow_color; Pixel bottom_shadow_color; Pixmap top_shadow_pixmap; commit 977f102a49749e09cec1766158ec617704606089 Author: Michael Herstine Date: Tue Nov 16 08:48:24 2021 +0100 Make results details in ert-run-tests-batch configurable * lisp/emacs-lisp/ert.el (ert-batch-print-length) (ert-batch-print-level,.ert-batch-backtrace-line-length) (ert-batch-test, ert-run-tests-interactively): Added the three variables, bound them to these settings when formatting batch test results including backtraces. Removed the optional parameters output-buffer & message-fn from ert-run-tests-interactively. * test/lisp/emacs-lisp/ert-tests.el (ert-test-run-tests-interactively, ert-test-run-tests-batch): use cl-letf to capture output, new tests resp. * test/lisp/ert-x-tests.el (ert-test-run-tests-interactively-2): Changed to use cl-letf to capture output instead of using message-fn. * lisp/emacs-lisp/backtrace.el (backtrace--line-length-or-nil) (backtrace--print-func-and-args): Fixed a bug when setting backtrace-line-length to nil by adding a new function to check for that case & having backtrace--print-func-and-args use it. * doc/misc/ert.texi: document the new variables & their usage (bug#51037). diff --git a/doc/misc/ert.texi b/doc/misc/ert.texi index 440c61add8..af215482f4 100644 --- a/doc/misc/ert.texi +++ b/doc/misc/ert.texi @@ -390,12 +390,37 @@ summary as shown below: emacs -batch -l ert -f ert-summarize-tests-batch-and-exit output.log @end example +@vindex ert-batch-print-level +@vindex ert-batch-print-length +ERT attempts to limit the output size for failed tests by choosing +conservative values for @code{print-level} and @code{print-length} +when printing Lisp values. This can in some cases make it difficult +to see which portions of those values are incorrect. Use +@code{ert-batch-print-level} and @code{ert-batch-print-length} +to customize that: + +@example +emacs -batch -l ert -l my-tests.el \ + --eval "(let ((ert-batch-print-level 10) \ + (ert-batch-print-length 120)) \ + (ert-run-tests-batch-and-exit))" +@end example + +@vindex ert-batch-backtrace-line-length +Even modest settings for @code{print-level} and @code{print-length} can +produce extremely long lines in backtraces, however, with attendant +pauses in execution progress. Set +@code{ert-batch-backtrace-line-length} to t to use the value of +@code{backtrace-line-length}, @code{nil} to stop any limitations on backtrace +line lengths (that is, to get full backtraces), or a positive integer to +limit backtrace line length to that number. + @vindex ert-quiet By default, ERT in batch mode is quite verbose, printing a line with result after each test. This gives you progress information: how many tests have been executed and how many there are. However, in some cases this much output may be undesirable. In this case, set -@code{ert-quiet} variable to a non-nil value: +@code{ert-quiet} variable to a non-@code{nil} value: @example emacs -batch -l ert -l my-tests.el \ diff --git a/etc/NEWS b/etc/NEWS index 68b5cc82b4..92ae8ac624 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -54,6 +54,13 @@ This is in addition to previously-supported ways of discovering 24-bit color support: either via the "RGB" or "setf24" capabilities, or if the 'COLORTERM' environment variable is set to the value "truecolor". ++++ +** New ERT variables 'ert-batch-print-length' and 'ert-batch-print-level'. +These variables will override 'print-length' and 'print-level' when +printing Lisp values in ERT batch test results. + +** Emacs now supports Unicode Standard version 14.0. + ** Emoji +++ diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index a5721aa319..a8b484aee0 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -55,9 +55,9 @@ order to debug the code that does fontification." (defcustom backtrace-line-length 5000 "Target length for lines in Backtrace buffers. Backtrace mode will attempt to abbreviate printing of backtrace -frames to make them shorter than this, but success is not -guaranteed. If set to nil or zero, Backtrace mode will not -abbreviate the forms it prints." +frames by setting `print-level' and `print-length' to make them +shorter than this, but success is not guaranteed. If set to nil +or zero, backtrace mode will not abbreviate the forms it prints." :type 'integer :group 'backtrace :version "27.1") @@ -751,6 +751,13 @@ property for use by navigation." (insert (make-string (- backtrace--flags-width (- (point) beg)) ?\s)) (put-text-property beg (point) 'backtrace-section 'func))) +(defun backtrace--line-length-or-nil () + "Return `backtrace-line-length' if valid, nil else." + ;; mirror the logic in `cl-print-to-string-with-limits' + (and (natnump backtrace-line-length) + (not (zerop backtrace-line-length)) + backtrace-line-length)) + (defun backtrace--print-func-and-args (frame _view) "Print the function, arguments and buffer position of a backtrace FRAME. Format it according to VIEW." @@ -769,11 +776,16 @@ Format it according to VIEW." (if (atom fun) (funcall backtrace-print-function fun) (insert - (backtrace--print-to-string fun (when args (/ backtrace-line-length 2))))) + (backtrace--print-to-string + fun + (when (and args (backtrace--line-length-or-nil)) + (/ backtrace-line-length 2))))) (if args (insert (backtrace--print-to-string - args (max (truncate (/ backtrace-line-length 5)) - (- backtrace-line-length (- (point) beg))))) + args + (if (backtrace--line-length-or-nil) + (max (truncate (/ backtrace-line-length 5)) + (- backtrace-line-length (- (point) beg)))))) ;; The backtrace-form property is so that backtrace-multi-line ;; will find it. backtrace-multi-line doesn't do anything ;; useful with it, just being consistent. diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 8ebc81fd41..36b4408dc8 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -77,6 +77,37 @@ Use nil for no limit (caution: backtrace lines can be very long)." :type '(choice (const :tag "No truncation" nil) integer)) +(defvar ert-batch-print-length 10 + "`print-length' setting used in `ert-run-tests-batch'. + +When formatting lists in test conditions, `print-length' will be +temporarily set to this value. See also +`ert-batch-backtrace-line-length' for its effect on stack +traces.") + +(defvar ert-batch-print-level 5 + "`print-level' setting used in `ert-run-tests-batch'. + +When formatting lists in test conditions, `print-level' will be +temporarily set to this value. See also +`ert-batch-backtrace-line-length' for its effect on stack +traces.") + +(defvar ert-batch-backtrace-line-length t + "Target length for lines in ERT batch backtraces. + +Even modest settings for `print-length' and `print-level' can +produce extremely long lines in backtraces and lengthy delays in +forming them. This variable governs the target maximum line +length by manipulating these two variables while printing stack +traces. Setting this variable to t will re-use the value of +`backtrace-line-length' while print stack traces in ERT batch +mode. A value of nil will short-circuit this mechanism; line +lengths will be completely determined by `ert-batch-line-length' +and `ert-batch-line-level'. Any other value will be temporarily +bound to `backtrace-line-length' when producing stack traces +in batch mode.") + (defface ert-test-result-expected '((((class color) (background light)) :background "green1") (((class color) (background dark)) @@ -1402,8 +1433,7 @@ Returns the stats object." (ert-reason-for-test-result result) "")))) (message "%s" ""))))) - (test-started - ) + (test-started) (test-ended (cl-destructuring-bind (stats test result) event-args (unless (ert-test-result-expected-p test result) @@ -1413,8 +1443,18 @@ Returns the stats object." (ert-test-result-with-condition (message "Test %S backtrace:" (ert-test-name test)) (with-temp-buffer - (insert (backtrace-to-string - (ert-test-result-with-condition-backtrace result))) + (let ((backtrace-line-length + (cond + ((eq ert-batch-backtrace-line-length t) + backtrace-line-length) + ((eq ert-batch-backtrace-line-length nil) + nil) + (t + ert-batch-backtrace-line-length))) + (print-level ert-batch-print-level) + (print-length ert-batch-print-length)) + (insert (backtrace-to-string + (ert-test-result-with-condition-backtrace result)))) (if (not ert-batch-backtrace-right-margin) (message "%s" (buffer-substring-no-properties (point-min) @@ -1433,8 +1473,8 @@ Returns the stats object." (ert--insert-infos result) (insert " ") (let ((print-escape-newlines t) - (print-level 5) - (print-length 10)) + (print-level ert-batch-print-level) + (print-length ert-batch-print-length)) (ert--pp-with-indentation-and-newline (ert-test-result-with-condition-condition result))) (goto-char (1- (point-max))) @@ -1962,13 +2002,13 @@ otherwise." (ewoc-refresh ert--results-ewoc) (font-lock-default-function enabledp)) -(defun ert--setup-results-buffer (stats listener buffer-name) +(defvar ert--output-buffer-name "*ert*") + +(defun ert--setup-results-buffer (stats listener) "Set up a test results buffer. -STATS is the stats object; LISTENER is the results listener; -BUFFER-NAME, if non-nil, is the buffer name to use." - (unless buffer-name (setq buffer-name "*ert*")) - (let ((buffer (get-buffer-create buffer-name))) +STATS is the stats object; LISTENER is the results listener." + (let ((buffer (get-buffer-create ert--output-buffer-name))) (with-current-buffer buffer (let ((inhibit-read-only t)) (buffer-disable-undo) @@ -2000,18 +2040,11 @@ BUFFER-NAME, if non-nil, is the buffer name to use." (defvar ert--selector-history nil "List of recent test selectors read from terminal.") -;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? -;; They are needed only for our automated self-tests at the moment. -;; Or should there be some other mechanism? ;;;###autoload -(defun ert-run-tests-interactively (selector - &optional output-buffer-name message-fn) +(defun ert-run-tests-interactively (selector) "Run the tests specified by SELECTOR and display the results in a buffer. -SELECTOR works as described in `ert-select-tests'. -OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they -are used for automated self-tests and specify which buffer to use -and how to display message." +SELECTOR works as described in `ert-select-tests'." (interactive (list (let ((default (if ert--selector-history ;; Can't use `first' here as this form is @@ -2024,23 +2057,17 @@ and how to display message." obarray #'ert-test-boundp nil nil 'ert--selector-history default nil))) nil)) - (unless message-fn (setq message-fn 'message)) - (let ((output-buffer-name output-buffer-name) - buffer - listener - (message-fn message-fn)) + (let (buffer listener) (setq listener (lambda (event-type &rest event-args) (cl-ecase event-type (run-started (cl-destructuring-bind (stats) event-args - (setq buffer (ert--setup-results-buffer stats - listener - output-buffer-name)) + (setq buffer (ert--setup-results-buffer stats listener)) (pop-to-buffer buffer))) (run-ended (cl-destructuring-bind (stats abortedp) event-args - (funcall message-fn + (message "%sRan %s tests, %s results were as expected%s%s" (if (not abortedp) "" @@ -2394,7 +2421,7 @@ To be used in the ERT results buffer." (interactive nil ert-results-mode) (cl-assert (eql major-mode 'ert-results-mode)) (let ((selector (ert--stats-selector ert--results-stats))) - (ert-run-tests-interactively selector (buffer-name)))) + (ert-run-tests-interactively selector))) (defun ert-results-rerun-test-at-point () "Re-run the test at point. diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index 79576d2403..1a8c9bf4f0 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -39,10 +39,11 @@ (defun ert-self-test () "Run ERT's self-tests and make sure they actually ran." (let ((window-configuration (current-window-configuration))) - (let ((ert--test-body-was-run nil)) + (let ((ert--test-body-was-run nil) + (ert--output-buffer-name " *ert self-tests*")) ;; The buffer name chosen here should not compete with the default ;; results buffer name for completion in `switch-to-buffer'. - (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*"))) + (let ((stats (ert-run-tests-interactively "^ert-"))) (cl-assert ert--test-body-was-run) (if (zerop (ert-stats-completed-unexpected stats)) ;; Hide results window only when everything went well. @@ -519,17 +520,18 @@ This macro is used to test if macroexpansion in `should' works." :body (lambda () (ert-skip "skip message"))))) (let ((ert-debug-on-error nil)) - (let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*")) - (messages nil) - (mock-message-fn - (lambda (format-string &rest args) - (push (apply #'format format-string args) messages)))) + (cl-letf* ((buffer-name (generate-new-buffer-name + " *ert-test-run-tests*")) + (ert--output-buffer-name buffer-name) + (messages nil) + ((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) (save-window-excursion (unwind-protect (let ((case-fold-search nil)) (ert-run-tests-interactively - `(member ,passing-test ,failing-test, skipped-test) buffer-name - mock-message-fn) + `(member ,passing-test ,failing-test, skipped-test)) (should (equal messages `(,(concat "Ran 3 tests, 1 results were " "as expected, 1 unexpected, " @@ -551,6 +553,68 @@ This macro is used to test if macroexpansion in `should' works." (when (get-buffer buffer-name) (kill-buffer buffer-name)))))))) +(ert-deftest ert-test-run-tests-batch () + (let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc")))))))) + (long-list (make-list 11 1)) + (failing-test-1 + (make-ert-test :name 'failing-test-1 + :body (lambda () (should (equal complex-list 1))))) + (failing-test-2 + (make-ert-test :name 'failing-test-2 + :body (lambda () (should (equal long-list 1)))))) + (let ((ert-debug-on-error nil) + messages) + (cl-letf* (((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil) + (ert-batch-backtrace-right-margin nil) + (ert-batch-print-level 10) + (ert-batch-print-length 11)) + (ert-run-tests-batch + `(member ,failing-test-1 ,failing-test-2)))))) + (let ((long-text "(different-types[ \t\n]+(1 1 1 1 1 1 1 1 1 1 1)[ \t\n]+1)))[ \t\n]*$") + (complex-text "(different-types[ \t\n]+((:1[ \t\n]+(:2[ \t\n]+(:3[ \t\n]+(:4[ \t\n]+(:5[ \t\n]+(:6[ \t\n]+\"abc\")))))))[ \t\n]+1)))[ \t\n]*$") + found-long + found-complex) + (cl-loop for msg in (reverse messages) + do + (unless found-long + (setq found-long (string-match long-text msg))) + (unless found-complex + (setq found-complex (string-match complex-text msg)))) + (should found-long) + (should found-complex))))) + +(ert-deftest ert-test-run-tests-batch-expensive () + (let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc")))))))) + (failing-test-1 + (make-ert-test :name 'failing-test-1 + :body (lambda () (should (equal complex-list 1)))))) + (let ((ert-debug-on-error nil) + messages) + (cl-letf* (((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil) + (ert-batch-backtrace-right-margin nil) + (ert-batch-backtrace-line-length nil) + (ert-batch-print-level 6) + (ert-batch-print-length 11)) + (ert-run-tests-batch + `(member ,failing-test-1)))))) + (let ((frame "ert-fail(((should (equal complex-list 1)) :form (equal ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1) :value nil :explanation (different-types ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1)))") + found-frame) + (cl-loop for msg in (reverse messages) + do + (unless found-frame + (setq found-frame (cl-search frame msg :test 'equal)))) + (should found-frame))))) + (ert-deftest ert-test-special-operator-p () (should (ert--special-operator-p 'if)) (should-not (ert--special-operator-p 'car)) diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index 9baa994158..7106b7abc0 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -103,23 +103,27 @@ (ert-deftest ert-test-run-tests-interactively-2 () :tags '(:causes-redisplay) - (let* ((passing-test (make-ert-test :name 'passing-test - :body (lambda () (ert-pass)))) - (failing-test (make-ert-test :name 'failing-test - :body (lambda () - (ert-info ((propertize "foo\nbar" - 'a 'b)) - (ert-fail - "failure message"))))) - (skipped-test (make-ert-test :name 'skipped-test - :body (lambda () (ert-skip - "skip message")))) - (ert-debug-on-error nil) - (buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) - (messages nil) - (mock-message-fn - (lambda (format-string &rest args) - (push (apply #'format format-string args) messages)))) + (cl-letf* ((passing-test (make-ert-test + :name 'passing-test + :body (lambda () (ert-pass)))) + (failing-test (make-ert-test + :name 'failing-test + :body (lambda () + (ert-info ((propertize "foo\nbar" + 'a 'b)) + (ert-fail + "failure message"))))) + (skipped-test (make-ert-test + :name 'skipped-test + :body (lambda () (ert-skip + "skip message")))) + (ert-debug-on-error nil) + (messages nil) + (buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) + ((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages))) + (ert--output-buffer-name buffer-name)) (cl-flet ((expected-string (with-font-lock-p) (ert-propertized-string "Selector: (member " @@ -152,14 +156,12 @@ "failing-test" nil "\n Info: " '(a b) "foo\n" nil " " '(a b) "bar" - nil "\n (ert-test-failed \"failure message\")\n\n\n" - ))) + nil "\n (ert-test-failed \"failure message\")\n\n\n"))) (save-window-excursion (unwind-protect (let ((case-fold-search nil)) (ert-run-tests-interactively - `(member ,passing-test ,failing-test ,skipped-test) buffer-name - mock-message-fn) + `(member ,passing-test ,failing-test ,skipped-test)) (should (equal messages `(,(concat "Ran 3 tests, 1 results were " "as expected, 1 unexpected, " commit 331366395e80affec9637cec3759d49135b94844 Author: Lars Ingebrigtsen Date: Tue Nov 16 08:23:53 2021 +0100 Start adjusting the manuals to talk about the keymap-* functions * lisp/dired.el (dired--make-directory-clickable): * doc/lispref/keymaps.texi (Keymaps): (Key Sequences): (Prefix Keys): (Active Keymaps): (Key Lookup): (Functions for Key Lookup): (Changing Key Bindings): (Key Binding Commands): (Tool Bar): * doc/lispref/commands.texi (Interactive Codes): (Event Examples): (Event Mod): * doc/emacs/kmacro.texi (Save Keyboard Macro): * doc/emacs/custom.texi (Keymaps): (Keymaps): (Minibuffer Maps): (Rebinding): (Init Rebinding): (Modifier Keys): (Mouse Buttons): (Init Examples): (Init Non-ASCII): Adjust the documentation to remove description of the old syntaxes, and use the new keymap-* functions. * doc/lispref/keymaps.texi (Low-Level Key Binding): New node that describes `define-key' and the old key syntaxes. diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi index d9d6a68005..917f6f4921 100644 --- a/doc/emacs/custom.texi +++ b/doc/emacs/custom.texi @@ -1584,7 +1584,7 @@ which overrides the global definitions of some keys. self-inserting because the global keymap binds it to the command @code{self-insert-command}. The standard Emacs editing characters such as @kbd{C-a} also get their standard meanings from the global -keymap. Commands to rebind keys, such as @kbd{M-x global-set-key}, +keymap. Commands to rebind keys, such as @kbd{M-x keymap-global-set}, work by storing the new binding in the proper place in the global map (@pxref{Rebinding}). To view the current key bindings, use the @kbd{C-h b} command. @@ -1736,8 +1736,8 @@ them, it may be convenient to disable completion on those keys by putting this in your init file: @lisp -(define-key minibuffer-local-completion-map " " 'self-insert-command) -(define-key minibuffer-local-completion-map "?" 'self-insert-command) +(keymap-set minibuffer-local-completion-map "SPC" 'self-insert-command) +(keymap-set minibuffer-local-completion-map "?" 'self-insert-command) @end lisp @node Rebinding @@ -1756,19 +1756,19 @@ local keymap, which affects all buffers using the same major mode. Emacs session. @xref{Init Rebinding}, for a description of how to make key rebindings affect future Emacs sessions. -@findex global-set-key -@findex local-set-key -@findex global-unset-key -@findex local-unset-key +@findex keymap-global-set +@findex keymap-local-set +@findex keymap-global-unset +@findex keymap-local-unset @table @kbd -@item M-x global-set-key @key{RET} @var{key} @var{cmd} @key{RET} +@item M-x keymap-global-set @key{RET} @var{key} @var{cmd} @key{RET} Define @var{key} globally to run @var{cmd}. -@item M-x local-set-key @key{RET} @var{key} @var{cmd} @key{RET} +@item M-x keymap-local-set @key{RET} @var{key} @var{cmd} @key{RET} Define @var{key} locally (in the major mode now in effect) to run @var{cmd}. -@item M-x global-unset-key @key{RET} @var{key} +@item M-x keymap-global-unset @key{RET} @var{key} Make @var{key} undefined in the global map. -@item M-x local-unset-key @key{RET} @var{key} +@item M-x keymap-local-unset @key{RET} @var{key} Make @var{key} undefined locally (in the major mode now in effect). @end table @@ -1777,11 +1777,11 @@ command (@pxref{Interactive Shell}), replacing the normal global definition of @kbd{C-z}: @example -M-x global-set-key @key{RET} C-z shell @key{RET} +M-x keymap-global-set @key{RET} C-z shell @key{RET} @end example @noindent -The @code{global-set-key} command reads the command name after the +The @code{keymap-global-set} command reads the command name after the key. After you press the key, a message like this appears so that you can confirm that you are binding the key you want: @@ -1802,7 +1802,7 @@ reads another character; if that is @kbd{4}, another prefix character, it reads one more character, and so on. For example, @example -M-x global-set-key @key{RET} C-x 4 $ spell-other-window @key{RET} +M-x keymap-global-set @key{RET} C-x 4 $ spell-other-window @key{RET} @end example @noindent @@ -1810,8 +1810,8 @@ redefines @kbd{C-x 4 $} to run the (fictitious) command @code{spell-other-window}. You can remove the global definition of a key with -@code{global-unset-key}. This makes the key @dfn{undefined}; if you -type it, Emacs will just beep. Similarly, @code{local-unset-key} makes +@code{keymap-global-unset}. This makes the key @dfn{undefined}; if you +type it, Emacs will just beep. Similarly, @code{keymap-local-unset} makes a key undefined in the current major mode keymap, which makes the global definition (or lack of one) come back into effect in that major mode. @@ -1844,11 +1844,11 @@ you can specify them in your initialization file by writing Lisp code. simplest is to use the @code{kbd} function, which converts a textual representation of a key sequence---similar to how we have written key sequences in this manual---into a form that can be passed as an -argument to @code{global-set-key}. For example, here's how to bind +argument to @code{keymap-global-set}. For example, here's how to bind @kbd{C-z} to the @code{shell} command (@pxref{Interactive Shell}): @example -(global-set-key (kbd "C-z") 'shell) +(keymap-global-set "C-z" 'shell) @end example @noindent @@ -1861,69 +1861,24 @@ causes an error; it certainly isn't what you want. and mouse events: @example -(global-set-key (kbd "C-c y") 'clipboard-yank) -(global-set-key (kbd "C-M-q") 'query-replace) -(global-set-key (kbd "") 'flyspell-mode) -(global-set-key (kbd "C-") 'display-line-numbers-mode) -(global-set-key (kbd "C-") 'forward-sentence) -(global-set-key (kbd "") 'mouse-save-then-kill) -@end example - - Instead of using @code{kbd}, you can use a Lisp string or vector to -specify the key sequence. Using a string is simpler, but only works -for @acronym{ASCII} characters and Meta-modified @acronym{ASCII} -characters. For example, here's how to bind @kbd{C-x M-l} to -@code{make-symbolic-link} (@pxref{Copying and Naming}): - -@example -(global-set-key "\C-x\M-l" 'make-symbolic-link) -@end example - - To bind a key sequence including @key{TAB}, @key{RET}, @key{ESC}, or -@key{DEL}, the string should contain the Emacs Lisp escape sequence -@samp{\t}, @samp{\r}, @samp{\e}, or @samp{\d} respectively. Here is -an example which binds @kbd{C-x @key{TAB}} to @code{indent-rigidly} -(@pxref{Indentation}): - -@example -(global-set-key "\C-x\t" 'indent-rigidly) -@end example - - When the key sequence includes function keys or mouse button events, -or non-@acronym{ASCII} characters such as @code{C-=} or @code{H-a}, -you can use a vector to specify the key sequence. Each element in the -vector stands for an input event; the elements are separated by spaces -and surrounded by a pair of square brackets. If a vector element is a -character, write it as a Lisp character constant: @samp{?} followed by -the character as it would appear in a string. Function keys are -represented by symbols (@pxref{Function Keys}); simply write the -symbol's name, with no other delimiters or punctuation. Here are some -examples: - -@example -(global-set-key [?\C-=] 'make-symbolic-link) -(global-set-key [?\M-\C-=] 'make-symbolic-link) -(global-set-key [?\H-a] 'make-symbolic-link) -(global-set-key [f7] 'make-symbolic-link) -(global-set-key [C-mouse-1] 'make-symbolic-link) -@end example - -@noindent -You can use a vector for the simple cases too: - -@example -(global-set-key [?\C-z ?\M-l] 'make-symbolic-link) +(keymap-global-set "C-c y" 'clipboard-yank) +(keymap-global-set "C-M-q" 'query-replace) +(keymap-global-set "" 'flyspell-mode) +(keymap-global-set "C-" 'display-line-numbers-mode) +(keymap-global-set "C-" 'forward-sentence) +(keymap-global-set "" 'mouse-save-then-kill) @end example Language and coding systems may cause problems with key bindings for non-@acronym{ASCII} characters. @xref{Init Non-ASCII}. -@findex define-key +@findex keymap-set +@findex keymap-unset As described in @ref{Local Keymaps}, major modes and minor modes can define local keymaps. These keymaps are constructed when the mode is -loaded for the first time in a session. The function @code{define-key} -can be used to make changes in a specific keymap. This function can -also unset keys, when passed @code{nil} as the binding. +loaded for the first time in a session. The function @code{keymap-set} +can be used to make changes in a specific keymap. To remove a key +binding, use @code{keymap-unset}. Since a mode's keymaps are not constructed until it has been loaded, you must delay running code which modifies them, e.g., by putting it @@ -1935,11 +1890,11 @@ the one for @kbd{C-c C-x x} in Texinfo mode: @example (add-hook 'texinfo-mode-hook (lambda () - (define-key texinfo-mode-map "\C-cp" + (keymap-set texinfo-mode-map "C-c p" 'backward-paragraph) - (define-key texinfo-mode-map "\C-cn" + (keymap-set texinfo-mode-map "C-c n" 'forward-paragraph))) - (define-key texinfo-mode-map "\C-c\C-xx" nil) + (keymap-set texinfo-mode-map "C-c C-x x" nil) @end example @node Modifier Keys @@ -1961,7 +1916,7 @@ between those keystrokes. However, you can bind shifted @key{Control} alphabetical keystrokes in GUI frames: @lisp -(global-set-key (kbd "C-S-n") #'previous-line) +(keymap-global-set "C-S-n" #'previous-line) @end lisp For all other modifiers, you can make the modified alphabetical @@ -2115,7 +2070,7 @@ button, @code{mouse-2} for the next, and so on. Here is how you can redefine the second mouse button to split the current window: @example -(global-set-key [mouse-2] 'split-window-below) +(keymap-global-set "" 'split-window-below) @end example The symbols for drag events are similar, but have the prefix @@ -2198,7 +2153,7 @@ Thus, here is how to define the command for clicking the first button in a mode line to run @code{scroll-up-command}: @example -(global-set-key [mode-line mouse-1] 'scroll-up-command) +(keymap-global-set " " 'scroll-up-command) @end example Here is the complete list of these dummy prefix keys and their @@ -2589,13 +2544,13 @@ Rebind the key @kbd{C-x l} to run the function @code{make-symbolic-link} (@pxref{Init Rebinding}). @example -(global-set-key "\C-xl" 'make-symbolic-link) +(keymap-global-set "C-x l" 'make-symbolic-link) @end example or @example -(define-key global-map "\C-xl" 'make-symbolic-link) +(keymap-set global-map "C-x l" 'make-symbolic-link) @end example Note once again the single-quote used to refer to the symbol @@ -2605,7 +2560,7 @@ Note once again the single-quote used to refer to the symbol Do the same thing for Lisp mode only. @example -(define-key lisp-mode-map "\C-xl" 'make-symbolic-link) +(keymap-set lisp-mode-map "C-x l" 'make-symbolic-link) @end example @item @@ -2622,7 +2577,7 @@ so that they run @code{forward-line} instead. Make @kbd{C-x C-v} undefined. @example -(global-unset-key "\C-x\C-v") +(keymap-global-unset "C-x C-v") @end example One reason to undefine a key is so that you can make it a prefix. @@ -2798,18 +2753,6 @@ strings incorrectly. You should then avoid adding Emacs Lisp code that modifies the coding system in other ways, such as calls to @code{set-language-environment}. - To bind non-@acronym{ASCII} keys, you must use a vector (@pxref{Init -Rebinding}). The string syntax cannot be used, since the -non-@acronym{ASCII} characters will be interpreted as meta keys. For -instance: - -@example -(global-set-key [?@var{char}] 'some-function) -@end example - -@noindent -Type @kbd{C-q}, followed by the key you want to bind, to insert @var{char}. - @node Early Init File @subsection The Early Init File @cindex early init file diff --git a/doc/emacs/kmacro.texi b/doc/emacs/kmacro.texi index 78964bb903..e0533f049e 100644 --- a/doc/emacs/kmacro.texi +++ b/doc/emacs/kmacro.texi @@ -439,7 +439,7 @@ name to execute the last keyboard macro, in its current form. (If you later add to the definition of this macro, that does not alter the name's definition as a macro.) The macro name is a Lisp symbol, and defining it in this way makes it a valid command name for calling with -@kbd{M-x} or for binding a key to with @code{global-set-key} +@kbd{M-x} or for binding a key to with @code{keymap-global-set} (@pxref{Keymaps}). If you specify a name that has a prior definition other than a keyboard macro, an error message is shown and nothing is changed. diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index 6ed46fa6a2..1509c200e0 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -451,7 +451,7 @@ reads and discards the following up-event. You can get access to that up-event with the @samp{U} code character. This kind of input is used by commands such as @code{describe-key} and -@code{global-set-key}. +@code{keymap-global-set}. @item K A key sequence on a form that can be used as input to functions like @@ -2147,7 +2147,7 @@ bind it to the @code{signal usr1} event sequence: (defun usr1-handler () (interactive) (message "Got USR1 signal")) -(global-set-key [signal usr1] 'usr1-handler) +(keymap-global-set " " 'usr1-handler) @end smallexample @node Classifying Events @@ -3016,7 +3016,7 @@ supplied to input methods (@pxref{Input Methods}). Use if you want to translate characters after input methods operate. @end defvar -@defun keyboard-translate from to +@defun key-translate from to This function modifies @code{keyboard-translate-table} to translate character code @var{from} into character code @var{to}. It creates the keyboard translate table if necessary. @@ -3027,12 +3027,12 @@ make @kbd{C-x}, @kbd{C-c} and @kbd{C-v} perform the cut, copy and paste operations: @example -(keyboard-translate ?\C-x 'control-x) -(keyboard-translate ?\C-c 'control-c) -(keyboard-translate ?\C-v 'control-v) -(global-set-key [control-x] 'kill-region) -(global-set-key [control-c] 'kill-ring-save) -(global-set-key [control-v] 'yank) +(key-translate "C-x" "") +(key-translate "C-c" "") +(key-translate "C-v" "") +(keymap-global-set "" 'kill-region) +(keymap-global-set "" 'kill-ring-save) +(keymap-global-set "" 'yank) @end example @noindent diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 1c0b0fa1b5..4f47a1d1bb 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -840,6 +840,7 @@ Keymaps * Key Lookup:: Finding a key's binding in one keymap. * Functions for Key Lookup:: How to request key lookup. * Changing Key Bindings:: Redefining a key in a keymap. +* Low-Level Key Binding:: Legacy key syntax description. * Remapping Commands:: A keymap can translate one command to another. * Translation Keymaps:: Keymaps for translating sequences of events. * Key Binding Commands:: Interactive interfaces for redefining keys. diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi index 899499ed46..86faba2619 100644 --- a/doc/lispref/keymaps.texi +++ b/doc/lispref/keymaps.texi @@ -30,6 +30,7 @@ is found. The whole process is called @dfn{key lookup}. * Key Lookup:: Finding a key's binding in one keymap. * Functions for Key Lookup:: How to request key lookup. * Changing Key Bindings:: Redefining a key in a keymap. +* Low-Level Key Binding:: Legacy key syntax description. * Remapping Commands:: A keymap can translate one command to another. * Translation Keymaps:: Keymaps for translating sequences of events. * Key Binding Commands:: Interactive interfaces for redefining keys. @@ -95,21 +96,11 @@ Manual}. (kbd "C-M-") @result{} [C-M-down] @end example -@findex kbd-valid-p +@findex key-valid-p The @code{kbd} function is very permissive, and will try to return something sensible even if the syntax used isn't completely conforming. To check whether the syntax is actually valid, use the -@code{kbd-valid-p} function. - -@code{define-key} also supports using the shorthand syntax -@samp{["..."]} syntax to define a key. The string has to be a -strictly valid @code{kbd} sequence, and if it's not valid, an error -will be signalled. For instance, to bind @key{C-c f}, you can say: - -@lisp -(define-key global-map ["C-c f"] #'find-file-literally) -@end lisp - +@code{key-valid-p} function. @end defun @@ -627,16 +618,16 @@ active keymap. @result{} nil @end group @group -(local-set-key "\C-p" ctl-x-map) +(keymap-local-set "C-p" ctl-x-map) @result{} nil @end group @group -(key-binding "\C-p\C-f") +(keymap-binding "C-p C-f") @result{} find-file @end group @group -(key-binding "\C-p6") +(keymap-binding "C-p 6") @result{} nil @end group @end example @@ -699,7 +690,7 @@ use, in place of the buffer's default local keymap. @cindex major mode keymap The local keymap is normally set by the buffer's major mode, and every buffer with the same major mode shares the same local keymap. -Hence, if you call @code{local-set-key} (@pxref{Key Binding Commands}) +Hence, if you call @code{keymap-local-set} (@pxref{Key Binding Commands}) to change the local keymap in one buffer, that also affects the local keymaps in other buffers with the same major mode. @@ -733,39 +724,7 @@ Normally it ignores @code{overriding-local-map} and then it pays attention to them. @var{position} can optionally be either an event position as returned by @code{event-start} or a buffer position, and may change the keymaps as described for -@code{key-binding}. -@end defun - -@defun key-binding key &optional accept-defaults no-remap position -This function returns the binding for @var{key} according to the -current active keymaps. The result is @code{nil} if @var{key} is -undefined in the keymaps. - -The argument @var{accept-defaults} controls checking for default -bindings, as in @code{lookup-key} (@pxref{Functions for Key Lookup}). - -When commands are remapped (@pxref{Remapping Commands}), -@code{key-binding} normally processes command remappings so as to -return the remapped command that will actually be executed. However, -if @var{no-remap} is non-@code{nil}, @code{key-binding} ignores -remappings and returns the binding directly specified for @var{key}. - -If @var{key} starts with a mouse event (perhaps following a prefix -event), the maps to be consulted are determined based on the event's -position. Otherwise, they are determined based on the value of point. -However, you can override either of them by specifying @var{position}. -If @var{position} is non-@code{nil}, it should be either a buffer -position or an event position like the value of @code{event-start}. -Then the maps consulted are determined based on @var{position}. - -Emacs signals an error if @var{key} is not a string or a vector. - -@example -@group -(key-binding "\C-x\C-f") - @result{} find-file -@end group -@end example +@code{keymap-binding}. @end defun @node Searching Keymaps @@ -1042,7 +1001,7 @@ keymap. Let's use the term @dfn{keymap entry} to describe the value found by looking up an event type in a keymap. (This doesn't include the item string and other extra elements in a keymap element for a menu item, because -@code{lookup-key} and other key lookup functions don't include them in +@code{keymap-lookup} and other key lookup functions don't include them in the returned value.) While any Lisp object may be stored in a keymap as a keymap entry, not all make sense for key lookup. Here is a table of the meaningful types of keymap entries: @@ -1193,7 +1152,7 @@ Used in keymaps to undefine keys. It calls @code{ding}, but does not cause an error. @end deffn -@defun local-key-binding key &optional accept-defaults +@defun keymap-local-binding key &optional accept-defaults This function returns the binding for @var{key} in the current local keymap, or @code{nil} if it is undefined there. @@ -1201,7 +1160,7 @@ The argument @var{accept-defaults} controls checking for default bindings, as in @code{lookup-key} (above). @end defun -@defun global-key-binding key &optional accept-defaults +@defun keymap-global-binding key &optional accept-defaults This function returns the binding for command @var{key} in the current global keymap, or @code{nil} if it is undefined there. @@ -1284,65 +1243,55 @@ change a binding in the global keymap, the change is effective in all buffers (though it has no direct effect in buffers that shadow the global binding with a local one). If you change the current buffer's local map, that usually affects all buffers using the same major mode. -The @code{global-set-key} and @code{local-set-key} functions are +The @code{keymap-global-set} and @code{keymap-local-set} functions are convenient interfaces for these operations (@pxref{Key Binding -Commands}). You can also use @code{define-key}, a more general +Commands}). You can also use @code{keymap-set}, a more general function; then you must explicitly specify the map to change. When choosing the key sequences for Lisp programs to rebind, please follow the Emacs conventions for use of various keys (@pxref{Key Binding Conventions}). -@cindex meta character key constants -@cindex control character key constants - @code{define-key} (and other functions that are used to rebind keys) -understand a number of different syntaxes for the keys. + The functions below signal an error if @var{keymap} is not a keymap, +or if @var{key} is not a valid key. -@table @asis -@item A vector containing a single string. -This is the preferred way to represent a key sequence. Here's a -couple of examples: +@var{key} is a string representing a single key or a series of key +strokes. Key strokes are separated by a single space character. -@example -["C-c M-f"] -["S-"] -@end example +Each key stroke is either a single character, or the name of an +event, surrounded by angle brackets. In addition, any key stroke +may be preceded by one or more modifier keys. Finally, a limited +number of characters have a special shorthand syntax. Here's some +example key sequences: -The syntax is the same as the one used by Emacs when displaying key -bindings, for instance in @samp{*Help*} buffers and help texts. +@table @kbd +@item f +The key @kbd{f}. -If the syntax isn't valid, an error will be raised when running -@code{define-key}, or when byte-compiling code that has these calls. +@item S o m +A three key sequence of the keys @kbd{S}, @kbd{o} and @kbd{m}. -@item A vector containing lists of keys. -You can use a list containing modifier names plus one base event (a -character or function key name). For example, @code{[(control ?a) -(meta b)]} is equivalent to @kbd{C-a M-b} and @code{[(hyper control -left)]} is equivalent to @kbd{C-H-left}. +@item C-c o +A two key sequence of the keys @kbd{c} with the control modifier and +then the key @kbd{o} -@item A string with control and meta characters. -Internally, key sequences are often represented as strings using the -special escape sequences for control and meta characters -(@pxref{String Type}), but this representation can also be used by -users when rebinding keys. A string like @code{"\M-x"} is read as -containing a single @kbd{M-x}, @code{"\C-f"} is read as containing a -single @kbd{C-f}, and @code{"\M-\C-x"} and @code{"\C-\M-x"} are both -read as containing a single @kbd{C-M-x}. +@item H- +The key named @kbd{left} with the hyper modifier. -@item a vector of characters. -This is the other internal representation of key sequences, and -supports a fuller range of modifiers than the string representation. -One example is @samp{[?\C-\H-x home]}, which represents the @kbd{C-H-x -home} key sequence. @xref{Character Type}. +@item M-RET +The @kbd{return} key with a meta modifier. + +@item C-M- +The @kbd{space} key with both the control and meta modifiers. @end table - The functions below signal an error if @var{keymap} is not a keymap, -or if @var{key} is not a string or vector representing a key sequence. -You can use event types (symbols) as shorthand for events that are -lists. The @code{kbd} function (@pxref{Key Sequences}) is a -convenient way to specify the key sequence. +The only keys that have a special shorthand syntax are @kbd{NUL}, +@kbd{RET}, @kbd{TAB}, @kbd{LFD}, @kbd{ESC}, @kbd{SPC} and @kbd{DEL}. + +The modifiers have to be specified in alphabetical order: +@samp{A-C-H-M-S-s}, which is @samp{Alt-Control-Hyper-Meta-Shift-super}. -@defun define-key keymap key binding +@defun keymap-set keymap key binding This function sets the binding for @var{key} in @var{keymap}. (If @var{key} is more than one event long, the change is actually made in another keymap reached from @var{keymap}.) The argument @@ -1350,7 +1299,7 @@ in another keymap reached from @var{keymap}.) The argument meaningful. (For a list of meaningful types, see @ref{Key Lookup}.) The value returned by @code{define-key} is @var{binding}. -If @var{key} is @code{[t]}, this sets the default binding in +If @var{key} is @kbd{}, this sets the default binding in @var{keymap}. When an event has no binding of its own, the Emacs command loop uses the keymap's default binding, if there is one. @@ -1358,7 +1307,7 @@ command loop uses the keymap's default binding, if there is one. @cindex key sequence error Every prefix of @var{key} must be a prefix key (i.e., bound to a keymap) or undefined; otherwise an error is signaled. If some prefix of -@var{key} is undefined, then @code{define-key} defines it as a prefix +@var{key} is undefined, then @code{keymap-set} defines it as a prefix key so that the rest of @var{key} can be defined as specified. If there was previously no binding for @var{key} in @var{keymap}, the @@ -1376,7 +1325,7 @@ bindings in it: @result{} (keymap) @end group @group -(define-key map ["C-f"] 'forward-char) +(keymap-set map "C-f" 'forward-char) @result{} forward-char @end group @group @@ -1386,7 +1335,7 @@ map @group ;; @r{Build sparse submap for @kbd{C-x} and bind @kbd{f} in that.} -(define-key map ["C-x f"] 'forward-word) +(keymap-set map "C-x f" 'forward-word) @result{} forward-word @end group @group @@ -1399,14 +1348,14 @@ map @group ;; @r{Bind @kbd{C-p} to the @code{ctl-x-map}.} -(define-key map ["C-p"] ctl-x-map) +(keymap-set map "C-p" ctl-x-map) ;; @code{ctl-x-map} @result{} [nil @dots{} find-file @dots{} backward-kill-sentence] @end group @group ;; @r{Bind @kbd{C-f} to @code{foo} in the @code{ctl-x-map}.} -(define-key map ["C-p C-f"] 'foo) +(keymap-set map "C-p C-f" 'foo) @result{} 'foo @end group @group @@ -1426,9 +1375,9 @@ changing the bindings of both @kbd{C-p C-f} and @kbd{C-x C-f} in the default global map. @defun define-keymap &key options... &rest pairs... -@code{define-key} is the general work horse for defining a key in a +@code{keymap-set} is the general work horse for defining a key in a keymap. When writing modes, however, you frequently have to bind a -large number of keys at once, and using @code{define-key} on them all +large number of keys at once, and using @code{keymap-set} on them all can be tedious and error-prone. Instead you can use @code{define-keymap}, which creates a keymaps and binds a number of keys. Here's a very basic example: @@ -1437,14 +1386,14 @@ keys. Here's a very basic example: (define-keymap "n" #'forward-line "f" #'previous-line - ["C-c C-c"] #'quit-window) + "C-c C-c" #'quit-window) @end lisp This function creates a new sparse keymap, defines the two keystrokes in @var{pairs}, and returns the new keymap. @var{pairs} is a list of alternating key bindings and key definitions, -as accepted by @code{define-key}. In addition the key can be the +as accepted by @code{keymap-set}. In addition the key can be the special symbol @code{:menu}, in which case the definition should be a menu definition as accepted by @code{easy-menu-define} (@pxref{Easy Menu}). Here's a brief example: @@ -1513,8 +1462,8 @@ Here's an example: @lisp (defvar-keymap eww-textarea-map :parent text-mode-map - "\r" #'forward-line - [?\t] #'shr-next-link) + "RET" #'forward-line + "TAB" #'shr-next-link) @end lisp @end defmac @@ -1617,13 +1566,112 @@ Modes}); then its keymap will automatically inherit from (defvar special-mode-map (let ((map (make-sparse-keymap))) (suppress-keymap map) - (define-key map "q" 'quit-window) + (keymap-set map "q" 'quit-window) @dots{} map)) @end group @end smallexample @end defun +@node Low-Level Key Binding +@section Low-Level Key Binding + + Historically, Emacs has supported a number of different syntaxes for +defining keys. The documented way to bind a key today is to use the +syntax supported by @code{key-valid-p}, which is what all the +functions like @code{keymap-set} and @code{keymap-lookup} supports. +This section of the manual documents the old syntax and interface +functions, and should not be used in new code. + +@cindex meta character key constants +@cindex control character key constants + @code{define-key} (and other low-level functions that are used to +rebind keys) understand a number of different syntaxes for the keys. + +@table @asis +@item A vector containing lists of keys. +You can use a list containing modifier names plus one base event (a +character or function key name). For example, @code{[(control ?a) +(meta b)]} is equivalent to @kbd{C-a M-b} and @code{[(hyper control +left)]} is equivalent to @kbd{C-H-left}. + +@item A string with control and meta characters. +Internally, key sequences are often represented as strings using the +special escape sequences for control and meta characters +(@pxref{String Type}), but this representation can also be used by +users when rebinding keys. A string like @code{"\M-x"} is read as +containing a single @kbd{M-x}, @code{"\C-f"} is read as containing a +single @kbd{C-f}, and @code{"\M-\C-x"} and @code{"\C-\M-x"} are both +read as containing a single @kbd{C-M-x}. + +@item a vector of characters. +This is the other internal representation of key sequences, and +supports a fuller range of modifiers than the string representation. +One example is @samp{[?\C-\H-x home]}, which represents the @kbd{C-H-x +home} key sequence. @xref{Character Type}. +@end table + +@defun define-key keymap key binding &optional remove +This function is like @code{keymap-set} (@pxref{Changing Key +Bindings}, but understands only the legacy key syntaxes. + +In addition, this function also has a @var{remove} argument. If it is +non-@code{nil}, the definition will be removed. This is almost the +same as setting the definition to @code{nil}, but makes a difference +if the @var{keymap} has a parent, and @var{key} is shadowing the same +binding in the parent. With @var{remove}, subsequent lookups will +return the binding in the parent, and with a nil @var{def}, the +lookups will return @code{nil}. +@end defun + +There's a number of other legacy key definition functions. Below is a +list of them, with the equivalent modern function to use instead. + +@table @code +@findex global-set-key +@item global-set-key +Use @code{keymap-global-set} instead. + +@findex local-set-key +@item local-set-key +Use @code{keymap-local-set} instead. + +@findex global-unset-key +@item global-unset-key +Use @code{keymap-global-unset} instead. + +@findex local-unset-key +@item local-unset-key +Use @code{keymap-local-unset} instead. + +@findex substitute-key-definition +@item substitute-key-definition +Use @code{keymap-substitute} instead. + +@findex define-key-after +@item define-key-after +Use @code{keymap-set-after} instead. + +@findex keyboard-translate +@item keyboard-translate +Use @code{key-translate} instead. + +@findex lookup-keymap +@findex key-binding +@item lookup-keymap +@itemx key-binding +Use @code{keymap-lookup} instead. + +@findex local-key-binding +@item local-key-binding +Use @code{keymap-local-lookup} instead. + +@findex global-key-binding +@item gobal-key-binding +Use @code{keymap-global-lookup} instead. +@end table + + @node Remapping Commands @section Remapping Commands @cindex remapping commands @@ -1834,32 +1882,18 @@ problematic suffixes/prefixes are @kbd{@key{ESC}}, @kbd{M-O} (which is really This section describes some convenient interactive interfaces for changing key bindings. They work by calling @code{define-key}. - People often use @code{global-set-key} in their init files + People often use @code{keymap-global-set} in their init files (@pxref{Init File}) for simple customization. For example, @smallexample -(global-set-key (kbd "C-x C-\\") 'next-line) -@end smallexample - -@noindent -or - -@smallexample -(global-set-key [?\C-x ?\C-\\] 'next-line) -@end smallexample - -@noindent -or - -@smallexample -(global-set-key [(control ?x) (control ?\\)] 'next-line) +(keymap-global-set "C-x C-\\" 'next-line) @end smallexample @noindent redefines @kbd{C-x C-\} to move down a line. @smallexample -(global-set-key [M-mouse-1] 'mouse-set-point) +(keymap-global-set "M-" 'mouse-set-point) @end smallexample @noindent @@ -1873,14 +1907,7 @@ they usually will be in a Lisp file (@pxref{Loading Non-ASCII}), you must type the keys as multibyte too. For instance, if you use this: @smallexample -(global-set-key "ö" 'my-function) ; bind o-umlaut -@end smallexample - -@noindent -or - -@smallexample -(global-set-key ?ö 'my-function) ; bind o-umlaut +(keymap-global-set "ö" 'my-function) ; bind o-umlaut @end smallexample @noindent @@ -1891,20 +1918,20 @@ binding, you need to teach Emacs how to decode the keyboard by using an appropriate input method (@pxref{Input Methods, , Input Methods, emacs, The GNU Emacs Manual}). -@deffn Command global-set-key key binding +@deffn Command keymap-global-set key binding This function sets the binding of @var{key} in the current global map to @var{binding}. @smallexample @group -(global-set-key @var{key} @var{binding}) +(keymap-global-set @var{key} @var{binding}) @equiv{} -(define-key (current-global-map) @var{key} @var{binding}) +(keymap-set (current-global-map) @var{key} @var{binding}) @end group @end smallexample @end deffn -@deffn Command global-unset-key key +@deffn Command keymap-global-unset key @cindex unbinding keys This function removes the binding of @var{key} from the current global map. @@ -1915,50 +1942,32 @@ that uses @var{key} as a prefix---which would not be allowed if @smallexample @group -(global-unset-key "\C-l") +(keymap-global-unset "C-l") @result{} nil @end group @group -(global-set-key "\C-l\C-l" 'redraw-display) +(keymap-global-set "C-l C-l" 'redraw-display) @result{} nil @end group @end smallexample - -This function is equivalent to using @code{define-key} as follows: - -@smallexample -@group -(global-unset-key @var{key}) -@equiv{} -(define-key (current-global-map) @var{key} nil) -@end group -@end smallexample @end deffn -@deffn Command local-set-key key binding +@deffn Command keymap-local-set key binding This function sets the binding of @var{key} in the current local keymap to @var{binding}. @smallexample @group -(local-set-key @var{key} @var{binding}) +(keymap-local-set @var{key} @var{binding}) @equiv{} -(define-key (current-local-map) @var{key} @var{binding}) +(keymap-set (current-local-map) @var{key} @var{binding}) @end group @end smallexample @end deffn -@deffn Command local-unset-key key +@deffn Command keymap-local-unset key This function removes the binding of @var{key} from the current local map. - -@smallexample -@group -(local-unset-key @var{key}) -@equiv{} -(define-key (current-local-map) @var{key} nil) -@end group -@end smallexample @end deffn @node Scanning Keymaps @@ -2813,9 +2822,9 @@ using an indirection through @code{tool-bar-map}. By default, the global map binds @code{[tool-bar]} as follows: @example -(global-set-key [tool-bar] - `(menu-item ,(purecopy "tool bar") ignore - :filter tool-bar-make-keymap)) +(keymap-global-set "" + `(menu-item ,(purecopy "tool bar") ignore + :filter tool-bar-make-keymap)) @end example @noindent diff --git a/lisp/dired.el b/lisp/dired.el index 40dfc39b9a..8650fb9baa 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1672,9 +1672,9 @@ see `dired-use-ls-dired' for more details.") (dired-goto-subdir current-dir) (dired current-dir))))) (define-keymap - [mouse-2] click - [follow-link] 'mouse-face - ["RET"] click)))) + "" click + "" 'mouse-face + "RET" click)))) (setq segment-start (point))))))) commit 2daffe3550ff829396f13dd21d5cb573fede30d9 Author: Lars Ingebrigtsen Date: Tue Nov 16 08:18:30 2021 +0100 Adjust `defvar-keymap' and `define-keymap' to the new syntax * lisp/vc/smerge-mode.el (smerge-basic-map): * lisp/vc/pcvs.el (cvs-mode-map): (cvs-minor-mode-prefix): * lisp/vc/log-view.el (log-view-mode-map): * lisp/vc/log-edit.el (log-edit-mode-map): * lisp/vc/diff-mode.el (diff-mode-shared-map): (diff-minor-mode-prefix): * lisp/vc/cvs-status.el (cvs-status-mode-map): * lisp/simple.el (special-mode-map): * lisp/outline.el (outline--insert-open-button): (outline--insert-close-button): * lisp/net/shr.el (shr-map): * lisp/net/eww.el (eww-link-keymap): (eww-mode-map): (eww-submit-map): (eww-bookmark-mode-map): (eww-history-mode-map): (eww-buffers-mode-map): * lisp/mh-e/mh-speed.el (:keymap): * lisp/mh-e/mh-show.el (:keymap): * lisp/mh-e/mh-search.el (:keymap): * lisp/mh-e/mh-letter.el (:keymap): * lisp/mh-e/mh-folder.el (:keymap): * lisp/international/emoji.el (emoji-list-mode-map): * lisp/gnus/spam.el (:keymap): * lisp/gnus/mml.el (mml-mode-map): * lisp/gnus/message.el (message-mode-map): * lisp/gnus/gnus-undo.el (gnus-undo-mode-map): * lisp/gnus/gnus-topic.el (gnus-topic-mode-map): * lisp/gnus/gnus-sum.el (:keymap): * lisp/gnus/gnus-srvr.el (gnus-server-mode-map): (gnus-browse-mode-map): * lisp/gnus/gnus-salt.el (gnus-pick-mode-map): (gnus-tree-mode-map): * lisp/gnus/gnus-msg.el (:prefix): * lisp/gnus/gnus-ml.el (gnus-mailing-list-mode-map): * lisp/gnus/gnus-kill.el (gnus-kill-file-mode-map): * lisp/gnus/gnus-html.el (gnus-html-displayed-image-map): * lisp/gnus/gnus-group.el (:keymap): * lisp/gnus/gnus-eform.el (gnus-edit-form-mode-map): * lisp/gnus/gnus-draft.el (gnus-draft-mode-map): * lisp/gnus/gnus-dired.el (gnus-dired-mode-map): * lisp/gnus/gnus-bookmark.el (gnus-bookmark-bmenu-mode-map): * lisp/gnus/gnus-art.el (:keymap): (gnus-article-edit-mode-map): * lisp/gnus/gnus-agent.el (gnus-agent-group-mode-map): (gnus-agent-summary-mode-map): (gnus-agent-server-mode-map): (gnus-category-mode-map): Adjust `defvar-keymap' and `define-keymap' to the new syntax. diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 20da295aca..169a351c2c 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -476,15 +476,15 @@ manipulated as follows: (intern (format "gnus-agent-%s-mode-hook" buffer))))) (defvar-keymap gnus-agent-group-mode-map - "Ju" #'gnus-agent-fetch-groups - "Jc" #'gnus-enter-category-buffer - "Jj" #'gnus-agent-toggle-plugged - "Js" #'gnus-agent-fetch-session - "JY" #'gnus-agent-synchronize-flags - "JS" #'gnus-group-send-queue - "Ja" #'gnus-agent-add-group - "Jr" #'gnus-agent-remove-group - "Jo" #'gnus-agent-toggle-group-plugged) + "J u" #'gnus-agent-fetch-groups + "J c" #'gnus-enter-category-buffer + "J j" #'gnus-agent-toggle-plugged + "J s" #'gnus-agent-fetch-session + "J Y" #'gnus-agent-synchronize-flags + "J S" #'gnus-group-send-queue + "J a" #'gnus-agent-add-group + "J r" #'gnus-agent-remove-group + "J o" #'gnus-agent-toggle-group-plugged) (defun gnus-agent-group-make-menu-bar () (unless (boundp 'gnus-agent-group-menu) @@ -504,14 +504,14 @@ manipulated as follows: )))) (defvar-keymap gnus-agent-summary-mode-map - "Jj" #'gnus-agent-toggle-plugged - "Ju" #'gnus-agent-summary-fetch-group - "JS" #'gnus-agent-fetch-group - "Js" #'gnus-agent-summary-fetch-series - "J#" #'gnus-agent-mark-article - "J\M-#" #'gnus-agent-unmark-article + "J j" #'gnus-agent-toggle-plugged + "J u" #'gnus-agent-summary-fetch-group + "J S" #'gnus-agent-fetch-group + "J s" #'gnus-agent-summary-fetch-series + "J #" #'gnus-agent-mark-article + "J M-#" #'gnus-agent-unmark-article "@" #'gnus-agent-toggle-mark - "Jc" #'gnus-agent-catchup) + "J c" #'gnus-agent-catchup) (defun gnus-agent-summary-make-menu-bar () (unless (boundp 'gnus-agent-summary-menu) @@ -526,9 +526,9 @@ manipulated as follows: ["Catchup undownloaded" gnus-agent-catchup t])))) (defvar-keymap gnus-agent-server-mode-map - "Jj" #'gnus-agent-toggle-plugged - "Ja" #'gnus-agent-add-server - "Jr" #'gnus-agent-remove-server) + "J j" #'gnus-agent-toggle-plugged + "J a" #'gnus-agent-add-server + "J r" #'gnus-agent-remove-server) (defun gnus-agent-server-make-menu-bar () (unless (boundp 'gnus-agent-server-menu) @@ -2606,8 +2606,8 @@ General format specifiers can also be used. See Info node "s" #'gnus-category-edit-score "l" #'gnus-category-list - "\C-c\C-i" #'gnus-info-find-node - "\C-c\C-b" #'gnus-bug) + "C-c C-i" #'gnus-info-find-node + "C-c C-b" #'gnus-bug) (defcustom gnus-category-menu-hook nil "Hook run after the creation of the menu." diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 23f1431b80..9594c32e81 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -4419,36 +4419,36 @@ If variable `gnus-use-long-file-name' is non-nil, it is (define-keymap :keymap gnus-article-mode-map :suppress t :parent button-buffer-map - " " #'gnus-article-goto-next-page - [?\S-\ ] #'gnus-article-goto-prev-page - "\177" #'gnus-article-goto-prev-page - [delete] #'gnus-article-goto-prev-page - "\C-c^" #'gnus-article-refer-article + "SPC" #'gnus-article-goto-next-page + "S-SPC" #'gnus-article-goto-prev-page + "DEL" #'gnus-article-goto-prev-page + "" #'gnus-article-goto-prev-page + "C-c ^" #'gnus-article-refer-article "h" #'gnus-article-show-summary "s" #'gnus-article-show-summary - "\C-c\C-m" #'gnus-article-mail + "C-c C-m" #'gnus-article-mail "?" #'gnus-article-describe-briefly "<" #'beginning-of-buffer ">" #'end-of-buffer - "\C-c\C-i" #'gnus-info-find-node - "\C-c\C-b" #'gnus-bug + "C-c TAB" #'gnus-info-find-node + "C-c C-b" #'gnus-bug "R" #'gnus-article-reply-with-original "F" #'gnus-article-followup-with-original - "\C-hk" #'gnus-article-describe-key - "\C-hc" #'gnus-article-describe-key-briefly - "\C-hb" #'gnus-article-describe-bindings + "C-h k" #'gnus-article-describe-key + "C-h c" #'gnus-article-describe-key-briefly + "C-h b" #'gnus-article-describe-bindings "e" #'gnus-article-read-summary-keys - "\C-d" #'gnus-article-read-summary-keys - "\C-c\C-f" #'gnus-summary-mail-forward - "\M-*" #'gnus-article-read-summary-keys - "\M-#" #'gnus-article-read-summary-keys - "\M-^" #'gnus-article-read-summary-keys - "\M-g" #'gnus-article-read-summary-keys + "C-d" #'gnus-article-read-summary-keys + "C-c C-f" #'gnus-summary-mail-forward + "M-*" #'gnus-article-read-summary-keys + "M-#" #'gnus-article-read-summary-keys + "M-^" #'gnus-article-read-summary-keys + "M-g" #'gnus-article-read-summary-keys "S" (define-keymap :prefix 'gnus-article-send-map "W" #'gnus-article-wide-reply-with-original - [t] #'gnus-article-read-summary-send-keys)) + "" #'gnus-article-read-summary-send-keys)) (substitute-key-definition #'undefined #'gnus-article-read-summary-keys gnus-article-mode-map) @@ -7254,41 +7254,40 @@ other groups." (defvar-keymap gnus-article-edit-mode-map :full t :parent text-mode-map - "\C-c?" #'describe-mode - "\C-c\C-c" #'gnus-article-edit-done - "\C-c\C-k" #'gnus-article-edit-exit - "\C-c\C-f\C-t" #'message-goto-to - "\C-c\C-f\C-o" #'message-goto-from - "\C-c\C-f\C-b" #'message-goto-bcc - ;;"\C-c\C-f\C-w" message-goto-fcc - "\C-c\C-f\C-c" #'message-goto-cc - "\C-c\C-f\C-s" #'message-goto-subject - "\C-c\C-f\C-r" #'message-goto-reply-to - "\C-c\C-f\C-n" #'message-goto-newsgroups - "\C-c\C-f\C-d" #'message-goto-distribution - "\C-c\C-f\C-f" #'message-goto-followup-to - "\C-c\C-f\C-m" #'message-goto-mail-followup-to - "\C-c\C-f\C-k" #'message-goto-keywords - "\C-c\C-f\C-u" #'message-goto-summary - "\C-c\C-f\C-i" #'message-insert-or-toggle-importance - "\C-c\C-f\C-a" #'message-generate-unsubscribed-mail-followup-to - "\C-c\C-b" #'message-goto-body - "\C-c\C-i" #'message-goto-signature - - "\C-c\C-t" #'message-insert-to - "\C-c\C-n" #'message-insert-newsgroups - "\C-c\C-o" #'message-sort-headers - "\C-c\C-e" #'message-elide-region - "\C-c\C-v" #'message-delete-not-region - "\C-c\C-z" #'message-kill-to-signature - "\M-\r" #'message-newline-and-reformat - "\C-c\C-a" #'mml-attach-file - "\C-a" #'message-beginning-of-line - "\t" #'message-tab - "\M-;" #'comment-region - - "\C-c\C-w" (define-keymap :prefix 'gnus-article-edit-wash-map - "f" #'gnus-article-edit-full-stops)) + "C-c ?" #'describe-mode + "C-c C-c" #'gnus-article-edit-done + "C-c C-k" #'gnus-article-edit-exit + "C-c C-f C-t" #'message-goto-to + "C-c C-f C-o" #'message-goto-from + "C-c C-f C-b" #'message-goto-bcc + "C-c C-f C-c" #'message-goto-cc + "C-c C-f C-s" #'message-goto-subject + "C-c C-f C-r" #'message-goto-reply-to + "C-c C-f C-n" #'message-goto-newsgroups + "C-c C-f C-d" #'message-goto-distribution + "C-c C-f C-f" #'message-goto-followup-to + "C-c C-f RET" #'message-goto-mail-followup-to + "C-c C-f C-k" #'message-goto-keywords + "C-c C-f C-u" #'message-goto-summary + "C-c C-f TAB" #'message-insert-or-toggle-importance + "C-c C-f C-a" #'message-generate-unsubscribed-mail-followup-to + "C-c C-b" #'message-goto-body + "C-c TAB" #'message-goto-signature + + "C-c C-t" #'message-insert-to + "C-c C-n" #'message-insert-newsgroups + "C-c C-o" #'message-sort-headers + "C-c C-e" #'message-elide-region + "C-c C-v" #'message-delete-not-region + "C-c C-z" #'message-kill-to-signature + "M-RET" #'message-newline-and-reformat + "C-c C-a" #'mml-attach-file + "C-a" #'message-beginning-of-line + "TAB" #'message-tab + "M-;" #'comment-region + + "C-c C-w" (define-keymap :prefix 'gnus-article-edit-wash-map + "f" #'gnus-article-edit-full-stops)) (easy-menu-define gnus-article-edit-mode-field-menu gnus-article-edit-mode-map "" diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el index 171da9d17a..e9696b66a9 100644 --- a/lisp/gnus/gnus-bookmark.el +++ b/lisp/gnus/gnus-bookmark.el @@ -423,16 +423,16 @@ That is, all information but the name." :full t :suppress 'nodigits "q" #'quit-window - "\C-m" #'gnus-bookmark-bmenu-select + "RET" #'gnus-bookmark-bmenu-select "v" #'gnus-bookmark-bmenu-select "d" #'gnus-bookmark-bmenu-delete "k" #'gnus-bookmark-bmenu-delete - "\C-d" #'gnus-bookmark-bmenu-delete-backwards + "C-d" #'gnus-bookmark-bmenu-delete-backwards "x" #'gnus-bookmark-bmenu-execute-deletions - " " #'next-line + "SPC" #'next-line "n" #'next-line "p" #'previous-line - "\177" #'gnus-bookmark-bmenu-backup-unmark + "DEL" #'gnus-bookmark-bmenu-backup-unmark "?" #'describe-mode "u" #'gnus-bookmark-bmenu-unmark "m" #'gnus-bookmark-bmenu-mark @@ -440,7 +440,7 @@ That is, all information but the name." "s" #'gnus-bookmark-bmenu-save "t" #'gnus-bookmark-bmenu-toggle-infos "a" #'gnus-bookmark-bmenu-show-details - [mouse-2] #'gnus-bookmark-bmenu-select-by-mouse) + "" #'gnus-bookmark-bmenu-select-by-mouse) ;; Bookmark Buffer Menu mode is suitable only for specially formatted ;; data. diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el index be46d3a341..1d16e00700 100644 --- a/lisp/gnus/gnus-dired.el +++ b/lisp/gnus/gnus-dired.el @@ -54,9 +54,9 @@ (autoload 'gnus-print-buffer "gnus-sum") (defvar-keymap gnus-dired-mode-map - "\C-c\C-m\C-a" #'gnus-dired-attach - "\C-c\C-m\C-l" #'gnus-dired-find-file-mailcap - "\C-c\C-m\C-p" #'gnus-dired-print) + "C-c C-m C-a" #'gnus-dired-attach + "C-c C-m C-l" #'gnus-dired-find-file-mailcap + "C-c C-m C-p" #'gnus-dired-print) ;; FIXME: Make it customizable, change the default to `mail-user-agent' when ;; this file is renamed (e.g. to `dired-mime.el'). diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index 756e6d2d36..7c56db0ba4 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -34,11 +34,11 @@ ;;; Draft minor mode (defvar-keymap gnus-draft-mode-map - "Dt" #'gnus-draft-toggle-sending + "D t" #'gnus-draft-toggle-sending "e" #' gnus-draft-edit-message ;; Use `B w' for `gnus-summary-edit-article' - "De" #'gnus-draft-edit-message - "Ds" #'gnus-draft-send-message - "DS" #'gnus-draft-send-all-messages) + "D e" #'gnus-draft-edit-message + "D s" #'gnus-draft-send-message + "D S" #'gnus-draft-send-all-messages) (defun gnus-draft-make-menu-bar () (unless (boundp 'gnus-draft-menu) diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el index b0aa58f0f2..c727926731 100644 --- a/lisp/gnus/gnus-eform.el +++ b/lisp/gnus/gnus-eform.el @@ -50,8 +50,8 @@ (defvar-keymap gnus-edit-form-mode-map :parent emacs-lisp-mode-map - "\C-c\C-c" #'gnus-edit-form-done - "\C-c\C-k" #'gnus-edit-form-exit) + "C-c C-c" #'gnus-edit-form-done + "C-c C-k" #'gnus-edit-form-exit) (defun gnus-edit-form-make-menu-bar () (unless (boundp 'gnus-edit-form-menu) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index ddc819877c..f0b0ca5879 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -574,79 +574,79 @@ simple manner." ;;; (define-keymap :keymap gnus-group-mode-map - " " #'gnus-group-read-group + "SPC" #'gnus-group-read-group "=" #'gnus-group-select-group - "\r" #'gnus-group-select-group - "\M-\r" #'gnus-group-quick-select-group - "\M- " #'gnus-group-visible-select-group - [(meta control return)] #'gnus-group-select-group-ephemerally + "RET" #'gnus-group-select-group + "M-RET" #'gnus-group-quick-select-group + "M-SPC" #'gnus-group-visible-select-group + "C-M-" #'gnus-group-select-group-ephemerally "j" #'gnus-group-jump-to-group "n" #'gnus-group-next-unread-group "p" #'gnus-group-prev-unread-group - "\177" #'gnus-group-prev-unread-group - [delete] #'gnus-group-prev-unread-group + "DEL" #'gnus-group-prev-unread-group + "" #'gnus-group-prev-unread-group "N" #'gnus-group-next-group "P" #'gnus-group-prev-group - "\M-n" #'gnus-group-next-unread-group-same-level - "\M-p" #'gnus-group-prev-unread-group-same-level + "M-n" #'gnus-group-next-unread-group-same-level + "M-p" #'gnus-group-prev-unread-group-same-level "," #'gnus-group-best-unread-group "." #'gnus-group-first-unread-group "u" #'gnus-group-toggle-subscription-at-point "U" #'gnus-group-toggle-subscription "c" #'gnus-group-catchup-current "C" #'gnus-group-catchup-current-all - "\M-c" #'gnus-group-clear-data + "M-c" #'gnus-group-clear-data "l" #'gnus-group-list-groups "L" #'gnus-group-list-all-groups "m" #'gnus-group-mail "i" #'gnus-group-news "g" #'gnus-group-get-new-news - "\M-g" #'gnus-group-get-new-news-this-group + "M-g" #'gnus-group-get-new-news-this-group "R" #'gnus-group-restart "r" #'gnus-group-read-init-file "B" #'gnus-group-browse-foreign-server "b" #'gnus-group-check-bogus-groups "F" #'gnus-group-find-new-groups - "\C-c\C-d" #'gnus-group-describe-group - "\M-d" #'gnus-group-describe-all-groups - "\C-c\C-a" #'gnus-group-apropos - "\C-c\M-\C-a" #'gnus-group-description-apropos + "C-c C-d" #'gnus-group-describe-group + "M-d" #'gnus-group-describe-all-groups + "C-c C-a" #'gnus-group-apropos + "C-c C-M-a" #'gnus-group-description-apropos "a" #'gnus-group-post-news - "\ek" #'gnus-group-edit-local-kill - "\eK" #'gnus-group-edit-global-kill - "\C-k" #'gnus-group-kill-group - "\C-y" #'gnus-group-yank-group - "\C-w" #'gnus-group-kill-region - "\C-x\C-t" #'gnus-group-transpose-groups - "\C-c\C-l" #'gnus-group-list-killed - "\C-c\C-x" #'gnus-group-expire-articles - "\C-c\M-\C-x" #'gnus-group-expire-all-groups + "ESC k" #'gnus-group-edit-local-kill + "ESC K" #'gnus-group-edit-global-kill + "C-k" #'gnus-group-kill-group + "C-y" #'gnus-group-yank-group + "C-w" #'gnus-group-kill-region + "C-x C-t" #'gnus-group-transpose-groups + "C-c C-l" #'gnus-group-list-killed + "C-c C-x" #'gnus-group-expire-articles + "C-c C-M-x" #'gnus-group-expire-all-groups "V" #'gnus-version "s" #'gnus-group-save-newsrc "z" #'gnus-group-suspend "q" #'gnus-group-exit "Q" #'gnus-group-quit "?" #'gnus-group-describe-briefly - "\C-c\C-i" #'gnus-info-find-node - "\M-e" #'gnus-group-edit-group-method + "C-c C-i" #'gnus-info-find-node + "M-e" #'gnus-group-edit-group-method "^" #'gnus-group-enter-server-mode - [mouse-2] #'gnus-mouse-pick-group - [follow-link] 'mouse-face + "" #'gnus-mouse-pick-group + "" 'mouse-face "<" #'beginning-of-buffer ">" #'end-of-buffer - "\C-c\C-b" #'gnus-bug - "\C-c\C-s" #'gnus-group-sort-groups + "C-c C-b" #'gnus-bug + "C-c C-s" #'gnus-group-sort-groups "t" #'gnus-topic-mode - "\C-c\M-g" #'gnus-activate-all-groups - "\M-&" #'gnus-group-universal-argument + "C-c M-g" #'gnus-activate-all-groups + "M-&" #'gnus-group-universal-argument "#" #'gnus-group-mark-group - "\M-#" #'gnus-group-unmark-group + "M-#" #'gnus-group-unmark-group "~" (define-keymap :prefix 'gnus-group-cloud-map "u" #'gnus-cloud-upload-all-data "~" #'gnus-cloud-upload-all-data "d" #'gnus-cloud-download-all-data - "\r" #'gnus-cloud-download-all-data) + "RET" #'gnus-cloud-download-all-data) "M" (define-keymap :prefix 'gnus-group-mark-map "m" #'gnus-group-mark-group @@ -682,8 +682,8 @@ simple manner." "c" #'gnus-group-customize "z" #'gnus-group-compact-group "x" #'gnus-group-expunge-group - "\177" #'gnus-group-delete-group - [delete] #'gnus-group-delete-group + "DEL" #'gnus-group-delete-group + "" #'gnus-group-delete-group "S" (define-keymap :prefix 'gnus-group-sort-map "s" #'gnus-group-sort-groups @@ -774,7 +774,7 @@ simple manner." "k" #'gnus-group-kill-group "y" #'gnus-group-yank-group "w" #'gnus-group-kill-region - "\C-k" #'gnus-group-kill-level + "C-k" #'gnus-group-kill-level "z" #'gnus-group-kill-all-zombies)) (defun gnus-topic-mode-p () diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index c1815d3486..ef376f138e 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -79,9 +79,9 @@ fit these criteria." (defvar-keymap gnus-html-displayed-image-map "a" #'gnus-html-show-alt-text "i" #'gnus-html-browse-image - "\r" #'gnus-html-browse-url + "RET" #'gnus-html-browse-url "u" #'gnus-article-copy-string - [tab] #'forward-button) + "" #'forward-button) (defun gnus-html-encode-url (url) "Encode URL." diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index 7e589c54e9..7137efd730 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -68,13 +68,13 @@ of time." (defvar-keymap gnus-kill-file-mode-map :parent emacs-lisp-mode-map - "\C-c\C-k\C-s" #'gnus-kill-file-kill-by-subject - "\C-c\C-k\C-a" #'gnus-kill-file-kill-by-author - "\C-c\C-k\C-t" #'gnus-kill-file-kill-by-thread - "\C-c\C-k\C-x" #'gnus-kill-file-kill-by-xref - "\C-c\C-a" #'gnus-kill-file-apply-buffer - "\C-c\C-e" #'gnus-kill-file-apply-last-sexp - "\C-c\C-c" #'gnus-kill-file-exit) + "C-c C-k C-s" #'gnus-kill-file-kill-by-subject + "C-c C-k C-a" #'gnus-kill-file-kill-by-author + "C-c C-k C-t" #'gnus-kill-file-kill-by-thread + "C-c C-k C-x" #'gnus-kill-file-kill-by-xref + "C-c C-a" #'gnus-kill-file-apply-buffer + "C-c C-e" #'gnus-kill-file-apply-last-sexp + "C-c C-c" #'gnus-kill-file-exit) (define-derived-mode gnus-kill-file-mode emacs-lisp-mode "Kill" "Major mode for editing kill files. diff --git a/lisp/gnus/gnus-ml.el b/lisp/gnus/gnus-ml.el index bf33194cf7..a5358e9ff4 100644 --- a/lisp/gnus/gnus-ml.el +++ b/lisp/gnus/gnus-ml.el @@ -32,12 +32,12 @@ ;;; Mailing list minor mode (defvar-keymap gnus-mailing-list-mode-map - "\C-c\C-nh" #'gnus-mailing-list-help - "\C-c\C-ns" #'gnus-mailing-list-subscribe - "\C-c\C-nu" #'gnus-mailing-list-unsubscribe - "\C-c\C-np" #'gnus-mailing-list-post - "\C-c\C-no" #'gnus-mailing-list-owner - "\C-c\C-na" #'gnus-mailing-list-archive) + "C-c C-n h" #'gnus-mailing-list-help + "C-c C-n s" #'gnus-mailing-list-subscribe + "C-c C-n u" #'gnus-mailing-list-unsubscribe + "C-c C-n p" #'gnus-mailing-list-post + "C-c C-n o" #'gnus-mailing-list-owner + "C-c C-n a" #'gnus-mailing-list-archive) (defvar gnus-mailing-list-menu) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index dfadfd3920..bb265642bc 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -369,13 +369,13 @@ only affect the Gcc copy, but not the original message." "m" #'gnus-summary-mail-other-window "u" #'gnus-uu-post-news "A" #'gnus-summary-attach-article - "\M-c" #'gnus-summary-mail-crosspost-complaint - "Br" #'gnus-summary-reply-broken-reply-to - "BR" #'gnus-summary-reply-broken-reply-to-with-original - "om" #'gnus-summary-mail-forward - "op" #'gnus-summary-post-forward - "Om" #'gnus-uu-digest-mail-forward - "Op" #'gnus-uu-digest-post-forward + "M-c" #'gnus-summary-mail-crosspost-complaint + "B r" #'gnus-summary-reply-broken-reply-to + "B R" #'gnus-summary-reply-broken-reply-to-with-original + "o m" #'gnus-summary-mail-forward + "o p" #'gnus-summary-post-forward + "O m" #'gnus-uu-digest-mail-forward + "O p" #'gnus-uu-digest-post-forward "D" (define-keymap :prefix 'gnus-send-bounce-map "b" #'gnus-summary-resend-bounced-mail diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el index 8ffe4a4c57..205e936bc7 100644 --- a/lisp/gnus/gnus-salt.el +++ b/lisp/gnus/gnus-salt.el @@ -65,11 +65,11 @@ It accepts the same format specs that `gnus-summary-line-format' does." ;;; Internal variables. (defvar-keymap gnus-pick-mode-map - " " #'gnus-pick-next-page + "SPC" #'gnus-pick-next-page "u" #'gnus-pick-unmark-article-or-thread "." #'gnus-pick-article-or-thread - [down-mouse-2] #'gnus-pick-mouse-pick-region - "\r" #'gnus-pick-start-reading) + "" #'gnus-pick-mouse-pick-region + "RET" #'gnus-pick-start-reading) (defun gnus-pick-make-menu-bar () (unless (boundp 'gnus-pick-menu) @@ -420,12 +420,12 @@ Two predefined functions are available: (defvar-keymap gnus-tree-mode-map :full t :suppress t - "\r" #'gnus-tree-select-article - [mouse-2] #'gnus-tree-pick-article - "\C-?" #'gnus-tree-read-summary-keys + "RET" #'gnus-tree-select-article + "" #'gnus-tree-pick-article + "DEL" #'gnus-tree-read-summary-keys "h" #'gnus-tree-show-summary - "\C-c\C-i" #'gnus-info-find-node) + "C-c C-i" #'gnus-info-find-node) (substitute-key-definition 'undefined #'gnus-tree-read-summary-keys gnus-tree-mode-map) diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index f2ffb067b8..fa880b7edd 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -105,9 +105,9 @@ If nil, a faster, but more primitive, buffer is used instead." (defvar-keymap gnus-server-mode-map :full t :suppress t - " " #'gnus-server-read-server-in-server-buffer - "\r" #'gnus-server-read-server - [mouse-2] #'gnus-server-pick-server + "SPC" #'gnus-server-read-server-in-server-buffer + "RET" #'gnus-server-read-server + "" #'gnus-server-pick-server "q" #'gnus-server-exit "l" #'gnus-server-list-servers "k" #'gnus-server-kill-server @@ -119,9 +119,9 @@ If nil, a faster, but more primitive, buffer is used instead." "s" #'gnus-server-scan-server "O" #'gnus-server-open-server - "\M-o" #'gnus-server-open-all-servers + "M-o" #'gnus-server-open-all-servers "C" #'gnus-server-close-server - "\M-c" #'gnus-server-close-all-servers + "M-c" #'gnus-server-close-all-servers "D" #'gnus-server-deny-server "L" #'gnus-server-offline-server "R" #'gnus-server-remove-denials @@ -138,8 +138,8 @@ If nil, a faster, but more primitive, buffer is used instead." "i" #'gnus-server-toggle-cloud-server "I" #'gnus-server-set-cloud-method-server - "\C-c\C-i" #'gnus-info-find-node - "\C-c\C-b" #'gnus-bug) + "C-c C-i" #'gnus-info-find-node + "C-c C-b" #'gnus-bug) (defcustom gnus-server-menu-hook nil "Hook run after the creation of the server mode menu." @@ -694,29 +694,29 @@ claim them." (defvar-keymap gnus-browse-mode-map :full t :suppress t - " " #'gnus-browse-read-group + "SPC" #'gnus-browse-read-group "=" #'gnus-browse-select-group "n" #'gnus-browse-next-group "p" #'gnus-browse-prev-group - "\177" #'gnus-browse-prev-group - [delete] #'gnus-browse-prev-group + "DEL" #'gnus-browse-prev-group + "" #'gnus-browse-prev-group "N" #'gnus-browse-next-group "P" #'gnus-browse-prev-group - "\M-n" #'gnus-browse-next-group - "\M-p" #'gnus-browse-prev-group - "\r" #'gnus-browse-select-group + "M-n" #'gnus-browse-next-group + "M-p" #'gnus-browse-prev-group + "RET" #'gnus-browse-select-group "u" #'gnus-browse-toggle-subscription-at-point "l" #'gnus-browse-exit "L" #'gnus-browse-exit "q" #'gnus-browse-exit "Q" #'gnus-browse-exit "d" #'gnus-browse-describe-group - [delete] #'gnus-browse-delete-group - "\C-c\C-c" #'gnus-browse-exit + "" #'gnus-browse-delete-group + "C-c C-c" #'gnus-browse-exit "?" #'gnus-browse-describe-briefly - "\C-c\C-i" #'gnus-info-find-node - "\C-c\C-b" #'gnus-bug) + "C-c C-i" #'gnus-info-find-node + "C-c C-b" #'gnus-bug) (defun gnus-browse-make-menu-bar () (gnus-turn-off-edit-menu 'browse) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index f06661209b..dcdf3d977d 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1908,129 +1908,129 @@ increase the score of each group you read." ;; Non-orthogonal keys (define-keymap :keymap gnus-summary-mode-map - " " #'gnus-summary-next-page - [?\S-\ ] #'gnus-summary-prev-page - "\177" #'gnus-summary-prev-page - [delete] #'gnus-summary-prev-page - "\r" #'gnus-summary-scroll-up - "\M-\r" #'gnus-summary-scroll-down + "SPC" #'gnus-summary-next-page + "S-SPC" #'gnus-summary-prev-page + "DEL" #'gnus-summary-prev-page + "" #'gnus-summary-prev-page + "RET" #'gnus-summary-scroll-up + "M-RET" #'gnus-summary-scroll-down "n" #'gnus-summary-next-unread-article "p" #'gnus-summary-prev-unread-article "N" #'gnus-summary-next-article "P" #'gnus-summary-prev-article - "\M-\C-n" #'gnus-summary-next-same-subject - "\M-\C-p" #'gnus-summary-prev-same-subject - "\M-n" #'gnus-summary-next-unread-subject - "\M-p" #'gnus-summary-prev-unread-subject + "C-M-n" #'gnus-summary-next-same-subject + "C-M-p" #'gnus-summary-prev-same-subject + "M-n" #'gnus-summary-next-unread-subject + "M-p" #'gnus-summary-prev-unread-subject "." #'gnus-summary-first-unread-article "," #'gnus-summary-best-unread-article "[" #'gnus-summary-prev-unseen-article "]" #'gnus-summary-next-unseen-article - "\M-s\M-s" #'gnus-summary-search-article-forward - "\M-s\M-r" #'gnus-summary-search-article-backward - "\M-r" #'gnus-summary-search-article-backward - "\M-S" #'gnus-summary-repeat-search-article-forward - "\M-R" #'gnus-summary-repeat-search-article-backward + "M-s M-s" #'gnus-summary-search-article-forward + "M-s M-r" #'gnus-summary-search-article-backward + "M-r" #'gnus-summary-search-article-backward + "M-S" #'gnus-summary-repeat-search-article-forward + "M-R" #'gnus-summary-repeat-search-article-backward "<" #'gnus-summary-beginning-of-article ">" #'gnus-summary-end-of-article "j" #'gnus-summary-goto-article "^" #'gnus-summary-refer-parent-article - "\M-^" #'gnus-summary-refer-article + "M-^" #'gnus-summary-refer-article "u" #'gnus-summary-tick-article-forward "!" #'gnus-summary-tick-article-forward "U" #'gnus-summary-tick-article-backward "d" #'gnus-summary-mark-as-read-forward "D" #'gnus-summary-mark-as-read-backward "E" #'gnus-summary-mark-as-expirable - "\M-u" #'gnus-summary-clear-mark-forward - "\M-U" #'gnus-summary-clear-mark-backward + "M-u" #'gnus-summary-clear-mark-forward + "M-U" #'gnus-summary-clear-mark-backward "k" #'gnus-summary-kill-same-subject-and-select - "\C-k" #'gnus-summary-kill-same-subject - "\M-\C-k" #'gnus-summary-kill-thread - "\M-\C-l" #'gnus-summary-lower-thread + "C-k" #'gnus-summary-kill-same-subject + "C-M-k" #'gnus-summary-kill-thread + "C-M-l" #'gnus-summary-lower-thread "e" #'gnus-summary-edit-article "#" #'gnus-summary-mark-as-processable - "\M-#" #'gnus-summary-unmark-as-processable - "\M-\C-t" #'gnus-summary-toggle-threads - "\M-\C-s" #'gnus-summary-show-thread - "\M-\C-h" #'gnus-summary-hide-thread - "\M-\C-f" #'gnus-summary-next-thread - "\M-\C-b" #'gnus-summary-prev-thread - [(meta down)] #'gnus-summary-next-thread - [(meta up)] #'gnus-summary-prev-thread - "\M-\C-u" #'gnus-summary-up-thread - "\M-\C-d" #'gnus-summary-down-thread + "M-#" #'gnus-summary-unmark-as-processable + "C-M-t" #'gnus-summary-toggle-threads + "C-M-s" #'gnus-summary-show-thread + "C-M-h" #'gnus-summary-hide-thread + "C-M-f" #'gnus-summary-next-thread + "C-M-b" #'gnus-summary-prev-thread + "M-" #'gnus-summary-next-thread + "M-" #'gnus-summary-prev-thread + "C-M-u" #'gnus-summary-up-thread + "C-M-d" #'gnus-summary-down-thread "&" #'gnus-summary-execute-command "c" #'gnus-summary-catchup-and-exit - "\C-w" #'gnus-summary-mark-region-as-read - "\C-t" #'toggle-truncate-lines + "C-w" #'gnus-summary-mark-region-as-read + "C-t" #'toggle-truncate-lines "?" #'gnus-summary-mark-as-dormant - "\C-c\M-\C-s" #'gnus-summary-limit-include-expunged - "\C-c\C-s\C-n" #'gnus-summary-sort-by-number - "\C-c\C-s\C-m\C-n" #'gnus-summary-sort-by-most-recent-number - "\C-c\C-s\C-l" #'gnus-summary-sort-by-lines - "\C-c\C-s\C-c" #'gnus-summary-sort-by-chars - "\C-c\C-s\C-m\C-m" #'gnus-summary-sort-by-marks - "\C-c\C-s\C-a" #'gnus-summary-sort-by-author - "\C-c\C-s\C-t" #'gnus-summary-sort-by-recipient - "\C-c\C-s\C-s" #'gnus-summary-sort-by-subject - "\C-c\C-s\C-d" #'gnus-summary-sort-by-date - "\C-c\C-s\C-m\C-d" #'gnus-summary-sort-by-most-recent-date - "\C-c\C-s\C-i" #'gnus-summary-sort-by-score - "\C-c\C-s\C-o" #'gnus-summary-sort-by-original - "\C-c\C-s\C-r" #'gnus-summary-sort-by-random - "\C-c\C-s\C-u" #'gnus-summary-sort-by-newsgroups - "\C-c\C-s\C-x" #'gnus-summary-sort-by-extra + "C-c C-M-s" #'gnus-summary-limit-include-expunged + "C-c C-s C-n" #'gnus-summary-sort-by-number + "C-c C-s C-m C-n" #'gnus-summary-sort-by-most-recent-number + "C-c C-s C-l" #'gnus-summary-sort-by-lines + "C-c C-s C-c" #'gnus-summary-sort-by-chars + "C-c C-s C-m C-m" #'gnus-summary-sort-by-marks + "C-c C-s C-a" #'gnus-summary-sort-by-author + "C-c C-s C-t" #'gnus-summary-sort-by-recipient + "C-c C-s C-s" #'gnus-summary-sort-by-subject + "C-c C-s C-d" #'gnus-summary-sort-by-date + "C-c C-s C-m C-d" #'gnus-summary-sort-by-most-recent-date + "C-c C-s C-i" #'gnus-summary-sort-by-score + "C-c C-s C-o" #'gnus-summary-sort-by-original + "C-c C-s C-r" #'gnus-summary-sort-by-random + "C-c C-s C-u" #'gnus-summary-sort-by-newsgroups + "C-c C-s C-x" #'gnus-summary-sort-by-extra "=" #'gnus-summary-expand-window - "\C-x\C-s" #'gnus-summary-reselect-current-group - "\M-g" #'gnus-summary-rescan-group - "\C-c\C-r" #'gnus-summary-caesar-message + "C-x C-s" #'gnus-summary-reselect-current-group + "M-g" #'gnus-summary-rescan-group + "C-c C-r" #'gnus-summary-caesar-message "f" #'gnus-summary-followup "F" #'gnus-summary-followup-with-original "C" #'gnus-summary-cancel-article "r" #'gnus-summary-reply "R" #'gnus-summary-reply-with-original - "\C-c\C-f" #'gnus-summary-mail-forward + "C-c C-f" #'gnus-summary-mail-forward "o" #'gnus-summary-save-article - "\C-o" #'gnus-summary-save-article-mail + "C-o" #'gnus-summary-save-article-mail "|" #'gnus-summary-pipe-output - "\M-k" #'gnus-summary-edit-local-kill - "\M-K" #'gnus-summary-edit-global-kill + "M-k" #'gnus-summary-edit-local-kill + "M-K" #'gnus-summary-edit-global-kill ;; "V" gnus-version - "\C-c\C-d" #'gnus-summary-describe-group - "\C-c\C-p" #'gnus-summary-make-group-from-search + "C-c C-d" #'gnus-summary-describe-group + "C-c C-p" #'gnus-summary-make-group-from-search "q" #'gnus-summary-exit "Q" #'gnus-summary-exit-no-update - "\C-c\C-i" #'gnus-info-find-node - [mouse-2] #'gnus-mouse-pick-article - [follow-link] 'mouse-face + "C-c C-i" #'gnus-info-find-node + "" #'gnus-mouse-pick-article + "" 'mouse-face "m" #'gnus-summary-mail-other-window "a" #'gnus-summary-post-news "x" #'gnus-summary-limit-to-unread "s" #'gnus-summary-isearch-article - "\t" #'gnus-summary-button-forward - [backtab] #'gnus-summary-button-backward + "TAB" #'gnus-summary-button-forward + "" #'gnus-summary-button-backward "w" #'gnus-summary-browse-url "t" #'gnus-summary-toggle-header "g" #'gnus-summary-show-article "l" #'gnus-summary-goto-last-article - "\C-c\C-v\C-v" #'gnus-uu-decode-uu-view - "\C-d" #'gnus-summary-enter-digest-group - "\M-\C-d" #'gnus-summary-read-document - "\M-\C-e" #'gnus-summary-edit-parameters - "\M-\C-a" #'gnus-summary-customize-parameters - "\C-c\C-b" #'gnus-bug + "C-c C-v C-v" #'gnus-uu-decode-uu-view + "C-d" #'gnus-summary-enter-digest-group + "C-M-d" #'gnus-summary-read-document + "C-M-e" #'gnus-summary-edit-parameters + "C-M-a" #'gnus-summary-customize-parameters + "C-c C-b" #'gnus-bug "*" #'gnus-cache-enter-article - "\M-*" #'gnus-cache-remove-article - "\M-&" #'gnus-summary-universal-argument - "\C-l" #'gnus-recenter + "M-*" #'gnus-cache-remove-article + "M-&" #'gnus-summary-universal-argument + "C-l" #'gnus-recenter "I" #'gnus-summary-increase-score "L" #'gnus-summary-lower-score - "\M-i" #'gnus-symbolic-argument + "M-i" #'gnus-symbolic-argument "h" #'gnus-summary-select-article-buffer "b" #'gnus-article-view-part - "\M-t" #'gnus-summary-toggle-display-buttonized + "M-t" #'gnus-summary-toggle-display-buttonized "S" #'gnus-summary-send-map @@ -2041,19 +2041,19 @@ increase the score of each group you read." "d" #'gnus-summary-mark-as-read-forward "r" #'gnus-summary-mark-as-read-forward "c" #'gnus-summary-clear-mark-forward - " " #'gnus-summary-clear-mark-forward + "SPC" #'gnus-summary-clear-mark-forward "e" #'gnus-summary-mark-as-expirable "x" #'gnus-summary-mark-as-expirable "?" #'gnus-summary-mark-as-dormant "b" #'gnus-summary-set-bookmark "B" #'gnus-summary-remove-bookmark "#" #'gnus-summary-mark-as-processable - "\M-#" #'gnus-summary-unmark-as-processable + "M-#" #'gnus-summary-unmark-as-processable "S" #'gnus-summary-limit-include-expunged "C" #'gnus-summary-catchup "H" #'gnus-summary-catchup-to-here "h" #'gnus-summary-catchup-from-here - "\C-c" #'gnus-summary-catchup-all + "C-c" #'gnus-summary-catchup-all "k" #'gnus-summary-kill-same-subject-and-select "K" #'gnus-summary-kill-same-subject @@ -2118,10 +2118,10 @@ increase the score of each group you read." "p" #'gnus-summary-prev-unread-article "N" #'gnus-summary-next-article "P" #'gnus-summary-prev-article - "\C-n" #'gnus-summary-next-same-subject - "\C-p" #'gnus-summary-prev-same-subject - "\M-n" #'gnus-summary-next-unread-subject - "\M-p" #'gnus-summary-prev-unread-subject + "C-n" #'gnus-summary-next-same-subject + "C-p" #'gnus-summary-prev-same-subject + "M-n" #'gnus-summary-next-unread-subject + "M-p" #'gnus-summary-prev-unread-subject "f" #'gnus-summary-first-unread-article "b" #'gnus-summary-best-unread-article "u" #'gnus-summary-next-unseen-article @@ -2139,7 +2139,7 @@ increase the score of each group you read." "T" #'gnus-summary-toggle-threads "t" #'gnus-summary-rethread-current "^" #'gnus-summary-reparent-thread - "\M-^" #'gnus-summary-reparent-children + "M-^" #'gnus-summary-reparent-children "s" #'gnus-summary-show-thread "S" #'gnus-summary-show-all-threads "h" #'gnus-summary-hide-thread @@ -2150,7 +2150,7 @@ increase the score of each group you read." "o" #'gnus-summary-top-thread "d" #'gnus-summary-down-thread "#" #'gnus-uu-mark-thread - "\M-#" #'gnus-uu-unmark-thread) + "M-#" #'gnus-uu-unmark-thread) "Y" (define-keymap :prefix 'gnus-summary-buffer-map "g" #'gnus-summary-prepare @@ -2173,14 +2173,14 @@ increase the score of each group you read." "P" #'gnus-summary-prev-group) "A" (define-keymap :prefix 'gnus-summary-article-map - " " #'gnus-summary-next-page + "SPC" #'gnus-summary-next-page "n" #'gnus-summary-next-page - [?\S-\ ] #'gnus-summary-prev-page - "\177" #'gnus-summary-prev-page - [delete] #'gnus-summary-prev-page + "S-SPC" #'gnus-summary-prev-page + "DEL" #'gnus-summary-prev-page + "" #'gnus-summary-prev-page "p" #'gnus-summary-prev-page - "\r" #'gnus-summary-scroll-up - "\M-\r" #'gnus-summary-scroll-down + "RET" #'gnus-summary-scroll-up + "M-RET" #'gnus-summary-scroll-down "<" #'gnus-summary-beginning-of-article ">" #'gnus-summary-end-of-article "b" #'gnus-summary-beginning-of-article @@ -2194,8 +2194,8 @@ increase the score of each group you read." "W" #'gnus-warp-to-article "g" #'gnus-summary-show-article "s" #'gnus-summary-isearch-article - "\t" #'gnus-summary-button-forward - [backtab] #'gnus-summary-button-backward + "TAB" #'gnus-summary-button-forward + "" #'gnus-summary-button-backward "w" #'gnus-summary-browse-url "P" #'gnus-summary-print-article "S" #'gnus-sticky-article @@ -2250,7 +2250,7 @@ increase the score of each group you read." "l" #'gnus-article-hide-list-identifiers "B" #'gnus-article-strip-banner "P" #'gnus-article-hide-pem - "\C-c" #'gnus-article-hide-citation-maybe) + "C-c" #'gnus-article-hide-citation-maybe) "H" (define-keymap :prefix 'gnus-summary-wash-highlight-map "a" #'gnus-article-highlight @@ -2312,10 +2312,10 @@ increase the score of each group you read." "B" (define-keymap :prefix 'gnus-summary-backend-map "e" #'gnus-summary-expire-articles - "\M-\C-e" #'gnus-summary-expire-articles-now - "\177" #'gnus-summary-delete-article - [delete] #'gnus-summary-delete-article - [backspace] #'gnus-summary-delete-article + "C-M-e" #'gnus-summary-expire-articles-now + "DEL" #'gnus-summary-delete-article + "" #'gnus-summary-delete-article + "" #'gnus-summary-delete-article "m" #'gnus-summary-move-article "r" #'gnus-summary-respool-article "w" #'gnus-summary-edit-article diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index e78dd1542c..0855e98917 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -1059,26 +1059,26 @@ articles in the topic and its subtopics." (defvar-keymap gnus-topic-mode-map ;; Override certain group mode keys. "=" #'gnus-topic-select-group - "\r" #'gnus-topic-select-group - " " #'gnus-topic-read-group - "\C-c\C-x" #'gnus-topic-expire-articles + "RET" #'gnus-topic-select-group + "SPC" #'gnus-topic-read-group + "C-c C-x" #'gnus-topic-expire-articles "c" #'gnus-topic-catchup-articles - "\C-k" #'gnus-topic-kill-group - "\C-y" #'gnus-topic-yank-group - "\M-g" #'gnus-topic-get-new-news-this-topic - "AT" #'gnus-topic-list-active - "Gp" #'gnus-topic-edit-parameters + "C-k" #'gnus-topic-kill-group + "C-y" #'gnus-topic-yank-group + "M-g" #'gnus-topic-get-new-news-this-topic + "A T" #'gnus-topic-list-active + "G p" #'gnus-topic-edit-parameters "#" #'gnus-topic-mark-topic - "\M-#" #'gnus-topic-unmark-topic - [tab] #'gnus-topic-indent - [(meta tab)] #'gnus-topic-unindent - "\C-i" #'gnus-topic-indent - "\M-\C-i" #'gnus-topic-unindent - [mouse-2] #'gnus-mouse-pick-topic + "M-#" #'gnus-topic-unmark-topic + "" #'gnus-topic-indent + "M-" #'gnus-topic-unindent + "TAB" #'gnus-topic-indent + "C-M-i" #'gnus-topic-unindent + "" #'gnus-mouse-pick-topic "T" (define-keymap :prefix 'gnus-group-topic-map "#" #'gnus-topic-mark-topic - "\M-#" #'gnus-topic-unmark-topic + "M-#" #'gnus-topic-unmark-topic "n" #'gnus-topic-create-topic "m" #'gnus-topic-move-group "D" #'gnus-topic-remove-group @@ -1088,13 +1088,13 @@ articles in the topic and its subtopics." "j" #'gnus-topic-jump-to-topic "M" #'gnus-topic-move-matching "C" #'gnus-topic-copy-matching - "\M-p" #'gnus-topic-goto-previous-topic - "\M-n" #'gnus-topic-goto-next-topic - "\C-i" #'gnus-topic-indent - [tab] #'gnus-topic-indent + "M-p" #'gnus-topic-goto-previous-topic + "M-n" #'gnus-topic-goto-next-topic + "TAB" #'gnus-topic-indent + "" #'gnus-topic-indent "r" #'gnus-topic-rename - "\177" #'gnus-topic-delete - [delete] #'gnus-topic-delete + "DEL" #'gnus-topic-delete + "" #'gnus-topic-delete "H" #'gnus-topic-toggle-display-empty-topics "S" (define-keymap :prefix 'gnus-topic-sort-map diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el index 0717a7ccfb..a82b1f87a3 100644 --- a/lisp/gnus/gnus-undo.el +++ b/lisp/gnus/gnus-undo.el @@ -76,11 +76,11 @@ ;;; Minor mode definition. (defvar-keymap gnus-undo-mode-map - "\M-\C-_" #'gnus-undo - "\C-_" #'gnus-undo - "\C-xu" #'gnus-undo + "C-M-_" #'gnus-undo + "C-_" #'gnus-undo + "C-x u" #'gnus-undo ;; many people are used to type `C-/' on GUI frames and get `C-_'. - [(control /)] #'gnus-undo) + "C-/" #'gnus-undo) (defun gnus-undo-make-menu-bar () ;; This is disabled for the time being. diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 77e8fcdfd1..4a0ea59586 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -2875,75 +2875,75 @@ Consider adding this function to `message-header-setup-hook'" (defvar-keymap message-mode-map :full t :parent text-mode-map :doc "Message Mode keymap." - "\C-c?" #'describe-mode - - "\C-c\C-f\C-t" #'message-goto-to - "\C-c\C-f\C-o" #'message-goto-from - "\C-c\C-f\C-b" #'message-goto-bcc - "\C-c\C-f\C-w" #'message-goto-fcc - "\C-c\C-f\C-c" #'message-goto-cc - "\C-c\C-f\C-s" #'message-goto-subject - "\C-c\C-f\C-r" #'message-goto-reply-to - "\C-c\C-f\C-n" #'message-goto-newsgroups - "\C-c\C-f\C-d" #'message-goto-distribution - "\C-c\C-f\C-f" #'message-goto-followup-to - "\C-c\C-f\C-m" #'message-goto-mail-followup-to - "\C-c\C-f\C-k" #'message-goto-keywords - "\C-c\C-f\C-u" #'message-goto-summary - "\C-c\C-f\C-i" #'message-insert-or-toggle-importance - "\C-c\C-f\C-a" #'message-generate-unsubscribed-mail-followup-to + "C-c ?" #'describe-mode + + "C-c C-f C-t" #'message-goto-to + "C-c C-f C-o" #'message-goto-from + "C-c C-f C-b" #'message-goto-bcc + "C-c C-f C-w" #'message-goto-fcc + "C-c C-f C-c" #'message-goto-cc + "C-c C-f C-s" #'message-goto-subject + "C-c C-f C-r" #'message-goto-reply-to + "C-c C-f C-n" #'message-goto-newsgroups + "C-c C-f C-d" #'message-goto-distribution + "C-c C-f C-f" #'message-goto-followup-to + "C-c C-f C-m" #'message-goto-mail-followup-to + "C-c C-f C-k" #'message-goto-keywords + "C-c C-f C-u" #'message-goto-summary + "C-c C-f C-i" #'message-insert-or-toggle-importance + "C-c C-f C-a" #'message-generate-unsubscribed-mail-followup-to ;; modify headers (and insert notes in body) - "\C-c\C-fs" #'message-change-subject + "C-c C-f s" #'message-change-subject ;; - "\C-c\C-fx" #'message-cross-post-followup-to + "C-c C-f x" #'message-cross-post-followup-to ;; prefix+message-cross-post-followup-to = same w/o cross-post - "\C-c\C-ft" #'message-reduce-to-to-cc - "\C-c\C-fa" #'message-add-archive-header + "C-c C-f t" #'message-reduce-to-to-cc + "C-c C-f a" #'message-add-archive-header ;; mark inserted text - "\C-c\M-m" #'message-mark-inserted-region - "\C-c\M-f" #'message-mark-insert-file - - "\C-c\C-b" #'message-goto-body - "\C-c\C-i" #'message-goto-signature - - "\C-c\C-t" #'message-insert-to - "\C-c\C-fw" #'message-insert-wide-reply - "\C-c\C-n" #'message-insert-newsgroups - "\C-c\C-l" #'message-to-list-only - "\C-c\C-f\C-e" #'message-insert-expires - "\C-c\C-u" #'message-insert-or-toggle-importance - "\C-c\M-n" #'message-insert-disposition-notification-to - - "\C-c\C-y" #'message-yank-original - "\C-c\M-\C-y" #'message-yank-buffer - "\C-c\C-q" #'message-fill-yanked-message - "\C-c\C-w" #'message-insert-signature - "\C-c\M-h" #'message-insert-headers - "\C-c\C-r" #'message-caesar-buffer-body - "\C-c\C-o" #'message-sort-headers - "\C-c\M-r" #'message-rename-buffer - - "\C-c\C-c" #'message-send-and-exit - "\C-c\C-s" #'message-send - "\C-c\C-k" #'message-kill-buffer - "\C-c\C-d" #'message-dont-send - "\C-c\n" #'gnus-delay-article - - "\C-c\M-k" #'message-kill-address - "\C-c\C-e" #'message-elide-region - "\C-c\C-v" #'message-delete-not-region - "\C-c\C-z" #'message-kill-to-signature - "\M-\r" #'message-newline-and-reformat - [remap split-line] #'message-split-line - - "\C-c\C-a" #'mml-attach-file - "\C-c\C-p" #'message-insert-screenshot - - "\C-a" #'message-beginning-of-line - "\t" #'message-tab - - "\M-n" #'message-display-abbrev) + "C-c M-m" #'message-mark-inserted-region + "C-c M-f" #'message-mark-insert-file + + "C-c C-b" #'message-goto-body + "C-c C-i" #'message-goto-signature + + "C-c C-t" #'message-insert-to + "C-c C-f w" #'message-insert-wide-reply + "C-c C-n" #'message-insert-newsgroups + "C-c C-l" #'message-to-list-only + "C-c C-f C-e" #'message-insert-expires + "C-c C-u" #'message-insert-or-toggle-importance + "C-c M-n" #'message-insert-disposition-notification-to + + "C-c C-y" #'message-yank-original + "C-c C-M-y" #'message-yank-buffer + "C-c C-q" #'message-fill-yanked-message + "C-c C-w" #'message-insert-signature + "C-c M-h" #'message-insert-headers + "C-c C-r" #'message-caesar-buffer-body + "C-c C-o" #'message-sort-headers + "C-c M-r" #'message-rename-buffer + + "C-c C-c" #'message-send-and-exit + "C-c C-s" #'message-send + "C-c C-k" #'message-kill-buffer + "C-c C-d" #'message-dont-send + "C-c C-j" #'gnus-delay-article + + "C-c M-k" #'message-kill-address + "C-c C-e" #'message-elide-region + "C-c C-v" #'message-delete-not-region + "C-c C-z" #'message-kill-to-signature + "M-RET" #'message-newline-and-reformat + " " #'message-split-line + + "C-c C-a" #'mml-attach-file + "C-c C-p" #'message-insert-screenshot + + "C-a" #'message-beginning-of-line + "TAB" #'message-tab + + "M-n" #'message-display-abbrev) (easy-menu-define message-mode-menu message-mode-map "Message Menu." diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 079c1b5122..e60d777e0d 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -1143,48 +1143,40 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ;;; Mode for inserting and editing MML forms ;;; -(defvar mml-mode-map - (let ((sign (make-sparse-keymap)) - (encrypt (make-sparse-keymap)) - (signpart (make-sparse-keymap)) - (encryptpart (make-sparse-keymap)) - (map (make-sparse-keymap)) - (main (make-sparse-keymap))) - (define-key map "\C-s" 'mml-secure-message-sign) - (define-key map "\C-c" 'mml-secure-message-encrypt) - (define-key map "\C-e" 'mml-secure-message-sign-encrypt) - (define-key map "\C-p\C-s" 'mml-secure-sign) - (define-key map "\C-p\C-c" 'mml-secure-encrypt) - (define-key sign "p" 'mml-secure-message-sign-pgpmime) - (define-key sign "o" 'mml-secure-message-sign-pgp) - (define-key sign "s" 'mml-secure-message-sign-smime) - (define-key signpart "p" 'mml-secure-sign-pgpmime) - (define-key signpart "o" 'mml-secure-sign-pgp) - (define-key signpart "s" 'mml-secure-sign-smime) - (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime) - (define-key encrypt "o" 'mml-secure-message-encrypt-pgp) - (define-key encrypt "s" 'mml-secure-message-encrypt-smime) - (define-key encryptpart "p" 'mml-secure-encrypt-pgpmime) - (define-key encryptpart "o" 'mml-secure-encrypt-pgp) - (define-key encryptpart "s" 'mml-secure-encrypt-smime) - (define-key map "\C-n" 'mml-unsecure-message) - (define-key map "f" 'mml-attach-file) - (define-key map "b" 'mml-attach-buffer) - (define-key map "e" 'mml-attach-external) - (define-key map "q" 'mml-quote-region) - (define-key map "m" 'mml-insert-multipart) - (define-key map "p" 'mml-insert-part) - (define-key map "v" 'mml-validate) - (define-key map "P" 'mml-preview) - (define-key map "s" sign) - (define-key map "S" signpart) - (define-key map "c" encrypt) - (define-key map "C" encryptpart) - ;;(define-key map "n" 'mml-narrow-to-part) - ;; `M-m' conflicts with `back-to-indentation'. - ;; (define-key main "\M-m" map) - (define-key main "\C-c\C-m" map) - main)) +(defvar-keymap mml-mode-map + "C-c C-m" + (define-keymap + "C-s" #'mml-secure-message-sign + "C-c" #'mml-secure-message-encrypt + "C-e" #'mml-secure-message-sign-encrypt + "C-p C-s" #'mml-secure-sign + "C-p C-c" #'mml-secure-encrypt + + "s" (define-keymap + "p" #'mml-secure-message-sign-pgpmime + "o" #'mml-secure-message-sign-pgp + "s" #'mml-secure-message-sign-smime) + "S" (define-keymap + "p" #'mml-secure-sign-pgpmime + "o" #'mml-secure-sign-pgp + "s" #'mml-secure-sign-smime) + "c" (define-keymap + "p" #'mml-secure-message-encrypt-pgpmime + "o" #'mml-secure-message-encrypt-pgp + "s" #'mml-secure-message-encrypt-smime) + "C" (define-keymap + "p" #'mml-secure-encrypt-pgpmime + "o" #'mml-secure-encrypt-pgp + "s" #'mml-secure-encrypt-smime) + "C-n" #'mml-unsecure-message + "f" #'mml-attach-file + "b" #'mml-attach-buffer + "e" #'mml-attach-external + "q" #'mml-quote-region + "m" #'mml-insert-multipart + "p" #'mml-insert-part + "v" #'mml-validate + "P" #'mml-preview)) (easy-menu-define mml-menu mml-mode-map "" diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index cfef69f103..508ef5424e 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -664,11 +664,11 @@ order for SpamAssassin to recognize the new registered spam." ;;; Key bindings for spam control. (define-keymap :keymap gnus-summary-mode-map - "St" #'spam-generic-score - "Sx" #'gnus-summary-mark-as-spam - "Mst" #'spam-generic-score - "Msx" #'gnus-summary-mark-as-spam - "\M-d" #'gnus-summary-mark-as-spam + "S t" #'spam-generic-score + "S x" #'gnus-summary-mark-as-spam + "M s t" #'spam-generic-score + "M s x" #'gnus-summary-mark-as-spam + "M-d" #'gnus-summary-mark-as-spam "$" #'gnus-summary-mark-as-spam) (defvar spam-cache-lookups t diff --git a/lisp/international/emoji.el b/lisp/international/emoji.el index d2570e9911..5f8c358caa 100644 --- a/lisp/international/emoji.el +++ b/lisp/international/emoji.el @@ -184,10 +184,10 @@ character) under point is." (get-char-code-property (aref glyph 0) 'name))) (defvar-keymap emoji-list-mode-map - ["RET"] #'emoji-list-select - [""] #'emoji-list-select + "RET" #'emoji-list-select + "" #'emoji-list-select "h" #'emoji-list-help - [follow-link] 'mouse-face) + "" 'mouse-face) (define-derived-mode emoji-list-mode special-mode "Emoji" "Mode to display emojis." diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el index c700b3348d..ddf13d193e 100644 --- a/lisp/mh-e/mh-folder.el +++ b/lisp/mh-e/mh-folder.el @@ -212,7 +212,7 @@ annotation.") ;; Save the "b" binding for a future `back'. Maybe? (define-keymap :keymap mh-folder-mode-map - " " #'mh-page-msg + "SPC" #'mh-page-msg "!" #'mh-refile-or-write-again "'" #'mh-toggle-tick "," #'mh-header-display @@ -223,15 +223,15 @@ annotation.") "?" #'mh-help "E" #'mh-extract-rejected-mail "M" #'mh-modify - "\177" #'mh-previous-page - "\C-d" #'mh-delete-msg-no-motion - "\t" #'mh-index-next-folder - [backtab] #'mh-index-previous-folder - "\M-\t" #'mh-index-previous-folder - "\e<" #'mh-first-msg - "\e>" #'mh-last-msg - "\ed" #'mh-redistribute - "\r" #'mh-show + "DEL" #'mh-previous-page + "C-d" #'mh-delete-msg-no-motion + "TAB" #'mh-index-next-folder + "" #'mh-index-previous-folder + "C-M-i" #'mh-index-previous-folder + "ESC <" #'mh-first-msg + "ESC >" #'mh-last-msg + "ESC d" #'mh-redistribute + "RET" #'mh-show "^" #'mh-alt-refile-msg "c" #'mh-copy-msg "d" #'mh-delete-msg @@ -242,10 +242,10 @@ annotation.") "k" #'mh-delete-subject-or-thread "m" #'mh-alt-send "n" #'mh-next-undeleted-msg - "\M-n" #'mh-next-unread-msg + "M-n" #'mh-next-unread-msg "o" #'mh-refile-msg "p" #'mh-previous-undeleted-msg - "\M-p" #'mh-previous-unread-msg + "M-p" #'mh-previous-unread-msg "q" #'mh-quit "r" #'mh-reply "s" #'mh-send @@ -324,9 +324,9 @@ annotation.") "u" #'mh-store-msg) ;uuencode "D" (define-keymap :prefix 'mh-digest-map - " " #'mh-page-digest + "SPC" #'mh-page-digest "?" #'mh-prefix-help - "\177" #'mh-page-digest-backwards + "DEL" #'mh-page-digest-backwards "b" #'mh-burst-digest) "K" (define-keymap :prefix 'mh-mime-map @@ -337,11 +337,11 @@ annotation.") "o" #'mh-folder-save-mime-part "t" #'mh-toggle-mime-buttons "v" #'mh-folder-toggle-mime-part - "\t" #'mh-next-button - [backtab] #'mh-prev-button - "\M-\t" #'mh-prev-button) + "TAB" #'mh-next-button + "" #'mh-prev-button + "C-M-i" #'mh-prev-button) - [mouse-2] #'mh-show-mouse) + "" #'mh-show-mouse) ;; "C-c /" prefix is used in mh-folder-mode by pgp.el and mailcrypt diff --git a/lisp/mh-e/mh-letter.el b/lisp/mh-e/mh-letter.el index 1f7902640a..ebe94a7af8 100644 --- a/lisp/mh-e/mh-letter.el +++ b/lisp/mh-e/mh-letter.el @@ -115,67 +115,67 @@ ;; If this changes, modify mh-letter-mode-help-messages accordingly, above. (define-keymap :keymap mh-letter-mode-map - " " #'mh-letter-complete-or-space + "SPC" #'mh-letter-complete-or-space "," #'mh-letter-confirm-address - "\C-c?" #'mh-help - "\C-c\C-\\" #'mh-fully-kill-draft ;if no C-q - "\C-c\C-^" #'mh-insert-signature ;if no C-s - "\C-c\C-c" #'mh-send-letter - "\C-c\C-d" #'mh-insert-identity - "\C-c\C-e" #'mh-mh-to-mime - "\C-c\C-f\C-a" #'mh-to-field - "\C-c\C-f\C-b" #'mh-to-field - "\C-c\C-f\C-c" #'mh-to-field - "\C-c\C-f\C-d" #'mh-to-field - "\C-c\C-f\C-f" #'mh-to-fcc - "\C-c\C-f\C-l" #'mh-to-field - "\C-c\C-f\C-m" #'mh-to-field - "\C-c\C-f\C-r" #'mh-to-field - "\C-c\C-f\C-s" #'mh-to-field - "\C-c\C-f\C-t" #'mh-to-field - "\C-c\C-fa" #'mh-to-field - "\C-c\C-fb" #'mh-to-field - "\C-c\C-fc" #'mh-to-field - "\C-c\C-fd" #'mh-to-field - "\C-c\C-ff" #'mh-to-fcc - "\C-c\C-fl" #'mh-to-field - "\C-c\C-fm" #'mh-to-field - "\C-c\C-fr" #'mh-to-field - "\C-c\C-fs" #'mh-to-field - "\C-c\C-ft" #'mh-to-field - "\C-c\C-i" #'mh-insert-letter - "\C-c\C-m\C-e" #'mh-mml-secure-message-encrypt - "\C-c\C-m\C-f" #'mh-compose-forward - "\C-c\C-m\C-g" #'mh-mh-compose-anon-ftp - "\C-c\C-m\C-i" #'mh-compose-insertion - "\C-c\C-m\C-m" #'mh-mml-to-mime - "\C-c\C-m\C-n" #'mh-mml-unsecure-message - "\C-c\C-m\C-s" #'mh-mml-secure-message-sign - "\C-c\C-m\C-t" #'mh-mh-compose-external-compressed-tar - "\C-c\C-m\C-u" #'mh-mh-to-mime-undo - "\C-c\C-m\C-x" #'mh-mh-compose-external-type - "\C-c\C-mee" #'mh-mml-secure-message-encrypt - "\C-c\C-mes" #'mh-mml-secure-message-signencrypt - "\C-c\C-mf" #'mh-compose-forward - "\C-c\C-mg" #'mh-mh-compose-anon-ftp - "\C-c\C-mi" #'mh-compose-insertion - "\C-c\C-mm" #'mh-mml-to-mime - "\C-c\C-mn" #'mh-mml-unsecure-message - "\C-c\C-mse" #'mh-mml-secure-message-signencrypt - "\C-c\C-mss" #'mh-mml-secure-message-sign - "\C-c\C-mt" #'mh-mh-compose-external-compressed-tar - "\C-c\C-mu" #'mh-mh-to-mime-undo - "\C-c\C-mx" #'mh-mh-compose-external-type - "\C-c\C-o" #'mh-open-line - "\C-c\C-q" #'mh-fully-kill-draft - "\C-c\C-s" #'mh-insert-signature - "\C-c\C-t" #'mh-letter-toggle-header-field-display - "\C-c\C-w" #'mh-check-whom - "\C-c\C-y" #'mh-yank-cur-msg - "\C-c\M-d" #'mh-insert-auto-fields - "\M-\t" #'completion-at-point - "\t" #'mh-letter-next-header-field-or-indent - [backtab] #'mh-letter-previous-header-field) + "C-c ?" #'mh-help + "C-c C-\\" #'mh-fully-kill-draft ;if no C-q + "C-c C-^" #'mh-insert-signature ;if no C-s + "C-c C-c" #'mh-send-letter + "C-c C-d" #'mh-insert-identity + "C-c C-e" #'mh-mh-to-mime + "C-c C-f C-a" #'mh-to-field + "C-c C-f C-b" #'mh-to-field + "C-c C-f C-c" #'mh-to-field + "C-c C-f C-d" #'mh-to-field + "C-c C-f C-f" #'mh-to-fcc + "C-c C-f C-l" #'mh-to-field + "C-c C-f C-m" #'mh-to-field + "C-c C-f C-r" #'mh-to-field + "C-c C-f C-s" #'mh-to-field + "C-c C-f C-t" #'mh-to-field + "C-c C-f a" #'mh-to-field + "C-c C-f b" #'mh-to-field + "C-c C-f c" #'mh-to-field + "C-c C-f d" #'mh-to-field + "C-c C-f f" #'mh-to-fcc + "C-c C-f l" #'mh-to-field + "C-c C-f m" #'mh-to-field + "C-c C-f r" #'mh-to-field + "C-c C-f s" #'mh-to-field + "C-c C-f t" #'mh-to-field + "C-c C-i" #'mh-insert-letter + "C-c C-m C-e" #'mh-mml-secure-message-encrypt + "C-c C-m C-f" #'mh-compose-forward + "C-c C-m C-g" #'mh-mh-compose-anon-ftp + "C-c C-m TAB" #'mh-compose-insertion + "C-c C-m C-m" #'mh-mml-to-mime + "C-c C-m C-n" #'mh-mml-unsecure-message + "C-c C-m C-s" #'mh-mml-secure-message-sign + "C-c C-m C-t" #'mh-mh-compose-external-compressed-tar + "C-c C-m C-u" #'mh-mh-to-mime-undo + "C-c C-m C-x" #'mh-mh-compose-external-type + "C-c C-m e e" #'mh-mml-secure-message-encrypt + "C-c C-m e s" #'mh-mml-secure-message-signencrypt + "C-c C-m f" #'mh-compose-forward + "C-c C-m g" #'mh-mh-compose-anon-ftp + "C-c C-m i" #'mh-compose-insertion + "C-c C-m m" #'mh-mml-to-mime + "C-c C-m n" #'mh-mml-unsecure-message + "C-c C-m s e" #'mh-mml-secure-message-signencrypt + "C-c C-m s s" #'mh-mml-secure-message-sign + "C-c C-m t" #'mh-mh-compose-external-compressed-tar + "C-c C-m u" #'mh-mh-to-mime-undo + "C-c C-m x" #'mh-mh-compose-external-type + "C-c C-o" #'mh-open-line + "C-c C-q" #'mh-fully-kill-draft + "C-c C-s" #'mh-insert-signature + "C-c C-t" #'mh-letter-toggle-header-field-display + "C-c C-w" #'mh-check-whom + "C-c C-y" #'mh-yank-cur-msg + "C-c M-d" #'mh-insert-auto-fields + "C-M-i" #'completion-at-point + "TAB" #'mh-letter-next-header-field-or-indent + "" #'mh-letter-previous-header-field) ;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el. diff --git a/lisp/mh-e/mh-search.el b/lisp/mh-e/mh-search.el index ef84c5eb28..8012e624f1 100644 --- a/lisp/mh-e/mh-search.el +++ b/lisp/mh-e/mh-search.el @@ -550,19 +550,19 @@ group of results." ;; If this changes, modify mh-search-mode-help-messages accordingly, below. (define-keymap :keymap mh-search-mode-map - "\C-c?" #'mh-help - "\C-c\C-c" #'mh-index-do-search - "\C-c\C-p" #'mh-pick-do-search - "\C-c\C-f\C-b" #'mh-to-field - "\C-c\C-f\C-c" #'mh-to-field - "\C-c\C-f\C-m" #'mh-to-field - "\C-c\C-f\C-s" #'mh-to-field - "\C-c\C-f\C-t" #'mh-to-field - "\C-c\C-fb" #'mh-to-field - "\C-c\C-fc" #'mh-to-field - "\C-c\C-fm" #'mh-to-field - "\C-c\C-fs" #'mh-to-field - "\C-c\C-ft" #'mh-to-field) + "C-c ?" #'mh-help + "C-c C-c" #'mh-index-do-search + "C-c C-p" #'mh-pick-do-search + "C-c C-f C-b" #'mh-to-field + "C-c C-f C-c" #'mh-to-field + "C-c C-f C-m" #'mh-to-field + "C-c C-f C-s" #'mh-to-field + "C-c C-f C-t" #'mh-to-field + "C-c C-f b" #'mh-to-field + "C-c C-f c" #'mh-to-field + "C-c C-f m" #'mh-to-field + "C-c C-f s" #'mh-to-field + "C-c C-f t" #'mh-to-field) diff --git a/lisp/mh-e/mh-show.el b/lisp/mh-e/mh-show.el index 524179648d..0f85cd6f69 100644 --- a/lisp/mh-e/mh-show.el +++ b/lisp/mh-e/mh-show.el @@ -560,7 +560,7 @@ still visible.\n") ;;; MH-Show Keys (define-keymap :keymap mh-show-mode-map - " " #'mh-show-page-msg + "SPC" #'mh-show-page-msg "!" #'mh-show-refile-or-write-again "'" #'mh-show-toggle-tick "," #'mh-show-header-display @@ -570,12 +570,12 @@ still visible.\n") "?" #'mh-help "E" #'mh-show-extract-rejected-mail "M" #'mh-show-modify - "\177" #'mh-show-previous-page - "\C-d" #'mh-show-delete-msg-no-motion - "\t" #'mh-show-next-button - [backtab] #'mh-show-prev-button - "\M-\t" #'mh-show-prev-button - "\ed" #'mh-show-redistribute + "DEL" #'mh-show-previous-page + "C-d" #'mh-show-delete-msg-no-motion + "TAB" #'mh-show-next-button + "" #'mh-show-prev-button + "C-M-i" #'mh-show-prev-button + "ESC d" #'mh-show-redistribute "^" #'mh-show-refile-msg "c" #'mh-show-copy-msg "d" #'mh-show-delete-msg @@ -586,10 +586,10 @@ still visible.\n") "k" #'mh-show-delete-subject-or-thread "m" #'mh-show-send "n" #'mh-show-next-undeleted-msg - "\M-n" #'mh-show-next-unread-msg + "M-n" #'mh-show-next-unread-msg "o" #'mh-show-refile-msg "p" #'mh-show-previous-undeleted-msg - "\M-p" #'mh-show-previous-unread-msg + "M-p" #'mh-show-previous-unread-msg "q" #'mh-show-quit "r" #'mh-show-reply "s" #'mh-show-send @@ -670,8 +670,8 @@ still visible.\n") "D" (define-keymap :prefix 'mh-show-digest-map "?" #'mh-prefix-help - " " #'mh-show-page-digest - "\177" #'mh-show-page-digest-backwards + "SPC" #'mh-show-page-digest + "DEL" #'mh-show-page-digest-backwards "b" #'mh-show-burst-digest) "K" (define-keymap :prefix 'mh-show-mime-map @@ -682,9 +682,9 @@ still visible.\n") "o" #'mh-show-save-mime-part "i" #'mh-show-inline-mime-part "t" #'mh-show-toggle-mime-buttons - "\t" #'mh-show-next-button - [backtab] #'mh-show-prev-button - "\M-\t" #'mh-show-prev-button)) + "TAB" #'mh-show-next-button + "" #'mh-show-prev-button + "C-M-i" #'mh-show-prev-button)) diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el index 82b108c8c8..bf3a9e5774 100644 --- a/lisp/mh-e/mh-speed.el +++ b/lisp/mh-e/mh-speed.el @@ -86,7 +86,7 @@ (define-keymap :keymap mh-folder-speedbar-key-map "+" #'mh-speed-expand-folder "-" #'mh-speed-contract-folder - "\r" #'mh-speed-view + "RET" #'mh-speed-view "r" #'mh-speed-refresh) (defvar mh-show-speedbar-key-map mh-folder-speedbar-key-map) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 70ebc1d2ec..031a73143e 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -314,11 +314,11 @@ parameter, and should return the (possibly) transformed URL." (defvar-keymap eww-link-keymap :parent shr-map - "\r" #'eww-follow-link) + "RET" #'eww-follow-link) (defvar-keymap eww-image-link-keymap :parent shr-map - "\r" #'eww-follow-link) + "RET" #'eww-follow-link) (defun eww-suggested-uris nil "Return the list of URIs to suggest at the `eww' prompt. @@ -1045,11 +1045,11 @@ the like." (defvar-keymap eww-mode-map "g" #'eww-reload ;FIXME: revert-buffer-function instead! "G" #'eww - [?\M-\r] #'eww-open-in-new-buffer - [?\t] #'shr-next-link - [?\M-\t] #'shr-previous-link - [backtab] #'shr-previous-link - [delete] #'scroll-down-command + "M-RET" #'eww-open-in-new-buffer + "TAB" #'shr-next-link + "C-M-i" #'shr-previous-link + "" #'shr-previous-link + "" #'scroll-down-command "l" #'eww-back-url "r" #'eww-forward-url "n" #'eww-next-url @@ -1068,16 +1068,16 @@ the like." "S" #'eww-list-buffers "F" #'eww-toggle-fonts "D" #'eww-toggle-paragraph-direction - [(meta C)] #'eww-toggle-colors - [(meta I)] #'eww-toggle-images + "M-C" #'eww-toggle-colors + "M-I" #'eww-toggle-images "b" #'eww-add-bookmark "B" #'eww-list-bookmarks - [(meta n)] #'eww-next-bookmark - [(meta p)] #'eww-previous-bookmark + "M-n" #'eww-next-bookmark + "M-p" #'eww-previous-bookmark - [(mouse-8)] #'eww-back-url - [(mouse-9)] #'eww-forward-url + "" #'eww-back-url + "" #'eww-forward-url :menu '("Eww" ["Exit" quit-window t] @@ -1300,42 +1300,42 @@ just re-display the HTML already fetched." (defvar eww-form nil) (defvar-keymap eww-submit-map - "\r" #'eww-submit - [(control c) (control c)] #'eww-submit) + "RET" #'eww-submit + "C-c C-c" #'eww-submit) (defvar-keymap eww-submit-file - "\r" #'eww-select-file - [(control c) (control c)] #'eww-submit) + "RET" #'eww-select-file + "C-c C-c" #'eww-submit) (defvar-keymap eww-checkbox-map - " " #'eww-toggle-checkbox - "\r" #'eww-toggle-checkbox - [(control c) (control c)] #'eww-submit) + "SPC" #'eww-toggle-checkbox + "RET" #'eww-toggle-checkbox + "C-c C-c" #'eww-submit) (defvar-keymap eww-text-map :full t :parent text-mode-map - "\r" #'eww-submit - [(control a)] #'eww-beginning-of-text - [(control c) (control c)] #'eww-submit - [(control e)] #'eww-end-of-text - [?\t] #'shr-next-link - [?\M-\t] #'shr-previous-link - [backtab] #'shr-previous-link) + "RET" #'eww-submit + "C-a" #'eww-beginning-of-text + "C-c C-c" #'eww-submit + "C-e" #'eww-end-of-text + "TAB" #'shr-next-link + "M-TAB" #'shr-previous-link + "" #'shr-previous-link) (defvar-keymap eww-textarea-map :full t :parent text-mode-map - "\r" #'forward-line - [(control c) (control c)] #'eww-submit - [?\t] #'shr-next-link - [?\M-\t] #'shr-previous-link - [backtab] #'shr-previous-link) + "RET" #'forward-line + "C-c C-c" #'eww-submit + "TAB" #'shr-next-link + "M-TAB" #'shr-previous-link + "" #'shr-previous-link) (defvar-keymap eww-select-map :doc "Map for select buttons" - "\r" #'eww-change-select - [follow-link] 'mouse-face - [mouse-2] #'eww-change-select - [(control c) (control c)] #'eww-submit) + "RET" #'eww-change-select + "" 'mouse-face + "" #'eww-change-select + "C-c C-c" #'eww-submit) (defun eww-beginning-of-text () "Move to the start of the input field." @@ -2171,9 +2171,9 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (eww-browse-url (plist-get bookmark :url)))) (defvar-keymap eww-bookmark-mode-map - [(control k)] #'eww-bookmark-kill - [(control y)] #'eww-bookmark-yank - "\r" #'eww-bookmark-browse + "C-k" #'eww-bookmark-kill + "C-y" #'eww-bookmark-yank + "RET" #'eww-bookmark-browse :menu '("Eww Bookmark" ["Exit" quit-window t] ["Browse" eww-bookmark-browse @@ -2247,7 +2247,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (eww-restore-history history))) (defvar-keymap eww-history-mode-map - "\r" #'eww-history-browse + "RET" #'eww-history-browse "n" #'next-line "p" #'previous-line :menu '("Eww History" @@ -2366,8 +2366,8 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (eww-buffer-show)) (defvar-keymap eww-buffers-mode-map - [(control k)] #'eww-buffer-kill - "\r" #'eww-buffer-select + "C-k" #'eww-buffer-kill + "RET" #'eww-buffer-select "n" #'eww-buffer-show-next "p" #'eww-buffer-show-previous :menu '("Eww Buffers" diff --git a/lisp/net/shr.el b/lisp/net/shr.el index fd7469389a..b9e8a18e25 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -251,17 +251,17 @@ and other things: "a" #'shr-show-alt-text "i" #'shr-browse-image "z" #'shr-zoom-image - [?\t] #'shr-next-link - [?\M-\t] #'shr-previous-link - [follow-link] 'mouse-face - [mouse-2] #'shr-browse-url - [C-down-mouse-1] #'shr-mouse-browse-url-new-window + "TAB" #'shr-next-link + "C-M-i" #'shr-previous-link + "" 'mouse-face + "" #'shr-browse-url + "C-" #'shr-mouse-browse-url-new-window "I" #'shr-insert-image "w" #'shr-maybe-probe-and-copy-url "u" #'shr-maybe-probe-and-copy-url "v" #'shr-browse-url "O" #'shr-save-contents - "\r" #'shr-browse-url) + "RET" #'shr-browse-url) (defvar shr-image-map (let ((map (copy-keymap shr-map))) diff --git a/lisp/outline.el b/lisp/outline.el index 9a2e4324b2..a4d2a3b7d7 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -992,8 +992,8 @@ If non-nil, EVENT should be a mouse event." (overlay-put o 'keymap (define-keymap :parent outline-minor-mode-cycle-map - ["RET"] #'outline-hide-subtree - [""] #'outline-hide-subtree))))) + "RET" #'outline-hide-subtree + "" #'outline-hide-subtree))))) (defun outline--insert-close-button () (save-excursion @@ -1003,8 +1003,8 @@ If non-nil, EVENT should be a mouse event." (overlay-put o 'keymap (define-keymap :parent outline-minor-mode-cycle-map - ["RET"] #'outline-show-subtree - [""] #'outline-show-subtree))))) + "RET" #'outline-show-subtree + "" #'outline-show-subtree))))) (defun outline--fix-up-all-buttons (&optional from to) (when from diff --git a/lisp/simple.el b/lisp/simple.el index ad6d28cb14..58283e7b7f 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -541,9 +541,9 @@ Other major modes are defined by comparison with this one." (defvar-keymap special-mode-map :suppress t "q" #'quit-window - " " #'scroll-up-command - [?\S-\ ] #'scroll-down-command - "\C-?" #'scroll-down-command + "SPC" #'scroll-up-command + "S-SPC" #'scroll-down-command + "DEL" #'scroll-down-command "?" #'describe-mode "h" #'describe-mode ">" #'end-of-buffer diff --git a/lisp/vc/cvs-status.el b/lisp/vc/cvs-status.el index 86b62eb1ce..7886cc1eae 100644 --- a/lisp/vc/cvs-status.el +++ b/lisp/vc/cvs-status.el @@ -40,8 +40,8 @@ "p" #'previous-line "N" #'cvs-status-next "P" #'cvs-status-prev - ["M-n"] #'cvs-status-next - ["M-p"] #'cvs-status-prev + "M-n" #'cvs-status-next + "M-p" #'cvs-status-prev "t" #'cvs-status-cvstrees "T" #'cvs-status-trees ">" #'cvs-mode-checkout) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index e68aa2257d..87d30666da 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -169,49 +169,49 @@ and hunk-based syntax highlighting otherwise as a fallback." "N" #'diff-file-next "p" #'diff-hunk-prev "P" #'diff-file-prev - ["TAB"] #'diff-hunk-next - [backtab] #'diff-hunk-prev + "TAB" #'diff-hunk-next + "" #'diff-hunk-prev "k" #'diff-hunk-kill "K" #'diff-file-kill "}" #'diff-file-next ; From compilation-minor-mode. "{" #'diff-file-prev - ["RET"] #'diff-goto-source - [mouse-2] #'diff-goto-source + "RET" #'diff-goto-source + "" #'diff-goto-source "W" #'widen "o" #'diff-goto-source ; other-window "A" #'diff-ediff-patch "r" #'diff-restrict-view "R" #'diff-reverse-direction - [remap undo] #'diff-undo) + " " #'diff-undo) (defvar-keymap diff-mode-map :doc "Keymap for `diff-mode'. See also `diff-mode-shared-map'." - ["ESC"] (let ((map (define-keymap :parent diff-mode-shared-map))) - ;; We want to inherit most bindings from - ;; `diff-mode-shared-map', but not all since they may hide - ;; useful `M-' global bindings when editing. - (dolist (key '("A" "r" "R" "g" "q" "W" "z")) - (define-key map key nil)) - map) + "ESC" (let ((map (define-keymap :parent diff-mode-shared-map))) + ;; We want to inherit most bindings from + ;; `diff-mode-shared-map', but not all since they may hide + ;; useful `M-' global bindings when editing. + (dolist (key '("A" "r" "R" "g" "q" "W" "z")) + (keymap-set map key nil)) + map) ;; From compilation-minor-mode. - ["C-c C-c"] #'diff-goto-source + "C-c C-c" #'diff-goto-source ;; By analogy with the global C-x 4 a binding. - ["C-x 4 A"] #'diff-add-change-log-entries-other-window + "C-x 4 A" #'diff-add-change-log-entries-other-window ;; Misc operations. - ["C-c C-a"] #'diff-apply-hunk - ["C-c C-e"] #'diff-ediff-patch - ["C-c C-n"] #'diff-restrict-view - ["C-c C-s"] #'diff-split-hunk - ["C-c C-t"] #'diff-test-hunk - ["C-c C-r"] #'diff-reverse-direction - ["C-c C-u"] #'diff-context->unified + "C-c C-a" #'diff-apply-hunk + "C-c C-e" #'diff-ediff-patch + "C-c C-n" #'diff-restrict-view + "C-c C-s" #'diff-split-hunk + "C-c C-t" #'diff-test-hunk + "C-c C-r" #'diff-reverse-direction + "C-c C-u" #'diff-context->unified ;; `d' because it duplicates the context :-( --Stef - ["C-c C-d"] #'diff-unified->context - ["C-c C-w"] #'diff-ignore-whitespace-hunk + "C-c C-d" #'diff-unified->context + "C-c C-w" #'diff-ignore-whitespace-hunk ;; `l' because it "refreshes" the hunk like C-l refreshes the screen - ["C-c C-l"] #'diff-refresh-hunk - ["C-c C-b"] #'diff-refine-hunk ;No reason for `b' :-( - ["C-c C-f"] #'next-error-follow-minor-mode) + "C-c C-l" #'diff-refresh-hunk + "C-c C-b" #'diff-refine-hunk ;No reason for `b' :-( + "C-c C-f" #'next-error-follow-minor-mode) (easy-menu-define diff-mode-menu diff-mode-map "Menu for `diff-mode'." @@ -264,9 +264,11 @@ and hunk-based syntax highlighting otherwise as a fallback." :help "Go to the next count'th file"] )) -(defcustom diff-minor-mode-prefix "\C-c=" +(defcustom diff-minor-mode-prefix "C-c =" "Prefix key for `diff-minor-mode' commands." - :type '(choice (string "\e") (string "C-c=") string)) + :type '(choice (string "ESC") + (string "C-c =") string) + :version "29.1") (defvar-keymap diff-minor-mode-map :doc "Keymap for `diff-minor-mode'. See also `diff-mode-shared-map'." diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index c8d089e411..6e3f302263 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -55,18 +55,18 @@ (define-obsolete-variable-alias 'vc-log-entry-mode 'log-edit-mode-map "28.1") (defvar-keymap log-edit-mode-map - (kbd "C-c C-c") #'log-edit-done - (kbd "C-c C-a") #'log-edit-insert-changelog - (kbd "C-c C-w") #'log-edit-generate-changelog-from-diff - (kbd "C-c C-d") #'log-edit-show-diff - (kbd "C-c C-f") #'log-edit-show-files - (kbd "C-c C-k") #'log-edit-kill-buffer - (kbd "C-a") #'log-edit-beginning-of-line - (kbd "M-n") #'log-edit-next-comment - (kbd "M-p") #'log-edit-previous-comment - (kbd "M-r") #'log-edit-comment-search-backward - (kbd "M-s") #'log-edit-comment-search-forward - (kbd "C-c ?") #'log-edit-mode-help) + "C-c C-c" #'log-edit-done + "C-c C-a" #'log-edit-insert-changelog + "C-c C-w" #'log-edit-generate-changelog-from-diff + "C-c C-d" #'log-edit-show-diff + "C-c C-f" #'log-edit-show-files + "C-c C-k" #'log-edit-kill-buffer + "C-a" #'log-edit-beginning-of-line + "M-n" #'log-edit-next-comment + "M-p" #'log-edit-previous-comment + "M-r" #'log-edit-comment-search-backward + "M-s" #'log-edit-comment-search-forward + "C-c ?" #'log-edit-mode-help) (easy-menu-define log-edit-menu log-edit-mode-map "Menu used for `log-edit-mode'." diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index 2c78000e38..d45c1696a2 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -123,7 +123,7 @@ :prefix "log-view-") (defvar-keymap log-view-mode-map - (kbd "RET") #'log-view-toggle-entry-display + "RET" #'log-view-toggle-entry-display "m" #'log-view-toggle-mark-entry "e" #'log-view-modify-change-comment "d" #'log-view-diff @@ -133,12 +133,12 @@ "f" #'log-view-find-revision "n" #'log-view-msg-next "p" #'log-view-msg-prev - (kbd "TAB") #'log-view-msg-next - (kbd "") #'log-view-msg-prev + "TAB" #'log-view-msg-next + "" #'log-view-msg-prev "N" #'log-view-file-next "P" #'log-view-file-prev - (kbd "M-n") #'log-view-file-next - (kbd "M-p") #'log-view-file-prev) + "M-n" #'log-view-file-next + "M-p" #'log-view-file-prev) (easy-menu-define log-view-mode-menu log-view-mode-map "Log-View Display Menu." diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el index 2daa42fbf8..fa28d074a9 100644 --- a/lisp/vc/pcvs.el +++ b/lisp/vc/pcvs.el @@ -164,33 +164,33 @@ "z" #'kill-this-buffer "F" #'cvs-mode-set-flags "!" #'cvs-mode-force-command - ["C-c C-c"] #'cvs-mode-kill-process + "C-c C-c" #'cvs-mode-kill-process ;; marking "m" #'cvs-mode-mark "M" #'cvs-mode-mark-all-files "S" #'cvs-mode-mark-on-state "u" #'cvs-mode-unmark - ["DEL"] #'cvs-mode-unmark-up + "DEL" #'cvs-mode-unmark-up "%" #'cvs-mode-mark-matching-files "T" #'cvs-mode-toggle-marks - ["M-DEL"] #'cvs-mode-unmark-all-files + "M-DEL" #'cvs-mode-unmark-all-files ;; navigation keys - " " #'cvs-mode-next-line + "SPC" #'cvs-mode-next-line "n" #'cvs-mode-next-line "p" #'cvs-mode-previous-line - "\t" #'cvs-mode-next-line - [backtab] #'cvs-mode-previous-line + "TAB" #'cvs-mode-next-line + "" #'cvs-mode-previous-line ;; M- keys are usually those that operate on modules - ["M-c"] #'cvs-checkout - ["M-e"] #'cvs-examine + "M-c" #'cvs-checkout + "M-e" #'cvs-examine "g" #'cvs-mode-revert-buffer - ["M-u"] #'cvs-update - ["M-s"] #'cvs-status + "M-u" #'cvs-update + "M-s" #'cvs-status ;; diff commands "=" #'cvs-mode-diff "d" cvs-mode-diff-map ;; keys that operate on individual files - ["C-k"] #'cvs-mode-acknowledge + "C-k" #'cvs-mode-acknowledge "A" #'cvs-mode-add-change-log-entry-other-window "C" #'cvs-mode-commit-setup "O" #'cvs-mode-update @@ -202,7 +202,7 @@ "c" #'cvs-mode-commit "e" #'cvs-mode-examine "f" #'cvs-mode-find-file - ["RET"] #'cvs-mode-find-file + "RET" #'cvs-mode-find-file "i" #'cvs-mode-ignore "l" #'cvs-mode-log "o" #'cvs-mode-find-file-other-window @@ -214,12 +214,12 @@ ;; cvstree bindings "+" #'cvs-mode-tree ;; mouse bindings - [mouse-2] #'cvs-mode-find-file - [follow-link] (lambda (pos) + "" #'cvs-mode-find-file + "" (lambda (pos) (eq (get-char-property pos 'face) 'cvs-filename)) - [(down-mouse-3)] #'cvs-menu + "" #'cvs-menu ;; dired-like bindings - "\C-o" #'cvs-mode-display-file) + "C-o" #'cvs-mode-display-file) (easy-menu-define cvs-menu cvs-mode-map "Menu used in `cvs-mode'." '("CVS" @@ -266,9 +266,10 @@ ;;;; CVS-Minor mode ;;;; -(defcustom cvs-minor-mode-prefix "\C-xc" +(defcustom cvs-minor-mode-prefix "C-x c" "Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'." :type 'string + :version "29.1" :group 'pcl-cvs) (defvar-keymap cvs-minor-mode-map diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index 2cc5ee739f..ee6ddf1588 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -156,16 +156,17 @@ Used in `smerge-diff-base-upper' and related functions." "E" #'smerge-ediff "C" #'smerge-combine-with-next "R" #'smerge-refine - ["C-m"] #'smerge-keep-current + "C-m" #'smerge-keep-current "=" (define-keymap :name "Diff" "<" (cons "base-upper" #'smerge-diff-base-upper) ">" (cons "base-lower" #'smerge-diff-base-lower) "=" (cons "upper-lower" #'smerge-diff-upper-lower))) -(defcustom smerge-command-prefix "\C-c^" +(defcustom smerge-command-prefix "C-c ^" "Prefix for `smerge-mode' commands." + :version "29.1" :type '(choice (const :tag "ESC" "\e") - (const :tag "C-c ^" "\C-c^" ) + (const :tag "C-c ^" "C-c ^") (const :tag "none" "") string)) commit de477ec683482a5dd27d791d7fdcfc4021ed3cb7 Author: Lars Ingebrigtsen Date: Tue Nov 16 08:15:43 2021 +0100 Add new 'keymap-*' functions * lisp/keymap.el: New file with all the new keymap-* functions. * lisp/loadup.el ("keymap"): Load. * lisp/subr.el (kbd): Refactor out all the code to key-parse. (define-key-after, keyboard-translate, global-set-key) (local-set-key, global-unset-key, local-unset-key) (local-key-binding, global-key-binding) (substitute-key-definition): Note in doc strings that these are legacy functions. (define-keymap--define): Use keymap-set. * lisp/emacs-lisp/byte-opt.el: Remove the optimizations for defvar-keymap and define-keymap since the macros now only understand the kbd syntax. * lisp/emacs-lisp/bytecomp.el (byte-compile-define-keymap) (byte-compile-define-keymap--define): Warn about invalid key definitions in all keymap-* functions. * lisp/emacs-lisp/shortdoc.el (keymaps): Add shortdocs form keymap* functions. * src/keymap.c (possibly_translate_key_sequence): Adjust callers to key-valid-p and key-parse. (syms_of_keymap): Adjust defs. diff --git a/etc/NEWS b/etc/NEWS index ed95f891db..68b5cc82b4 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -593,12 +593,62 @@ Use 'exif-parse-file' and 'exif-field' instead. * Lisp Changes in Emacs 29.1 +** Keymaps and key definitions + ++++ +*** New functions for defining and manipulating keystrokes have been added. +These all take just the syntax defined by 'key-valid-p'. None of the +older functions have been depreciated or altered, but are deemphasised +in the documentation. + ++++ +*** Use 'keymap-set' instead of 'define-key'. + ++++ +*** Use 'keymap-global-set' instead of 'global-set-key'. + ++++ +*** Use 'keymap-local-set' instead of 'local-set-key'. + ++++ +*** Use 'keymap-global-unset' instead of 'global-unset-key'. + ++++ +*** Use 'keymap-local-unset' instead of 'local-unset-key'. + ++++ +*** Use 'keymap-substitute' instead of 'substitute-key-definition'. + ++++ +*** Use 'keymap-set-after' instead of 'define-key-after'. + ++++ +*** Use 'keymap-lookup' instead of 'lookup-keymap' and 'key-binding'. + +++ -** 'define-key' now takes an optional REMOVE argument. +*** Use 'keymap-local-lookup' instead of 'local-key-binding'. + ++++ +*** Use 'keymap-global-lookup' instead of 'global-key-binding'. + ++++ +*** 'define-key' now takes an optional REMOVE argument. If non-nil, remove the definition from the keymap. This is subtly different from setting a definition to nil (when the keymap has a parent). ++++ +*** New function 'key-valid-p'. +The 'kbd' function is quite permissive, and will try to return +something usable even if the syntax of the argument isn't completely +correct. The 'key-valid-p' predicate does a stricter check of the +syntax. + +--- +*** New function 'key-parse'. +This is like 'kbd', but only returns vectors instead of a mix of +vectors and strings. + +++ ** New function 'file-name-split'. This returns a list of all the components of a file name. @@ -691,13 +741,6 @@ The 'tabulated-list-entries' variable now supports using an image descriptor, which means to insert an image in that column instead of text. See the documentation string of that variable for details. -+++ -** 'define-key' now understands a new strict 'kbd' representation for keys. -The '(define-key map ["C-c M-f"] #'some-command)' syntax is now -supported, and is like the 'kbd' representation, but is stricter. If -the string doesn't represent a valid key sequence, an error is -signalled (both when evaluating and byte compiling). - +++ ** :keys in 'menu-item' can now be a function. If so, it is called whenever the menu is computed, and can be used to @@ -734,13 +777,6 @@ This macro allows defining keymap variables more conveniently. ** 'kbd' can now be used in built-in, preloaded libraries. It no longer depends on edmacro.el and cl-lib.el. -+++ -** New function 'kbd-valid-p'. -The 'kbd' function is quite permissive, and will try to return -something usable even if the syntax of the argument isn't completely -correct. The 'kbd-valid-p' predicate does a stricter check of the -syntax. - +++ ** New function 'image-at-point-p'. This function returns t if point is on a valid image, and nil diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 9c64083b64..f6db803b78 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1186,72 +1186,6 @@ See Info node `(elisp) Integer Basics'." (put 'concat 'byte-optimizer #'byte-optimize-concat) -(defun byte-optimize-define-key (form) - "Expand key bindings in FORM." - (let ((key (nth 2 form))) - (if (and (vectorp key) - (= (length key) 1) - (stringp (aref key 0))) - ;; We have key on the form ["C-c C-c"]. - (if (not (kbd-valid-p (aref key 0))) - (error "Invalid `kbd' syntax: %S" key) - (list (nth 0 form) (nth 1 form) - (kbd (aref key 0)) (nth 4 form))) - ;; No improvement. - form))) - -(put 'define-key 'byte-optimizer #'byte-optimize-define-key) - -(defun byte-optimize-define-keymap (form) - "Expand key bindings in FORM." - (let ((result nil) - (orig-form form) - improved) - (push (pop form) result) - (while (and form - (keywordp (car form)) - (not (eq (car form) :menu))) - (unless (memq (car form) - '(:full :keymap :parent :suppress :name :prefix)) - (error "Invalid keyword: %s" (car form))) - (push (pop form) result) - (when (null form) - (error "Uneven number of keywords in %S" form)) - (push (pop form) result)) - ;; Bindings. - (while form - (let ((key (pop form))) - (if (and (vectorp key) - (= (length key) 1) - (stringp (aref key 0))) - (progn - (unless (kbd-valid-p (aref key 0)) - (error "Invalid `kbd' syntax: %S" key)) - (push (kbd (aref key 0)) result) - (setq improved t)) - ;; No improvement. - (push key result))) - (when (null form) - (error "Uneven number of key bindings in %S" form)) - (push (pop form) result)) - (if improved - (nreverse result) - orig-form))) - -(defun byte-optimize-define-keymap--define (form) - "Expand key bindings in FORM." - (if (not (consp (nth 1 form))) - form - (let ((optimized (byte-optimize-define-keymap (nth 1 form)))) - (if (eq optimized (nth 1 form)) - ;; No improvement. - form - (list (car form) optimized))))) - -(put 'define-keymap 'byte-optimizer #'byte-optimize-define-keymap) -(put 'define-keymap--define 'byte-optimizer - #'byte-optimize-define-keymap--define) - ;; I'm not convinced that this is necessary. Doesn't the optimizer loop ;; take care of this? - Jamie ;; I think this may some times be necessary to reduce ie (quote 5) to 5, diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 471a0b623a..4078a7314f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5043,6 +5043,71 @@ binding slots have been popped." nil)) (_ (byte-compile-keep-pending form)))) + + + +;; Key syntax warnings. + +(mapc + (lambda (elem) + (put (car elem) 'byte-hunk-handler + (lambda (form) + (dolist (idx (cdr elem)) + (let ((key (elt form idx))) + (when (or (vectorp key) + (and (stringp key) + (not (key-valid-p key)))) + (byte-compile-warn "Invalid `kbd' syntax: %S" key)))) + form))) + ;; Functions and the place(s) for the key definition(s). + '((keymap-set 2) + (keymap-global-set 1) + (keymap-local-set 1) + (keymap-unset 2) + (keymap-global-unset 1) + (keymap-local-unset 1) + (keymap-substitute 1 2) + (keymap-set-after 2) + (key-translate 1 2) + (keymap-lookup 2) + (keymap-global-lookup 1) + (keymap-local-lookup 1))) + +(put 'define-keymap 'byte-hunk-handler #'byte-compile-define-keymap) +(defun byte-compile-define-keymap (form) + (let ((result nil) + (orig-form form)) + (push (pop form) result) + (while (and form + (keywordp (car form)) + (not (eq (car form) :menu))) + (unless (memq (car form) + '(:full :keymap :parent :suppress :name :prefix)) + (byte-compile-warn "Invalid keyword: %s" (car form))) + (push (pop form) result) + (when (null form) + (byte-compile-warn "Uneven number of keywords in %S" form)) + (push (pop form) result)) + ;; Bindings. + (while form + (let ((key (pop form))) + (when (stringp key) + (unless (key-valid-p key) + (byte-compile-warn "Invalid `kbd' syntax: %S" key))) + ;; No improvement. + (push key result)) + (when (null form) + (byte-compile-warn "Uneven number of key bindings in %S" form)) + (push (pop form) result)) + orig-form)) + +(put 'define-keymap--define 'byte-hunk-handler + #'byte-compile-define-keymap--define) +(defun byte-compile-define-keymap--define (form) + (when (consp (nth 1 form)) + (byte-compile-define-keymap (nth 1 form))) + form) + ;;; tags diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index a9f548b104..228d1e0551 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -1222,6 +1222,39 @@ There can be any number of :example/:result elements." (text-property-search-backward :no-eval (text-property-search-backward 'face nil t))) +(define-short-documentation-group keymaps + "Defining keymaps" + (define-keymap + :no-eval (define-keymap "C-c C-c" #'quit-buffer)) + (defvar-keymap + :no-eval (defvar-keymap my-keymap "C-c C-c" map #'quit-buffer)) + "Setting keys" + (keymap-set + :no-eval (keymap-set map "C-c C-c" #'quit-buffer)) + (keymap-local-set + :no-eval (keymap-local-set "C-c C-c" #'quit-buffer)) + (keymap-global-set + :no-eval (keymap-global-set "C-c C-c" #'quit-buffer)) + (keymap-unset + :no-eval (keymap-unset map "C-c C-c")) + (keymap-local-unset + :no-eval (keymap-local-unset "C-c C-c")) + (keymap-global-unset + :no-eval (keymap-global-unset "C-c C-c")) + (keymap-substitute + :no-eval (keymap-substitute "C-c C-c" "M-a" map)) + (keymap-set-after + :no-eval (keymap-set-after map "" menu-bar-separator)) + "Predicates" + (keymapp + :eval (keymapp (define-keymap))) + (key-valid-p + :eval (key-valid-p "C-c C-c") + :eval (key-valid-p "C-cC-c")) + "Lookup" + (keymap-lookup + :eval (keymap-lookup (current-global-map) "C-x x g"))) + ;;;###autoload (defun shortdoc-display-group (group &optional function) "Pop to a buffer with short documentation summary for functions in GROUP. diff --git a/lisp/keymap.el b/lisp/keymap.el new file mode 100644 index 0000000000..8938197ecf --- /dev/null +++ b/lisp/keymap.el @@ -0,0 +1,437 @@ +;;; keymap.el --- Keymap functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 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: + +;; This library deals with the "new" keymap binding interface: The +;; only key syntax allowed by these functions is the `kbd' one. + +;;; Code: + + + +(defun keymap--check (key) + "Signal an error if KEY doesn't have a valid syntax." + (unless (key-valid-p key) + (error "%S is not a valid key definition; see `key-valid-p'" key))) + +(defun keymap-set (keymap key definition) + "Set key sequence KEY to DEFINITION in KEYMAP. +KEY is a string that satisfies `key-valid-p'. + +DEFINITION is anything that can be a key's definition: + nil (means key is undefined in this keymap), + a command (a Lisp function suitable for interactive calling), + a string (treated as a keyboard macro), + a keymap (to define a prefix key), + a symbol (when the key is looked up, the symbol will stand for its + function definition, which should at that time be one of the above, + or another symbol whose function definition is used, etc.), + a cons (STRING . DEFN), meaning that DEFN is the definition + (DEFN should be a valid definition in its own right) and + STRING is the menu item name (which is used only if the containing + keymap has been created with a menu name, see `make-keymap'), + or a cons (MAP . CHAR), meaning use definition of CHAR in keymap MAP, + or an extended menu item definition. + (See info node `(elisp)Extended Menu Items'.)" + (keymap--check key) + (define-key keymap (key-parse key) definition)) + +(defun keymap-global-set (key command) + "Give KEY a global binding as COMMAND. +COMMAND is the command definition to use; usually it is +a symbol naming an interactively-callable function. + +KEY is a string that satisfies `key-valid-p'. + +Note that if KEY has a local binding in the current buffer, +that local binding will continue to shadow any global binding +that you make with this function." + (interactive + (let* ((menu-prompting nil) + (key (read-key-sequence "Set key globally: " nil t))) + (list key + (read-command (format "Set key %s to command: " + (key-description key)))))) + (keymap-set (current-global-map) key command)) + +(defun keymap-local-set (key command) + "Give KEY a local binding as COMMAND. +COMMAND is the command definition to use; usually it is +a symbol naming an interactively-callable function. + +KEY is a string that satisfies `key-valid-p'. + +The binding goes in the current buffer's local map, which in most +cases is shared with all other buffers in the same major mode." + (interactive "KSet key locally: \nCSet key %s locally to command: ") + (let ((map (current-local-map))) + (unless map + (use-local-map (setq map (make-sparse-keymap)))) + (keymap-set map key command))) + +(defun keymap-global-unset (key &optional remove) + "Remove global binding of KEY (if any). +KEY is a string that satisfies `key-valid-p'. + +If REMOVE (interactively, the prefix arg), remove the binding +instead of unsetting it. See `keymap-unset' for details." + (interactive + (list (key-description (read-key-sequence "Set key locally: ")) + current-prefix-arg)) + (keymap-unset (current-global-map) key remove)) + +(defun keymap-local-unset (key &optional remove) + "Remove local binding of KEY (if any). +KEY is a string that satisfies `key-valid-p'. + +If REMOVE (interactively, the prefix arg), remove the binding +instead of unsetting it. See `keymap-unset' for details." + (interactive + (list (key-description (read-key-sequence "Unset key locally: ")) + current-prefix-arg)) + (when (current-local-map) + (keymap-unset (current-local-map) key remove))) + +(defun keymap-unset (keymap key &optional remove) + "Remove key sequence KEY from KEYMAP. +KEY is a string that satisfies `key-valid-p'. + +If REMOVE, remove the binding instead of unsetting it. This only +makes a difference when there's a parent keymap. When unsetting +a key in a child map, it will still shadow the same key in the +parent keymap. Removing the binding will allow the key in the +parent keymap to be used." + (keymap--check key) + (define-key keymap key nil remove)) + +(defun keymap-substitute (olddef newdef keymap &optional oldmap prefix) + "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. +In other words, OLDDEF is replaced with NEWDEF wherever it appears. +Alternatively, if optional fourth argument OLDMAP is specified, we redefine +in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP. + +If you don't specify OLDMAP, you can usually get the same results +in a cleaner way with command remapping, like this: + (define-key KEYMAP [remap OLDDEF] NEWDEF) +\n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)" + ;; Don't document PREFIX in the doc string because we don't want to + ;; advertise it. It's meant for recursive calls only. Here's its + ;; meaning + + ;; If optional argument PREFIX is specified, it should be a key + ;; prefix, a string. Redefined bindings will then be bound to the + ;; original key, with PREFIX added at the front. + (unless prefix + (setq prefix "")) + (keymap--check olddef) + (keymap--check newdef) + (setq olddef (key-parse olddef)) + (setq newdef (key-parse newdef)) + (let* ((scan (or oldmap keymap)) + (prefix1 (vconcat prefix [nil])) + (key-substitution-in-progress + (cons scan key-substitution-in-progress))) + ;; Scan OLDMAP, finding each char or event-symbol that + ;; has any definition, and act on it with hack-key. + (map-keymap + (lambda (char defn) + (aset prefix1 (length prefix) char) + (substitute-key-definition-key defn olddef newdef prefix1 keymap)) + scan))) + +(defun keymap-set-after (keymap key definition &optional after) + "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. +This is like `keymap-set' except that the binding for KEY is placed +just after the binding for the event AFTER, instead of at the beginning +of the map. Note that AFTER must be an event type (like KEY), NOT a command +\(like DEFINITION). + +If AFTER is t or omitted, the new binding goes at the end of the keymap. +AFTER should be a single event type--a symbol or a character, not a sequence. + +Bindings are always added before any inherited map. + +The order of bindings in a keymap matters only when it is used as +a menu, so this function is not useful for non-menu keymaps." + (declare (indent defun)) + (keymap--check key) + (when after + (keymap--check after)) + (define-key-after keymap (key-parse key) definition + (and after (key-parse after)))) + +(defun key-parse (keys) + "Convert KEYS to the internal Emacs key representation. +See `kbd' for a descripion of KEYS." + (declare (pure t) (side-effect-free t)) + ;; A pure function is expected to preserve the match data. + (save-match-data + (let ((case-fold-search nil) + (len (length keys)) ; We won't alter keys in the loop below. + (pos 0) + (res [])) + (while (and (< pos len) + (string-match "[^ \t\n\f]+" keys pos)) + (let* ((word-beg (match-beginning 0)) + (word-end (match-end 0)) + (word (substring keys word-beg len)) + (times 1) + key) + ;; Try to catch events of the form "". + (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word) + (setq word (match-string 0 word) + pos (+ word-beg (match-end 0))) + (setq word (substring keys word-beg word-end) + pos word-end)) + (when (string-match "\\([0-9]+\\)\\*." word) + (setq times (string-to-number (substring word 0 (match-end 1)))) + (setq word (substring word (1+ (match-end 1))))) + (cond ((string-match "^<<.+>>$" word) + (setq key (vconcat (if (eq (key-binding [?\M-x]) + 'execute-extended-command) + [?\M-x] + (or (car (where-is-internal + 'execute-extended-command)) + [?\M-x])) + (substring word 2 -2) "\r"))) + ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word) + (progn + (setq word (concat (match-string 1 word) + (match-string 3 word))) + (not (string-match + "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$" + word)))) + (setq key (list (intern word)))) + ((or (equal word "REM") (string-match "^;;" word)) + (setq pos (string-match "$" keys pos))) + (t + (let ((orig-word word) (prefix 0) (bits 0)) + (while (string-match "^[ACHMsS]-." word) + (setq bits (+ bits + (cdr + (assq (aref word 0) + '((?A . ?\A-\^@) (?C . ?\C-\^@) + (?H . ?\H-\^@) (?M . ?\M-\^@) + (?s . ?\s-\^@) (?S . ?\S-\^@)))))) + (setq prefix (+ prefix 2)) + (setq word (substring word 2))) + (when (string-match "^\\^.$" word) + (setq bits (+ bits ?\C-\^@)) + (setq prefix (1+ prefix)) + (setq word (substring word 1))) + (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r") + ("LFD" . "\n") ("TAB" . "\t") + ("ESC" . "\e") ("SPC" . " ") + ("DEL" . "\177"))))) + (when found (setq word (cdr found)))) + (when (string-match "^\\\\[0-7]+$" word) + (let ((n 0)) + (dolist (ch (cdr (string-to-list word))) + (setq n (+ (* n 8) ch -48))) + (setq word (vector n)))) + (cond ((= bits 0) + (setq key word)) + ((and (= bits ?\M-\^@) (stringp word) + (string-match "^-?[0-9]+$" word)) + (setq key (mapcar (lambda (x) (+ x bits)) + (append word nil)))) + ((/= (length word) 1) + (error "%s must prefix a single character, not %s" + (substring orig-word 0 prefix) word)) + ((and (/= (logand bits ?\C-\^@) 0) (stringp word) + ;; We used to accept . and ? here, + ;; but . is simply wrong, + ;; and C-? is not used (we use DEL instead). + (string-match "[@-_a-z]" word)) + (setq key (list (+ bits (- ?\C-\^@) + (logand (aref word 0) 31))))) + (t + (setq key (list (+ bits (aref word 0))))))))) + (when key + (dolist (_ (number-sequence 1 times)) + (setq res (vconcat res key)))))) + (if (and (>= (length res) 4) + (eq (aref res 0) ?\C-x) + (eq (aref res 1) ?\() + (eq (aref res (- (length res) 2)) ?\C-x) + (eq (aref res (- (length res) 1)) ?\))) + (apply #'vector (let ((lres (append res nil))) + ;; Remove the first and last two elements. + (setq lres (cdr (cdr lres))) + (nreverse lres) + (setq lres (cdr (cdr lres))) + (nreverse lres))) + res)))) + +(defun key-valid-p (keys) + "Say whether KEYS is a valid `kbd' sequence. +A `kbd' sequence is a string consisting of one and more key +strokes. The key strokes are separated by a space character. + +Each key stroke is either a single character, or the name of an +event, surrounded by angle brackets. In addition, any key stroke +may be preceded by one or more modifier keys. Finally, a limited +number of characters have a special shorthand syntax. + +Here's some example key sequences. + + \"f\" (the key 'f') + \"S o m\" (a three key sequence of the keys 'S', 'o' and 'm') + \"C-c o\" (a two key sequence of the keys 'c' with the control modifier + and then the key 'o') + \"H-\" (the key named \"left\" with the hyper modifier) + \"M-RET\" (the \"return\" key with a meta modifier) + \"C-M-\" (the \"space\" key with both the control and meta modifiers) + +These are the characters that have shorthand syntax: +NUL, RET, TAB, LFD, ESC, SPC, DEL. + +Modifiers have to be specified in this order: + + A-C-H-M-S-s + +which is + + Alt-Control-Hyper-Meta-Shift-super" + (declare (pure t) (side-effect-free t)) + (and + (stringp keys) + (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) + (save-match-data + (catch 'exit + (let ((prefixes + "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?") + (case-fold-search nil)) + (dolist (key (split-string keys " ")) + ;; Every key might have these modifiers, and they should be + ;; in this order. + (when (string-match (concat "\\`" prefixes) key) + (setq key (substring key (match-end 0)))) + (unless (or (and (= (length key) 1) + ;; Don't accept control characters as keys. + (not (< (aref key 0) ?\s)) + ;; Don't accept Meta'd characters as keys. + (or (multibyte-string-p key) + (not (<= 127 (aref key 0) 255)))) + (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key) + ;; Don't allow . + (= (progn + (string-match + (concat "\\`<" prefixes) key) + (match-end 0)) + 1)) + (string-match-p + "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'" + key)) + ;; Invalid. + (throw 'exit nil))) + t))))) + +(defun key-translate (from to) + "Translate character FROM to TO on the current terminal. +This function creates a `keyboard-translate-table' if necessary +and then modifies one entry in it. + +Both KEY and TO are strings that satisfy `key-valid-p'." + (keymap--check from) + (keymap--check to) + (or (char-table-p keyboard-translate-table) + (setq keyboard-translate-table + (make-char-table 'keyboard-translate-table nil))) + (aset keyboard-translate-table (key-parse from) (key-parse to))) + +(defun keymap-lookup (keymap key &optional accept-default no-remap position) + "Return the binding for command KEY. +KEY is a string that satisfies `key-valid-p'. + +If KEYMAP is nil, look up in the current keymaps. If non-nil, it +should either be a keymap or a list of keymaps, and only these +keymap(s) will be consulted. + +The binding is probably a symbol with a function definition. + +Normally, `keymap-lookup' ignores bindings for t, which act as +default bindings, used when nothing else in the keymap applies; +this makes it usable as a general function for probing keymaps. +However, if the optional second argument ACCEPT-DEFAULT is +non-nil, `keymap-lookup' does recognize the default bindings, +just as `read-key-sequence' does. + +Like the normal command loop, `keymap-lookup' will remap the +command resulting from looking up KEY by looking up the command +in the current keymaps. However, if the optional third argument +NO-REMAP is non-nil, `keymap-lookup' returns the unmapped +command. + +If KEY is a key sequence initiated with the mouse, the used keymaps +will depend on the clicked mouse position with regard to the buffer +and possible local keymaps on strings. + +If the optional argument POSITION is non-nil, it specifies a mouse +position as returned by `event-start' and `event-end', and the lookup +occurs in the keymaps associated with it instead of KEY. It can also +be a number or marker, in which case the keymap properties at the +specified buffer position instead of point are used." + (keymap--check key) + (when (and keymap (not position)) + (error "Can't pass in both keymap and position")) + (if keymap + (let ((value (lookup-key (key-parse key) keymap accept-default))) + (when (and (not no-remap) + (symbolp value)) + (or (command-remapping value) value))) + (key-binding (kbd key) accept-default no-remap position))) + +(defun keymap-local-lookup (keys &optional accept-default) + "Return the binding for command KEYS in current local keymap only. +KEY is a string that satisfies `key-valid-p'. + +The binding is probably a symbol with a function definition. + +If optional argument ACCEPT-DEFAULT is non-nil, recognize default +bindings; see the description of `keymap-lookup' for more details +about this." + (when-let ((map (current-local-map))) + (keymap-lookup map keys accept-default))) + +(defun keymap-global-lookup (keys &optional accept-default message) + "Return the binding for command KEYS in current global keymap only. +KEY is a string that satisfies `key-valid-p'. + +The binding is probably a symbol with a function definition. +This function's return values are the same as those of `keymap-lookup' +\(which see). + +If optional argument ACCEPT-DEFAULT is non-nil, recognize default +bindings; see the description of `keymap-lookup' for more details +about this. + +If MESSAGE (and interactively), message the result." + (interactive + (list (key-description (read-key-sequence "Look up key in global keymap: ")) + nil t)) + (let ((def (keymap-lookup (current-global-map) keys accept-default))) + (when message + (message "%s is bound to %s globally" keys def)) + def)) + +(provide 'keymap) + +;;; keymap.el ends here diff --git a/lisp/loadup.el b/lisp/loadup.el index e8ecb67d56..15a71ef244 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -131,6 +131,7 @@ (load "emacs-lisp/byte-run") (load "emacs-lisp/backquote") (load "subr") +(load "keymap") ;; Do it after subr, since both after-load-functions and add-hook are ;; implemented in subr.el. diff --git a/lisp/subr.el b/lisp/subr.el index 3902251586..7ba764880e 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -925,69 +925,6 @@ side-effects, and the argument LIST is not modified." ;;;; Keymap support. -(defun kbd-valid-p (keys) - "Say whether KEYS is a valid `kbd' sequence. -A `kbd' sequence is a string consisting of one and more key -strokes. The key strokes are separated by a space character. - -Each key stroke is either a single character, or the name of an -event, surrounded by angle brackets. In addition, any key stroke -may be preceded by one or more modifier keys. Finally, a limited -number of characters have a special shorthand syntax. - -Here's some example key sequences. - - \"f\" (the key 'f') - \"S o m\" (a three key sequence of the keys 'S', 'o' and 'm') - \"C-c o\" (a two key sequence of the keys 'c' with the control modifier - and then the key 'o') - \"H-\" (the key named \"left\" with the hyper modifier) - \"M-RET\" (the \"return\" key with a meta modifier) - \"C-M-\" (the \"space\" key with both the control and meta modifiers) - -These are the characters that have shorthand syntax: -NUL, RET, TAB, LFD, ESC, SPC, DEL. - -Modifiers have to be specified in this order: - - A-C-H-M-S-s - -which is - - Alt-Control-Hyper-Meta-Shift-super" - (declare (pure t) (side-effect-free t)) - (and (stringp keys) - (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) - (save-match-data - (catch 'exit - (let ((prefixes - "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?") - (case-fold-search nil)) - (dolist (key (split-string keys " ")) - ;; Every key might have these modifiers, and they should be - ;; in this order. - (when (string-match (concat "\\`" prefixes) key) - (setq key (substring key (match-end 0)))) - (unless (or (and (= (length key) 1) - ;; Don't accept control characters as keys. - (not (< (aref key 0) ?\s)) - ;; Don't accept Meta'd characters as keys. - (or (multibyte-string-p key) - (not (<= 127 (aref key 0) 255)))) - (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key) - ;; Don't allow . - (= (progn - (string-match - (concat "\\`<" prefixes) key) - (match-end 0)) - 1)) - (string-match-p - "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'" - key)) - ;; Invalid. - (throw 'exit nil))) - t))))) - (defun kbd (keys) "Convert KEYS to the internal Emacs key representation. KEYS should be a string in the format returned by commands such @@ -1006,110 +943,15 @@ Here's some example key sequences: For an approximate inverse of this, see `key-description'." (declare (pure t) (side-effect-free t)) - ;; A pure function is expected to preserve the match data. - (save-match-data - (let ((case-fold-search nil) - (len (length keys)) ; We won't alter keys in the loop below. - (pos 0) - (res [])) - (while (and (< pos len) - (string-match "[^ \t\n\f]+" keys pos)) - (let* ((word-beg (match-beginning 0)) - (word-end (match-end 0)) - (word (substring keys word-beg len)) - (times 1) - key) - ;; Try to catch events of the form "". - (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word) - (setq word (match-string 0 word) - pos (+ word-beg (match-end 0))) - (setq word (substring keys word-beg word-end) - pos word-end)) - (when (string-match "\\([0-9]+\\)\\*." word) - (setq times (string-to-number (substring word 0 (match-end 1)))) - (setq word (substring word (1+ (match-end 1))))) - (cond ((string-match "^<<.+>>$" word) - (setq key (vconcat (if (eq (key-binding [?\M-x]) - 'execute-extended-command) - [?\M-x] - (or (car (where-is-internal - 'execute-extended-command)) - [?\M-x])) - (substring word 2 -2) "\r"))) - ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word) - (progn - (setq word (concat (match-string 1 word) - (match-string 3 word))) - (not (string-match - "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$" - word)))) - (setq key (list (intern word)))) - ((or (equal word "REM") (string-match "^;;" word)) - (setq pos (string-match "$" keys pos))) - (t - (let ((orig-word word) (prefix 0) (bits 0)) - (while (string-match "^[ACHMsS]-." word) - (setq bits (+ bits (cdr (assq (aref word 0) - '((?A . ?\A-\^@) (?C . ?\C-\^@) - (?H . ?\H-\^@) (?M . ?\M-\^@) - (?s . ?\s-\^@) (?S . ?\S-\^@)))))) - (setq prefix (+ prefix 2)) - (setq word (substring word 2))) - (when (string-match "^\\^.$" word) - (setq bits (+ bits ?\C-\^@)) - (setq prefix (1+ prefix)) - (setq word (substring word 1))) - (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r") - ("LFD" . "\n") ("TAB" . "\t") - ("ESC" . "\e") ("SPC" . " ") - ("DEL" . "\177"))))) - (when found (setq word (cdr found)))) - (when (string-match "^\\\\[0-7]+$" word) - (let ((n 0)) - (dolist (ch (cdr (string-to-list word))) - (setq n (+ (* n 8) ch -48))) - (setq word (vector n)))) - (cond ((= bits 0) - (setq key word)) - ((and (= bits ?\M-\^@) (stringp word) - (string-match "^-?[0-9]+$" word)) - (setq key (mapcar (lambda (x) (+ x bits)) - (append word nil)))) - ((/= (length word) 1) - (error "%s must prefix a single character, not %s" - (substring orig-word 0 prefix) word)) - ((and (/= (logand bits ?\C-\^@) 0) (stringp word) - ;; We used to accept . and ? here, - ;; but . is simply wrong, - ;; and C-? is not used (we use DEL instead). - (string-match "[@-_a-z]" word)) - (setq key (list (+ bits (- ?\C-\^@) - (logand (aref word 0) 31))))) - (t - (setq key (list (+ bits (aref word 0))))))))) - (when key - (dolist (_ (number-sequence 1 times)) - (setq res (vconcat res key)))))) - (when (and (>= (length res) 4) - (eq (aref res 0) ?\C-x) - (eq (aref res 1) ?\() - (eq (aref res (- (length res) 2)) ?\C-x) - (eq (aref res (- (length res) 1)) ?\))) - (setq res (apply #'vector (let ((lres (append res nil))) - ;; Remove the first and last two elements. - (setq lres (cdr (cdr lres))) - (nreverse lres) - (setq lres (cdr (cdr lres))) - (nreverse lres) - lres)))) - (if (not (memq nil (mapcar (lambda (ch) - (and (numberp ch) - (<= 0 ch 127))) - res))) - ;; Return a string. - (concat (mapcar #'identity res)) - ;; Return a vector. - res)))) + (let ((res (key-parse keys))) + (if (not (memq nil (mapcar (lambda (ch) + (and (numberp ch) + (<= 0 ch 127))) + res))) + ;; Return a string. + (concat (mapcar #'identity res)) + ;; Return a vector. + res))) (defun undefined () "Beep to tell the user this binding is undefined." @@ -1160,6 +1002,9 @@ PARENT if non-nil should be a keymap." (defun define-key-after (keymap key definition &optional after) "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. +This is a legacy function; see `keymap-set-after' for the +recommended function to use instead. + This is like `define-key' except that the binding for KEY is placed just after the binding for the event AFTER, instead of at the beginning of the map. Note that AFTER must be an event type (like KEY), NOT a command @@ -1330,6 +1175,9 @@ Subkeymaps may be modified but are not canonicalized." (defun keyboard-translate (from to) "Translate character FROM to TO on the current terminal. +This is a legacy function; see `keymap-translate' for the +recommended function to use instead. + This function creates a `keyboard-translate-table' if necessary and then modifies one entry in it." (or (char-table-p keyboard-translate-table) @@ -1341,6 +1189,9 @@ and then modifies one entry in it." (defun global-set-key (key command) "Give KEY a global binding as COMMAND. +This is a legacy function; see `keymap-global-set' for the +recommended function to use instead. + COMMAND is the command definition to use; usually it is a symbol naming an interactively-callable function. KEY is a key sequence; noninteractively, it is a string or vector @@ -1362,6 +1213,9 @@ that you make with this function." (defun local-set-key (key command) "Give KEY a local binding as COMMAND. +This is a legacy function; see `keymap-local-set' for the +recommended function to use instead. + COMMAND is the command definition to use; usually it is a symbol naming an interactively-callable function. KEY is a key sequence; noninteractively, it is a string or vector @@ -1380,12 +1234,18 @@ cases is shared with all other buffers in the same major mode." (defun global-unset-key (key) "Remove global binding of KEY. +This is a legacy function; see `keymap-global-unset' for the +recommended function to use instead. + KEY is a string or vector representing a sequence of keystrokes." (interactive "kUnset key globally: ") (global-set-key key nil)) (defun local-unset-key (key) "Remove local binding of KEY. +This is a legacy function; see `keymap-local-unset' for the +recommended function to use instead. + KEY is a string or vector representing a sequence of keystrokes." (interactive "kUnset key locally: ") (if (current-local-map) @@ -1394,6 +1254,9 @@ KEY is a string or vector representing a sequence of keystrokes." (defun local-key-binding (keys &optional accept-default) "Return the binding for command KEYS in current local keymap only. +This is a legacy function; see `keymap-local-binding' for the +recommended function to use instead. + KEYS is a string or vector, a sequence of keystrokes. The binding is probably a symbol with a function definition. @@ -1405,6 +1268,9 @@ about this." (defun global-key-binding (keys &optional accept-default) "Return the binding for command KEYS in current global keymap only. +This is a legacy function; see `keymap-global-binding' for the +recommended function to use instead. + KEYS is a string or vector, a sequence of keystrokes. The binding is probably a symbol with a function definition. This function's return values are the same as those of `lookup-key' @@ -1423,6 +1289,9 @@ about this." (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix) "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. +This is a legacy function; see `keymap-substitute' for the +recommended function to use instead. + In other words, OLDDEF is replaced with NEWDEF wherever it appears. Alternatively, if optional fourth argument OLDMAP is specified, we redefine in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP. @@ -6683,7 +6552,7 @@ pairs. Available keywords are: command (see `define-prefix-command'). If this is the case, this symbol is returned instead of the map itself. -KEY/DEFINITION pairs are as KEY and DEF in `define-key'. KEY can +KEY/DEFINITION pairs are as KEY and DEF in `keymap-set'. KEY can also be the special symbol `:menu', in which case DEFINITION should be a MENU form as accepted by `easy-menu-define'. @@ -6735,7 +6604,7 @@ should be a MENU form as accepted by `easy-menu-define'. (let ((def (pop definitions))) (if (eq key :menu) (easy-menu-define nil keymap "" def) - (define-key keymap key def))))) + (keymap-set keymap key def))))) keymap))) (defmacro defvar-keymap (variable-name &rest defs) diff --git a/src/keymap.c b/src/keymap.c index c6990cffaf..7993e31ac6 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -1053,16 +1053,16 @@ possibly_translate_key_sequence (Lisp_Object key, ptrdiff_t *length) { /* KEY is on the ["C-c"] format, so translate to internal format. */ - if (NILP (Ffboundp (Qkbd_valid_p))) + if (NILP (Ffboundp (Qkey_valid_p))) xsignal2 (Qerror, - build_string ("`kbd-valid-p' is not defined, so this syntax can't be used: %s"), + build_string ("`key-valid-p' is not defined, so this syntax can't be used: %s"), key); - if (NILP (call1 (Qkbd_valid_p, AREF (key, 0)))) - xsignal2 (Qerror, build_string ("Invalid `kbd' syntax: %S"), key); - key = call1 (Qkbd, AREF (key, 0)); + if (NILP (call1 (Qkey_valid_p, AREF (key, 0)))) + xsignal2 (Qerror, build_string ("Invalid `key-parse' syntax: %S"), key); + key = call1 (Qkey_parse, AREF (key, 0)); *length = CHECK_VECTOR_OR_STRING (key); if (*length == 0) - xsignal2 (Qerror, build_string ("Invalid `kbd' syntax: %S"), key); + xsignal2 (Qerror, build_string ("Invalid `key-parse' syntax: %S"), key); } return key; @@ -3458,6 +3458,6 @@ that describe key bindings. That is why the default is nil. */); defsubr (&Swhere_is_internal); defsubr (&Sdescribe_buffer_bindings); - DEFSYM (Qkbd, "kbd"); - DEFSYM (Qkbd_valid_p, "kbd-valid-p"); + DEFSYM (Qkey_parse, "key-parse"); + DEFSYM (Qkey_valid_p, "key-valid-p"); } diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 238c9be1ab..ca0ded1ea3 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -198,123 +198,123 @@ ;; These should be equivalent: (should (equal (kbd "\C-xf") (kbd "C-x f")))) -(ert-deftest subr-test-kbd-valid-p () - (should (not (kbd-valid-p ""))) - (should (kbd-valid-p "f")) - (should (kbd-valid-p "X")) - (should (not (kbd-valid-p " X"))) - (should (kbd-valid-p "X f")) - (should (not (kbd-valid-p "a b"))) - (should (not (kbd-valid-p "foobar"))) - (should (not (kbd-valid-p "return"))) - - (should (kbd-valid-p "")) - (should (kbd-valid-p " TAB")) - (should (kbd-valid-p " RET")) - (should (kbd-valid-p " SPC")) - (should (kbd-valid-p "")) - (should (not (kbd-valid-p "[f1]"))) - (should (kbd-valid-p "")) - (should (not (kbd-valid-p "< right >"))) +(ert-deftest subr-test-key-valid-p () + (should (not (key-valid-p ""))) + (should (key-valid-p "f")) + (should (key-valid-p "X")) + (should (not (key-valid-p " X"))) + (should (key-valid-p "X f")) + (should (not (key-valid-p "a b"))) + (should (not (key-valid-p "foobar"))) + (should (not (key-valid-p "return"))) + + (should (key-valid-p "")) + (should (key-valid-p " TAB")) + (should (key-valid-p " RET")) + (should (key-valid-p " SPC")) + (should (key-valid-p "")) + (should (not (key-valid-p "[f1]"))) + (should (key-valid-p "")) + (should (not (key-valid-p "< right >"))) ;; Modifiers: - (should (kbd-valid-p "C-x")) - (should (kbd-valid-p "C-x a")) - (should (kbd-valid-p "C-;")) - (should (kbd-valid-p "C-a")) - (should (kbd-valid-p "C-c SPC")) - (should (kbd-valid-p "C-c TAB")) - (should (kbd-valid-p "C-c c")) - (should (kbd-valid-p "C-x 4 C-f")) - (should (kbd-valid-p "C-x C-f")) - (should (kbd-valid-p "C-M-")) - (should (not (kbd-valid-p ""))) - (should (kbd-valid-p "C-RET")) - (should (kbd-valid-p "C-SPC")) - (should (kbd-valid-p "C-TAB")) - (should (kbd-valid-p "C-")) - (should (kbd-valid-p "C-c C-c C-c")) - - (should (kbd-valid-p "M-a")) - (should (kbd-valid-p "M-")) - (should (not (kbd-valid-p "M-C-a"))) - (should (kbd-valid-p "C-M-a")) - (should (kbd-valid-p "M-ESC")) - (should (kbd-valid-p "M-RET")) - (should (kbd-valid-p "M-SPC")) - (should (kbd-valid-p "M-TAB")) - (should (kbd-valid-p "M-x a")) - (should (kbd-valid-p "M-")) - (should (kbd-valid-p "M-c M-c M-c")) - - (should (kbd-valid-p "s-SPC")) - (should (kbd-valid-p "s-a")) - (should (kbd-valid-p "s-x a")) - (should (kbd-valid-p "s-c s-c s-c")) - - (should (not (kbd-valid-p "S-H-a"))) - (should (kbd-valid-p "S-a")) - (should (kbd-valid-p "S-x a")) - (should (kbd-valid-p "S-c S-c S-c")) - - (should (kbd-valid-p "H-")) - (should (kbd-valid-p "H-DEL")) - (should (kbd-valid-p "H-a")) - (should (kbd-valid-p "H-x a")) - (should (kbd-valid-p "H-c H-c H-c")) - - (should (kbd-valid-p "A-H-a")) - (should (kbd-valid-p "A-SPC")) - (should (kbd-valid-p "A-TAB")) - (should (kbd-valid-p "A-a")) - (should (kbd-valid-p "A-c A-c A-c")) - - (should (kbd-valid-p "C-M-a")) - (should (kbd-valid-p "C-M-")) + (should (key-valid-p "C-x")) + (should (key-valid-p "C-x a")) + (should (key-valid-p "C-;")) + (should (key-valid-p "C-a")) + (should (key-valid-p "C-c SPC")) + (should (key-valid-p "C-c TAB")) + (should (key-valid-p "C-c c")) + (should (key-valid-p "C-x 4 C-f")) + (should (key-valid-p "C-x C-f")) + (should (key-valid-p "C-M-")) + (should (not (key-valid-p ""))) + (should (key-valid-p "C-RET")) + (should (key-valid-p "C-SPC")) + (should (key-valid-p "C-TAB")) + (should (key-valid-p "C-")) + (should (key-valid-p "C-c C-c C-c")) + + (should (key-valid-p "M-a")) + (should (key-valid-p "M-")) + (should (not (key-valid-p "M-C-a"))) + (should (key-valid-p "C-M-a")) + (should (key-valid-p "M-ESC")) + (should (key-valid-p "M-RET")) + (should (key-valid-p "M-SPC")) + (should (key-valid-p "M-TAB")) + (should (key-valid-p "M-x a")) + (should (key-valid-p "M-")) + (should (key-valid-p "M-c M-c M-c")) + + (should (key-valid-p "s-SPC")) + (should (key-valid-p "s-a")) + (should (key-valid-p "s-x a")) + (should (key-valid-p "s-c s-c s-c")) + + (should (not (key-valid-p "S-H-a"))) + (should (key-valid-p "S-a")) + (should (key-valid-p "S-x a")) + (should (key-valid-p "S-c S-c S-c")) + + (should (key-valid-p "H-")) + (should (key-valid-p "H-DEL")) + (should (key-valid-p "H-a")) + (should (key-valid-p "H-x a")) + (should (key-valid-p "H-c H-c H-c")) + + (should (key-valid-p "A-H-a")) + (should (key-valid-p "A-SPC")) + (should (key-valid-p "A-TAB")) + (should (key-valid-p "A-a")) + (should (key-valid-p "A-c A-c A-c")) + + (should (key-valid-p "C-M-a")) + (should (key-valid-p "C-M-")) ;; Special characters. - (should (kbd-valid-p "DEL")) - (should (kbd-valid-p "ESC C-a")) - (should (kbd-valid-p "ESC")) - (should (kbd-valid-p "LFD")) - (should (kbd-valid-p "NUL")) - (should (kbd-valid-p "RET")) - (should (kbd-valid-p "SPC")) - (should (kbd-valid-p "TAB")) - (should (not (kbd-valid-p "\^i"))) - (should (not (kbd-valid-p "^M"))) + (should (key-valid-p "DEL")) + (should (key-valid-p "ESC C-a")) + (should (key-valid-p "ESC")) + (should (key-valid-p "LFD")) + (should (key-valid-p "NUL")) + (should (key-valid-p "RET")) + (should (key-valid-p "SPC")) + (should (key-valid-p "TAB")) + (should (not (key-valid-p "\^i"))) + (should (not (key-valid-p "^M"))) ;; With numbers. - (should (not (kbd-valid-p "\177"))) - (should (not (kbd-valid-p "\000"))) - (should (not (kbd-valid-p "\\177"))) - (should (not (kbd-valid-p "\\000"))) - (should (not (kbd-valid-p "C-x \\150"))) + (should (not (key-valid-p "\177"))) + (should (not (key-valid-p "\000"))) + (should (not (key-valid-p "\\177"))) + (should (not (key-valid-p "\\000"))) + (should (not (key-valid-p "C-x \\150"))) ;; Multibyte - (should (kbd-valid-p "ñ")) - (should (kbd-valid-p "ü")) - (should (kbd-valid-p "ö")) - (should (kbd-valid-p "ğ")) - (should (kbd-valid-p "ա")) - (should (not (kbd-valid-p "üüöö"))) - (should (kbd-valid-p "C-ü")) - (should (kbd-valid-p "M-ü")) - (should (kbd-valid-p "H-ü")) + (should (key-valid-p "ñ")) + (should (key-valid-p "ü")) + (should (key-valid-p "ö")) + (should (key-valid-p "ğ")) + (should (key-valid-p "ա")) + (should (not (key-valid-p "üüöö"))) + (should (key-valid-p "C-ü")) + (should (key-valid-p "M-ü")) + (should (key-valid-p "H-ü")) ;; Handle both new and old style key descriptions (bug#45536). - (should (kbd-valid-p "s-")) - (should (not (kbd-valid-p ""))) - (should (kbd-valid-p "C-M-")) - (should (not (kbd-valid-p ""))) - - (should (kbd-valid-p "")) - (should (kbd-valid-p "")) - - (should (not (kbd-valid-p "c-x"))) - (should (not (kbd-valid-p "C-xx"))) - (should (not (kbd-valid-p "M-xx"))) - (should (not (kbd-valid-p "M-x")))) + (should (key-valid-p "s-")) + (should (not (key-valid-p ""))) + (should (key-valid-p "C-M-")) + (should (not (key-valid-p ""))) + + (should (key-valid-p "")) + (should (key-valid-p "")) + + (should (not (key-valid-p "c-x"))) + (should (not (key-valid-p "C-xx"))) + (should (not (key-valid-p "M-xx"))) + (should (not (key-valid-p "M-x")))) (ert-deftest subr-test-define-prefix-command () (define-prefix-command 'foo-prefix-map) commit 560c921ed8d2d14e593aaee68b8be57b189128e5 Author: Lars Ingebrigtsen Date: Tue Nov 16 08:02:22 2021 +0100 Allow removing keymap definitions * src/keymap.c (initial_define_lispy_key): Adjust caller. (store_in_keymap): Allow removing definitions in addition to setting them to nil. (Fdefine_key): Ditto. (define_as_prefix): Adjust caller. * src/term.c (term_get_fkeys_1): Adjust caller. diff --git a/etc/NEWS b/etc/NEWS index 0a19dcaf7a..ed95f891db 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -593,6 +593,12 @@ Use 'exif-parse-file' and 'exif-field' instead. * Lisp Changes in Emacs 29.1 ++++ +** 'define-key' now takes an optional REMOVE argument. +If non-nil, remove the definition from the keymap. This is subtly +different from setting a definition to nil (when the keymap has a +parent). + +++ ** New function 'file-name-split'. This returns a list of all the components of a file name. diff --git a/src/keymap.c b/src/keymap.c index 29d2ca7ab7..c6990cffaf 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -73,7 +73,8 @@ static Lisp_Object where_is_cache; /* Which keymaps are reverse-stored in the cache. */ static Lisp_Object where_is_cache_keymaps; -static Lisp_Object store_in_keymap (Lisp_Object, Lisp_Object, Lisp_Object); +static Lisp_Object store_in_keymap (Lisp_Object, Lisp_Object, Lisp_Object, + bool); static Lisp_Object define_as_prefix (Lisp_Object, Lisp_Object); static void describe_vector (Lisp_Object, Lisp_Object, Lisp_Object, @@ -130,7 +131,8 @@ in case you use it as a menu with `x-popup-menu'. */) void initial_define_lispy_key (Lisp_Object keymap, const char *keyname, const char *defname) { - store_in_keymap (keymap, intern_c_string (keyname), intern_c_string (defname)); + store_in_keymap (keymap, intern_c_string (keyname), + intern_c_string (defname), Qnil); } DEFUN ("keymapp", Fkeymapp, Skeymapp, 1, 1, 0, @@ -729,7 +731,8 @@ get_keyelt (Lisp_Object object, bool autoload) } static Lisp_Object -store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def) +store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, + Lisp_Object def, bool remove) { /* Flush any reverse-map cache. */ where_is_cache = Qnil; @@ -805,21 +808,26 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def) } else if (CHAR_TABLE_P (elt)) { + Lisp_Object sdef = def; + if (remove) + sdef = Qnil; + /* nil has a special meaning for char-tables, so + we use something else to record an explicitly + unbound entry. */ + else if (NILP (sdef)) + sdef = Qt; + /* Character codes with modifiers are not included in a char-table. All character codes without modifiers are included. */ if (FIXNATP (idx) && !(XFIXNAT (idx) & CHAR_MODIFIER_MASK)) { - Faset (elt, idx, - /* nil has a special meaning for char-tables, so - we use something else to record an explicitly - unbound entry. */ - NILP (def) ? Qt : def); + Faset (elt, idx, sdef); return def; } else if (CONSP (idx) && CHARACTERP (XCAR (idx))) { - Fset_char_table_range (elt, idx, NILP (def) ? Qt : def); + Fset_char_table_range (elt, idx, sdef); return def; } insertion_point = tail; @@ -838,7 +846,12 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def) else if (EQ (idx, XCAR (elt))) { CHECK_IMPURE (elt, XCONS (elt)); - XSETCDR (elt, def); + if (remove) + /* Remove the element. */ + insertion_point = Fdelq (elt, insertion_point); + else + /* Just set the definition. */ + XSETCDR (elt, def); return def; } else if (CONSP (idx) @@ -851,7 +864,10 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def) if (from <= XFIXNAT (XCAR (elt)) && to >= XFIXNAT (XCAR (elt))) { - XSETCDR (elt, def); + if (remove) + insertion_point = Fdelq (elt, insertion_point); + else + XSETCDR (elt, def); if (from == to) return def; } @@ -1054,8 +1070,11 @@ possibly_translate_key_sequence (Lisp_Object key, ptrdiff_t *length) /* GC is possible in this function if it autoloads a keymap. */ -DEFUN ("define-key", Fdefine_key, Sdefine_key, 3, 3, 0, +DEFUN ("define-key", Fdefine_key, Sdefine_key, 3, 4, 0, doc: /* In KEYMAP, define key sequence KEY as DEF. +This is a legacy function; see `keymap-set' for the recommended +function to use instead. + KEYMAP is a keymap. KEY is a string or a vector of symbols and characters, representing a @@ -1082,10 +1101,16 @@ DEF is anything that can be a key's definition: or an extended menu item definition. (See info node `(elisp)Extended Menu Items'.) +If REMOVE is non-nil, the definition will be removed. This is almost +the same as setting the definition to nil, but makes a difference if +the KEYMAP has a parent, and KEY is shadowing the same binding in the +parent. With REMOVE, subsequent lookups will return the binding in +the parent, and with a nil DEF, the lookups will return nil. + If KEYMAP is a sparse keymap with a binding for KEY, the existing binding is altered. If there is no binding for KEY, the new pair binding KEY to DEF is added at the front of KEYMAP. */) - (Lisp_Object keymap, Lisp_Object key, Lisp_Object def) + (Lisp_Object keymap, Lisp_Object key, Lisp_Object def, Lisp_Object remove) { bool metized = false; @@ -1155,7 +1180,7 @@ binding KEY to DEF is added at the front of KEYMAP. */) message_with_string ("Key sequence contains invalid event %s", c, 1); if (idx == length) - return store_in_keymap (keymap, c, def); + return store_in_keymap (keymap, c, def, !NILP (remove)); Lisp_Object cmd = access_keymap (keymap, c, 0, 1, 1); @@ -1260,6 +1285,9 @@ lookup_key_1 (Lisp_Object keymap, Lisp_Object key, Lisp_Object accept_default) DEFUN ("lookup-key", Flookup_key, Slookup_key, 2, 3, 0, doc: /* Look up key sequence KEY in KEYMAP. Return the definition. +This is a legacy function; see `keymap-lookup' for the recommended +function to use instead. + A value of nil means undefined. See doc of `define-key' for kinds of definitions. @@ -1413,7 +1441,7 @@ static Lisp_Object define_as_prefix (Lisp_Object keymap, Lisp_Object c) { Lisp_Object cmd = Fmake_sparse_keymap (Qnil); - store_in_keymap (keymap, c, cmd); + store_in_keymap (keymap, c, cmd, Qnil); return cmd; } diff --git a/src/term.c b/src/term.c index b4f3dfc25e..8e106e7c63 100644 --- a/src/term.c +++ b/src/term.c @@ -1358,7 +1358,7 @@ term_get_fkeys_1 (void) char *sequence = tgetstr (keys[i].cap, address); if (sequence) Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (sequence), - make_vector (1, intern (keys[i].name))); + make_vector (1, intern (keys[i].name)), Qnil); } /* The uses of the "k0" capability are inconsistent; sometimes it @@ -1377,13 +1377,13 @@ term_get_fkeys_1 (void) /* Define f0 first, so that f10 takes precedence in case the key sequences happens to be the same. */ Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k0), - make_vector (1, intern ("f0"))); + make_vector (1, intern ("f0")), Qnil); Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k_semi), - make_vector (1, intern ("f10"))); + make_vector (1, intern ("f10")), Qnil); } else if (k0) Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k0), - make_vector (1, intern (k0_name))); + make_vector (1, intern (k0_name)), Qnil); } /* Set up cookies for numbered function keys above f10. */ @@ -1405,8 +1405,10 @@ term_get_fkeys_1 (void) if (sequence) { sprintf (fkey, "f%d", i); - Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (sequence), - make_vector (1, intern (fkey))); + Fdefine_key (KVAR (kboard, Vinput_decode_map), + build_string (sequence), + make_vector (1, intern (fkey)), + Qnil); } } } @@ -1422,7 +1424,7 @@ term_get_fkeys_1 (void) char *sequence = tgetstr (cap2, address); \ if (sequence) \ Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (sequence), \ - make_vector (1, intern (sym))); \ + make_vector (1, intern (sym)), Qnil); \ } /* if there's no key_next keycap, map key_npage to `next' keysym */ diff --git a/test/src/keymap-tests.el b/test/src/keymap-tests.el index 8e28faf2b2..629d6c5584 100644 --- a/test/src/keymap-tests.el +++ b/test/src/keymap-tests.el @@ -373,6 +373,40 @@ g .. h foo (should (eq (lookup-key (current-global-map) ["C-x C-f"]) 'find-file)) (should (eq (lookup-key (current-global-map) [?\C-x ?\C-f]) 'find-file))) +(ert-deftest keymap-removal () + ;; Set to nil. + (let ((map (define-keymap "a" 'foo))) + (should (equal map '(keymap (97 . foo)))) + (define-key map "a" nil) + (should (equal map '(keymap (97))))) + ;; Remove. + (let ((map (define-keymap "a" 'foo))) + (should (equal map '(keymap (97 . foo)))) + (define-key map "a" nil t) + (should (equal map '(keymap))))) + +(ert-deftest keymap-removal-inherit () + ;; Set to nil. + (let ((parent (make-sparse-keymap)) + (child (make-keymap))) + (set-keymap-parent child parent) + (define-key parent [?a] 'foo) + (define-key child [?a] 'bar) + + (should (eq (lookup-key child [?a]) 'bar)) + (define-key child [?a] nil) + (should (eq (lookup-key child [?a]) nil))) + ;; Remove. + (let ((parent (make-sparse-keymap)) + (child (make-keymap))) + (set-keymap-parent child parent) + (define-key parent [?a] 'foo) + (define-key child [?a] 'bar) + + (should (eq (lookup-key child [?a]) 'bar)) + (define-key child [?a] nil t) + (should (eq (lookup-key child [?a]) 'foo)))) + (provide 'keymap-tests) ;;; keymap-tests.el ends here commit aa4cffccac0794870985c9d6cec82a0eb7bab137 Author: Lars Ingebrigtsen Date: Mon Nov 15 10:07:11 2021 +0100 Make erc-mode noninteractive * lisp/erc/erc.el (erc-mode): Mark it as noninteractive, because using it from `M-x' will only lead to problems (bug#51841). diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index abb1f64a82..c5a4fbe5a0 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1479,6 +1479,7 @@ Defaults to the server buffer." (define-derived-mode erc-mode fundamental-mode "ERC" "Major mode for Emacs IRC." + :interactive nil (setq local-abbrev-table erc-mode-abbrev-table) (setq-local next-line-add-newlines nil) (setq line-move-ignore-invisible t) commit e0abd83b4990bdfb8c8c4a518a5d0cc4f2d96bdf Merge: d89d5e0f94 e852822f3d Author: Stefan Kangas Date: Tue Nov 16 07:18:19 2021 +0100 Merge from origin/emacs-28 e852822f3d Fix removal of fringe marks of deleted bookmarks b418aad85a * lisp/repeat.el (repeat-echo-message): Bind message-log-m... fe2ac7cb7c * lisp/repeat.el (describe-repeat-maps): Use help-fns--ana... c840bfe7e1 * lisp/repeat.el: Detect changes in the minibuffer state (... 5044151486 Avoid segfaults due to freed face cache 199e2468d3 Doc fix; change recommended file name of custom-file commit d89d5e0f9466b9823fe31d02a374d654163594e4 Author: Mike Kupfer Date: Mon Nov 15 22:03:54 2021 -0800 Fix handling of folder "+/" in MH-E * lisp/mh-e/mh-utils.el (mh-sub-folders): Fix handling of "+/". * test/lisp/mh-e/mh-utils-tests.el (mh-folder-completion-function-08-plus-slash) (mh-folder-completion-function-09-plus-slash-tmp): Fix errors made importing tests from mh-unit.el; remove declaration that these tests are expected to fail. diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el index feebf6416f..1c322b8034 100644 --- a/lisp/mh-e/mh-utils.el +++ b/lisp/mh-e/mh-utils.el @@ -531,7 +531,12 @@ results of the actual folders call. If optional argument ADD-TRAILING-SLASH-FLAG is non-nil then a slash is added to each of the sub-folder names that may have nested folders within them." - (let* ((folder (mh-normalize-folder-name folder nil nil t)) + ;; In most cases we want to remove a trailing slash. We keep the + ;; slash for "+/", because it refers to folders in the system root + ;; directory, whereas "+" refers to the user's top-level folders. + (let* ((folder (mh-normalize-folder-name folder nil + (string= folder "+/") + t)) (match (gethash folder mh-sub-folders-cache 'no-result)) (sub-folders (cond ((eq match 'no-result) (setf (gethash folder mh-sub-folders-cache) diff --git a/test/lisp/mh-e/mh-utils-tests.el b/test/lisp/mh-e/mh-utils-tests.el index d9a26e5895..0df4d44646 100644 --- a/test/lisp/mh-e/mh-utils-tests.el +++ b/test/lisp/mh-e/mh-utils-tests.el @@ -437,8 +437,7 @@ and the `should' macro requires idempotent evaluation anyway." (ert-deftest mh-folder-completion-function-08-plus-slash () "Test `mh-folder-completion-function' with `+/'." - :expected-result :failed ;to be fixed in a patch by mkupfer - (mh-test-folder-completion-1 "+/" "+/" "tmp/" nil) + (mh-test-folder-completion-1 "+/" "+/" "tmp/" t) ;; case "bb" (with-mh-test-env (should (equal nil @@ -447,8 +446,7 @@ and the `should' macro requires idempotent evaluation anyway." (ert-deftest mh-folder-completion-function-09-plus-slash-tmp () "Test `mh-folder-completion-function' with `+/tmp'." - :expected-result :failed ;to be fixed in a patch by mkupfer - (mh-test-folder-completion-1 "+/tmp" "+/tmp" "tmp/" t)) + (mh-test-folder-completion-1 "+/tmp" "+/tmp/" "tmp/" t)) (ert-deftest mh-folder-completion-function-10-plus-slash-abs-folder () "Test `mh-folder-completion-function' with `+/abso-folder'." commit cb0aa89bcfb801ec2737e9b1a534bb87d3363dd9 Author: Mike Kupfer Date: Mon Nov 15 21:55:53 2021 -0800 Fix checkdoc complaints in MH-E * lisp/mh-e/mh-compat.el (mh-flet): Rewrite most of the docstring. (mh-write-file-functions): Remove trailing space. * lisp/mh-e-mh-scan.el (mh-scan-cmd-note-width): Break up a line that was too long. diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el index 19be5afd79..23dc48a574 100644 --- a/lisp/mh-e/mh-compat.el +++ b/lisp/mh-e/mh-compat.el @@ -46,10 +46,9 @@ ;; cl-letf. This macro is based upon gmm-flet from Gnus. (defmacro mh-flet (bindings &rest body) "Make temporary overriding function definitions. -This is an analogue of a dynamically scoped `let' that operates on -the function cell of FUNCs rather than their value cell. - -\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" +That is, temporarily rebind the functions listed in BINDINGS and then +execute BODY. BINDINGS is a list containing one or more lists of the +form (FUNCNAME ARGLIST BODY...), similar to defun." (declare (indent 1) (debug ((&rest (sexp sexp &rest form)) &rest form))) (if (fboundp 'cl-letf) `(cl-letf ,(mapcar (lambda (binding) @@ -138,7 +137,7 @@ This is taken from RFC 2396.") #'window-full-height-p "29.1") (defmacro mh-write-file-functions () - "Return `write-file-functions'. " + "Return `write-file-functions'." (declare (obsolete nil "29.1")) ''write-file-functions) diff --git a/lisp/mh-e/mh-scan.el b/lisp/mh-e/mh-scan.el index bf3cfeff5c..9ac251e8b7 100644 --- a/lisp/mh-e/mh-scan.el +++ b/lisp/mh-e/mh-scan.el @@ -327,7 +327,11 @@ Note that columns in Emacs start with 0.") (defvar mh-scan-cmd-note-width 1 "Number of columns consumed by the cmd-note field in `mh-scan-format'. -This column will have one of the values: \" \", \"^\", \"D\", \"B\", \"A\", \"+\", where +This column will have one of the values: + + \" \", \"^\", \"D\", \"B\", \"A\", \"+\" + +where \" \" is the default value, \"^\" is the `mh-note-refiled' character, commit 1d3381ae352d97f69d649a5140286cf8f39e0d2b Author: Stefan Kangas Date: Tue Nov 16 05:06:48 2021 +0100 Fix recently changed wdired test on MS-Windows * test/lisp/wdired-tests.el (wdired-test-bug34915): Don't try to create a local socket on MS-Windows, as it is not supported on that platform. Problem reported by Robert Pluim . diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el index 9678fce84d..47ed26f609 100644 --- a/test/lisp/wdired-tests.el +++ b/test/lisp/wdired-tests.el @@ -146,11 +146,12 @@ wdired-get-filename before and after editing." (make-symbolic-link "foo" "bar") (make-directory "foodir") (dired-smart-shell-command "mkfifo foopipe") - (setq proc (make-network-process - :name "foo" - :family 'local - :server t - :service (expand-file-name "foosocket" test-dir))) + (when (featurep 'make-network-process '(:family local)) + (setq proc (make-network-process + :name "foo" + :family 'local + :server t + :service (expand-file-name "foosocket" test-dir)))) (kill-buffer buf)) (dired test-dir) (dired-toggle-read-only) commit 7cfc3f34bb138def9a1e5b5bce2173b7bb884ad5 Author: Po Lu Date: Tue Nov 16 09:30:32 2021 +0800 Prevent xwidget windows from obscuring child frames * src/xwidget.c (x_draw_xwidget_glyph_string): Lower view window when creating it. diff --git a/src/xwidget.c b/src/xwidget.c index 3bf4f12799..008eb07bca 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -1683,6 +1683,7 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) clip_bottom - clip_top, 0, CopyFromParent, CopyFromParent, CopyFromParent, CWEventMask, &a); + XLowerWindow (xv->dpy, xv->wdesc); XDefineCursor (xv->dpy, xv->wdesc, xv->cursor); xv->cr_surface = cairo_xlib_surface_create (xv->dpy, xv->wdesc, commit a17e3976a8dcbc0eb2034fe3cf62562d8d2494bf Author: Po Lu Date: Tue Nov 16 09:25:55 2021 +0800 Fix xwidget isearch for queries that look like format strings * lisp/xwidget.el (xwidget-webkit-isearch--update): Give special treatment to messages. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 485d995f41..a587fe85db 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -911,8 +911,8 @@ WebKit widget. The query will be set to the contents of (xwidget-webkit-current-session) t xwidget-webkit-isearch--is-reverse t)) (let ((message-log-max nil)) - (message (concat (propertize "Search contents: " 'face 'minibuffer-prompt) - xwidget-webkit-isearch--string)))) + (message "%s" (concat (propertize "Search contents: " 'face 'minibuffer-prompt) + xwidget-webkit-isearch--string)))) (defun xwidget-webkit-isearch-erasing-char (count) "Erase the last COUNT characters of the current query." commit 367cf464a120d4c57d32322e98f3372294f68f4d Author: Po Lu Date: Tue Nov 16 09:08:43 2021 +0800 Fix documentation string * src/xwidget.c (Vxwidget_list, Vxwidget_views_list): Fix horrid doc string. diff --git a/src/xwidget.c b/src/xwidget.c index aae2479134..3bf4f12799 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -2600,11 +2600,11 @@ syms_of_xwidget (void) DEFSYM (QCplist, ":plist"); DEFVAR_LISP ("xwidget-list", Vxwidget_list, - doc: /* xwidgets list. */); + doc: /* List of all xwidgets that have not been killed. */); Vxwidget_list = Qnil; DEFVAR_LISP ("xwidget-view-list", Vxwidget_view_list, - doc: /* xwidget views list. */); + doc: /* List of all xwidget views. */); Vxwidget_view_list = Qnil; Fprovide (intern ("xwidget-internal"), Qnil); commit e852822f3db469c985bf022651f184d6ff2c518a Author: Eli Zaretskii Date: Mon Nov 15 20:20:30 2021 +0200 Fix removal of fringe marks of deleted bookmarks * lisp/bookmark.el (bookmark--remove-fringe-mark): The fringe overlay is at BOL, not at POS. (Bug#51233) diff --git a/lisp/bookmark.el b/lisp/bookmark.el index fb90f01456..623f0acd28 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -479,7 +479,10 @@ See user option `bookmark-set-fringe'." (dolist (buf (buffer-list)) (with-current-buffer buf (when (equal filename buffer-file-name) - (setq overlays (overlays-in pos (1+ pos))) + (setq overlays + (save-excursion + (goto-char pos) + (overlays-in (point-at-bol) (1+ (point-at-bol))))) (while (and (not found) (setq temp (pop overlays))) (when (eq 'bookmark (overlay-get temp 'category)) (delete-overlay (setq found temp)))))))))) commit b418aad85a3d62aa427e7af72c96ca1d644dbc02 Author: Juri Linkov Date: Mon Nov 15 19:53:29 2021 +0200 * lisp/repeat.el (repeat-echo-message): Bind message-log-max to nil. Don't insert messages about repeatable keys in the *Messages* buffer. diff --git a/lisp/repeat.el b/lisp/repeat.el index 96ea8a0250..45201ad1aa 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -481,19 +481,20 @@ See `describe-repeat-maps' for a list of all repeatable commands." (defun repeat-echo-message (keymap) "Display available repeating keys in the echo area." - (if keymap - (let ((message (repeat-echo-message-string keymap))) - (if (current-message) - (message "%s [%s]" (current-message) message) - (message "%s" message))) - (let ((message (current-message))) - (when message - (cond - ((string-prefix-p "Repeat with " message) - (message nil)) - ((string-search " [Repeat with " message) - (message "%s" (replace-regexp-in-string - " \\[Repeat with .*\\'" "" message)))))))) + (let ((message-log-max nil)) + (if keymap + (let ((message (repeat-echo-message-string keymap))) + (if (current-message) + (message "%s [%s]" (current-message) message) + (message "%s" message))) + (let ((message (current-message))) + (when message + (cond + ((string-prefix-p "Repeat with " message) + (message nil)) + ((string-search " [Repeat with " message) + (message "%s" (replace-regexp-in-string + " \\[Repeat with .*\\'" "" message))))))))) (defvar repeat-echo-mode-line-string (propertize "[Repeating...] " 'face 'mode-line-emphasis) commit fe2ac7cb7cf206c86f80304906beb58302c0d31f Author: Robert Pluim Date: Mon Nov 15 19:50:30 2021 +0200 * lisp/repeat.el (describe-repeat-maps): Use help-fns--analyze-function. Print keys bound to commands in every keymap (bug#49265) diff --git a/lisp/repeat.el b/lisp/repeat.el index 4ad6019a04..96ea8a0250 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -507,10 +507,13 @@ See `describe-repeat-maps' for a list of all repeatable commands." repeat-echo-mode-line-string))) (force-mode-line-update t))) +(declare-function help-fns--analyze-function "help-fns" (function)) + (defun describe-repeat-maps () "Describe mappings of commands repeatable by symbol property `repeat-map'. Used in `repeat-mode'." (interactive) + (require 'help-fns) (help-setup-xref (list #'describe-repeat-maps) (called-interactively-p 'interactive)) (let ((keymaps nil)) @@ -527,7 +530,12 @@ Used in `repeat-mode'." (princ (format-message "`%s' keymap is repeatable by these commands:\n" (car keymap))) (dolist (command (sort (cdr keymap) 'string-lessp)) - (princ (format-message " `%s'\n" command))) + (let* ((info (help-fns--analyze-function command)) + (map (list (symbol-value (car keymap)))) + (desc (key-description + (or (where-is-internal command map t) + (where-is-internal (nth 3 info) map t))))) + (princ (format-message " `%s' (bound to '%s')\n" command desc)))) (princ "\n")))))) (provide 'repeat) commit c840bfe7e13200b12e3d96eb83f3972f5d25cd0c Author: Juri Linkov Date: Mon Nov 15 19:39:37 2021 +0200 * lisp/repeat.el: Detect changes in the minibuffer state (bug#47566) (repeat--prev-mb): New internal variable. (repeat-post-hook): Check the property 'repeat-map' on the symbol from 'this-command' in addition to 'real-this-command'. Don't allow repeatable maps in the activated minibuffer or in the minibuffer from another command. Set 'repeat--prev-mb' at the end. diff --git a/lisp/repeat.el b/lisp/repeat.el index ac08952eaa..4ad6019a04 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -402,12 +402,17 @@ See `describe-repeat-maps' for a list of all repeatable commands." (length commands) (length (delete-dups keymaps)))))) +(defvar repeat--prev-mb '(0) + "Previous minibuffer state.") + (defun repeat-post-hook () "Function run after commands to set transient keymap for repeatable keys." (let ((was-in-progress repeat-in-progress)) (setq repeat-in-progress nil) (when repeat-mode (let ((rep-map (or repeat-map + (and (symbolp this-command) + (get this-command 'repeat-map)) (and (symbolp real-this-command) (get real-this-command 'repeat-map))))) (when rep-map @@ -415,11 +420,16 @@ See `describe-repeat-maps' for a list of all repeatable commands." (setq rep-map (symbol-value rep-map))) (let ((map (copy-keymap rep-map))) - ;; Exit when the last char is not among repeatable keys, - ;; so e.g. `C-x u u' repeats undo, whereas `C-/ u' doesn't. - (when (and (zerop (minibuffer-depth)) ; avoid remapping in prompts - (or (lookup-key map (this-command-keys-vector)) - prefix-arg)) + (when (and + ;; Detect changes in the minibuffer state to allow repetitions + ;; in the same minibuffer, but not when the minibuffer is activated + ;; in the middle of repeating sequence (bug#47566). + (or (< (minibuffer-depth) (car repeat--prev-mb)) + (eq current-minibuffer-command (cdr repeat--prev-mb))) + ;; Exit when the last char is not among repeatable keys, + ;; so e.g. `C-x u u' repeats undo, whereas `C-/ u' doesn't. + (or (lookup-key map (this-command-keys-vector)) + prefix-arg)) ;; Messaging (unless prefix-arg @@ -449,6 +459,7 @@ See `describe-repeat-maps' for a list of all repeatable commands." (funcall repeat-echo-function nil))))))))))) (setq repeat-map nil) + (setq repeat--prev-mb (cons (minibuffer-depth) current-minibuffer-command)) (when (and was-in-progress (not repeat-in-progress)) (when repeat-exit-timer (cancel-timer repeat-exit-timer) commit 5b250ca79b9aeeeea0b521db9645882240f08c9f Author: Michael Albinus Date: Mon Nov 15 17:50:15 2021 +0100 Fix minor problems resulting from Tramp regression tests * lisp/net/tramp-adb.el (tramp-adb-file-name-handler-alist): * lisp/net/tramp-archive.el (tramp-archive-file-name-handler-alist): * lisp/net/tramp-crypt.el (tramp-crypt-file-name-handler-alist): * lisp/net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist): * lisp/net/tramp-rclone.el (tramp-rclone-file-name-handler-alist): * lisp/net/tramp-sshfs.el (tramp-sshfs-file-name-handler-alist): Add comment. * lisp/net/tramp-cache.el (tramp-flush-file-upper-properties): FILE can be "~". * lisp/net/tramp.el ('tramp-ensure-dissected-file-name): Add `tramp-suppress-trace' property. (tramp-get-debug-buffer): Add local key for debugging. (tramp-handle-abbreviate-file-name): Adapt implementation. * test/lisp/net/tramp-tests.el (tramp-test07-abbreviate-file-name): Adapt test. (tramp-test17-insert-directory-one-file) (tramp--test-check-files): Use proper `no-dir' argument for `dired-get-filename'. diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 895543d6db..341357d404 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -107,7 +107,8 @@ It is used for TCP/IP devices." ;;;###tramp-autoload (defconst tramp-adb-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 3e0d876dd9..efd38e6b4b 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -211,7 +211,8 @@ It must be supported by libarchive(3).") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-archive-file-name-handler-alist - '((access-file . tramp-archive-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-archive-handle-access-file) (add-name-to-file . tramp-archive-handle-not-implemented) ;; `byte-compiler-base-file-name' performed by default handler. ;; `copy-directory' performed by default handler. diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 5e7d24ff72..f2be297d59 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -224,7 +224,9 @@ Return VALUE." (defun tramp-flush-file-upper-properties (key file) "Remove some properties of FILE's upper directory." (when (file-name-absolute-p file) - (let ((file (directory-file-name (file-name-directory file)))) + ;; `file-name-directory' can return nil, for example for "~". + (when-let ((file (file-name-directory file)) + (file (directory-file-name file))) ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 42b67ac7a8..f60841cf8c 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -157,7 +157,8 @@ If NAME doesn't belong to a crypted remote directory, retun nil." ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-crypt-file-name-handler-alist - '((access-file . tramp-crypt-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-crypt-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 220ce63c0f..a4a7bacd8a 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -744,7 +744,8 @@ It has been changed in GVFS 1.14.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-gvfs-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 28a1c01aa6..09862c6a04 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -71,7 +71,8 @@ ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-rclone-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index a9d8dc933b..a19c99316e 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -71,7 +71,8 @@ ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-sshfs-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index d314df7b00..26425199bf 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1677,6 +1677,8 @@ If it's not a Tramp filename, return nil." ((tramp-tramp-file-p vec-or-filename) (tramp-dissect-file-name vec-or-filename)))) +(put #'tramp-ensure-dissected-file-name 'tramp-suppress-trace t) + (defun tramp-dissect-hop-name (name &optional nodefault) "Return a `tramp-file-name' structure of `hop' part of NAME. See `tramp-dissect-file-name' for details." @@ -1924,7 +1926,9 @@ The outline level is equal to the verbosity of the Tramp message." `(t (eval ,tramp-debug-font-lock-keywords t) ,(eval tramp-debug-font-lock-keywords t))) ;; Do not edit the debug buffer. - (use-local-map special-mode-map)) + (use-local-map special-mode-map) + ;; For debugging purposes. + (define-key (current-local-map) "\M-n" 'clone-buffer)) (current-buffer))) (put #'tramp-get-debug-buffer 'tramp-suppress-trace t) @@ -3284,21 +3288,26 @@ User is always nil." (defvar tramp-handle-write-region-hook nil "Normal hook to be run at the end of `tramp-*-handle-write-region'.") +;; `directory-abbrev-apply' and `directory-abbrev-make-regexp' exists +;; since Emacs 29.1. Since this handler isn't called for older +;; Emacsen, it is save to invoke them via `tramp-compat-funcall'. (defun tramp-handle-abbreviate-file-name (filename) "Like `abbreviate-file-name' for Tramp files." (let* ((case-fold-search (file-name-case-insensitive-p filename)) + (vec (tramp-dissect-file-name filename)) (home-dir - (with-parsed-tramp-file-name filename nil - (with-tramp-connection-property v "home-directory" - (directory-abbrev-apply (expand-file-name - (tramp-make-tramp-file-name v "~"))))))) - ;; If any elt of directory-abbrev-alist matches this name, + (with-tramp-connection-property vec "home-directory" + (tramp-compat-funcall + 'directory-abbrev-apply + (expand-file-name (tramp-make-tramp-file-name vec "~")))))) + ;; If any elt of `directory-abbrev-alist' matches this name, ;; abbreviate accordingly. - (setq filename (directory-abbrev-apply filename)) - (if (string-match (directory-abbrev-make-regexp home-dir) filename) - (with-parsed-tramp-file-name filename nil - (tramp-make-tramp-file-name - v (concat "~" (substring filename (match-beginning 1))))) + (setq filename (tramp-compat-funcall 'directory-abbrev-apply filename)) + ;; Abbreviate home directory. + (if (string-match + (tramp-compat-funcall 'directory-abbrev-make-regexp home-dir) filename) + (tramp-make-tramp-file-name + vec (concat "~" (substring filename (match-beginning 1)))) filename))) (defun tramp-handle-access-file (filename string) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 698d18b528..150ea29838 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2297,11 +2297,13 @@ This checks also `file-name-as-directory', `file-name-directory', (let* ((remote-host (file-remote-p tramp-test-temporary-file-directory)) (home-dir (expand-file-name (concat remote-host "~")))) ;; Check home-dir abbreviation. - (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) - (concat remote-host "~/foo/bar"))) - (should (equal (abbreviate-file-name (concat remote-host - "/nowhere/special")) - (concat remote-host "/nowhere/special"))) + (unless (string-suffix-p "~" home-dir) + (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) + (concat remote-host "~/foo/bar"))) + (should (equal (abbreviate-file-name + (concat remote-host "/nowhere/special")) + (concat remote-host "/nowhere/special")))) + ;; Check `directory-abbrev-alist' abbreviation. (let ((directory-abbrev-alist `((,(concat "\\`" (regexp-quote home-dir) "/foo") @@ -2310,8 +2312,8 @@ This checks also `file-name-as-directory', `file-name-directory', . ,(concat remote-host "/nw"))))) (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) (concat remote-host "~/f/bar"))) - (should (equal (abbreviate-file-name (concat remote-host - "/nowhere/special")) + (should (equal (abbreviate-file-name + (concat remote-host "/nowhere/special")) (concat remote-host "/nw/special")))))) (ert-deftest tramp-test07-file-exists-p () @@ -3327,7 +3329,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (goto-char (point-min)) (while (not (or (eobp) (string-equal - (dired-get-filename 'localp 'no-error) + (dired-get-filename 'no-dir 'no-error) (file-name-nondirectory tmp-name2)))) (forward-line 1)) (should-not (eobp)) @@ -3337,14 +3339,14 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; Point shall still be the recent file. (should (string-equal - (dired-get-filename 'localp 'no-error) + (dired-get-filename 'no-dir 'no-error) (file-name-nondirectory tmp-name2))) (should-not (re-search-forward "dired" nil t)) ;; The copied file has been inserted the line before. (forward-line -1) (should (string-equal - (dired-get-filename 'localp 'no-error) + (dired-get-filename 'no-dir 'no-error) (file-name-nondirectory tmp-name3)))) (kill-buffer buffer)) @@ -6329,7 +6331,7 @@ This requires restrictions of file name syntax." (setq buffer (dired-noselect tmp-name1 "--dired -al")) (goto-char (point-min)) (while (not (eobp)) - (when-let ((name (dired-get-filename 'localp 'no-error))) + (when-let ((name (dired-get-filename 'no-dir 'no-error))) (unless (string-match-p name directory-files-no-dot-files-regexp) (should (member name files)))) commit 5044151486cfd88edceb841d2bf8378dcc906e34 Author: Eli Zaretskii Date: Mon Nov 15 15:35:31 2021 +0200 Avoid segfaults due to freed face cache * src/xfaces.c (face_at_buffer_position): Make sure DEFAULT_FACE is usable. (Bug#51864) diff --git a/src/xfaces.c b/src/xfaces.c index 5e63e87d75..18e65d07e2 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -6423,7 +6423,10 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos, else face_id = lookup_basic_face (w, f, DEFAULT_FACE_ID); - default_face = FACE_FROM_ID (f, face_id); + default_face = FACE_FROM_ID_OR_NULL (f, face_id); + if (!default_face) + default_face = FACE_FROM_ID (f, + lookup_basic_face (w, f, DEFAULT_FACE_ID)); } /* Optimize common cases where we can use the default face. */ commit 83023117de77c3c41286b0eeb56e2e5417080c43 Author: Jim Porter Date: Mon Nov 15 13:34:00 2021 +0100 Add another 'abbreviate-file-name' test * test/lisp/files-tests.el (files-tests-file-name-non-special-abbreviate-file-name): New test. diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index d00f1ce326..2c4557ead6 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -465,6 +465,15 @@ unquoted file names." (let (file-name-handler-alist) (concat (file-name-sans-extension name) part (file-name-extension name t)))) +(ert-deftest files-tests-file-name-non-special-abbreviate-file-name () + (let* ((homedir temporary-file-directory) + (process-environment (cons (format "HOME=%s" homedir) + process-environment)) + (abbreviated-home-dir nil)) + ;; Check that abbreviation doesn't occur for quoted file names. + (should (equal (concat "/:" homedir "foo/bar") + (abbreviate-file-name (concat "/:" homedir "foo/bar")))))) + (ert-deftest files-tests-file-name-non-special-access-file () (files-tests--with-temp-non-special (tmpfile nospecial) ;; Both versions of the file name work. commit bf505a63f98ed61934a8fb81ec65c96859606b6e Author: Jim Porter Date: Mon Nov 15 13:33:07 2021 +0100 Support abbreviating home directory of Tramp filenames * doc/lispref/files.texi (Magic File Names): Mention 'abbreviate-file-name' in the list of magic file name handlers. * etc/NEWS: Announce the change. * lisp/files.el (file-name-non-special): * lisp/net/tramp.el (tramp-file-name-for-operation): * lisp/net/tramp-sh.el (tramp-sh-file-name-handler-alist): * lisp/net/tramp-smb.el (tramp-smb-file-name-handler-alist): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-file-name-handler-alist): Add 'abbreviate-file-name'. * lisp/files.el (directory-abbrev-make-regexp): (directory-abbrev-apply): New functions. (abbreviate-file-name): Check for file name handler. * test/lisp/net/tramp-tests.el (tramp-test07-abbreviate-file-name): New test. diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index d93770a0d2..4b114ba111 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -3308,8 +3308,8 @@ first, before handlers for jobs such as remote file access. @ifnottex @noindent -@code{access-file}, @code{add-name-to-file}, -@code{byte-compiler-base-file-name},@* +@code{abbreviate-file-name}, @code{access-file}, +@code{add-name-to-file}, @code{byte-compiler-base-file-name},@* @code{copy-directory}, @code{copy-file}, @code{delete-directory}, @code{delete-file}, @code{diff-latest-backup-file}, @@ -3368,7 +3368,8 @@ first, before handlers for jobs such as remote file access. @iftex @noindent @flushleft -@code{access-file}, @code{add-name-to-file}, +@code{abbreviate-file-name}, @code{access-file}, +@code{add-name-to-file}, @code{byte-com@discretionary{}{}{}piler-base-file-name}, @code{copy-directory}, @code{copy-file}, @code{delete-directory}, @code{delete-file}, diff --git a/etc/NEWS b/etc/NEWS index 312fc18f4f..0a19dcaf7a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -497,6 +497,14 @@ The newly created buffer will be displayed via 'display-buffer', which can be customized through the usual mechanism of 'display-buffer-alist' and friends. +** Tramp + +--- +*** Tramp supports abbreviating remote home directories now. +When calling 'abbreviate-file-name' on a Tramp filename, the result +will abbreviate the user's home directory, for example by abbreviating +"/ssh:user@host:/home/user" to "/ssh:user@host:~". + * New Modes and Packages in Emacs 29.1 @@ -632,6 +640,9 @@ This convenience function is useful when writing code that parses files at run-time, and allows Lisp programs to re-parse files only when they have changed. ++++ +** 'abbreviate-file-name' now respects magic file name handlers. + --- ** New function 'font-has-char-p'. This can be used to check whether a specific font has a glyph for a diff --git a/lisp/files.el b/lisp/files.el index 3490d0428a..49bf06bfc1 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -68,6 +68,31 @@ a regexp matching the name it is linked to." :group 'abbrev :group 'find-file) +(defun directory-abbrev-make-regexp (directory) + "Create a regexp to match DIRECTORY for `directory-abbrev-alist'." + (let ((regexp + ;; We include a slash at the end, to avoid spurious + ;; matches such as `/usr/foobar' when the home dir is + ;; `/usr/foo'. + (concat "\\`" (regexp-quote directory) "\\(/\\|\\'\\)"))) + ;; The value of regexp could be multibyte or unibyte. In the + ;; latter case, we need to decode it. + (if (multibyte-string-p regexp) + regexp + (decode-coding-string regexp + (if (eq system-type 'windows-nt) + 'utf-8 + locale-coding-system))))) + +(defun directory-abbrev-apply (filename) + "Apply the abbreviations in `directory-abbrev-alist' to FILENAME. +Note that when calling this, you should set `case-fold-search' as +appropriate for the filesystem used for FILENAME." + (dolist (dir-abbrev directory-abbrev-alist filename) + (when (string-match (car dir-abbrev) filename) + (setq filename (concat (cdr dir-abbrev) + (substring filename (match-end 0))))))) + (defcustom make-backup-files t "Non-nil means make a backup of a file the first time it is saved. This can be done by renaming the file or by copying. @@ -2015,73 +2040,54 @@ if you want to permanently change your home directory after having started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)." ;; Get rid of the prefixes added by the automounter. (save-match-data ;FIXME: Why? - (if (and automount-dir-prefix - (string-match automount-dir-prefix filename) - (file-exists-p (file-name-directory - (substring filename (1- (match-end 0)))))) - (setq filename (substring filename (1- (match-end 0))))) - ;; Avoid treating /home/foo as /home/Foo during `~' substitution. - (let ((case-fold-search (file-name-case-insensitive-p filename))) - ;; If any elt of directory-abbrev-alist matches this name, - ;; abbreviate accordingly. - (dolist (dir-abbrev directory-abbrev-alist) - (if (string-match (car dir-abbrev) filename) - (setq filename - (concat (cdr dir-abbrev) - (substring filename (match-end 0)))))) - ;; Compute and save the abbreviated homedir name. - ;; We defer computing this until the first time it's needed, to - ;; give time for directory-abbrev-alist to be set properly. - ;; We include a slash at the end, to avoid spurious matches - ;; such as `/usr/foobar' when the home dir is `/usr/foo'. - (unless abbreviated-home-dir - (put 'abbreviated-home-dir 'home (expand-file-name "~")) - (setq abbreviated-home-dir - (let* ((abbreviated-home-dir "\\`\\'.") ;Impossible regexp. - (regexp - (concat "\\`" - (regexp-quote - (abbreviate-file-name - (get 'abbreviated-home-dir 'home))) - "\\(/\\|\\'\\)"))) - ;; Depending on whether default-directory does or - ;; doesn't include non-ASCII characters, the value - ;; of abbreviated-home-dir could be multibyte or - ;; unibyte. In the latter case, we need to decode - ;; it. Note that this function is called for the - ;; first time (from startup.el) when - ;; locale-coding-system is already set up. - (if (multibyte-string-p regexp) - regexp - (decode-coding-string regexp - (if (eq system-type 'windows-nt) - 'utf-8 - locale-coding-system)))))) - - ;; If FILENAME starts with the abbreviated homedir, - ;; and ~ hasn't changed since abbreviated-home-dir was set, - ;; make it start with `~' instead. - ;; If ~ has changed, we ignore abbreviated-home-dir rather than - ;; invalidating it, on the assumption that a change in HOME - ;; is likely temporary (eg for testing). - ;; FIXME Is it even worth caching abbreviated-home-dir? - ;; Ref: https://debbugs.gnu.org/19657#20 - (let (mb1) - (if (and (string-match abbreviated-home-dir filename) - (setq mb1 (match-beginning 1)) - ;; If the home dir is just /, don't change it. - (not (and (= (match-end 0) 1) - (= (aref filename 0) ?/))) - ;; MS-DOS root directories can come with a drive letter; - ;; Novell Netware allows drive letters beyond `Z:'. - (not (and (memq system-type '(ms-dos windows-nt cygwin)) - (string-match "\\`[a-zA-`]:/\\'" filename))) - (equal (get 'abbreviated-home-dir 'home) - (expand-file-name "~"))) - (setq filename - (concat "~" - (substring filename mb1)))) - filename)))) + (if-let ((handler (find-file-name-handler filename 'abbreviate-file-name))) + (funcall handler 'abbreviate-file-name filename) + (if (and automount-dir-prefix + (string-match automount-dir-prefix filename) + (file-exists-p (file-name-directory + (substring filename (1- (match-end 0)))))) + (setq filename (substring filename (1- (match-end 0))))) + ;; Avoid treating /home/foo as /home/Foo during `~' substitution. + (let ((case-fold-search (file-name-case-insensitive-p filename))) + ;; If any elt of directory-abbrev-alist matches this name, + ;; abbreviate accordingly. + (setq filename (directory-abbrev-apply filename)) + + ;; Compute and save the abbreviated homedir name. + ;; We defer computing this until the first time it's needed, to + ;; give time for directory-abbrev-alist to be set properly. + (unless abbreviated-home-dir + (put 'abbreviated-home-dir 'home (expand-file-name "~")) + (setq abbreviated-home-dir + (directory-abbrev-make-regexp + (let ((abbreviated-home-dir "\\`\\'.")) ;Impossible regexp. + (abbreviate-file-name + (get 'abbreviated-home-dir 'home)))))) + + ;; If FILENAME starts with the abbreviated homedir, + ;; and ~ hasn't changed since abbreviated-home-dir was set, + ;; make it start with `~' instead. + ;; If ~ has changed, we ignore abbreviated-home-dir rather than + ;; invalidating it, on the assumption that a change in HOME + ;; is likely temporary (eg for testing). + ;; FIXME Is it even worth caching abbreviated-home-dir? + ;; Ref: https://debbugs.gnu.org/19657#20 + (let (mb1) + (if (and (string-match abbreviated-home-dir filename) + (setq mb1 (match-beginning 1)) + ;; If the home dir is just /, don't change it. + (not (and (= (match-end 0) 1) + (= (aref filename 0) ?/))) + ;; MS-DOS root directories can come with a drive letter; + ;; Novell Netware allows drive letters beyond `Z:'. + (not (and (memq system-type '(ms-dos windows-nt cygwin)) + (string-match "\\`[a-zA-`]:/\\'" filename))) + (equal (get 'abbreviated-home-dir 'home) + (expand-file-name "~"))) + (setq filename + (concat "~" + (substring filename mb1)))) + filename))))) (defun find-buffer-visiting (filename &optional predicate) "Return the buffer visiting file FILENAME (a string). @@ -7836,10 +7842,11 @@ only these files will be asked to be saved." ;; Get a list of the indices of the args that are file names. (file-arg-indices (cdr (or (assq operation - '(;; The first seven are special because they + '(;; The first eight are special because they ;; return a file name. We want to include ;; the /: in the return value. So just ;; avoid stripping it in the first place. + (abbreviate-file-name) (directory-file-name) (expand-file-name) (file-name-as-directory) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index c61025a86b..b83569f3de 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -942,7 +942,8 @@ Format specifiers \"%s\" are replaced before the script is used.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-sh-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-sh-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-sh-handle-copy-directory) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 0b25164902..24119539db 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -222,7 +222,8 @@ See `tramp-actions-before-shell' for more info.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-smb-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-smb-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-smb-handle-copy-directory) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 7cf0ea451d..c91bced656 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -63,7 +63,8 @@ See `tramp-actions-before-shell' for more info.") ;;;###tramp-autoload (defconst tramp-sudoedit-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-sudoedit-handle-add-name-to-file) (byte-compiler-base-file-name . ignore) (copy-directory . tramp-handle-copy-directory) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 5fcf7f9b65..d314df7b00 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2495,6 +2495,8 @@ Must be handled by the callers." file-system-info ;; Emacs 28+ only. file-locked-p lock-file make-lock-file-name unlock-file + ;; Emacs 29+ only. + abbreviate-file-name ;; Tramp internal magic file name function. tramp-set-file-uid-gid)) (if (file-name-absolute-p (nth 0 args)) @@ -3282,6 +3284,23 @@ User is always nil." (defvar tramp-handle-write-region-hook nil "Normal hook to be run at the end of `tramp-*-handle-write-region'.") +(defun tramp-handle-abbreviate-file-name (filename) + "Like `abbreviate-file-name' for Tramp files." + (let* ((case-fold-search (file-name-case-insensitive-p filename)) + (home-dir + (with-parsed-tramp-file-name filename nil + (with-tramp-connection-property v "home-directory" + (directory-abbrev-apply (expand-file-name + (tramp-make-tramp-file-name v "~"))))))) + ;; If any elt of directory-abbrev-alist matches this name, + ;; abbreviate accordingly. + (setq filename (directory-abbrev-apply filename)) + (if (string-match (directory-abbrev-make-regexp home-dir) filename) + (with-parsed-tramp-file-name filename nil + (tramp-make-tramp-file-name + v (concat "~" (substring filename (match-beginning 1))))) + filename))) + (defun tramp-handle-access-file (filename string) "Like `access-file' for Tramp files." (setq filename (file-truename filename)) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 52c6159dc1..698d18b528 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2289,6 +2289,31 @@ This checks also `file-name-as-directory', `file-name-directory', (should (string-equal (file-name-directory file) file)) (should (string-equal (file-name-nondirectory file) ""))))))) +(ert-deftest tramp-test07-abbreviate-file-name () + "Check that Tramp abbreviates file names correctly." + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-emacs29-p)) + + (let* ((remote-host (file-remote-p tramp-test-temporary-file-directory)) + (home-dir (expand-file-name (concat remote-host "~")))) + ;; Check home-dir abbreviation. + (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) + (concat remote-host "~/foo/bar"))) + (should (equal (abbreviate-file-name (concat remote-host + "/nowhere/special")) + (concat remote-host "/nowhere/special"))) + ;; Check `directory-abbrev-alist' abbreviation. + (let ((directory-abbrev-alist + `((,(concat "\\`" (regexp-quote home-dir) "/foo") + . ,(concat home-dir "/f")) + (,(concat "\\`" (regexp-quote remote-host) "/nowhere") + . ,(concat remote-host "/nw"))))) + (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) + (concat remote-host "~/f/bar"))) + (should (equal (abbreviate-file-name (concat remote-host + "/nowhere/special")) + (concat remote-host "/nw/special")))))) + (ert-deftest tramp-test07-file-exists-p () "Check `file-exist-p', `write-region' and `delete-file'." (skip-unless (tramp--test-enabled)) commit 199e2468d3053d9cb81b5654664d88d4c8cec3ad Author: Stefan Kangas Date: Mon Nov 15 10:58:53 2021 +0100 Doc fix; change recommended file name of custom-file * lisp/cus-edit.el (custom-file): Change file name recommendation to match Info node '(emacs) Saving Customizations'. diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index a0bde39673..5c4448ae71 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -4646,8 +4646,8 @@ You can set this option through Custom, if you carefully read the last paragraph below. However, usually it is simpler to write something like the following in your init file: -\(setq custom-file \"~/.emacs-custom.el\") -\(load custom-file) +(setq custom-file \"~/.config/emacs-custom.el\") +(load custom-file) Note that both lines are necessary: the first line tells Custom to save all customizations in this file, but does not load it. commit cff1702a52d9f116d9180a1a1597130474574fd8 Author: Stefan Kangas Date: Mon Nov 15 09:42:48 2021 +0100 Fix hanging wdired test * test/lisp/wdired-tests.el (wdired-test-bug34915): Fix hanging test. Don't start the Emacs Server just to create a socket; just create the socket manually. diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el index e768a16552..9678fce84d 100644 --- a/test/lisp/wdired-tests.el +++ b/test/lisp/wdired-tests.el @@ -22,6 +22,7 @@ (require 'ert) (require 'ert-x) (require 'dired) +(require 'dired-x) (require 'wdired) (defvar dired-query) ; Pacify byte compiler. @@ -124,10 +125,6 @@ wdired-mode." (set-buffer-modified-p nil) (kill-buffer buf)))))))) -(defvar server-socket-dir) -(declare-function dired-smart-shell-command "dired-x" - (command &optional output-buffer error-buffer)) - (ert-deftest wdired-test-bug34915 () "Test editing when dired-listing-switches includes -F. Appended file indicators should not count as part of the file @@ -137,10 +134,10 @@ suffices to compare the return values of dired-get-filename and wdired-get-filename before and after editing." ;; FIXME: Add a test for a door (indicator ">") only under Solaris? (ert-with-temp-directory test-dir - (let* ((server-socket-dir test-dir) - (dired-listing-switches "-Fl") + (let* ((dired-listing-switches "-Fl") (dired-ls-F-marks-symlinks (eq system-type 'darwin)) - (buf (find-file-noselect test-dir))) + (buf (find-file-noselect test-dir)) + proc) (unwind-protect (progn (with-current-buffer buf @@ -148,11 +145,12 @@ wdired-get-filename before and after editing." (set-file-modes "foo" (file-modes-symbolic-to-number "+x")) (make-symbolic-link "foo" "bar") (make-directory "foodir") - (require 'dired-x) (dired-smart-shell-command "mkfifo foopipe") - (server-force-delete) - ;; FIXME? This seems a heavy-handed way of making a socket. - (server-start) ; Add a socket file. + (setq proc (make-network-process + :name "foo" + :family 'local + :server t + :service (expand-file-name "foosocket" test-dir))) (kill-buffer buf)) (dired test-dir) (dired-toggle-read-only) @@ -172,7 +170,7 @@ wdired-get-filename before and after editing." (setq dir (dired-get-filename 'no-dir t))) (should (equal dir (pop names))))))) (kill-buffer (get-buffer test-dir)) - (server-force-delete))))) + (ignore-errors (delete-process proc)))))) (ert-deftest wdired-test-bug39280 () "Test for https://debbugs.gnu.org/39280." commit 2a3c8f3d2e8a9b58c8b6c93168096ed096bcc5d6 Author: Lars Ingebrigtsen Date: Mon Nov 15 07:38:07 2021 +0100 Fix outline-cycle-buffer issue in `C-h b' buffers * lisp/outline.el (outline--fix-up-all-buttons): Fix issue when called after collapsing a buffer (bug#51855). diff --git a/lisp/outline.el b/lisp/outline.el index cefb811703..9a2e4324b2 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -1014,7 +1014,10 @@ If non-nil, EVENT should be a mouse event." (when outline-minor-mode-use-buttons (outline-map-region (lambda () - (if (eq (outline--cycle-state) 'show-all) + ;; `outline--cycle-state' will fail if we're in a totally + ;; collapsed buffer -- but in that case, we're not in a + ;; `show-all' situation. + (if (eq (ignore-errors (outline--cycle-state)) 'show-all) (outline--insert-open-button) (outline--insert-close-button))) (or from (point-min)) (or to (point-max))))) commit 6aeaf12551bc63c92cd85cd936c40b2f6a99e944 Author: Lars Ingebrigtsen Date: Mon Nov 15 07:16:49 2021 +0100 Allow mm-external-terminal-program to be a list of strings * doc/misc/emacs-mime.texi (Display Customization): Document it. * lisp/gnus/mm-decode.el (mm-external-terminal-program): Allow being a list. diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi index 7cd3e5f582..96a4ad556f 100644 --- a/doc/misc/emacs-mime.texi +++ b/doc/misc/emacs-mime.texi @@ -454,7 +454,8 @@ setting this option to non-@code{nil}. The default value is @code{t}. @item mm-external-terminal-program @vindex mm-external-terminal-program -The program used to start an external terminal. +This should be a list of strings; typically something like +@samp{("xterm" "-e")} or @samp{("gnome-terminal" "--")}. @item mm-enable-external @vindex mm-enable-external diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index aca4bf2062..d781407cdc 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -446,10 +446,11 @@ If not set, `default-directory' will be used." :type 'integer :group 'mime-display) -(defcustom mm-external-terminal-program "xterm" - "The program to start an external terminal." - :version "22.1" - :type 'string +(defcustom mm-external-terminal-program '("xterm" "-e") + "The program to start an external terminal. +This should be a list of strings." + :version "29.1" + :type '(choice string (repeat string)) :group 'mime-display) ;;; Internal variables. @@ -957,10 +958,16 @@ external if displayed external." (unwind-protect (if window-system (set-process-sentinel - (start-process "*display*" nil - mm-external-terminal-program - "-e" shell-file-name - shell-command-switch command) + (apply #'start-process "*display*" nil + (append + (if (listp mm-external-terminal-program) + mm-external-terminal-program + ;; Be backwards-compatible. + (list mm-external-terminal-program + "-e")) + (list shell-file-name + shell-command-switch + command))) (lambda (process _state) (if (eq 'exit (process-status process)) (run-at-time commit a7c9695835a15bb5510a5938d9a664982170be5f Author: Basil L. Contovounesios Date: Mon Nov 15 06:52:38 2021 +0100 Fix handling of changed prefix keys in tutorial * lisp/tutorial.el (tutorial--find-changed-keys): Use keymapp to detect prefix definitions rather than hard-coding them. A notable omission from the hard-coded list was mode-specific-command-prefix, whose subcommands are often rebound (bug#40725). diff --git a/lisp/tutorial.el b/lisp/tutorial.el index 186bf35fe7..bf985280d8 100644 --- a/lisp/tutorial.el +++ b/lisp/tutorial.el @@ -423,11 +423,9 @@ where ;; Handle prefix definitions specially ;; so that a mode that rebinds some subcommands ;; won't make it appear that the whole prefix is gone. - (key-fun (if (eq def-fun 'ESC-prefix) - (lookup-key global-map [27]) - (if (eq def-fun 'Control-X-prefix) - (lookup-key global-map [24]) - (key-binding key)))) + (key-fun (if (keymapp def-fun) + (lookup-key global-map key) + (key-binding key))) (where (where-is-internal (if rem-fun rem-fun def-fun))) cwhere) commit e7d64300aa67162132a4bc8bbb1741ccec1caac5 Merge: 7f85e1017d 044dd1e210 Author: Stefan Kangas Date: Mon Nov 15 07:00:24 2021 +0100 Merge from origin/emacs-28 044dd1e210 * rcirc.el (rcirc-define-command): Fix interactive-spec ge... commit 7f85e1017d91345505e857d20007d98e8c9618e3 Merge: fba537cebc 97059bcdff Author: Stefan Kangas Date: Mon Nov 15 07:00:24 2021 +0100 ; Merge from origin/emacs-28 The following commit was skipped: 97059bcdff Fix `C-h k' in gnus-article-mode (don't merge) commit fba537cebc4dd6fbc5d83aac80704fa08ce0be5d Merge: d5a4772712 85ac0efe7c Author: Stefan Kangas Date: Mon Nov 15 07:00:24 2021 +0100 Merge from origin/emacs-28 85ac0efe7c Fix semantic-symref-perform-search doc string commit d5a4772712334851921e0c11326b27b3744f9f04 Author: Po Lu Date: Mon Nov 15 13:43:55 2021 +0800 Fix xwidget-webkit-back-forward-list * src/xwidget.c (Fxwidget_webkit_back_forward_list): Use correct list variable in loop. diff --git a/src/xwidget.c b/src/xwidget.c index 4892752432..aae2479134 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -2506,7 +2506,7 @@ LIMIT is not specified or nil, it is treated as `50'. */) if (parent) { - for (i = 1, tem = parent; parent; parent = parent->next, ++i) + for (i = 1, tem = parent; tem; tem = tem->next, ++i) { item = tem->data; item_title = webkit_back_forward_list_item_get_title (item); @@ -2524,7 +2524,7 @@ LIMIT is not specified or nil, it is treated as `50'. */) if (parent) { - for (i = 1, tem = parent; parent; parent = parent->next, ++i) + for (i = 1, tem = parent; tem; tem = tem->next, ++i) { item = tem->data; item_title = webkit_back_forward_list_item_get_title (item); commit d9e91da7690a7872a27d9fcb652a170d84e4d891 Author: Po Lu Date: Mon Nov 15 09:27:31 2021 +0800 Stop assuming xwidget views will only be displayed in TEXT_AREA * src/xterm.c (x_scroll_run): Use view->area when calculating xwidget view clipping. * src/xwidget.c (x_draw_xwidget_glyph_string): Set view->area to s->area and use that instead. * src/xwidget.h (struct xwidget_view): Add glyph row area field. diff --git a/src/xterm.c b/src/xterm.c index fd498c0e32..5988d3a15f 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -4439,7 +4439,7 @@ x_scroll_run (struct window *w, struct run *run) int text_area_x, text_area_y, text_area_width, text_area_height; int clip_top, clip_bottom; - window_box (w, TEXT_AREA, &text_area_x, &text_area_y, + window_box (w, view->area, &text_area_x, &text_area_y, &text_area_width, &text_area_height); view->y = y; diff --git a/src/xwidget.c b/src/xwidget.c index 0e8bf13715..4892752432 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -1631,7 +1631,9 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) } #endif - window_box (s->w, TEXT_AREA, &text_area_x, &text_area_y, + xv->area = s->area; + + window_box (s->w, xv->area, &text_area_x, &text_area_y, &text_area_width, &text_area_height); clip_left = max (0, text_area_x - x); diff --git a/src/xwidget.h b/src/xwidget.h index 4377b50e84..df55dacffe 100644 --- a/src/xwidget.h +++ b/src/xwidget.h @@ -104,6 +104,8 @@ struct xwidget_view /* The "live" instance isn't drawn. */ bool hidden; + enum glyph_row_area area; + #if defined (USE_GTK) Display *dpy; Window wdesc; commit 364cf2494c9b94e1d265b637394c80c4eecfb505 Author: Ken Brown Date: Sun Nov 14 10:30:44 2021 -0500 Prefer POSIX timers to timerfd timers * src/atimer.c (set_alarm): Try to start a POSIX timer before starting a timerfd timer. On Cygwin, return if the POSIX timer is started successfully. (Bug#51734) diff --git a/src/atimer.c b/src/atimer.c index 9bde9c2446..df35603f32 100644 --- a/src/atimer.c +++ b/src/atimer.c @@ -309,24 +309,29 @@ set_alarm (void) struct itimerspec ispec; ispec.it_value = atimers->expiration; ispec.it_interval.tv_sec = ispec.it_interval.tv_nsec = 0; + if (alarm_timer_ok + && timer_settime (alarm_timer, TIMER_ABSTIME, &ispec, 0) == 0) + exit = true; + + /* Don't start both timerfd and POSIX timers on Cygwin; this + causes a slowdown (bug#51734). Prefer POSIX timers + because the timerfd notifications aren't delivered while + Emacs is busy, which prevents things like the hourglass + pointer from being displayed reliably (bug#19776). */ +# ifdef CYGWIN + if (exit) + return; +# endif + # ifdef HAVE_TIMERFD - if (timerfd_settime (timerfd, TFD_TIMER_ABSTIME, &ispec, 0) == 0) + if (0 <= timerfd + && timerfd_settime (timerfd, TFD_TIMER_ABSTIME, &ispec, 0) == 0) { add_timer_wait_descriptor (timerfd); exit = true; } # endif -# ifdef CYGWIN - /* Don't start both timerfd and alarms on Cygwin; this - causes a slowdown (bug#51734). */ - if (exit) - return; -# endif - if (alarm_timer_ok - && timer_settime (alarm_timer, TIMER_ABSTIME, &ispec, 0) == 0) - exit = true; - if (exit) return; } commit 044dd1e21028fad3cf8d976dae887503dbab6ae3 Author: Philip Kaludercic Date: Sun Nov 14 19:41:31 2021 +0100 * rcirc.el (rcirc-define-command): Fix interactive-spec generation * rcirc.el (rcirc-define-command): Wrap interactive spec in a list call. diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 52d74a3394..5c92c60eda 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -2583,7 +2583,7 @@ that, an interactive form can specified." ,(concat documentation "\n\nNote: If PROCESS or TARGET are nil, the values given" "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") - (interactive ,interactive-spec) + (interactive (list ,interactive-spec)) (unless (if (listp ,argument) (<= ,required (length ,argument) ,total) (string-match ,regexp ,argument)) commit e6df5a32d07564115488643206396ba0c28decf2 Author: Juri Linkov Date: Sun Nov 14 20:35:42 2021 +0200 * lisp/tab-line.el (tab-line-mode): Preserve existing value of tab-line-format Keep the old value of tab-line-format when enabling tab-line-mode and don't overwrite it with nil when disabling tab-line-mode (bug#51830). diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 5affae7913..110c6e9696 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -893,7 +893,14 @@ sight of the tab line." (define-minor-mode tab-line-mode "Toggle display of tab line in the windows displaying the current buffer." :lighter nil - (setq tab-line-format (when tab-line-mode '(:eval (tab-line-format))))) + (let ((default-value '(:eval (tab-line-format)))) + (if tab-line-mode + ;; Preserve the existing tab-line set outside of this mode + (unless tab-line-format + (setq tab-line-format default-value)) + ;; Reset only values set by this mode + (when (equal tab-line-format default-value) + (setq tab-line-format nil))))) (defcustom tab-line-exclude-modes '(completion-list-mode) commit 572eed83fcce65c3f81cbbfd777f5020bed1d81a Author: Stefan Monnier Date: Sun Nov 14 12:56:11 2021 -0500 * src/lread.c (read_escape): Fix handling of ?\C- for chars 128-255 diff --git a/src/lread.c b/src/lread.c index 3052bcbd06..2e63ec4891 100644 --- a/src/lread.c +++ b/src/lread.c @@ -2709,7 +2709,7 @@ read_escape (Lisp_Object readcharfun, bool stringp) c = read_escape (readcharfun, 0); if ((c & ~CHAR_MODIFIER_MASK) == '?') return 0177 | (c & CHAR_MODIFIER_MASK); - else if (! SINGLE_BYTE_CHAR_P ((c & ~CHAR_MODIFIER_MASK))) + else if (! ASCII_CHAR_P ((c & ~CHAR_MODIFIER_MASK))) return c | ctrl_modifier; /* ASCII control chars are made from letters (both cases), as well as the non-letters within 0100...0137. */ diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index be685fe999..c635c592b2 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -115,6 +115,10 @@ (should-error (read "#24r") :type 'invalid-read-syntax) (should-error (read "#") :type 'invalid-read-syntax)) +(ert-deftest lread-char-modifiers () + (should (eq ?\C-\M-é (+ (- ?\M-a ?a) ?\C-é))) + (should (eq (- ?\C-ŗ ?ŗ) (- ?\C-é ?é)))) + (ert-deftest lread-record-1 () (should (equal '(#s(foo) #s(foo)) (read "(#1=#s(foo) #1#)")))) commit 97059bcdffe722ab92ca39209c3a3b62144b19a1 Author: Lars Ingebrigtsen Date: Sun Nov 14 02:46:38 2021 +0100 Fix `C-h k' in gnus-article-mode (don't merge) * lisp/gnus/gnus-art.el (gnus-article-describe-key): (gnus-article-describe-key-briefly): Fix `describe-key' calling convention (bug#51796). diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index cce0fc32b7..b97cd711c4 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -6867,8 +6867,8 @@ KEY is a string or a vector." unread-command-events)) (let ((cursor-in-echo-area t) gnus-pick-mode) - (describe-key (cons (read-key-sequence nil t) - (this-single-command-raw-keys)) + (describe-key (list (cons (read-key-sequence nil t) + (this-single-command-raw-keys))) (current-buffer)))) (describe-key key))) @@ -6892,8 +6892,8 @@ KEY is a string or a vector." unread-command-events)) (let ((cursor-in-echo-area t) gnus-pick-mode) - (describe-key-briefly (cons (read-key-sequence nil t) - (this-single-command-raw-keys)) + (describe-key-briefly (list (cons (read-key-sequence nil t) + (this-single-command-raw-keys))) insert (current-buffer)))) (describe-key-briefly key insert))) commit d75ba220e0a5a4ed26d086c305bc4ea4e4647e5d Author: Eli Zaretskii Date: Sun Nov 14 19:42:37 2021 +0200 ; Revert "* lisp/progmodes/python.el (python-forward-sexp-function): :version fix." This reverts commit e6e29b435273ee9821b6536581bd151f3e50737d. The commit was a mistake. diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 329e654226..47d8d1ce8e 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -1429,7 +1429,7 @@ marks the next defun after the ones already marked." (defcustom python-forward-sexp-function #'python-nav-forward-sexp "Function to use when navigating between expressions." - :version "29.1" + :version "28.1" :type '(choice (const :tag "Python blocks" python-nav-forward-sexp) (const :tag "CC-mode like" nil) function)) commit e6e29b435273ee9821b6536581bd151f3e50737d Author: Eli Zaretskii Date: Sun Nov 14 18:58:57 2021 +0200 ; * lisp/progmodes/python.el (python-forward-sexp-function): :version fix. diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 47d8d1ce8e..329e654226 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -1429,7 +1429,7 @@ marks the next defun after the ones already marked." (defcustom python-forward-sexp-function #'python-nav-forward-sexp "Function to use when navigating between expressions." - :version "28.1" + :version "29.1" :type '(choice (const :tag "Python blocks" python-nav-forward-sexp) (const :tag "CC-mode like" nil) function)) commit acbc7239021e902470d36d99e6c607080fff8fc5 Author: Eli Zaretskii Date: Sun Nov 14 18:55:37 2021 +0200 Fix recent documentation updates * doc/lispref/text.texi (Special Properties): Improve wording. Add cross-reference and index entry. (Sticky Properties): Add indexing. diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 32773818e5..863b318c20 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -3650,13 +3650,14 @@ property is obsolete; use the @code{cursor-intangible} property instead. @item cursor-intangible @kindex cursor-intangible @r{(text property)} @findex cursor-intangible-mode +@cindex rear-nonsticky, and cursor-intangible property When the minor mode @code{cursor-intangible-mode} is turned on, point is moved away from any position that has a non-@code{nil} @code{cursor-intangible} property, just before redisplay happens. -Note that @code{rear-nonsticky} is taken into account when computing -allowed cursor positions, so (for instance) to insert a stretch of -five @samp{x} characters you can't put point on, you have to do -something like: +Note that ``stickiness'' of the property (@pxref{Sticky Properties}) +is taken into account when computing allowed cursor positions, so (for +instance) to insert a stretch of five @samp{x} characters into which +the cursor can't enter, you should do something like: @lisp (insert @@ -3960,6 +3961,8 @@ of the kill ring. To insert with inheritance, use the special primitives described in this section. Self-inserting characters inherit properties because they work using these primitives. +@cindex front-sticky text property +@cindex rear-nonsticky text property When you do insertion with inheritance, @emph{which} properties are inherited, and from where, depends on which properties are @dfn{sticky}. Insertion after a character inherits those of its properties that are commit 85ac0efe7c8c43627b2db7aabed18125eb4cb535 Author: Daniel Martín Date: Sun Nov 14 15:30:52 2021 +0100 Fix semantic-symref-perform-search doc string * lisp/cedet/semantic/symref/cscope.el (semantic-symref-perform-search): Fix the docstring to refer to the correct tool (bug#51846). diff --git a/lisp/cedet/semantic/symref/cscope.el b/lisp/cedet/semantic/symref/cscope.el index e63b7a7e91..bc3f4a248b 100644 --- a/lisp/cedet/semantic/symref/cscope.el +++ b/lisp/cedet/semantic/symref/cscope.el @@ -43,7 +43,7 @@ the hit list. See the function `cedet-cscope-search' for more details.") (cl-defmethod semantic-symref-perform-search ((tool semantic-symref-tool-cscope)) - "Perform a search with GNU Global." + "Perform a search with CScope." (let* ((rootproj (when (and (featurep 'ede) ede-minor-mode) (ede-toplevel))) (default-directory (if rootproj commit 8aba549263e2660b4ac4f1026b23fbc5caef8168 Author: Michael Albinus Date: Sun Nov 14 14:41:58 2021 +0100 Improve Tramp error handling * doc/misc/tramp.texi (Frequently Asked Questions): Add another `remote-file-error'. * lisp/net/tramp.el (tramp-find-foreign-file-name-handler): Improve error handling. diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 819670a508..0825e85e4d 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -5222,6 +5222,28 @@ time being you can suppress this error by the following code in your @end lisp +@item +I get an error @samp{Remote file error: Not a valid Tramp file name +function `tramp-FOO-file-name-p'} + +@value{tramp} has changed the signature of an internal function. +External packages implementing an own @value{tramp} backend must +follow this change. Please report this problem to the author of that +package. + +For the running session, @value{tramp} disables the external package, +and you can continue to work. If you don't want to see this error +while activating @value{tramp}, you can suppress it by the same code +as above in your @file{~/.emacs}: + +@lisp +@group +(setq debug-ignored-errors + (cons 'remote-file-error debug-ignored-errors)) +@end group +@end lisp + + @item How to disable other packages from calling @value{tramp}? diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 876bbb2c54..5fcf7f9b65 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2552,13 +2552,20 @@ Must be handled by the callers." (when (tramp-tramp-file-p filename) (let ((handler tramp-foreign-file-name-handler-alist) (vec (tramp-dissect-file-name filename)) - elt res) + elt func res) (while handler (setq elt (car handler) handler (cdr handler)) ;; Previously, this function was called with FILENAME, but now ;; it's called with the VEC. - (when (with-demoted-errors "Error: %S" (funcall (car elt) vec)) + (when (condition-case nil + (funcall (setq func (car elt)) vec) + (error + (setcar elt #'ignore) + (unless (member 'remote-file-error debug-ignored-errors) + (tramp-error + vec 'remote-file-error + "Not a valid Tramp file name function `%s'" func)))) (setq handler nil res (cdr elt)))) res))) commit 091a6126ac743382ee40795cfe24710c24bf4461 Merge: 5660ae795b 289f3a9e5f Author: Eli Zaretskii Date: Sun Nov 14 15:02:44 2021 +0200 ; Merge from origin/emacs-28 The following commit was skipped: 289f3a9 Add more files to be natively-compiled AOT commit 5660ae795b916664cea264b81febf2ed9c14f3fd Merge: 80d23e4438 5dbad52cbf Author: Eli Zaretskii Date: Sun Nov 14 15:02:42 2021 +0200 Merge from origin/emacs-28 5dbad52 gnus-summary-line-format doc string clarification d4536ff Fix follow-scroll-down in a small buffer which starts slightl... commit 80d23e4438aeb5bebba50ef961937977034c3be7 Merge: 96806a22fb 480241983e Author: Eli Zaretskii Date: Sun Nov 14 15:02:41 2021 +0200 ; Merge from origin/emacs-28 The following commits were skipped: 4802419 Fix compilation on MS-Windows cc4edea Use posix_spawn if possible. commit 96806a22fbb54573053fdb796ebde4b6284b98ae Merge: c3f53d2604 a56dd60d2f Author: Eli Zaretskii Date: Sun Nov 14 15:02:39 2021 +0200 Merge from origin/emacs-28 a56dd60 Improve style and comments in font-related sources commit 289f3a9e5f47bcc70391f0a36c556d964542ee80 Author: Eli Zaretskii Date: Sun Nov 14 14:46:27 2021 +0200 Add more files to be natively-compiled AOT * src/Makefile.in (elnlisp): Add emacs-lisp/gv.eln and other missing dependencies of comp.el. diff --git a/src/Makefile.in b/src/Makefile.in index 6d75e3537a..954d548216 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -796,6 +796,16 @@ elnlisp := \ international/charscript.eln \ emacs-lisp/comp.eln \ emacs-lisp/comp-cstr.eln \ + emacs-lisp/cl-macs.eln \ + emacs-lisp/rx.eln \ + emacs-lisp/cl-seq.eln \ + help-mode.eln \ + emacs-lisp/cl-extra.eln \ + emacs-lisp/gv.eln \ + emacs-lisp/seq.eln \ + emacs-lisp/cl-lib.eln \ + emacs-lisp/warnings.eln \ + emacs-lisp/subr-x.eln \ international/emoji-zwj.eln elnlisp := $(addprefix ${lispsource}/,${elnlisp}) $(lisp:.elc=.eln) commit c3f53d26043a4e4a91a3f1d140f080b6c8d190d2 Author: Po Lu Date: Thu Nov 11 09:01:38 2021 +0800 Expose xwidget navigation history to Lisp code * doc/lispref/display.texi (Xwidgets): Document changes. * etc/NEWS: Announce new function. * src/xwidget.c (Fxwidget_webkit_back_forward_list): New function. (syms_of_xwidget): Define new subr. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 3ab29dc591..dd2c6e003f 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -6971,6 +6971,39 @@ the absolute location of the web resources referenced by @var{text}, to be used for resolving relative links in @var{text}. @end defun +@defun xwidget-webkit-goto-history xwidget rel-pos +Make @var{xwidget}, a WebKit widget, load the @var{rel-pos}th element +in its navigation history. + +If @var{rel-pos} is zero, the current page will be reloaded instead. +@end defun + +@defun xwidget-webkit-back-forward-list xwidget &optional limit +Return the navigation history of @var{xwidget}, up to @var{limit} +items in each direction. If not specified, @var{limit} defaults to +50. + +The returned value is a list of the form @w{@code{(@var{back} +@var{here} @var{forward})}}, where @var{here} is the current +navigation item, while @var{back} is a list of items containing the +items recorded by WebKit before the current navigation item, and +@var{forward} is a list of items recorded after the current navigation +item. @var{back}, @var{here} and @var{forward} can all be @code{nil}. + +When @var{here} is @code{nil}, it means that no items have been +recorded yet; if @var{back} or @var{forward} are @code{nil}, it means +that there is no history recorded before or after the current item +respectively. + +Navigation items are themselves lists of the form @w{@code{(@var{idx} +@var{title} @var{uri})}}. In these lists, @var{idx} is an index that +can be passed to @code{xwidget-webkit-goto-history}, @var{title} is +the human-readable title of the item, and @var{uri} is the URI of the +item. The user should normally have no reason to load @var{uri} +manually to reach a specific history item. Instead, @var{idx} should +be passed as an index to @code{xwidget-webkit-goto-history}. +@end defun + @node Buttons @section Buttons @cindex buttons in buffers diff --git a/etc/NEWS b/etc/NEWS index c362e56cee..312fc18f4f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -781,6 +781,11 @@ markup, and passing the URI of the file as an argument to Some new functions, such as 'xwidget-webkit-search', have been added for performing searches on WebKit xwidgets. ++++ +*** New function 'xwidget-webkit-back-forward-list'. +This function is used to obtain the history of page-loads in a given +WebKit xwidget. + +++ *** 'load-changed' xwidget events are now more detailed. In particular, they can now have different arguments based on the diff --git a/src/xwidget.c b/src/xwidget.c index 344016ed74..0e8bf13715 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -20,6 +20,7 @@ along with GNU Emacs. If not, see . */ #include #include "buffer.h" +#include "coding.h" #include "xwidget.h" #include "lisp.h" @@ -2444,6 +2445,99 @@ to "about:blank". */) return Qnil; } + +DEFUN ("xwidget-webkit-back-forward-list", Fxwidget_webkit_back_forward_list, + Sxwidget_webkit_back_forward_list, 1, 2, 0, + doc: /* Return the navigation history of XWIDGET, a WebKit xwidget. + +Return the history as a list of the form (BACK HERE FORWARD), where +HERE is the current navigation item, while BACK and FORWARD are lists +of history items of the form (IDX TITLE URI). Here, IDX is an index +that can be passed to `xwidget-webkit-goto-history', TITLE is a string +containing the human-readable title of the history item, and URI is +the URI of the history item. + +BACK, HERE, and FORWARD can all be nil depending on the state of the +navigation history. + +BACK and FORWARD will each not contain more elements than LIMIT. If +LIMIT is not specified or nil, it is treated as `50'. */) + (Lisp_Object xwidget, Lisp_Object limit) +{ + struct xwidget *xw; + Lisp_Object back, here, forward; + WebKitWebView *webview; + WebKitBackForwardList *list; + WebKitBackForwardListItem *item; + GList *parent, *tem; + int i; + unsigned int lim; + Lisp_Object title, uri; + const gchar *item_title, *item_uri; + + back = Qnil; + here = Qnil; + forward = Qnil; + + if (NILP (limit)) + limit = make_fixnum (50); + else + CHECK_FIXNAT (limit); + + CHECK_LIVE_XWIDGET (xwidget); + xw = XXWIDGET (xwidget); + + webview = WEBKIT_WEB_VIEW (xw->widget_osr); + list = webkit_web_view_get_back_forward_list (webview); + item = webkit_back_forward_list_get_current_item (list); + lim = XFIXNAT (limit); + + if (item) + { + item_title = webkit_back_forward_list_item_get_title (item); + item_uri = webkit_back_forward_list_item_get_uri (item); + here = list3 (make_fixnum (0), + build_string_from_utf8 (item_title ? item_title : ""), + build_string_from_utf8 (item_uri ? item_uri : "")); + } + parent = webkit_back_forward_list_get_back_list_with_limit (list, lim); + + if (parent) + { + for (i = 1, tem = parent; parent; parent = parent->next, ++i) + { + item = tem->data; + item_title = webkit_back_forward_list_item_get_title (item); + item_uri = webkit_back_forward_list_item_get_uri (item); + title = build_string_from_utf8 (item_title ? item_title : ""); + uri = build_string_from_utf8 (item_uri ? item_uri : ""); + back = Fcons (list3 (make_fixnum (-i), title, uri), back); + } + } + + back = Fnreverse (back); + g_list_free (parent); + + parent = webkit_back_forward_list_get_forward_list_with_limit (list, lim); + + if (parent) + { + for (i = 1, tem = parent; parent; parent = parent->next, ++i) + { + item = tem->data; + item_title = webkit_back_forward_list_item_get_title (item); + item_uri = webkit_back_forward_list_item_get_uri (item); + title = build_string_from_utf8 (item_title ? item_title : ""); + uri = build_string_from_utf8 (item_uri ? item_uri : ""); + forward = Fcons (list3 (make_fixnum (i), title, uri), forward); + } + } + + forward = Fnreverse (forward); + g_list_free (parent); + + return list3 (back, here, forward); +} #endif void @@ -2488,6 +2582,7 @@ syms_of_xwidget (void) defsubr (&Sset_xwidget_buffer); #ifdef USE_GTK defsubr (&Sxwidget_webkit_load_html); + defsubr (&Sxwidget_webkit_back_forward_list); #endif defsubr (&Skill_xwidget); commit 609bc1d33ad81f9f2ffa0ff34522cfdb743d2dbb Author: Po Lu Date: Sun Nov 14 13:02:41 2021 +0800 Add `kill-xwidget' * doc/lispref/display.texi (Xwidgets): Document 'kill-xwidget'. * src/xwidget.c (kill_xwidget, Fkill_xwidget): New function. (syms_of_xwidget): Define new subr. (kill_buffer_xwidgets): Use `kill_xwidget' instead. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index a8a7837a4a..3ab29dc591 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -6806,10 +6806,11 @@ widget that the newly created widget should share settings and subprocesses with. The xwidget that is returned will be killed alongside its buffer -(@pxref{Killing Buffers}). Once it is killed, the xwidget may -continue to exist as a Lisp object and act as a @code{display} -property until all references to it are gone, but most actions that -can be performed on live xwidgets will no longer be available. +(@pxref{Killing Buffers}). You can also kill it using +@code{xwidget-kill}. Once it is killed, the xwidget may continue to +exist as a Lisp object and act as a @code{display} property until all +references to it are gone, but most actions that can be performed on +live xwidgets will no longer be available. @end defun @defun xwidgetp object @@ -6822,6 +6823,11 @@ This function returns @code{t} if @var{object} is an xwidget that hasn't been killed, and @code{nil} otherwise. @end defun +@defun kill-xwidget xwidget +This function kills @var{xwidget}, by removing it from its buffer and +releasing window system resources it holds. +@end defun + @defun xwidget-plist xwidget This function returns the property list of @var{xwidget}. @end defun diff --git a/src/xwidget.c b/src/xwidget.c index 609a231d4b..344016ed74 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -76,6 +76,8 @@ allocate_xwidget_view (void) static struct xwidget_view *xwidget_view_lookup (struct xwidget *, struct window *); +static void kill_xwidget (struct xwidget *); + #ifdef USE_GTK static void webkit_view_load_changed_cb (WebKitWebView *, WebKitLoadEvent, @@ -2386,6 +2388,25 @@ using `xwidget-webkit-search'. */) return Qnil; } +DEFUN ("kill-xwidget", Fkill_xwidget, Skill_xwidget, + 1, 1, 0, + doc: /* Kill the specified XWIDGET. +This releases all window system resources associated with XWIDGET, +removes it from `xwidget-list', and detaches it from its buffer. */) + (Lisp_Object xwidget) +{ + struct xwidget *xw; + + CHECK_LIVE_XWIDGET (xwidget); + xw = XXWIDGET (xwidget); + + block_input (); + kill_xwidget (xw); + unblock_input (); + + return Qnil; +} + #ifdef USE_GTK DEFUN ("xwidget-webkit-load-html", Fxwidget_webkit_load_html, Sxwidget_webkit_load_html, 2, 3, 0, @@ -2468,6 +2489,7 @@ syms_of_xwidget (void) #ifdef USE_GTK defsubr (&Sxwidget_webkit_load_html); #endif + defsubr (&Skill_xwidget); DEFSYM (QCxwidget, ":xwidget"); DEFSYM (QCtitle, ":title"); @@ -2708,6 +2730,40 @@ kill_frame_xwidget_views (struct frame *f) } #endif +static void +kill_xwidget (struct xwidget *xw) +{ +#ifdef USE_GTK + xw->buffer = Qnil; + + if (xw->widget_osr && xw->widgetwindow_osr) + { + gtk_widget_destroy (xw->widget_osr); + gtk_widget_destroy (xw->widgetwindow_osr); + } + + if (xw->find_text) + xfree (xw->find_text); + + if (!NILP (xw->script_callbacks)) + { + for (ptrdiff_t idx = 0; idx < ASIZE (xw->script_callbacks); idx++) + { + Lisp_Object cb = AREF (xw->script_callbacks, idx); + if (!NILP (cb)) + xfree (xmint_pointer (XCAR (cb))); + ASET (xw->script_callbacks, idx, Qnil); + } + } + + xw->widget_osr = NULL; + xw->widgetwindow_osr = NULL; + xw->find_text = NULL; +#elif defined NS_IMPL_COCOA + nsxwidget_kill (xw); +#endif +} + /* Kill all xwidget in BUFFER. */ void kill_buffer_xwidgets (Lisp_Object buffer) @@ -2721,31 +2777,8 @@ kill_buffer_xwidgets (Lisp_Object buffer) { CHECK_LIVE_XWIDGET (xwidget); struct xwidget *xw = XXWIDGET (xwidget); - xw->buffer = Qnil; - -#ifdef USE_GTK - if (xw->widget_osr && xw->widgetwindow_osr) - { - gtk_widget_destroy (xw->widget_osr); - gtk_widget_destroy (xw->widgetwindow_osr); - } - if (xw->find_text) - xfree (xw->find_text); - if (!NILP (xw->script_callbacks)) - for (ptrdiff_t idx = 0; idx < ASIZE (xw->script_callbacks); idx++) - { - Lisp_Object cb = AREF (xw->script_callbacks, idx); - if (!NILP (cb)) - xfree (xmint_pointer (XCAR (cb))); - ASET (xw->script_callbacks, idx, Qnil); - } - xw->widget_osr = NULL; - xw->widgetwindow_osr = NULL; - xw->find_text = NULL; -#elif defined NS_IMPL_COCOA - nsxwidget_kill (xw); -#endif + kill_xwidget (xw); } } } commit 06632fbaf81900143aec988a846ee18e33a85e50 Author: Lars Ingebrigtsen Date: Sun Nov 14 09:41:22 2021 +0100 Fix previous -responsible-p change * lisp/vc/vc-sccs.el (vc-sccs-responsible-p): * lisp/vc/vc-rcs.el (vc-rcs-responsible-p): * lisp/vc/vc-cvs.el (vc-cvs-responsible-p): Make the previous change work with relative file names, too. diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index 7062c4971f..c895447224 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -313,7 +313,7 @@ to the CVS command." file (file-name-directory file)))) (and (file-directory-p (expand-file-name "CVS" dir)) - dir))) + (file-name-directory (expand-file-name "CVS" dir))))) (defun vc-cvs-could-register (file) "Return non-nil if FILE could be registered in CVS. diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index 226e162d8b..2422e99d3d 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -294,7 +294,7 @@ to the RCS command." file (file-name-directory file)))) (and (file-directory-p (expand-file-name "RCS" dir)) - dir))) + (file-name-directory (expand-file-name "RCS" dir))))) (defun vc-rcs-receive-file (file rev) "Implementation of receive-file for RCS." diff --git a/lisp/vc/vc-sccs.el b/lisp/vc/vc-sccs.el index d59ccb37b3..4b56fbf28e 100644 --- a/lisp/vc/vc-sccs.el +++ b/lisp/vc/vc-sccs.el @@ -216,7 +216,7 @@ to the SCCS command." ;; TODO: check for all the patterns in vc-sccs-master-templates (or (and (file-directory-p (expand-file-name "SCCS" (file-name-directory file))) - file) + (file-name-directory file)) (let ((dir (vc-sccs-search-project-dir (or (file-name-directory file) "") (file-name-nondirectory file)))) (and (stringp dir) commit 5dbad52cbfa81585111edd67631af632ac13fdea Author: Lars Ingebrigtsen Date: Sun Nov 14 04:54:40 2021 +0100 gnus-summary-line-format doc string clarification * lisp/gnus/gnus.el (gnus-summary-line-format): Clarify the Date part of the doc string (bug#51823). diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index f558360361..1d19a2ac56 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -2717,7 +2717,7 @@ with some simple extensions. %F Contents of the From: header (string) %f Contents of the From: or To: headers (string) %x Contents of the Xref: header (string) -%D Date of the article (string) +%D Contents of the Date: header article (string) %d Date of the article (string) in DD-MMM format %o Date of the article (string) in YYYYMMDD`T'HHMMSS format commit 370d4038c5a671d3b9e3a4d28d849948c1a96f53 Author: Lars Ingebrigtsen Date: Sun Nov 14 03:14:35 2021 +0100 Explain in the manual how to make `cursor-intangible' work * doc/lispref/text.texi (Special Properties): Explain how to make `cursor-intangible' work (bug#51095). diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 937680c200..32773818e5 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -3653,6 +3653,16 @@ property is obsolete; use the @code{cursor-intangible} property instead. When the minor mode @code{cursor-intangible-mode} is turned on, point is moved away from any position that has a non-@code{nil} @code{cursor-intangible} property, just before redisplay happens. +Note that @code{rear-nonsticky} is taken into account when computing +allowed cursor positions, so (for instance) to insert a stretch of +five @samp{x} characters you can't put point on, you have to do +something like: + +@lisp +(insert + (propertize "xxxx" 'cursor-intangible t) + (propertize "x" 'cursor-intangible t 'rear-nonsticky t)) +@end lisp @vindex cursor-sensor-inhibit When the variable @code{cursor-sensor-inhibit} is non-@code{nil}, the commit 9627b731c0611fd14850edd2e045f2c606fc151e Author: Po Lu Date: Sun Nov 14 09:58:21 2021 +0800 Fix crash in xwidget_end_redisplay * src/xwidget.c (xwidget_end_redisplay): Always test if xv is NULL. diff --git a/src/xwidget.c b/src/xwidget.c index ca0392a44d..609a231d4b 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -2643,19 +2643,16 @@ xwidget_end_redisplay (struct window *w, struct glyph_matrix *matrix) xwidget_end_redisplay (w->current_matrix); */ struct xwidget_view *xv = xwidget_view_lookup (xwidget_from_id (glyph->u.xwidget), w); -#ifdef USE_GTK - /* FIXME: Is it safe to assume xwidget_view_lookup - always succeeds here? If so, this comment can be removed. - If not, the code probably needs fixing. */ - eassume (xv); - xwidget_touch (xv); -#elif defined NS_IMPL_COCOA - /* In NS xwidget, xv can be NULL for the second or + + /* In NS xwidget, xv can be NULL for the second or later views for a model, the result of 1 to 1 - model view relation enforcement. */ + model view relation enforcement. `xwidget_view_lookup' + has also been observed to return NULL here on X-Windows + at least once, so stay safe and only touch it if it's + not NULL. */ + if (xv) xwidget_touch (xv); -#endif } } } commit e29c9308b14893622c257a1c106ec734e2e70dc7 Author: Lars Ingebrigtsen Date: Sun Nov 14 02:46:38 2021 +0100 Fix `C-h k' in gnus-article-mode * lisp/gnus/gnus-art.el (gnus-article-describe-key): (gnus-article-describe-key-briefly): Fix `describe-key' calling convention (bug#51796). diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 78ce89dde3..23f1431b80 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -6897,8 +6897,8 @@ KEY is a string or a vector." unread-command-events)) (let ((cursor-in-echo-area t) gnus-pick-mode) - (describe-key (cons (read-key-sequence nil t) - (this-single-command-raw-keys)) + (describe-key (list (cons (read-key-sequence nil t) + (this-single-command-raw-keys))) (current-buffer)))) (describe-key key))) @@ -6922,8 +6922,8 @@ KEY is a string or a vector." unread-command-events)) (let ((cursor-in-echo-area t) gnus-pick-mode) - (describe-key-briefly (cons (read-key-sequence nil t) - (this-single-command-raw-keys)) + (describe-key-briefly (list (cons (read-key-sequence nil t) + (this-single-command-raw-keys))) insert (current-buffer)))) (describe-key-briefly key insert))) commit ad442b8887eb08cf125797863bd992792cb4ac4a Author: Lars Ingebrigtsen Date: Sun Nov 14 02:38:48 2021 +0100 Make all vc-*-responsible-p functions return a string * lisp/vc/vc-sccs.el (vc-sccs-responsible-p): * lisp/vc/vc-rcs.el (vc-rcs-responsible-p): * lisp/vc/vc-dav.el (vc-dav-responsible-p): * lisp/vc/vc-cvs.el (vc-cvs-responsible-p): Return a file name instead of t when we get a match (which is what vc-backend-for-registration expects) (bug#51800). diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index 6f921ac2a0..7062c4971f 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -309,10 +309,11 @@ to the CVS command." (defun vc-cvs-responsible-p (file) "Return non-nil if CVS thinks it is responsible for FILE." - (file-directory-p (expand-file-name "CVS" - (if (file-directory-p file) - file - (file-name-directory file))))) + (let ((dir (if (file-directory-p file) + file + (file-name-directory file)))) + (and (file-directory-p (expand-file-name "CVS" dir)) + dir))) (defun vc-cvs-could-register (file) "Return non-nil if FILE could be registered in CVS. diff --git a/lisp/vc/vc-dav.el b/lisp/vc/vc-dav.el index fe631ee09a..49a8af10e7 100644 --- a/lisp/vc/vc-dav.el +++ b/lisp/vc/vc-dav.el @@ -136,10 +136,10 @@ It should return a status of either 0 (no differences found), or "Find the version control state of all files in DIR in a fast way." ) -(defun vc-dav-responsible-p (_url) +(defun vc-dav-responsible-p (url) "Return non-nil if DAV considers itself `responsible' for URL." ;; Check for DAV support on the web server. - t) + (and t url)) ;;; Unimplemented functions ;; diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index e38469ba9f..226e162d8b 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -290,10 +290,11 @@ to the RCS command." (defun vc-rcs-responsible-p (file) "Return non-nil if RCS thinks it would be responsible for registering FILE." ;; TODO: check for all the patterns in vc-rcs-master-templates - (file-directory-p (expand-file-name "RCS" - (if (file-directory-p file) - file - (file-name-directory file))))) + (let ((dir (if (file-directory-p file) + file + (file-name-directory file)))) + (and (file-directory-p (expand-file-name "RCS" dir)) + dir))) (defun vc-rcs-receive-file (file rev) "Implementation of receive-file for RCS." diff --git a/lisp/vc/vc-sccs.el b/lisp/vc/vc-sccs.el index bcbb87eba8..d59ccb37b3 100644 --- a/lisp/vc/vc-sccs.el +++ b/lisp/vc/vc-sccs.el @@ -214,9 +214,13 @@ to the SCCS command." (defun vc-sccs-responsible-p (file) "Return non-nil if SCCS thinks it would be responsible for registering FILE." ;; TODO: check for all the patterns in vc-sccs-master-templates - (or (file-directory-p (expand-file-name "SCCS" (file-name-directory file))) - (stringp (vc-sccs-search-project-dir (or (file-name-directory file) "") - (file-name-nondirectory file))))) + (or (and (file-directory-p + (expand-file-name "SCCS" (file-name-directory file))) + file) + (let ((dir (vc-sccs-search-project-dir (or (file-name-directory file) "") + (file-name-nondirectory file)))) + (and (stringp dir) + dir)))) (defun vc-sccs-checkin (files comment &optional rev) "SCCS-specific version of `vc-backend-checkin'." commit 48ffbcf7eb6626dd46b40c3cd1cb9df83720146a Author: Kévin Le Gouguec Date: Sun Nov 14 02:30:06 2021 +0100 Fix customization group of python-forward-sexp-function * lisp/progmodes/python.el (python-forward-sexp-function): Move from the "Flymake integration" subsection to the "Navigation" subsection, so that the option is sorted into the 'python' group rather than the 'python-flymake' group (bug#51807). diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index b12b22e992..47d8d1ce8e 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -1427,6 +1427,13 @@ marks the next defun after the ones already marked." ;;; Navigation +(defcustom python-forward-sexp-function #'python-nav-forward-sexp + "Function to use when navigating between expressions." + :version "28.1" + :type '(choice (const :tag "Python blocks" python-nav-forward-sexp) + (const :tag "CC-mode like" nil) + function)) + (defvar python-nav-beginning-of-defun-regexp (python-rx line-start (* space) defun (+ space) (group symbol-name)) "Regexp matching class or function definition. @@ -5572,13 +5579,6 @@ By default messages are considered errors." :type '(alist :key-type (regexp) :value-type (symbol))) -(defcustom python-forward-sexp-function #'python-nav-forward-sexp - "Function to use when navigating between expressions." - :version "28.1" - :type '(choice (const :tag "Python blocks" python-nav-forward-sexp) - (const :tag "CC-mode like" nil) - function)) - (defvar-local python--flymake-proc nil) (defun python--flymake-parse-output (source proc report-fn) commit 08ce17c2c0d32e200af3984d59f0b78ec500dc2c Author: Lars Ingebrigtsen Date: Sun Nov 14 02:21:45 2021 +0100 Fix Gnus gcc header tokenization * lisp/gnus/gnus-msg.el (gnus-summary-resend-message-insert-gcc) (gnus-inews-do-gcc): Fix tokenization of the gcc header. diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index e88aa8f7d0..dfadfd3920 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -1305,7 +1305,7 @@ For the \"inline\" alternatives, also see the variable (gnus-inews-insert-gcc) (let ((gcc (message-unquote-tokens (message-tokenize-header (mail-fetch-field "gcc" nil t) - " ,"))) + ","))) (self (with-current-buffer gnus-summary-buffer gnus-gcc-self-resent-messages))) (message-remove-header "gcc") @@ -1572,7 +1572,7 @@ this is a reply." (message-remove-header "gcc") (widen) (setq groups (message-unquote-tokens - (message-tokenize-header gcc " ,\n\t"))) + (message-tokenize-header gcc ",\n\t"))) ;; Copy the article over to some group(s). (while (setq group (pop groups)) (setq method (gnus-inews-group-method group)) commit 5beed9dfed64fe72ab8678d2706eddbbee3c157b Author: Lars Ingebrigtsen Date: Sun Nov 14 02:06:26 2021 +0100 Adjust build-dep-zips.py download link * admin/nt/dist-build/build-dep-zips.py (download_source): Adjust the download link (bug#40628). diff --git a/admin/nt/dist-build/build-dep-zips.py b/admin/nt/dist-build/build-dep-zips.py index 6bed191cae..dfff493b64 100755 --- a/admin/nt/dist-build/build-dep-zips.py +++ b/admin/nt/dist-build/build-dep-zips.py @@ -123,7 +123,7 @@ def ntldd_munge(out): ## Currently no packages seem to require this! ARCH_PKGS=[] -SRC_REPO="https://sourceforge.net/projects/msys2/files/REPOS/MINGW/Sources" +SRC_REPO="https://repo.msys2.org/mingw/sources" def immediate_deps(pkgs): @@ -169,7 +169,7 @@ def download_source(tarball): if not os.path.exists("../emacs-src-cache/{}".format(tarball)): print("Downloading {}...".format(tarball)) check_output_maybe( - "wget -a ../download.log -O ../emacs-src-cache/{} {}/{}/download" + "wget -a ../download.log -O ../emacs-src-cache/{} {}/{}" .format(tarball, SRC_REPO, tarball), shell=True ) commit 439a3094ff7fd84d1b1a5c6f5eb87431eec0d7fd Author: Manuel Giraud Date: Sun Nov 14 01:51:31 2021 +0100 Find most specific backend for `vc-backend-for-registration'. * lisp/vc/vc.el (vc-backend-for-registration): Count file name components instead of the length of the file name string (bug#50572). diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 4b56f1b795..64f752f248 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -944,8 +944,10 @@ use." bk) (dolist (backend vc-handled-backends) (when (not (vc-call-backend backend 'registered file)) - (let* ((path (vc-call-backend backend 'responsible-p file)) - (len (length path))) + (let* ((dir-name (vc-call-backend backend 'responsible-p file)) + (len (and dir-name + (length (file-name-split + (expand-file-name dir-name)))))) (when (and len (> len max)) (setq max len bk backend))))) (when bk @@ -977,7 +979,7 @@ use." (message "arg %s" arg) (and (file-directory-p arg) (string-prefix-p (expand-file-name arg) def-dir))))))) - (let ((default-directory repo-dir)) + (let ((default-directory repo-dir)) (vc-call-backend bk 'create-repo)) (throw 'found bk)))) commit d4536ff2572931b105198a85a452a777d6d3a1ff Author: Alan Mackenzie Date: Sat Nov 13 18:33:17 2021 +0000 Fix follow-scroll-down in a small buffer which starts slightly scrolled This fixes bug #51814. * lisp/follow.el (follow-scroll-down): Do away with the optimization of doing vertical-motion over only one window. Instead move over all windows, to checck for being close to point-min, and setting point accordingly. diff --git a/lisp/follow.el b/lisp/follow.el index 2ca2c1f17b..3761275bbf 100644 --- a/lisp/follow.el +++ b/lisp/follow.el @@ -669,24 +669,30 @@ Works like `scroll-down' when not in Follow mode." (t (let* ((orig-point (point)) (windows (follow-all-followers)) - (win (car (reverse windows))) - (start (window-start (car windows)))) + (start (window-start (car windows))) + (lines 0)) (if (eq start (point-min)) (if (or (null scroll-error-top-bottom) (bobp)) (signal 'beginning-of-buffer nil) (goto-char (point-min))) - (select-window win) - (goto-char start) - (vertical-motion (- (- (window-height win) - (if header-line-format 2 1) ; always mode-line - (if tab-line-format 1 0) - next-screen-context-lines))) - (set-window-start win (point)) - (if (< orig-point (window-end win t)) - (goto-char orig-point) - (goto-char start) - (vertical-motion (- next-screen-context-lines 1))) + (select-window (car windows)) + (dolist (win windows) + (setq lines + (+ lines + (- (window-height win) + (if header-line-format 2 1) ; Count mode-line, too. + (if tab-line-format 1 0))))) + (setq lines (- lines next-screen-context-lines)) + (goto-char start) + (let ((at-top (> (vertical-motion (- lines)) (- lines)))) + (set-window-start (car windows) (point)) + (if at-top + (goto-char orig-point) + (goto-char start) + (vertical-motion (- next-screen-context-lines 1)) + (if (< orig-point (point)) + (goto-char orig-point)))) (setq follow-internal-force-redisplay t)))))) (put 'follow-scroll-down 'scroll-command t) commit 480241983ea91e31ca4d757fe91df84d1d11d3c9 Author: Eli Zaretskii Date: Thu Dec 31 20:28:30 2020 +0200 Fix compilation on MS-Windows * src/callproc.c (emacs_spawn) : Define the label only if USABLE_POSIX_SPAWN is defined, to avoid a compiler warning. (cherry picked from commit a8fc08085110de00ebcbd67b5273a755a5cb8ea1) diff --git a/src/callproc.c b/src/callproc.c index 4aa24636c3..fad81694b0 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -1602,7 +1602,9 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int std_err, vfork_error = pid < 0 ? errno : 0; +#if USABLE_POSIX_SPAWN fork_done: +#endif if (pid < 0) { eassert (0 < vfork_error); commit cc4edea872ca653f3e0631ce50e47b5260c6773a Author: Philipp Stephani Date: Wed Dec 30 14:42:01 2020 +0100 Use posix_spawn if possible. posix_spawn is less error-prone than vfork + execve, and can make better use of system-specific enhancements like 'clone' on Linux. Use it if we don't need to configure a pseudoterminal. Backported from commit a60053f8368e058229721f1bf1567c2b1676b239. Unlike that commit, only define USABLE_POSIX_SPAWN on macOS, because there posix_spawn is much faster than vfork. Don't merge to master. * configure.ac (HAVE_SPAWN_H, HAVE_POSIX_SPAWN) (HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR) (HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP) (HAVE_POSIX_SPAWNATTR_SETFLAGS, HAVE_DECL_POSIX_SPAWN_SETSID): New configuration variables. * src/callproc.c (USABLE_POSIX_SPAWN): New configuration macro. (emacs_posix_spawn_init_actions) (emacs_posix_spawn_init_attributes, emacs_posix_spawn_init): New helper functions. (emacs_spawn): Use posix_spawn if possible. (cherry picked from commit a60053f8368e058229721f1bf1567c2b1676b239) diff --git a/configure.ac b/configure.ac index 6bc194d792..253f5bfcd6 100644 --- a/configure.ac +++ b/configure.ac @@ -4746,6 +4746,23 @@ dnl AC_CHECK_FUNCS_ONCE wouldn’t be right for snprintf, which needs dnl the current CFLAGS etc. AC_CHECK_FUNCS(snprintf) +dnl posix_spawn. The chdir and setsid functionality is relatively +dnl recent, so we check for it specifically. +AC_CHECK_HEADERS([spawn.h]) +AC_SUBST([HAVE_SPAWN_H]) +AC_CHECK_FUNCS([posix_spawn \ + posix_spawn_file_actions_addchdir \ + posix_spawn_file_actions_addchdir_np \ + posix_spawnattr_setflags]) +AC_SUBST([HAVE_POSIX_SPAWN]) +AC_SUBST([HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR]) +AC_SUBST([HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP]) +AC_SUBST([HAVE_POSIX_SPAWNATTR_SETFLAGS]) +AC_CHECK_DECLS([POSIX_SPAWN_SETSID], [], [], [[ + #include + ]]) +AC_SUBST([HAVE_DECL_POSIX_SPAWN_SETSID]) + dnl Check for glib. This differs from other library checks in that dnl Emacs need not link to glib unless some other library is already dnl linking to glib. Although glib provides no facilities that Emacs diff --git a/src/callproc.c b/src/callproc.c index fa43f97384..4aa24636c3 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -28,6 +28,21 @@ along with GNU Emacs. If not, see . */ #include #include +/* In order to be able to use `posix_spawn', it needs to support some + variant of `chdir' as well as `setsid'. */ +#if defined DARWIN_OS \ + && defined HAVE_SPAWN_H && defined HAVE_POSIX_SPAWN \ + && defined HAVE_POSIX_SPAWNATTR_SETFLAGS \ + && (defined HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR \ + || defined HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP) \ + && defined HAVE_DECL_POSIX_SPAWN_SETSID \ + && HAVE_DECL_POSIX_SPAWN_SETSID == 1 +# include +# define USABLE_POSIX_SPAWN 1 +#else +# define USABLE_POSIX_SPAWN 0 +#endif + #include "lisp.h" #ifdef SETUP_SLAVE_PTY @@ -1247,6 +1262,130 @@ child_setup (int in, int out, int err, char **new_argv, char **env, #endif /* not WINDOWSNT */ } +#if USABLE_POSIX_SPAWN + +/* Set up ACTIONS and ATTRIBUTES for `posix_spawn'. Return an error + number. */ + +static int +emacs_posix_spawn_init_actions (posix_spawn_file_actions_t *actions, + int std_in, int std_out, int std_err, + const char *cwd) +{ + int error = posix_spawn_file_actions_init (actions); + if (error != 0) + return error; + + error = posix_spawn_file_actions_adddup2 (actions, std_in, + STDIN_FILENO); + if (error != 0) + goto out; + + error = posix_spawn_file_actions_adddup2 (actions, std_out, + STDOUT_FILENO); + if (error != 0) + goto out; + + error = posix_spawn_file_actions_adddup2 (actions, + std_err < 0 ? std_out + : std_err, + STDERR_FILENO); + if (error != 0) + goto out; + + error = +#ifdef HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR + posix_spawn_file_actions_addchdir +#else + posix_spawn_file_actions_addchdir_np +#endif + (actions, cwd); + if (error != 0) + goto out; + + out: + if (error != 0) + posix_spawn_file_actions_destroy (actions); + return error; +} + +static int +emacs_posix_spawn_init_attributes (posix_spawnattr_t *attributes) +{ + int error = posix_spawnattr_init (attributes); + if (error != 0) + return error; + + error = posix_spawnattr_setflags (attributes, + POSIX_SPAWN_SETSID + | POSIX_SPAWN_SETSIGDEF + | POSIX_SPAWN_SETSIGMASK); + if (error != 0) + goto out; + + sigset_t sigdefault; + sigemptyset (&sigdefault); + +#ifdef DARWIN_OS + /* Work around a macOS bug, where SIGCHLD is apparently + delivered to a vforked child instead of to its parent. See: + https://lists.gnu.org/r/emacs-devel/2017-05/msg00342.html + */ + sigaddset (&sigdefault, SIGCHLD); +#endif + + sigaddset (&sigdefault, SIGINT); + sigaddset (&sigdefault, SIGQUIT); +#ifdef SIGPROF + sigaddset (&sigdefault, SIGPROF); +#endif + + /* Emacs ignores SIGPIPE, but the child should not. */ + sigaddset (&sigdefault, SIGPIPE); + /* Likewise for SIGPROF. */ +#ifdef SIGPROF + sigaddset (&sigdefault, SIGPROF); +#endif + + error = posix_spawnattr_setsigdefault (attributes, &sigdefault); + if (error != 0) + goto out; + + /* Stop blocking SIGCHLD in the child. */ + sigset_t oldset; + error = pthread_sigmask (SIG_SETMASK, NULL, &oldset); + if (error != 0) + goto out; + error = posix_spawnattr_setsigmask (attributes, &oldset); + if (error != 0) + goto out; + + out: + if (error != 0) + posix_spawnattr_destroy (attributes); + + return error; +} + +static int +emacs_posix_spawn_init (posix_spawn_file_actions_t *actions, + posix_spawnattr_t *attributes, int std_in, + int std_out, int std_err, const char *cwd) +{ + int error = emacs_posix_spawn_init_actions (actions, std_in, + std_out, std_err, cwd); + if (error != 0) + return error; + + error = emacs_posix_spawn_init_attributes (attributes); + if (error != 0) + return error; + + return 0; +} + +#endif + /* Start a new asynchronous subprocess. If successful, return zero and store the process identifier of the new process in *NEWPID. Use STDIN, STDOUT, and STDERR as standard streams for the new @@ -1266,10 +1405,58 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int std_err, char **argv, char **envp, const char *cwd, const char *pty, const sigset_t *oldset) { +#if USABLE_POSIX_SPAWN + /* Prefer the simpler `posix_spawn' if available. `posix_spawn' + doesn't yet support setting up pseudoterminals, so we fall back + to `vfork' if we're supposed to use a pseudoterminal. */ + + bool use_posix_spawn = pty == NULL; + + posix_spawn_file_actions_t actions; + posix_spawnattr_t attributes; + + if (use_posix_spawn) + { + /* Initialize optional attributes before blocking. */ + int error + = emacs_posix_spawn_init (&actions, &attributes, std_in, + std_out, std_err, cwd); + if (error != 0) + return error; + } +#endif + int pid; + int vfork_error; eassert (input_blocked_p ()); +#if USABLE_POSIX_SPAWN + if (use_posix_spawn) + { + vfork_error = posix_spawn (&pid, argv[0], &actions, &attributes, + argv, envp); + if (vfork_error != 0) + pid = -1; + + int error = posix_spawn_file_actions_destroy (&actions); + if (error != 0) + { + errno = error; + emacs_perror ("posix_spawn_file_actions_destroy"); + } + + error = posix_spawnattr_destroy (&attributes); + if (error != 0) + { + errno = error; + emacs_perror ("posix_spawnattr_destroy"); + } + + goto fork_done; + } +#endif + #ifndef WINDOWSNT /* vfork, and prevent local vars from being clobbered by the vfork. */ pid_t *volatile newpid_volatile = newpid; @@ -1413,8 +1600,9 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int std_err, /* Back in the parent process. */ - int vfork_error = pid < 0 ? errno : 0; + vfork_error = pid < 0 ? errno : 0; + fork_done: if (pid < 0) { eassert (0 < vfork_error); commit 4df334a0f74700e72bfea7817e660605c3f2a2ee Author: Stephen Gildea Date: Sat Nov 13 07:00:30 2021 -0800 MH-E threads code: use mh-scan variables correctly * lisp/mh-e/mh-thread.el (mh-thread-current-indentation-level) (mh-thread-find-children): Fix off-by-one error by using 'mh-scan-field-from-start-offset' directly, as 'mh-thread-parse-scan-line' does. Previously, these functions would incorrectly consider the "date note" column as part of the thread indenting. Since that column is almost always a Space character, that almost always worked. (mh-thread-ancestor): Update caller. * test/lisp/mh-e/mh-thread-tests.el: New unit tests for affected code. * lisp/mh-e/mh-scan.el (mh-msg-num-width-to-column): Fix doc string typo. diff --git a/lisp/mh-e/mh-scan.el b/lisp/mh-e/mh-scan.el index 5a1a671aee..bf3cfeff5c 100644 --- a/lisp/mh-e/mh-scan.el +++ b/lisp/mh-e/mh-scan.el @@ -509,7 +509,7 @@ with `mh-scan-msg-format-string'." Note that columns in Emacs start with 0. If `mh-scan-format-file' is set to \"Use MH-E scan Format\" this -means that either `mh-scan-format-mh' or `mh-scan-format-nmh' are +means that either `mh-scan-format-mh' or `mh-scan-format-nmh' is in use. This function therefore assumes that the first column is empty (to provide room for the cursor), the following WIDTH columns contain the message number, and the column for notations diff --git a/lisp/mh-e/mh-thread.el b/lisp/mh-e/mh-thread.el index 21954da6ac..1be2185ecd 100644 --- a/lisp/mh-e/mh-thread.el +++ b/lisp/mh-e/mh-thread.el @@ -139,7 +139,7 @@ to the message that started everything." (cond (thread-root-flag (while (mh-thread-immediate-ancestor)) (mh-maybe-show)) - ((equal current-level 1) + ((equal current-level 0) (message "Message has no ancestor")) (t (mh-thread-immediate-ancestor) (mh-maybe-show))))) @@ -242,8 +242,8 @@ sibling." (defun mh-thread-current-indentation-level () "Find the number of spaces by which current message is indented." (save-excursion - (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width - mh-scan-date-width 1)) + (let ((address-start-offset (+ mh-cmd-note + mh-scan-field-from-start-offset)) (level 0)) (beginning-of-line) (forward-char address-start-offset) @@ -275,8 +275,8 @@ at the end." (beginning-of-line) (if (eobp) nil - (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width - mh-scan-date-width 1)) + (let ((address-start-offset (+ mh-cmd-note + mh-scan-field-from-start-offset)) (level (mh-thread-current-indentation-level)) spaces begin) (setq begin (point)) diff --git a/test/lisp/mh-e/mh-thread-tests.el b/test/lisp/mh-e/mh-thread-tests.el new file mode 100644 index 0000000000..4f09677e53 --- /dev/null +++ b/test/lisp/mh-e/mh-thread-tests.el @@ -0,0 +1,131 @@ +;;; mh-thread-tests.el --- tests for mh-thread.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'mh-thread) +(eval-when-compile (require 'cl-lib)) + +(defun mh-thread-tests-before-from () + "Generate the fields of a scan line up to where the 'From' field would start. +The exact contents are not important, but the number of characters is." + (concat (make-string mh-cmd-note ?9) + (make-string mh-scan-cmd-note-width ?A) + (make-string mh-scan-destination-width ?t) + (make-string mh-scan-date-width ?/) + (make-string mh-scan-date-flag-width ?*))) + +;;; Tests of support routines + +(ert-deftest mh-thread-current-indentation-level () + "Test that `mh-thread-current-indentation-level' identifies the level." + (with-temp-buffer + (insert (mh-thread-tests-before-from) "[Sender One] Subject of msg 1\n") + (insert (mh-thread-tests-before-from) " [Sender Two] Subject of msg 2\n") + (goto-char (point-min)) + (should (equal 0 (mh-thread-current-indentation-level))) + (forward-line) + (should (equal 2 (mh-thread-current-indentation-level))))) + +(ert-deftest mh-thread-find-children () + "Test `mh-thread-find-children'." + (let (expected-start expected-end) + (with-temp-buffer + (insert (mh-thread-tests-before-from) "[Sender One] line 1\n") + (setq expected-start (point)) + (insert (mh-thread-tests-before-from) " [Sender Two] line 2\n") + (insert (mh-thread-tests-before-from) " [Sender Three] line 3\n") + (insert (mh-thread-tests-before-from) " [Sender Four] line 4\n") + (setq expected-end (1- (point))) + (insert (mh-thread-tests-before-from) " [Sender Five] line 5\n") + (goto-char (1+ expected-start)) + (should (equal (list expected-start expected-end) + (mh-thread-find-children)))))) + +(ert-deftest mh-thread-immediate-ancestor () + "Test that `mh-thread-immediate-ancestor' moves to the correct message." + (with-temp-buffer + (insert (mh-thread-tests-before-from) "[Sender Other] line 1\n") + (insert (mh-thread-tests-before-from) "[Sender One] line 2\n") + (insert (mh-thread-tests-before-from) " [Sender Two] line 3\n") + (insert (mh-thread-tests-before-from) " [Sender Three] line 4\n") + (insert (mh-thread-tests-before-from) " [Sender Four] line 5\n") + (insert (mh-thread-tests-before-from) " [Sender Five] line 6\n") + (forward-line -1) + (should (equal (line-number-at-pos) 6)) + (mh-thread-immediate-ancestor) + (should (equal (line-number-at-pos) 4)) ;skips over sibling + (mh-thread-immediate-ancestor) + (should (equal (line-number-at-pos) 3)) ;goes up only one level at a time + (mh-thread-immediate-ancestor) + (should (equal (line-number-at-pos) 2)) + (mh-thread-immediate-ancestor) + (should (equal (line-number-at-pos) 2)))) ;no further motion at thread root + +;;; Tests of MH-Folder Commands + +(ert-deftest mh-thread-sibling-and-ancestor () + "Test motion by `mh-thread-ancestor' and `mh-thread-next-sibling'." + (with-temp-buffer + (insert (mh-thread-tests-before-from) "[Sender Other] line 1\n") + (insert (mh-thread-tests-before-from) "[Sender One] line 2\n") + (insert (mh-thread-tests-before-from) " [Sender Two] line 3\n") + (insert (mh-thread-tests-before-from) " [Sender Three] line 4\n") + (insert (mh-thread-tests-before-from) " [Sender Four] line 5\n") + (insert (mh-thread-tests-before-from) " [Sender Five] line 6\n") + (forward-line -1) + (let ((mh-view-ops '(unthread)) + (show-count 0)) + (cl-letf (((symbol-function 'mh-maybe-show) + (lambda () + (setq show-count (1+ show-count))))) + (should (equal (line-number-at-pos) 6)) + ;; test mh-thread-ancestor + (mh-thread-ancestor) + (should (equal (line-number-at-pos) 4)) ;skips over sibling + (should (equal show-count 1)) + (mh-thread-ancestor t) + (should (equal (line-number-at-pos) 2)) ;root flag skips to root + (should (equal show-count 2)) + (mh-thread-ancestor) + (should (equal (line-number-at-pos) 2)) ;do not move from root + (should (equal show-count 2)) ;do not re-show at root + ;; test mh-thread-sibling + (mh-thread-next-sibling) + (should (equal (line-number-at-pos) 2)) ;no next sibling, no motion + (should (equal show-count 2)) ;no sibling, no show + (mh-thread-next-sibling t) + (should (equal (line-number-at-pos) 1)) + (should (equal show-count 3)) + (mh-thread-next-sibling t) + (should (equal (line-number-at-pos) 1)) ;no previous sibling + (should (equal show-count 3)) + (goto-char (point-max)) + (forward-line -1) + (should (equal (line-number-at-pos) 6)) + (mh-thread-next-sibling t) + (should (equal (line-number-at-pos) 5)) + (should (equal show-count 4)) + (mh-thread-next-sibling t) + (should (equal (line-number-at-pos) 5)) ;no previous sibling + (should (equal show-count 4)) + )))) + +;;; mh-thread-tests.el ends here commit a56dd60d2fba9d873748ca3831ba61711628f698 Author: Eli Zaretskii Date: Sat Nov 13 16:37:39 2021 +0200 Improve style and comments in font-related sources * src/w32font.c (fill_in_logfont): Stylistic changes. * src/font.h (font_property_index, font_select_entity): Add/improve comments. diff --git a/src/font.c b/src/font.c index 6cd4a6b5c1..c0050a99cf 100644 --- a/src/font.c +++ b/src/font.c @@ -3151,8 +3151,9 @@ font_clear_prop (Lisp_Object *attrs, enum font_property_index prop) attrs[LFACE_FONT_INDEX] = font; } -/* Select a font from ENTITIES (list of font-entity vectors) that - supports C and is the best match for ATTRS and PIXEL_SIZE. */ +/* Select a font from ENTITIES (list of one or more font-entity + vectors) that supports the character C (if non-negative) and is the + best match for ATTRS and PIXEL_SIZE. */ static Lisp_Object font_select_entity (struct frame *f, Lisp_Object entities, @@ -3162,6 +3163,7 @@ font_select_entity (struct frame *f, Lisp_Object entities, Lisp_Object prefer; int i; + /* If we have a single candidate, return it if it supports C. */ if (NILP (XCDR (entities)) && ASIZE (XCAR (entities)) == 1) { @@ -3171,7 +3173,10 @@ font_select_entity (struct frame *f, Lisp_Object entities, return Qnil; } - /* Sort fonts by properties specified in ATTRS. */ + /* If we have several candidates, find the best match by sorting + them by properties specified in ATTRS. Style attributes (weight, + slant, width, and size) are taken from the font spec in ATTRS (if + that is non-nil), or from ATTRS, or left as nil. */ prefer = scratch_font_prefer; for (i = FONT_WEIGHT_INDEX; i <= FONT_SIZE_INDEX; i++) @@ -3208,6 +3213,8 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int int i, j, k, l; USE_SAFE_ALLOCA; + /* Registry specification alternatives: from the most specific to + the least specific and finally an unspecified one. */ registry[0] = AREF (spec, FONT_REGISTRY_INDEX); if (NILP (registry[0])) { @@ -3244,6 +3251,9 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int pixel_size = 1; } ASET (work, FONT_SIZE_INDEX, Qnil); + + /* Foundry specification alternatives: from the most specific to the + least specific and finally an unspecified one. */ foundry[0] = AREF (work, FONT_FOUNDRY_INDEX); if (! NILP (foundry[0])) foundry[1] = zero_vector; @@ -3257,6 +3267,8 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int else foundry[0] = Qnil, foundry[1] = zero_vector; + /* Additional style specification alternatives: from the most + specific to the least specific and finally an unspecified one. */ adstyle[0] = AREF (work, FONT_ADSTYLE_INDEX); if (! NILP (adstyle[0])) adstyle[1] = zero_vector; @@ -3277,6 +3289,8 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int adstyle[0] = Qnil, adstyle[1] = zero_vector; + /* Family specification alternatives: from the most specific to + the least specific and finally an unspecified one. */ val = AREF (work, FONT_FAMILY_INDEX); if (NILP (val) && STRINGP (attrs[LFACE_FAMILY_INDEX])) { @@ -3316,6 +3330,8 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int } } + /* Now look up suitable fonts, from the most specific spec to the + least specific spec. Accept the first one that matches. */ for (i = 0; SYMBOLP (family[i]); i++) { ASET (work, FONT_FAMILY_INDEX, family[i]); @@ -3328,9 +3344,12 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int for (l = 0; SYMBOLP (adstyle[l]); l++) { ASET (work, FONT_ADSTYLE_INDEX, adstyle[l]); + /* Produce the list of candidates for the spec in WORK. */ entities = font_list_entities (f, work); if (! NILP (entities)) { + /* If there are several candidates, select the + best match for PIXEL_SIZE and attributes in ATTRS. */ val = font_select_entity (f, entities, attrs, pixel_size, c); if (! NILP (val)) diff --git a/src/font.h b/src/font.h index 1da72cca07..6694164e09 100644 --- a/src/font.h +++ b/src/font.h @@ -69,9 +69,10 @@ INLINE_HEADER_BEGIN enum font_property_index { - /* FONT-TYPE is a symbol indicating a font backend; currently `x' - and `xft' are available on X, `uniscribe' and `gdi' on - Windows, and `ns' under Cocoa / GNUstep. */ + /* FONT-TYPE is a symbol indicating a font backend; currently `x', + `xft', `xfthb', `ftrc', and `ftcrhb' are available on X; + `harfbuzz', `uniscribe', and `gdi' on Windows, and `ns' under + Cocoa / GNUstep. */ FONT_TYPE_INDEX, /* FONT-FOUNDRY is a foundry name (symbol). */ diff --git a/src/w32font.c b/src/w32font.c index 6b9ab0468c..3025d0efa8 100644 --- a/src/w32font.c +++ b/src/w32font.c @@ -2019,13 +2019,9 @@ fill_in_logfont (struct frame *f, LOGFONT *logfont, Lisp_Object font_spec) tmp = AREF (font_spec, FONT_DPI_INDEX); if (FIXNUMP (tmp)) - { - dpi = XFIXNUM (tmp); - } + dpi = XFIXNUM (tmp); else if (FLOATP (tmp)) - { - dpi = (int) (XFLOAT_DATA (tmp) + 0.5); - } + dpi = (int) (XFLOAT_DATA (tmp) + 0.5); /* Height */ tmp = AREF (font_spec, FONT_SIZE_INDEX); commit d3666ccdba7c3837ffffe3c50a179c110ed55569 Author: Michael Albinus Date: Sat Nov 13 15:26:42 2021 +0100 Revert accidential commit in icomplete.el diff --git a/lisp/icomplete.el b/lisp/icomplete.el index 8ead8a6217..f909a3b177 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -418,7 +418,7 @@ if that doesn't produce a completion match." icomplete-show-matches-on-no-input t icomplete-hide-common-prefix nil icomplete-scroll (not (null icomplete-vertical-mode)) - completion-styles '(flex basic) + completion-styles '(flex) completion-flex-nospace nil completion-category-defaults nil completion-ignore-case t commit aa88845a170fef902fdd7d757b0f178ce41fe816 Author: Michael Albinus Date: Sat Nov 13 15:14:02 2021 +0100 Remove Tramp's `dired-compress-file' handler, not needed anymore * lisp/dired-aux.el (dired-check-process, dired-shell-command): Call `dired-uncache'. (dired-compress-file): Use `file-local-name'. * lisp/net/tramp-adb.el (tramp-adb-file-name-handler-alist): * lisp/net/tramp-archive.el (tramp-archive-file-name-handler-alist): * lisp/net/tramp-crypt.el (tramp-crypt-file-name-handler-alist): * lisp/net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist): * lisp/net/tramp-rclone.el (tramp-rclone-file-name-handler-alist): * lisp/net/tramp-smb.el (tramp-smb-file-name-handler-alist): * lisp/net/tramp-sshfs.el (tramp-sshfs-file-name-handler-alist): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-file-name-handler-alist): Remove superfluous comment. * lisp/net/tramp-sh.el (dired-compress-file): Declare. (tramp-sh-handle-dired-compress-file): Call real handler for Emacs >= 29. * lisp/net/tramp.el (tramp-file-name-for-operation): Reorder list. * test/lisp/net/tramp-tests.el (tramp-test45-dired-compress-file) (tramp-test45-dired-compress-dir): Adapt comment. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 7d81d45326..92409db33e 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1007,6 +1007,7 @@ Else returns nil for success." (erase-buffer) (setq default-directory dir ; caller's default-directory err (not (eq 0 (apply #'process-file program nil t nil arguments)))) + (dired-uncache dir) (if err (progn (dired-log (concat program " " (prin1-to-string arguments) "\n")) @@ -1032,6 +1033,7 @@ Return the result of `process-file' - zero for success." nil shell-command-switch cmd))) + (dired-uncache dir) (unless (zerop res) (pop-to-buffer out-buffer)) res)))) @@ -1280,9 +1282,9 @@ Return nil if no change in files." (prog1 (setq newname (file-name-as-directory newname)) (dired-shell-command (replace-regexp-in-string - "%o" (shell-quote-argument newname) + "%o" (shell-quote-argument (file-local-name newname)) (replace-regexp-in-string - "%i" (shell-quote-argument file) + "%i" (shell-quote-argument (file-local-name file)) command nil t) nil t))) @@ -1293,10 +1295,10 @@ Return nil if no change in files." (dired-check-process msg (substring command 0 match) (substring command (1+ match)) - file) + (file-local-name file)) (dired-check-process msg command - file)) + (file-local-name file))) newname)))) (t ;; We don't recognize the file as compressed, so compress it. @@ -1314,7 +1316,8 @@ Return nil if no change in files." (default-directory (file-name-directory file))) (dired-shell-command (replace-regexp-in-string - "%o" (shell-quote-argument out-name) + "%o" (shell-quote-argument + (file-local-name out-name)) (replace-regexp-in-string "%i" (shell-quote-argument (file-name-nondirectory file)) @@ -1344,9 +1347,10 @@ see `dired-compress-file-alist' for the supported suffixes list" out-name))) (dired-shell-command (replace-regexp-in-string - "%o" (shell-quote-argument out-name) + "%o" (shell-quote-argument + (file-local-name out-name)) (replace-regexp-in-string - "%i" (shell-quote-argument file) + "%i" (shell-quote-argument (file-local-name file)) (cdr rule) nil t) nil t)) @@ -1361,7 +1365,8 @@ see `dired-compress-file-alist' for the supported suffixes list" out-name))))) (file-error (if (not (dired-check-process (concat "Compressing " file) - "compress" "-f" file)) + "compress" "-f" + (file-local-name file))) ;; Don't use NEWNAME with `compress'. (concat file ".Z")))))))) diff --git a/lisp/icomplete.el b/lisp/icomplete.el index f909a3b177..8ead8a6217 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -418,7 +418,7 @@ if that doesn't produce a completion match." icomplete-show-matches-on-no-input t icomplete-hide-common-prefix nil icomplete-scroll (not (null icomplete-vertical-mode)) - completion-styles '(flex) + completion-styles '(flex basic) completion-flex-nospace nil completion-category-defaults nil completion-ignore-case t diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 374e5db587..895543d6db 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -119,7 +119,6 @@ It is used for TCP/IP devices." (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-adb-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . tramp-adb-handle-exec-path) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 578f9fcf91..3e0d876dd9 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -223,7 +223,6 @@ It must be supported by libarchive(3).") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . tramp-archive-handle-not-implemented) (dired-uncache . tramp-archive-handle-dired-uncache) (exec-path . ignore) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index f431f97563..42b67ac7a8 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -169,7 +169,6 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (directory-files . tramp-crypt-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . ignore) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 11de71aa0d..220ce63c0f 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -756,7 +756,6 @@ It has been changed in GVFS 1.14.") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . ignore) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index c997215a15..28a1c01aa6 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -83,7 +83,6 @@ (directory-files . tramp-fuse-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . ignore) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 533ddcf66e..c61025a86b 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -34,6 +34,8 @@ (eval-when-compile (require 'cl-lib)) (require 'tramp) +;; `dired-*' declarations can be removed, starting with Emacs 29.1. +(declare-function dired-compress-file "dired-aux") (declare-function dired-remove-file "dired-aux") (defvar dired-compress-file-suffixes) (defvar process-file-return-signal-string) @@ -952,7 +954,8 @@ Format specifiers \"%s\" are replaced before the script is used.") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-sh-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. + ;; Starting with Emacs 29.1, `dired-compress-file' performed by + ;; default handler. (dired-compress-file . tramp-sh-handle-dired-compress-file) (dired-uncache . tramp-handle-dired-uncache) (exec-path . tramp-sh-handle-exec-path) @@ -2472,57 +2475,60 @@ The method used must be an out-of-band method." ;; Dired. -;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (defun tramp-sh-handle-dired-compress-file (file) "Like `dired-compress-file' for Tramp files." - ;; Code stolen mainly from dired-aux.el. - (with-parsed-tramp-file-name file nil - (tramp-flush-file-properties v localname) - (let ((suffixes dired-compress-file-suffixes) - suffix) - ;; See if any suffix rule matches this file name. - (while suffixes - (let (case-fold-search) - (if (string-match-p (car (car suffixes)) localname) - (setq suffix (car suffixes) suffixes nil)) - (setq suffixes (cdr suffixes)))) - - (cond ((file-symlink-p file) nil) - ((and suffix (nth 2 suffix)) - ;; We found an uncompression rule. - (with-tramp-progress-reporter - v 0 (format "Uncompressing %s" file) - (when (tramp-send-command-and-check - v (if (string-match-p "%[io]" (nth 2 suffix)) - (replace-regexp-in-string - "%i" (tramp-shell-quote-argument localname) - (nth 2 suffix)) - (concat (nth 2 suffix) " " - (tramp-shell-quote-argument localname)))) - (unless (string-match-p "\\.tar\\.gz" file) - (dired-remove-file file)) - (string-match (car suffix) file) - (concat (substring file 0 (match-beginning 0)))))) - (t - ;; We don't recognize the file as compressed, so compress it. - ;; Try gzip. - (with-tramp-progress-reporter v 0 (format "Compressing %s" file) - (when (tramp-send-command-and-check - v (if (file-directory-p file) - (format "tar -cf - %s | gzip -c9 > %s.tar.gz" - (tramp-shell-quote-argument - (file-name-nondirectory localname)) - (tramp-shell-quote-argument localname)) - (concat "gzip -f " - (tramp-shell-quote-argument localname)))) - (unless (file-directory-p file) - (dired-remove-file file)) - (catch 'found nil - (dolist (target (mapcar (lambda (suffix) - (concat file suffix)) - '(".tar.gz" ".gz" ".z"))) - (when (file-exists-p target) - (throw 'found target))))))))))) + ;; Starting with Emacs 29.1, `dired-compress-file' is performed by + ;; default handler. + (if (>= emacs-major-version 29) + (tramp-run-real-handler #'dired-compress-file (list file)) + ;; Code stolen mainly from dired-aux.el. + (with-parsed-tramp-file-name file nil + (tramp-flush-file-properties v localname) + (let ((suffixes dired-compress-file-suffixes) + suffix) + ;; See if any suffix rule matches this file name. + (while suffixes + (let (case-fold-search) + (if (string-match-p (car (car suffixes)) localname) + (setq suffix (car suffixes) suffixes nil)) + (setq suffixes (cdr suffixes)))) + + (cond ((file-symlink-p file) nil) + ((and suffix (nth 2 suffix)) + ;; We found an uncompression rule. + (with-tramp-progress-reporter + v 0 (format "Uncompressing %s" file) + (when (tramp-send-command-and-check + v (if (string-match-p "%[io]" (nth 2 suffix)) + (replace-regexp-in-string + "%i" (tramp-shell-quote-argument localname) + (nth 2 suffix)) + (concat (nth 2 suffix) " " + (tramp-shell-quote-argument localname)))) + (unless (string-match-p "\\.tar\\.gz" file) + (dired-remove-file file)) + (string-match (car suffix) file) + (concat (substring file 0 (match-beginning 0)))))) + (t + ;; We don't recognize the file as compressed, so + ;; compress it. Try gzip. + (with-tramp-progress-reporter v 0 (format "Compressing %s" file) + (when (tramp-send-command-and-check + v (if (file-directory-p file) + (format "tar -cf - %s | gzip -c9 > %s.tar.gz" + (tramp-shell-quote-argument + (file-name-nondirectory localname)) + (tramp-shell-quote-argument localname)) + (concat "gzip -f " + (tramp-shell-quote-argument localname)))) + (unless (file-directory-p file) + (dired-remove-file file)) + (catch 'found nil + (dolist (target (mapcar (lambda (suffix) + (concat file suffix)) + '(".tar.gz" ".gz" ".z"))) + (when (file-exists-p target) + (throw 'found target)))))))))))) (defun tramp-sh-handle-insert-directory (filename switches &optional wildcard full-directory-p) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index ac567dc074..0b25164902 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -234,7 +234,6 @@ See `tramp-actions-before-shell' for more info.") (directory-files . tramp-smb-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . ignore) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index fc77d998aa..a9d8dc933b 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -83,7 +83,6 @@ (directory-files . tramp-fuse-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . tramp-sshfs-handle-exec-path) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 842990488e..7cf0ea451d 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -75,7 +75,6 @@ See `tramp-actions-before-shell' for more info.") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . ignore) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index f4493608a4..876bbb2c54 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2476,28 +2476,25 @@ Must be handled by the callers." '(access-file byte-compiler-base-file-name delete-directory delete-file diff-latest-backup-file directory-file-name directory-files directory-files-and-attributes - dired-uncache file-acl file-accessible-directory-p - file-attributes file-directory-p file-executable-p - file-exists-p file-local-copy file-modes - file-name-as-directory file-name-case-insensitive-p - file-name-directory file-name-nondirectory - file-name-sans-versions file-notify-add-watch - file-ownership-preserved-p file-readable-p - file-regular-p file-remote-p file-selinux-context - file-symlink-p file-truename file-writable-p - find-backup-file-name get-file-buffer insert-directory - insert-file-contents load make-directory - make-directory-internal set-file-acl set-file-modes - set-file-selinux-context set-file-times + dired-compress-file dired-uncache file-acl + file-accessible-directory-p file-attributes + file-directory-p file-executable-p file-exists-p + file-local-copy file-modes file-name-as-directory + file-name-case-insensitive-p file-name-directory + file-name-nondirectory file-name-sans-versions + file-notify-add-watch file-ownership-preserved-p + file-readable-p file-regular-p file-remote-p + file-selinux-context file-symlink-p file-truename + file-writable-p find-backup-file-name get-file-buffer + insert-directory insert-file-contents load + make-directory make-directory-internal set-file-acl + set-file-modes set-file-selinux-context set-file-times substitute-in-file-name unhandled-file-name-directory vc-registered ;; Emacs 27+ only. file-system-info ;; Emacs 28+ only. file-locked-p lock-file make-lock-file-name unlock-file - ;; Starting with Emacs 29.1, `dired-compress-file' isn't - ;; magic anymore. - dired-compress-file ;; Tramp internal magic file name function. tramp-set-file-uid-gid)) (if (file-name-absolute-p (nth 0 args)) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 397e707f13..52c6159dc1 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -6935,7 +6935,8 @@ process sentinels. They shall not disturb each other." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-crypt-p))) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. + ;; Starting with Emacs 29.1, `dired-compress-file' is performed by + ;; default handler. (skip-unless (not (tramp--test-emacs29-p))) (let ((default-directory tramp-test-temporary-file-directory) @@ -6955,7 +6956,8 @@ process sentinels. They shall not disturb each other." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-crypt-p))) - ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. + ;; Starting with Emacs 29.1, `dired-compress-file' is performed by + ;; default handler. (skip-unless (not (tramp--test-emacs29-p))) (let ((default-directory tramp-test-temporary-file-directory) commit f7abc04c4002a2fc7dc7c8c9ec2a264e25aaf5f5 Author: Po Lu Date: Sat Nov 13 21:37:06 2021 +0800 Fix scroll event test in handle_one_xevent * src/xterm.c (handle_one_xevent): Test for scroll wheel button correctly in xwidget code. diff --git a/src/xterm.c b/src/xterm.c index 4492db8502..fd498c0e32 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -9304,10 +9304,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, event->xbutton.button, event->xbutton.state, event->xbutton.time); - if (!EQ (selected_window, xvw->w) - && ((event->xbutton.button < 3) - || (event->xbutton.button > 7))) - { + if (!EQ (selected_window, xvw->w) && (event->xbutton.button < 4)) + { inev.ie.kind = SELECT_WINDOW_EVENT; inev.ie.frame_or_window = xvw->w; } commit 89d7a71ce6a7338e4650409f16e419a53fff9723 Author: Eli Zaretskii Date: Sat Nov 13 15:22:12 2021 +0200 Fix font selection via :family on MS-Windows * src/font.c (font_delete_unmatched) [HAVE_NTGUI]: Allow non-exact matches of :weight when looking for a suitable font. (Bug#51768) diff --git a/src/font.c b/src/font.c index f70054ea40..420a4f8e70 100644 --- a/src/font.c +++ b/src/font.c @@ -2759,10 +2759,31 @@ font_delete_unmatched (Lisp_Object vec, Lisp_Object spec, int size) continue; } for (prop = FONT_WEIGHT_INDEX; prop < FONT_SIZE_INDEX; prop++) - if (FIXNUMP (AREF (spec, prop)) - && ((XFIXNUM (AREF (spec, prop)) >> 8) - != (XFIXNUM (AREF (entity, prop)) >> 8))) - prop = FONT_SPEC_MAX; + { + if (FIXNUMP (AREF (spec, prop))) + { + int required = XFIXNUM (AREF (spec, prop)) >> 8; + int candidate = XFIXNUM (AREF (entity, prop)) >> 8; + + if (candidate != required +#ifdef HAVE_NTGUI + /* A kludge for w32 font search, where listing a + family returns only 4 standard weights: regular, + italic, bold, bold-italic. For other values one + must specify the font, not just the family in the + :family attribute of the face. But specifying + :family in the face attributes looks for regular + weight, so if we require exact match, the + non-regular font will be rejected. So we relax + the accuracy of the match here, and let + font_sort_entities find the best match. */ + && (prop != FONT_WEIGHT_INDEX + || eabs (candidate - required) > 100) +#endif + ) + prop = FONT_SPEC_MAX; + } + } if (prop < FONT_SPEC_MAX && size && XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) > 0) commit f740becf8ad1fdd992fb509edb10ff041f163c8f Author: Alan Mackenzie Date: Sat Nov 13 12:58:23 2021 +0000 Correct patch from 2021-11-12 on src/fileio.c * src/fileio.c (restore_window_points): Reverse commit 974192413f8a81171b8fd28dfd5c081ce06d3dec and instead replace a < by a <=. This ensures that if w->mpoint is at the top of the middle region being replaced, it gets adjusted and stays at the top after the reinsertion. diff --git a/src/fileio.c b/src/fileio.c index a7b1649fae..4015448ece 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -3827,20 +3827,17 @@ restore_window_points (Lisp_Object window_markers, ptrdiff_t inserted, Lisp_Object car = XCAR (window_markers); Lisp_Object marker = XCAR (car); Lisp_Object oldpos = XCDR (car); - ptrdiff_t newpos; if (MARKERP (marker) && FIXNUMP (oldpos) && XFIXNUM (oldpos) > same_at_start - && XFIXNUM (oldpos) < same_at_end) + && XFIXNUM (oldpos) <= same_at_end) { ptrdiff_t oldsize = same_at_end - same_at_start; ptrdiff_t newsize = inserted; double growth = newsize / (double)oldsize; - newpos = same_at_start - + growth * (XFIXNUM (oldpos) - same_at_start); + ptrdiff_t newpos + = same_at_start + growth * (XFIXNUM (oldpos) - same_at_start); + Fset_marker (marker, make_fixnum (newpos), Qnil); } - else - newpos = XFIXNUM (oldpos); - Fset_marker (marker, make_fixnum (newpos), Qnil); } } commit 102406edb1d387bcb3c82ac320c30da5bd705194 Author: Po Lu Date: Sat Nov 13 20:03:05 2021 +0800 Don't emit SELECT_WINDOW_EVENT when an xwidget is scrolled * src/xterm.c (handle_one_event): Don't select xwidget window on button event if the button pressed actually represents the scroll wheel. diff --git a/src/xterm.c b/src/xterm.c index 172abe919d..4492db8502 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -9304,7 +9304,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, event->xbutton.button, event->xbutton.state, event->xbutton.time); - if (!EQ (selected_window, xvw->w)) + if (!EQ (selected_window, xvw->w) + && ((event->xbutton.button < 3) + || (event->xbutton.button > 7))) { inev.ie.kind = SELECT_WINDOW_EVENT; inev.ie.frame_or_window = xvw->w; commit 60a85834202dc4e117d3e5086ab210bcd293d659 Author: Alan Mackenzie Date: Sat Nov 13 11:58:26 2021 +0000 C++ Mode: Fix incoorect background fontification of < Where c-record-found-types gets "bound" to itself, we postpone the calling of c-fontify-new-type on possible new found types until these are confirmed by the return from the function tentatively finding these types, for exmaple c-forward-<>-arglist. We check this "binding" by testing the value of c-record-found-types. Correct the background fontification algorithm. * lisp/progmodes/cc-engine.el (c-record-found-types): Move the definition to earlier in the file. (c-add-type-1): Check additionally c-record-found-types is nil before calling c-fontify-new-found-type. (c-forward-<>-arglist, c-forward-type): On return from a function which collects found types in c-record-found-types, call c-fontify-new-found-types for each such type. * lisp/progmodes/c-fonts.el (c-force-redisplay): Actually fontify the new found type. (c-fontify-new-found-type): Test for font-lock-mode being enabled. Remove the spurious condition on the `fontified' text property being nil before causing c-force-redisplay to get called. diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index a4568bd4ef..c7b01de9b9 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -6812,6 +6812,13 @@ comment at the start of cc-engine.el for more info." (defvar c-found-types nil) (make-variable-buffer-local 'c-found-types) +;; Dynamically bound variable that instructs `c-forward-type' to +;; record the ranges of types that only are found. Behaves otherwise +;; like `c-record-type-identifiers'. Also when this variable is non-nil, +;; `c-fontify-new-found-type' doesn't get called (yet) for the purported +;; type. +(defvar c-record-found-types nil) + (defsubst c-clear-found-types () ;; Clears `c-found-types'. (setq c-found-types @@ -6825,7 +6832,10 @@ comment at the start of cc-engine.el for more info." (let ((type (c-syntactic-content from to c-recognize-<>-arglists))) (unless (gethash type c-found-types) (puthash type t c-found-types) - (when (and (eq (string-match c-symbol-key type) 0) + (when (and (not c-record-found-types) ; Only call `c-fontify-new-fount-type' + ; when we haven't "bound" c-found-types + ; to itself in c-forward-<>-arglist. + (eq (string-match c-symbol-key type) 0) (eq (match-end 0) (length type))) (c-fontify-new-found-type type))))) @@ -8225,11 +8235,6 @@ multi-line strings (but not C++, for example)." (setq c-record-ref-identifiers (cons range c-record-ref-identifiers)))))) -;; Dynamically bound variable that instructs `c-forward-type' to -;; record the ranges of types that only are found. Behaves otherwise -;; like `c-record-type-identifiers'. -(defvar c-record-found-types nil) - (defmacro c-forward-keyword-prefixed-id (type) ;; Used internally in `c-forward-keyword-clause' to move forward ;; over a type (if TYPE is 'type) or a name (otherwise) which @@ -8459,6 +8464,11 @@ multi-line strings (but not C++, for example)." (c-forward-<>-arglist-recur all-types))) (progn (when (consp c-record-found-types) + (let ((cur c-record-found-types)) + (while (consp (car-safe cur)) + (c-fontify-new-found-type + (buffer-substring-no-properties (caar cur) (cdar cur))) + (setq cur (cdr cur)))) (setq c-record-type-identifiers ;; `nconc' doesn't mind that the tail of ;; `c-record-found-types' is t. @@ -9184,6 +9194,12 @@ multi-line strings (but not C++, for example)." (when (and (eq res t) (consp c-record-found-types)) + ;; Cause the confirmed types to get fontified. + (let ((cur c-record-found-types)) + (while (consp (car-safe cur)) + (c-fontify-new-found-type + (buffer-substring-no-properties (caar cur) (cdar cur))) + (setq cur (cdr cur)))) ;; Merge in the ranges of any types found by the second ;; `c-forward-type'. (setq c-record-type-identifiers diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index 9355409b2a..967464ac14 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -101,6 +101,7 @@ (cc-bytecomp-defun c-font-lock-objc-method) (cc-bytecomp-defun c-font-lock-invalid-string) (cc-bytecomp-defun c-before-context-fl-expand-region) +(cc-bytecomp-defun c-font-lock-fontify-region) ;; Note that font-lock in XEmacs doesn't expand face names as @@ -2428,6 +2429,7 @@ higher." (defun c-force-redisplay (start end) ;; Force redisplay immediately. This assumes `font-lock-support-mode' is ;; 'jit-lock-mode. Set the variable `c-re-redisplay-timer' to nil. + (save-excursion (c-font-lock-fontify-region start end)) (jit-lock-force-redisplay (copy-marker start) (copy-marker end)) (setq c-re-redisplay-timer nil)) @@ -2436,7 +2438,8 @@ higher." ;; buffer. If TYPE is currently displayed in a window, cause redisplay to ;; happen "instantaneously". These actions are done only when jit-lock-mode ;; is active. - (when (and (boundp 'font-lock-support-mode) + (when (and font-lock-mode + (boundp 'font-lock-support-mode) (eq font-lock-support-mode 'jit-lock-mode)) (c-save-buffer-state ((window-boundaries @@ -2455,7 +2458,6 @@ higher." (dolist (win-boundary window-boundaries) (when (and (< (match-beginning 0) (cdr win-boundary)) (> (match-end 0) (car win-boundary)) - (c-get-char-property (match-beginning 0) 'fontified) (not c-re-redisplay-timer)) (setq c-re-redisplay-timer (run-with-timer 0 nil #'c-force-redisplay commit f32280bfa6342090abaa9f015d4cd70fb81bbfef Author: Lars Ingebrigtsen Date: Sat Nov 13 10:05:36 2021 +0100 Don't create links to undefined commands in help--describe-command * lisp/help.el (help--describe-command): Don't create links to commands that aren't defined. diff --git a/lisp/help.el b/lisp/help.el index b2772f4389..4470e6baaa 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1328,9 +1328,11 @@ Return nil if the key sequence is too long." (defun help--describe-command (definition &optional translation) (cond ((symbolp definition) - (insert-text-button (symbol-name definition) - 'type 'help-function - 'help-args (list definition)) + (if (fboundp definition) + (insert-text-button (symbol-name definition) + 'type 'help-function + 'help-args (list definition)) + (insert (symbol-name definition))) (insert "\n")) ((or (stringp definition) (vectorp definition)) (if translation commit dafebe37ebe08d581506864e96058807d1aec56b Author: Po Lu Date: Sat Nov 13 15:38:12 2021 +0800 Use GTK native file choosers in xwidget callback * src/xwidget.c (run_file_chooser_cb): Use GtkFileChooserNative instead. diff --git a/src/xwidget.c b/src/xwidget.c index e5a5d9008d..ca0392a44d 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -791,7 +791,7 @@ run_file_chooser_cb (WebKitWebView *webview, gpointer user_data) { struct frame *f = SELECTED_FRAME (); - GtkWidget *chooser; + GtkFileChooserNative *chooser; GtkFileFilter *filter; bool select_multiple_p; guint response; @@ -806,25 +806,21 @@ run_file_chooser_cb (WebKitWebView *webview, if (!FRAME_WINDOW_P (f)) return TRUE; - chooser = gtk_file_chooser_dialog_new ("Select file", + chooser = gtk_file_chooser_native_new ("Select file", GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), - GTK_FILE_CHOOSER_ACTION_OPEN, - "Cancel", - GTK_RESPONSE_CANCEL, - "Select", - GTK_RESPONSE_ACCEPT, - NULL); + GTK_FILE_CHOOSER_ACTION_OPEN, "Select", + "Cancel"); filter = webkit_file_chooser_request_get_mime_types_filter (request); select_multiple_p = webkit_file_chooser_request_get_select_multiple (request); gtk_file_chooser_set_select_multiple (GTK_FILE_CHOOSER (chooser), select_multiple_p); gtk_file_chooser_add_filter (GTK_FILE_CHOOSER (chooser), filter); - response = gtk_dialog_run (GTK_DIALOG (chooser)); + response = gtk_native_dialog_run (GTK_NATIVE_DIALOG (chooser)); - if (response == GTK_RESPONSE_CANCEL) + if (response != GTK_RESPONSE_ACCEPT) { - gtk_widget_destroy (chooser); + gtk_native_dialog_destroy (GTK_NATIVE_DIALOG (chooser)); webkit_file_chooser_request_cancel (request); return TRUE; @@ -844,7 +840,7 @@ run_file_chooser_cb (WebKitWebView *webview, for (i = 0; i < len; ++i) g_free (files[i]); - gtk_widget_destroy (chooser); + gtk_native_dialog_destroy (GTK_NATIVE_DIALOG (chooser)); return TRUE; } commit b4c6ab8cb67be4d5b3e0041981968c6cce4afe89 Merge: a5008352c4 42d4e24ff3 Author: Stefan Kangas Date: Sat Nov 13 07:00:30 2021 +0100 Merge from origin/emacs-28 42d4e24ff3 ; Fix typos 0d0125daae Improve documentation of 'decode-coding-region' commit a5008352c43cda13b0a35547ee91f0c889d71d06 Author: Po Lu Date: Sat Nov 13 13:02:09 2021 +0800 Prevent NULL-pointer dereference on xwidget callback error * src/xwidget.c (webkit_javascript_finished_cb): Check if `error' is NULL before freeing it. diff --git a/src/xwidget.c b/src/xwidget.c index fad07efb29..e5a5d9008d 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -1363,8 +1363,8 @@ webkit_javascript_finished_cb (GObject *webview, if (!js_result) { - g_warning ("Error running javascript: %s", error->message); - g_error_free (error); + if (error) + g_error_free (error); return; } commit eb4567e5be17e30583baebced562cb83595643e3 Author: Po Lu Date: Sat Nov 13 11:24:13 2021 +0800 Fix file chooser hangs inside xwidget-webkit * src/xwidget.c (run_file_chooser_cb): New function that runs a nested event loop instead of acting asynchronously. (Fmake_xwidget): Attach file chooser signal. diff --git a/src/xwidget.c b/src/xwidget.c index c1fbfedc70..fad07efb29 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -91,6 +91,9 @@ webkit_decide_policy_cb (WebKitWebView *, WebKitPolicyDecisionType, gpointer); static GtkWidget *find_widget_at_pos (GtkWidget *, int, int, int *, int *); +static gboolean run_file_chooser_cb (WebKitWebView *, + WebKitFileChooserRequest *, + gpointer); struct widget_search_data { @@ -261,6 +264,10 @@ fails. */) "script-dialog", G_CALLBACK (webkit_script_dialog_cb), NULL); + g_signal_connect (G_OBJECT (xw->widget_osr), + "run-file-chooser", + G_CALLBACK (run_file_chooser_cb), + NULL); } g_signal_connect (G_OBJECT (xw->widgetwindow_osr), "damage-event", @@ -778,6 +785,70 @@ mouse_target_changed (WebKitWebView *webview, define_cursors (xw, hitresult); } +static gboolean +run_file_chooser_cb (WebKitWebView *webview, + WebKitFileChooserRequest *request, + gpointer user_data) +{ + struct frame *f = SELECTED_FRAME (); + GtkWidget *chooser; + GtkFileFilter *filter; + bool select_multiple_p; + guint response; + GSList *filenames; + GSList *tem; + int i, len; + gchar **files; + + /* Return TRUE to prevent WebKit from showing the default script + dialog in the offscreen window, which runs a nested main loop + Emacs can't respond to, and as such can't pass X events to. */ + if (!FRAME_WINDOW_P (f)) + return TRUE; + + chooser = gtk_file_chooser_dialog_new ("Select file", + GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + GTK_FILE_CHOOSER_ACTION_OPEN, + "Cancel", + GTK_RESPONSE_CANCEL, + "Select", + GTK_RESPONSE_ACCEPT, + NULL); + filter = webkit_file_chooser_request_get_mime_types_filter (request); + select_multiple_p = webkit_file_chooser_request_get_select_multiple (request); + + gtk_file_chooser_set_select_multiple (GTK_FILE_CHOOSER (chooser), + select_multiple_p); + gtk_file_chooser_add_filter (GTK_FILE_CHOOSER (chooser), filter); + response = gtk_dialog_run (GTK_DIALOG (chooser)); + + if (response == GTK_RESPONSE_CANCEL) + { + gtk_widget_destroy (chooser); + webkit_file_chooser_request_cancel (request); + + return TRUE; + } + + filenames = gtk_file_chooser_get_filenames (GTK_FILE_CHOOSER (chooser)); + len = g_slist_length (filenames); + files = alloca (sizeof *files * (len + 1)); + + for (tem = filenames, i = 0; tem; tem = tem->next, ++i) + files[i] = tem->data; + files[len] = NULL; + + g_slist_free (filenames); + webkit_file_chooser_request_select_files (request, (const gchar **) files); + + for (i = 0; i < len; ++i) + g_free (files[i]); + + gtk_widget_destroy (chooser); + + return TRUE; +} + static void xwidget_button_1 (struct xwidget_view *view, commit 59a58328bc086bdda1d8be816778f2a74379b02f Author: Po Lu Date: Sat Nov 13 08:51:32 2021 +0800 Remove unused xwidget code in EmacsFixed GTK widget class This is no longer required, as we rely on X to position xwidgets now. It also makes resizing Emacs frames slightly slower. * src/emacsgtkfixed.c (EMACS_FIXED_GET_CLASS) (struct GtkFixedPrivateL) (emacs_fixed_gtk_widget_size_allocate) (emacs_fixed_class_init) [HAVE_XWIDGETS]: Remove unused code. diff --git a/src/emacsgtkfixed.c b/src/emacsgtkfixed.c index 996ded2aca..1f5b0947e5 100644 --- a/src/emacsgtkfixed.c +++ b/src/emacsgtkfixed.c @@ -57,92 +57,6 @@ EMACS_FIXED (GtkWidget *widget) EmacsFixed); } -#ifdef HAVE_XWIDGETS - -static EmacsFixedClass * -EMACS_FIXED_GET_CLASS (GtkWidget *widget) -{ - return G_TYPE_INSTANCE_GET_CLASS (widget, emacs_fixed_get_type (), - EmacsFixedClass); -} - -struct GtkFixedPrivateL -{ - GList *children; -}; - -static void -emacs_fixed_gtk_widget_size_allocate (GtkWidget *widget, - GtkAllocation *allocation) -{ - /* For xwidgets. - - This basically re-implements the base class method and adds an - additional case for an xwidget view. - - It would be nicer if the bse class method could be called first, - and the xview modification only would remain here. It wasn't - possible to solve it that way yet. */ - EmacsFixedClass *klass; - GtkWidgetClass *parent_class; - struct GtkFixedPrivateL *priv; - - klass = EMACS_FIXED_GET_CLASS (widget); - parent_class = g_type_class_peek_parent (klass); - parent_class->size_allocate (widget, allocation); - - priv = G_TYPE_INSTANCE_GET_PRIVATE (widget, GTK_TYPE_FIXED, - struct GtkFixedPrivateL); - - gtk_widget_set_allocation (widget, allocation); - - if (gtk_widget_get_has_window (widget)) - { - if (gtk_widget_get_realized (widget)) - gdk_window_move_resize (gtk_widget_get_window (widget), - allocation->x, - allocation->y, - allocation->width, - allocation->height); - } - - for (GList *children = priv->children; children; children = children->next) - { - GtkFixedChild *child = children->data; - - if (!gtk_widget_get_visible (child->widget)) - continue; - - GtkRequisition child_requisition; - gtk_widget_get_preferred_size (child->widget, &child_requisition, NULL); - - GtkAllocation child_allocation; - child_allocation.x = child->x; - child_allocation.y = child->y; - - if (!gtk_widget_get_has_window (widget)) - { - child_allocation.x += allocation->x; - child_allocation.y += allocation->y; - } - - child_allocation.width = child_requisition.width; - child_allocation.height = child_requisition.height; - - struct xwidget_view *xv - = g_object_get_data (G_OBJECT (child->widget), XG_XWIDGET_VIEW); - if (xv) - { - child_allocation.width = xv->clip_right; - child_allocation.height = xv->clip_bottom - xv->clip_top; - } - - gtk_widget_size_allocate (child->widget, &child_allocation); - } -} - -#endif /* HAVE_XWIDGETS */ - static void emacs_fixed_class_init (EmacsFixedClass *klass) { @@ -152,9 +66,6 @@ emacs_fixed_class_init (EmacsFixedClass *klass) widget_class->get_preferred_width = emacs_fixed_get_preferred_width; widget_class->get_preferred_height = emacs_fixed_get_preferred_height; -#ifdef HAVE_XWIDGETS - widget_class->size_allocate = emacs_fixed_gtk_widget_size_allocate; -#endif g_type_class_add_private (klass, sizeof (EmacsFixedPrivate)); } commit 3ea70eea98374764313053a72f1fff4df6c39ee1 Author: Po Lu Date: Sat Nov 13 08:30:43 2021 +0800 Prevent xwidget webkit isearch messages from entering log buffer * lisp/xwidget.el (xwidget-webkit-isearch--update): Prevent logging when displaying search contents message. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index e98143b955..485d995f41 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -910,8 +910,9 @@ WebKit widget. The query will be set to the contents of (xwidget-webkit-search xwidget-webkit-isearch--string (xwidget-webkit-current-session) t xwidget-webkit-isearch--is-reverse t)) - (message (concat (propertize "Search contents: " 'face 'minibuffer-prompt) - xwidget-webkit-isearch--string))) + (let ((message-log-max nil)) + (message (concat (propertize "Search contents: " 'face 'minibuffer-prompt) + xwidget-webkit-isearch--string)))) (defun xwidget-webkit-isearch-erasing-char (count) "Erase the last COUNT characters of the current query." commit e4f8ce78183e95bfbe649fb2ac43f3fe3492c782 Author: Ken Brown Date: Thu Nov 11 15:09:24 2021 -0500 Don't start both timerfd and alarms on Cygwin * src/atimer.c (set_alarm) [CYGWIN]: Don't start both timerfd and alarms; this causes a slowdown. (Bug#51734) diff --git a/src/atimer.c b/src/atimer.c index 490c21bff1..9bde9c2446 100644 --- a/src/atimer.c +++ b/src/atimer.c @@ -316,6 +316,13 @@ set_alarm (void) exit = true; } # endif + +# ifdef CYGWIN + /* Don't start both timerfd and alarms on Cygwin; this + causes a slowdown (bug#51734). */ + if (exit) + return; +# endif if (alarm_timer_ok && timer_settime (alarm_timer, TIMER_ABSTIME, &ispec, 0) == 0) exit = true; commit 974192413f8a81171b8fd28dfd5c081ce06d3dec Author: Alan Mackenzie Date: Fri Nov 12 18:43:22 2021 +0000 In insert_file_contents, always set windows' point markers. This fixes bug #51776. * src/fileio.c (restore_window_points): Restore a w->mpoint even when that marker originally pointed into the unchanged area near BOB or EOB. This prevents that window's point being moved a long way from its starting place due to the removal of the central part of the buffer by insert_file_contents. diff --git a/src/fileio.c b/src/fileio.c index 3c13d3fe41..a7b1649fae 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -3827,6 +3827,7 @@ restore_window_points (Lisp_Object window_markers, ptrdiff_t inserted, Lisp_Object car = XCAR (window_markers); Lisp_Object marker = XCAR (car); Lisp_Object oldpos = XCDR (car); + ptrdiff_t newpos; if (MARKERP (marker) && FIXNUMP (oldpos) && XFIXNUM (oldpos) > same_at_start && XFIXNUM (oldpos) < same_at_end) @@ -3834,10 +3835,12 @@ restore_window_points (Lisp_Object window_markers, ptrdiff_t inserted, ptrdiff_t oldsize = same_at_end - same_at_start; ptrdiff_t newsize = inserted; double growth = newsize / (double)oldsize; - ptrdiff_t newpos - = same_at_start + growth * (XFIXNUM (oldpos) - same_at_start); - Fset_marker (marker, make_fixnum (newpos), Qnil); + newpos = same_at_start + + growth * (XFIXNUM (oldpos) - same_at_start); } + else + newpos = XFIXNUM (oldpos); + Fset_marker (marker, make_fixnum (newpos), Qnil); } } commit 2c5be6ddca96443722e5e527a015b1d3574ed081 Author: Michael Albinus Date: Fri Nov 12 18:17:32 2021 +0100 Remove Emacs 25 compatibility from Tramp * doc/misc/tramp.texi (Remote programs, Remote processes) (Frequently Asked Questions): Adapt Emacs versions. * doc/misc/trampver.texi: * lisp/net/trampver.el: Change version to "2.6.0-pre". * lisp/net/tramp-adb.el (top): Don't use `tramp-compat-funcall' for connection-local functions. * lisp/net/tramp-compat.el (tramp-unload-file-name-handlers) (tramp-handle-temporary-file-directory) (tramp-compat-temporary-file-directory-function) (tramp-compat-file-attribute-type) (tramp-compat-file-attribute-link-number) (tramp-compat-file-attribute-user-id) (tramp-compat-file-attribute-group-id) (tramp-compat-file-attribute-access-time) (tramp-compat-file-attribute-modification-time) (tramp-compat-file-attribute-status-change-time) (tramp-compat-file-attribute-size) (tramp-compat-file-attribute-modes, tramp-file-missing) (tramp-compat-file-missing, tramp-compat-file-local-name): Remove. (tramp-compat-file-name-quoted-p, tramp-compat-file-name-quote) (tramp-compat-file-name-unquote) (tramp-compat-progress-reporter-update) (tramp-compat-file-modes, tramp-compat-set-file-modes) (tramp-compat-set-file-times, tramp-compat-directory-files) (tramp-compat-directory-files-and-attributes): Adapt implementation. * lisp/net/tramp.el: * lisp/net/tramp-adb.el: * lisp/net/tramp-archive.el: * lisp/net/tramp-crypt.el: * lisp/net/tramp-fuse.el: * lisp/net/tramp-gvfs.el: * lisp/net/tramp-rclone.el: * lisp/net/tramp-sh.el: * lisp/net/tramp-smb.el: * lisp/net/tramp-sudoedit.el: Adapt callees. * lisp/net/tramp-crypt.el (tramp-crypt-config-file-name): Expand file name. * lisp/net/tramp-fuse.el (tramp-fuse-handle-file-readable-p): Remove. * lisp/net/tramp-gvfs.el (tramp-gvfs-enabled): Don't check Emacs version. (tramp-gvfs-handler-mounted-unmounted): Use `make-tramp-file-name'. * lisp/net/tramp-integration.el (rfn-eshadow-overlay): Remove declaration. (top): Don't use `tramp-compat-funcall' for connection-local functions. * lisp/net/tramp-rclone.el (tramp-rclone-file-name-handler-alist): Use `tramp-rclone-handle-file-readable-p'. (tramp-rclone-handle-file-readable-p): New defun. * lisp/net/tramp-sshfs.el (tramp-sshfs-file-name-handler-alist): Use `tramp-handle-file-readable-p'. * lisp/net/tramp.el (tramp-temp-name-prefix, tramp-lookup-syntax): Adapt docstring. (tramp-set-connection-local-variables) (tramp-set-connection-local-variables-for-buffer): Don't use `tramp-compat-funcall' for connection-local functions. (tramp-file-name-for-operation): Reorder list. (tramp-handle-make-symbolic-link): Don't handle TARGET and OK-IF-ALREADY-EXISTS. (tramp-read-passwd): Don't use `read-passwd' any longer. (top): Don't check for `interrupt-process-functions'. * test/lisp/net/tramp-archive-tests.el (tramp-archive--test-emacs26-p): Remove. (tramp-archive-test02-file-name-dissect): Use `make-tramp-file-name'. (all): Replace Emacs 26 compatibility functions with their original name. (tramp-archive-test46-auto-load) (tramp-archive-test46-delay-load): Rename. * test/lisp/net/tramp-tests.el (dired-aux, seq): Require them. (dired-compress, connection-local-criteria-alist) (connection-local-profile-alist, async-shell-command-width): Don't declare. (all): Replace Emacs 26 compatibility functions with their original name. (tramp-test04-substitute-in-file-name) (tramp-test10-write-region, tramp-test11-copy-file) (tramp-test12-rename-file, tramp-test15-copy-directory) (tramp-test17-insert-directory) (tramp-test17-dired-with-wildcards, tramp-test21-file-links) (tramp-test31-interrupt-process) (tramp-test34-connection-local-variables) (tramp-test34-explicit-shell-file-name) (tramp-test40-make-nearby-temp-file) (tramp-test41-special-characters, tramp-test42-utf8) (tramp-test46-delay-load, tramp-test46-remote-load-path) (tramp-test47-unload): Don't check for Emacs 26 special features. (tramp--test-emacs26-p): Remove. (tramp--test-emacs29-p): New defun. (tramp-test45-dired-compress-file) (tramp-test45-dired-compress-dir): Use it. (tramp-test44-asynchronous-requests): Use `seq-random-elt'. diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index a17a8d67e5..819670a508 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -2238,8 +2238,7 @@ preserves the path value, which can be used to update shell supports the login argument @samp{-l}. @end defopt -Starting with @w{Emacs 26}, @code{tramp-remote-path} can be set per -host via connection-local +@code{tramp-remote-path} can also be set per host via connection-local @ifinfo variables, @xref{Connection Variables, , , emacs}. @end ifinfo @@ -3533,9 +3532,8 @@ ensures the correct name of the remote shell program. When @code{explicit-shell-file-name} is equal to @code{nil}, calling @code{shell} interactively will prompt for a shell name. -Starting with @w{Emacs 26}, you could use connection-local variables -for setting different values of @code{explicit-shell-file-name} for -different remote hosts. +You could use connection-local variables for setting different values +of @code{explicit-shell-file-name} for different remote hosts. @ifinfo @xref{Connection Variables, , , emacs}. @end ifinfo @@ -4347,8 +4345,8 @@ Where is the latest @value{tramp}? @item Which systems does it work on? -The package works successfully on @w{Emacs 25}, @w{Emacs 26}, @w{Emacs -27}, and @w{Emacs 28}. +The package works successfully on @w{Emacs 26}, @w{Emacs 27}, @w{Emacs +28}, and @w{Emacs 29}. While Unix and Unix-like systems are the primary remote targets, @value{tramp} has equal success connecting to other platforms, such as diff --git a/doc/misc/trampver.texi b/doc/misc/trampver.texi index b11ee39f88..89c478035c 100644 --- a/doc/misc/trampver.texi +++ b/doc/misc/trampver.texi @@ -8,10 +8,10 @@ @c In the Tramp GIT, the version numbers are auto-frobbed from @c tramp.el, and the bug report address is auto-frobbed from @c configure.ac. -@set trampver 2.5.2-pre +@set trampver 2.6.0-pre @set trampurl https://www.gnu.org/software/tramp/ @set tramp-bug-report-address tramp-devel@@gnu.org -@set emacsver 25.1 +@set emacsver 26.1 @c Other flags from configuration. @set instprefix /usr/local diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index e7fe07e417..374e5db587 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -119,6 +119,7 @@ It is used for TCP/IP devices." (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-adb-handle-directory-files-and-attributes) + ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . tramp-adb-handle-exec-path) @@ -305,7 +306,7 @@ arguments to pass to the OPERATION." (directory &optional full match nosort id-format count) "Like `directory-files-and-attributes' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (with-parsed-tramp-file-name (expand-file-name directory) nil (copy-tree @@ -498,7 +499,7 @@ Emacs dired can't find files." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (unless (file-exists-p (file-truename filename)) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (with-tramp-progress-reporter v 3 (format "Fetching %s to tmp file %s" filename tmpfile) @@ -590,8 +591,7 @@ Emacs dired can't find files." ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime - (or (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (or (file-attribute-modification-time (file-attributes filename)) (current-time)))) ;; Unlock file. @@ -659,7 +659,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -719,8 +719,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))))) (defun tramp-adb-handle-rename-file @@ -741,7 +740,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -1348,22 +1347,18 @@ connection if a previous connection has died for some reason." ;; Mark it as connected. (tramp-set-connection-property p "connected" t))))))) -;;; Default connection-local variables for Tramp: -;; `connection-local-set-profile-variables' and -;; `connection-local-set-profiles' exists since Emacs 26.1. +;;; Default connection-local variables for Tramp. (defconst tramp-adb-connection-local-default-shell-variables '((shell-file-name . "/system/bin/sh") (shell-command-switch . "-c")) "Default connection-local shell variables for remote adb connections.") -(tramp-compat-funcall - 'connection-local-set-profile-variables +(connection-local-set-profile-variables 'tramp-adb-connection-local-default-shell-profile tramp-adb-connection-local-default-shell-variables) (with-eval-after-load 'shell - (tramp-compat-funcall - 'connection-local-set-profiles + (connection-local-set-profiles `(:application tramp :protocol ,tramp-adb-method) 'tramp-adb-connection-local-default-shell-profile)) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 8bf25151df..578f9fcf91 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -223,6 +223,7 @@ It must be supported by libarchive(3).") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) + ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . tramp-archive-handle-not-implemented) (dired-uncache . tramp-archive-handle-dired-uncache) (exec-path . ignore) @@ -618,7 +619,7 @@ offered." (defun tramp-archive-handle-file-system-info (filename) "Like `file-system-info' for file archives." (with-parsed-tramp-archive-file-name filename nil - (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0))) + (list (file-attribute-size (file-attributes archive)) 0 0))) (defun tramp-archive-handle-file-truename (filename) "Like `file-truename' for file archives." @@ -658,7 +659,7 @@ offered." ;; mounted directory, it is returned as it. Not what we want. (with-parsed-tramp-archive-file-name default-directory nil (let ((default-directory (file-name-directory archive))) - (tramp-compat-temporary-file-directory-function)))) + (temporary-file-directory)))) (defun tramp-archive-handle-not-implemented (operation &rest args) "Generic handler for operations not implemented for file archives." diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index fbc3d684ce..627ff1edae 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -23,17 +23,12 @@ ;;; Commentary: -;; Tramp's main Emacs version for development is Emacs 28. This -;; package provides compatibility functions for Emacs 25, Emacs 26 and -;; Emacs 27. +;; Tramp's main Emacs version for development is Emacs 29. This +;; package provides compatibility functions for Emacs 26, Emacs 27 and +;; Emacs 28. ;;; Code: -;; In Emacs 25, `tramp-unload-file-name-handlers' is not autoloaded. -;; So we declare it here in order to avoid recursive load. This will -;; be overwritten in tramp.el. -(defun tramp-unload-file-name-handlers () ".") - (require 'auth-source) (require 'format-spec) (require 'ls-lisp) ;; Due to `tramp-handle-insert-directory'. @@ -42,8 +37,6 @@ (require 'subr-x) (declare-function tramp-error "tramp") -;; `temporary-file-directory' as function is introduced with Emacs 26.1. -(declare-function tramp-handle-temporary-file-directory "tramp") (declare-function tramp-tramp-file-p "tramp") (defvar tramp-temp-name-prefix) @@ -83,133 +76,19 @@ Add the extension of F, if existing." tramp-temp-name-prefix tramp-compat-temporary-file-directory) dir-flag (file-name-extension f t))) -;; `temporary-file-directory' as function is introduced with Emacs 26.1. -(defalias 'tramp-compat-temporary-file-directory-function - (if (fboundp 'temporary-file-directory) - #'temporary-file-directory - #'tramp-handle-temporary-file-directory)) - -;; `file-attribute-*' are introduced in Emacs 26.1. - -(defalias 'tramp-compat-file-attribute-type - (if (fboundp 'file-attribute-type) - #'file-attribute-type - (lambda (attributes) - "The type field in ATTRIBUTES returned by `file-attributes'. -The value is either t for directory, string (name linked to) for -symbolic link, or nil." - (nth 0 attributes)))) - -(defalias 'tramp-compat-file-attribute-link-number - (if (fboundp 'file-attribute-link-number) - #'file-attribute-link-number - (lambda (attributes) - "Return the number of links in ATTRIBUTES returned by `file-attributes'." - (nth 1 attributes)))) - -(defalias 'tramp-compat-file-attribute-user-id - (if (fboundp 'file-attribute-user-id) - #'file-attribute-user-id - (lambda (attributes) - "The UID field in ATTRIBUTES returned by `file-attributes'. -This is either a string or a number. If a string value cannot be -looked up, a numeric value, either an integer or a float, is -returned." - (nth 2 attributes)))) - -(defalias 'tramp-compat-file-attribute-group-id - (if (fboundp 'file-attribute-group-id) - #'file-attribute-group-id - (lambda (attributes) - "The GID field in ATTRIBUTES returned by `file-attributes'. -This is either a string or a number. If a string value cannot be -looked up, a numeric value, either an integer or a float, is -returned." - (nth 3 attributes)))) - -(defalias 'tramp-compat-file-attribute-access-time - (if (fboundp 'file-attribute-access-time) - #'file-attribute-access-time - (lambda (attributes) - "The last access time in ATTRIBUTES returned by `file-attributes'. -This a Lisp timestamp in the style of `current-time'." - (nth 4 attributes)))) - -(defalias 'tramp-compat-file-attribute-modification-time - (if (fboundp 'file-attribute-modification-time) - #'file-attribute-modification-time - (lambda (attributes) - "The modification time in ATTRIBUTES returned by `file-attributes'. -This is the time of the last change to the file's contents, and -is a Lisp timestamp in the style of `current-time'." - (nth 5 attributes)))) - -(defalias 'tramp-compat-file-attribute-status-change-time - (if (fboundp 'file-attribute-status-change-time) - #'file-attribute-status-change-time - (lambda (attributes) - "The status modification time in ATTRIBUTES returned by `file-attributes'. -This is the time of last change to the file's attributes: owner -and group, access mode bits, etc., and is a Lisp timestamp in the -style of `current-time'." - (nth 6 attributes)))) - -(defalias 'tramp-compat-file-attribute-size - (if (fboundp 'file-attribute-size) - #'file-attribute-size - (lambda (attributes) - "The size (in bytes) in ATTRIBUTES returned by `file-attributes'. -If the size is too large for a fixnum, this is a bignum in Emacs 27 -and later, and is a float in Emacs 26 and earlier." - (nth 7 attributes)))) - -(defalias 'tramp-compat-file-attribute-modes - (if (fboundp 'file-attribute-modes) - #'file-attribute-modes - (lambda (attributes) - "The file modes in ATTRIBUTES returned by `file-attributes'. -This is a string of ten letters or dashes as in ls -l." - (nth 8 attributes)))) - -;; `file-missing' is introduced in Emacs 26.1. -(defconst tramp-file-missing - (if (get 'file-missing 'error-conditions) 'file-missing 'file-error) - "The error symbol for the `file-missing' error.") - -(defsubst tramp-compat-file-missing (vec file) - "Emit the `file-missing' error." - (if (get 'file-missing 'error-conditions) - (tramp-error vec tramp-file-missing file) - (tramp-error vec tramp-file-missing "No such file or directory: %s" file))) - -;; `file-local-name', `file-name-quoted-p', `file-name-quote' and -;; `file-name-unquote' are introduced in Emacs 26.1. -(defalias 'tramp-compat-file-local-name - (if (fboundp 'file-local-name) - #'file-local-name - (lambda (name) - "Return the local name component of NAME. -It returns a file name which can be used directly as argument of -`process-file', `start-file-process', or `shell-command'." - (or (file-remote-p name 'localname) name)))) - ;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' got ;; a second argument in Emacs 27.1. (defalias 'tramp-compat-file-name-quoted-p - (if (and - (fboundp 'file-name-quoted-p) - (equal (tramp-compat-funcall 'func-arity #'file-name-quoted-p) '(1 . 2))) + (if (equal (func-arity #'file-name-quoted-p) '(1 . 2)) #'file-name-quoted-p (lambda (name &optional top) "Whether NAME is quoted with prefix \"/:\". If NAME is a remote file name and TOP is nil, check the local part of NAME." (let ((file-name-handler-alist (unless top file-name-handler-alist))) - (string-prefix-p "/:" (tramp-compat-file-local-name name)))))) + (string-prefix-p "/:" (file-local-name name)))))) (defalias 'tramp-compat-file-name-quote - (if (and - (fboundp 'file-name-quote) - (equal (tramp-compat-funcall 'func-arity #'file-name-quote) '(1 . 2))) + (if (equal (func-arity #'file-name-quote) '(1 . 2)) #'file-name-quote (lambda (name &optional top) "Add the quotation prefix \"/:\" to file NAME. @@ -217,20 +96,17 @@ If NAME is a remote file name and TOP is nil, the local part of NAME is quoted." (let ((file-name-handler-alist (unless top file-name-handler-alist))) (if (tramp-compat-file-name-quoted-p name top) name - (concat - (file-remote-p name) "/:" (tramp-compat-file-local-name name))))))) + (concat (file-remote-p name) "/:" (file-local-name name))))))) (defalias 'tramp-compat-file-name-unquote - (if (and - (fboundp 'file-name-unquote) - (equal (tramp-compat-funcall 'func-arity #'file-name-unquote) '(1 . 2))) + (if (equal (func-arity #'file-name-unquote) '(1 . 2)) #'file-name-unquote (lambda (name &optional top) "Remove quotation prefix \"/:\" from file NAME. If NAME is a remote file name and TOP is nil, the local part of NAME is unquoted." (let* ((file-name-handler-alist (unless top file-name-handler-alist)) - (localname (tramp-compat-file-local-name name))) + (localname (file-local-name name))) (when (tramp-compat-file-name-quoted-p localname top) (setq localname (if (= (length localname) 2) "/" (substring localname 2)))) @@ -288,8 +164,7 @@ A nil value for either argument stands for the current time." ;; `progress-reporter-update' got argument SUFFIX in Emacs 27.1. (defalias 'tramp-compat-progress-reporter-update - (if (equal (tramp-compat-funcall 'func-arity #'progress-reporter-update) - '(1 . 3)) + (if (equal (func-arity #'progress-reporter-update) '(1 . 3)) #'progress-reporter-update (lambda (reporter &optional value _suffix) (progress-reporter-update reporter value)))) @@ -306,19 +181,19 @@ CONDITION can also be a list of error conditions." ;; `file-modes', `set-file-modes' and `set-file-times' got argument ;; FLAG in Emacs 28.1. (defalias 'tramp-compat-file-modes - (if (equal (tramp-compat-funcall 'func-arity #'file-modes) '(1 . 2)) + (if (equal (func-arity #'file-modes) '(1 . 2)) #'file-modes (lambda (filename &optional _flag) (file-modes filename)))) (defalias 'tramp-compat-set-file-modes - (if (equal (tramp-compat-funcall 'func-arity #'set-file-modes) '(2 . 3)) + (if (equal (func-arity #'set-file-modes) '(2 . 3)) #'set-file-modes (lambda (filename mode &optional _flag) (set-file-modes filename mode)))) (defalias 'tramp-compat-set-file-times - (if (equal (tramp-compat-funcall 'func-arity #'set-file-times) '(1 . 3)) + (if (equal (func-arity #'set-file-times) '(1 . 3)) #'set-file-times (lambda (filename &optional timestamp _flag) (set-file-times filename timestamp)))) @@ -326,14 +201,13 @@ CONDITION can also be a list of error conditions." ;; `directory-files' and `directory-files-and-attributes' got argument ;; COUNT in Emacs 28.1. (defalias 'tramp-compat-directory-files - (if (equal (tramp-compat-funcall 'func-arity #'directory-files) '(1 . 5)) + (if (equal (func-arity #'directory-files) '(1 . 5)) #'directory-files (lambda (directory &optional full match nosort _count) (directory-files directory full match nosort)))) (defalias 'tramp-compat-directory-files-and-attributes - (if (equal (tramp-compat-funcall 'func-arity #'directory-files-and-attributes) - '(1 . 6)) + (if (equal (func-arity #'directory-files-and-attributes) '(1 . 6)) #'directory-files-and-attributes (lambda (directory &optional full match nosort id-format _count) (directory-files-and-attributes directory full match nosort id-format)))) @@ -410,8 +284,6 @@ CONDITION can also be a list of error conditions." ;;; TODO: ;; -;; * `func-arity' exists since Emacs 26.1. -;; ;; * Starting with Emacs 27.1, there's no need to escape open ;; parentheses with a backslash in docstrings anymore. ;; diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 269560bfa9..f431f97563 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -169,6 +169,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (directory-files . tramp-crypt-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) + ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . ignore) @@ -293,8 +294,9 @@ arguments to pass to the OPERATION." (defun tramp-crypt-config-file-name (vec) "Return the encfs config file name for VEC." - (locate-user-emacs-file - (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config))) + (expand-file-name + (locate-user-emacs-file + (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config)))) (defun tramp-crypt-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -595,7 +597,7 @@ absolute file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -697,7 +699,7 @@ absolute file names." (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (let* (tramp-crypt-enabled diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index c359082dc1..cb270be68f 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -48,7 +48,7 @@ (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (with-parsed-tramp-file-name directory nil @@ -107,12 +107,6 @@ (unless (string-match-p elt item) (throw 'match nil))) (setq result (cons (concat item "/") result)))))))))) -(defun tramp-fuse-handle-file-readable-p (filename) - "Like `file-readable-p' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property v localname "file-readable-p" - (file-readable-p (tramp-fuse-local-file-name filename))))) - ;; This function isn't used. (defun tramp-fuse-handle-insert-directory (filename switches &optional wildcard full-directory-p) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 1f9d9d9415..11de71aa0d 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -122,10 +122,7 @@ (autoload 'zeroconf-init "zeroconf") (tramp-compat-funcall 'dbus-get-unique-name :system) (tramp-compat-funcall 'dbus-get-unique-name :session) - (or ;; Until Emacs 25, `process-attributes' could crash Emacs - ;; for some processes. Better we don't check. - (<= emacs-major-version 25) - (tramp-process-running-p "gvfs-fuse-daemon") + (or (tramp-process-running-p "gvfs-fuse-daemon") (tramp-process-running-p "gvfsd-fuse")))) "Non-nil when GVFS is available.") @@ -471,8 +468,7 @@ It has been changed in GVFS 1.14.") ;; ;; -;; The basic structure for GNOME Online Accounts. We use a list :type, -;; in order to be compatible with Emacs 25. +;; The basic structure for GNOME Online Accounts. (cl-defstruct (tramp-goa-account (:type list) :named) method user host port) ;;;###tramp-autoload @@ -672,8 +668,7 @@ It has been changed in GVFS 1.14.") ;; STRING key (always-call-mount, is-removable, ...) ;; VARIANT value (boolean?) -;; The basic structure for media devices. We use a list :type, in -;; order to be compatible with Emacs 25. +;; The basic structure for media devices. (cl-defstruct (tramp-media-device (:type list) :named) method host port) ;; "gvfs-" utilities have been deprecated in GVFS 1.31.1. We @@ -761,6 +756,7 @@ It has been changed in GVFS 1.14.") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) + ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . ignore) @@ -1001,7 +997,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -1101,8 +1097,7 @@ file names." (tramp-skeleton-delete-directory directory recursive trash (if (and recursive (not (file-symlink-p directory))) (mapc (lambda (file) - (if (eq t (tramp-compat-file-attribute-type - (file-attributes file))) + (if (eq t (file-attribute-type (file-attributes file))) (delete-directory file recursive) (delete-file file))) (directory-files @@ -1613,9 +1608,8 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-get-connection-property (tramp-get-process vec) "share" (tramp-get-connection-property vec "default-location" nil)))) - (tramp-compat-file-attribute-user-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format))))) + (file-attribute-user-id + (file-attributes (tramp-make-tramp-file-name vec localname) id-format))))) (defun tramp-gvfs-handle-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. @@ -1624,9 +1618,8 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-get-connection-property (tramp-get-process vec) "share" (tramp-get-connection-property vec "default-location" nil)))) - (tramp-compat-file-attribute-group-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format)))) + (file-attribute-group-id + (file-attributes (tramp-make-tramp-file-name vec localname) id-format)))) (defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." @@ -1864,9 +1857,9 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and host (tramp-file-name-host v) port (tramp-file-name-port v))))) (when (member method tramp-gvfs-methods) - (let ((v (make-tramp-file-name - :method method :user user :domain domain - :host host :port port))) + (let ((v (make-tramp-file-name + :method method :user user :domain domain + :host host :port port))) (tramp-message v 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message mount-info)) diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index 17264193fd..238abd3423 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -85,13 +85,6 @@ special handling of `substitute-in-file-name'." "An overlay covering the shadowed part of the filename." (format "[^%s/~]*\\(/\\|~\\)" tramp-postfix-host-format)) -;; Package rfn-eshadow is preloaded in Emacs, but for some reason, -;; it only did (defvar rfn-eshadow-overlay) without giving it a global -;; value, so it was only declared as dynamically-scoped within the -;; rfn-eshadow.el file. This is now fixed in Emacs>26.1 but we still need -;; this defvar here for older releases. -(defvar rfn-eshadow-overlay) - (defun tramp-rfn-eshadow-update-overlay () "Update `rfn-eshadow-overlay' to cover shadowed part of minibuffer input. This is intended to be used as a minibuffer `post-command-hook' for @@ -281,22 +274,18 @@ NAME must be equal to `tramp-current-connection'." (remove-hook 'compilation-start-hook #'tramp-compile-disable-ssh-controlmaster-options)))) -;;; Default connection-local variables for Tramp: -;; `connection-local-set-profile-variables' and -;; `connection-local-set-profiles' exists since Emacs 26.1. +;;; Default connection-local variables for Tramp. (defconst tramp-connection-local-default-system-variables '((path-separator . ":") (null-device . "/dev/null")) "Default connection-local system variables for remote connections.") -(tramp-compat-funcall - 'connection-local-set-profile-variables +(connection-local-set-profile-variables 'tramp-connection-local-default-system-profile tramp-connection-local-default-system-variables) -(tramp-compat-funcall - 'connection-local-set-profiles +(connection-local-set-profiles '(:application tramp) 'tramp-connection-local-default-system-profile) @@ -305,14 +294,12 @@ NAME must be equal to `tramp-current-connection'." (shell-command-switch . "-c")) "Default connection-local shell variables for remote connections.") -(tramp-compat-funcall - 'connection-local-set-profile-variables +(connection-local-set-profile-variables 'tramp-connection-local-default-shell-profile tramp-connection-local-default-shell-variables) (with-eval-after-load 'shell - (tramp-compat-funcall - 'connection-local-set-profiles + (connection-local-set-profiles '(:application tramp) 'tramp-connection-local-default-shell-profile)) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 64b0176d08..c997215a15 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -83,6 +83,7 @@ (directory-files . tramp-fuse-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) + ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . ignore) @@ -110,7 +111,7 @@ (file-notify-rm-watch . ignore) (file-notify-valid-p . ignore) (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-fuse-handle-file-readable-p) + (file-readable-p . tramp-rclone-handle-file-readable-p) (file-regular-p . tramp-handle-file-regular-p) (file-remote-p . tramp-handle-file-remote-p) (file-selinux-context . tramp-handle-file-selinux-context) @@ -222,7 +223,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -279,6 +280,12 @@ file names." (list filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)))) +(defun tramp-rclone-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property v localname "file-readable-p" + (file-readable-p (tramp-fuse-local-file-name filename))))) + (defun tramp-rclone-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." (ignore-errors diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index b20e5f8073..533ddcf66e 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -952,6 +952,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-sh-handle-directory-files-and-attributes) + ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . tramp-sh-handle-dired-compress-file) (dired-uncache . tramp-handle-dired-uncache) (exec-path . tramp-sh-handle-exec-path) @@ -1334,7 +1335,7 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - (modtime (or (tramp-compat-file-attribute-modification-time attr) + (modtime (or (file-attribute-modification-time attr) tramp-time-doesnt-exist))) (setq coding-system-used last-coding-system-used) (if (not (tramp-compat-time-equal-p modtime tramp-time-dont-know)) @@ -1372,7 +1373,7 @@ of." (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - (modtime (tramp-compat-file-attribute-modification-time attr)) + (modtime (file-attribute-modification-time attr)) (mt (visited-file-modtime))) (cond @@ -1620,14 +1621,14 @@ ID-FORMAT valid values are `string' and `integer'." ;; information would be lost by an (attempted) delete and create. (or (null attributes) (and - (= (tramp-compat-file-attribute-user-id attributes) + (= (file-attribute-user-id attributes) (tramp-get-remote-uid v 'integer)) (or (not group) ;; On BSD-derived systems files always inherit the ;; parent directory's group, so skip the group-gid ;; test. (tramp-check-remote-uname v "BSD\\|DragonFly\\|Darwin") - (= (tramp-compat-file-attribute-group-id attributes) + (= (file-attribute-group-id attributes) (tramp-get-remote-gid v 'integer))))))))) ;; Directory listings. @@ -1637,8 +1638,7 @@ ID-FORMAT valid values are `string' and `integer'." "Like `directory-files-and-attributes' for Tramp files." (unless id-format (setq id-format 'integer)) (unless (file-exists-p directory) - (tramp-compat-file-missing - (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (expand-file-name directory)) (let* ((temp @@ -1858,7 +1858,7 @@ ID-FORMAT valid values are `string' and `integer'." target) (with-parsed-tramp-file-name (if t1 dirname newname) nil (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) + (tramp-error v 'file-missing dirname)) ;; `copy-directory-create-symlink' exists since Emacs 28.1. (if (and (bound-and-true-p copy-directory-create-symlink) @@ -1952,7 +1952,7 @@ file names." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) - (length (tramp-compat-file-attribute-size + (length (file-attribute-size (file-attributes (file-truename filename)))) (attributes (and preserve-extended-attributes (file-extended-attributes filename))) @@ -1960,7 +1960,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -2052,7 +2052,7 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." ;; Check, whether file is too large. Emacs checks in `insert-file-1' ;; and `find-file-noselect', but that's not called here. (abort-if-file-too-large - (tramp-compat-file-attribute-size (file-attributes (file-truename filename))) + (file-attribute-size (file-attributes (file-truename filename))) (symbol-name op) filename) ;; We must disable multibyte, because binary data shall not be ;; converted. We don't want the target file to be compressed, so we @@ -2074,8 +2074,7 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (set-file-modes newname (tramp-default-file-modes filename)) @@ -2094,7 +2093,7 @@ as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep the uid and gid from FILENAME." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) - (file-times (tramp-compat-file-attribute-modification-time + (file-times (file-attribute-modification-time (file-attributes filename))) (file-modes (tramp-default-file-modes filename))) (with-parsed-tramp-file-name (if t1 filename newname) nil @@ -2419,8 +2418,7 @@ The method used must be an out-of-band method." (when (and keep-date (not copy-keep-date)) (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))) ;; Set the mode. @@ -2474,6 +2472,7 @@ The method used must be an out-of-band method." ;; Dired. +;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (defun tramp-sh-handle-dired-compress-file (file) "Like `dired-compress-file' for Tramp files." ;; Code stolen mainly from dired-aux.el. @@ -3199,9 +3198,9 @@ implementation will be used." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (unless (file-exists-p (file-truename filename)) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) - (let* ((size (tramp-compat-file-attribute-size + (let* ((size (file-attribute-size (file-attributes (file-truename filename)))) (rem-enc (tramp-get-inline-coding v "remote-encoding" size)) (loc-dec (tramp-get-inline-coding v "local-decoding" size)) @@ -3288,11 +3287,9 @@ implementation will be used." (tramp-error v 'file-already-exists filename)) (let ((file-locked (eq (file-locked-p lockname) t)) - (uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) + (uid (or (file-attribute-user-id (file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) + (gid (or (file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) ;; Lock file. @@ -3371,8 +3368,7 @@ implementation will be used." ;; specified. However, if the method _also_ specifies an ;; encoding function, then that is used for encoding the ;; contents of the tmp file. - (let* ((size (tramp-compat-file-attribute-size - (file-attributes tmpfile))) + (let* ((size (file-attribute-size (file-attributes tmpfile))) (rem-dec (tramp-get-inline-coding v "remote-decoding" size)) (loc-enc (tramp-get-inline-coding v "local-encoding" size))) (cond @@ -3507,10 +3503,10 @@ implementation will be used." ;; We must pass modtime explicitly, because FILENAME can ;; be different from (buffer-file-name), f.e. if ;; `file-precious-flag' is set. - (or (tramp-compat-file-attribute-modification-time file-attr) + (or (file-attribute-modification-time file-attr) (current-time))) - (when (and (= (tramp-compat-file-attribute-user-id file-attr) uid) - (= (tramp-compat-file-attribute-group-id file-attr) gid)) + (when (and (= (file-attribute-user-id file-attr) uid) + (= (file-attribute-group-id file-attr) gid)) (setq need-chown nil)))) ;; Set the ownership. diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index aeabc69246..ac567dc074 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -234,6 +234,7 @@ See `tramp-actions-before-shell' for more info.") (directory-files . tramp-smb-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) + ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . ignore) @@ -418,7 +419,7 @@ arguments to pass to the OPERATION." target) (with-parsed-tramp-file-name (if t1 dirname newname) nil (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) + (tramp-error v 'file-missing dirname)) ;; `copy-directory-create-symlink' exists since Emacs 28.1. (if (and (bound-and-true-p copy-directory-create-symlink) @@ -441,7 +442,7 @@ arguments to pass to the OPERATION." (with-tramp-progress-reporter v 0 (format "Copying %s to %s" dirname newname) (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) + (tramp-error v 'file-missing dirname)) (when (and (file-directory-p newname) (not (directory-name-p newname))) (tramp-error v 'file-already-exists newname)) @@ -566,8 +567,7 @@ arguments to pass to the OPERATION." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes dirname)) + (file-attribute-modification-time (file-attributes dirname)) (unless ok-if-already-exists 'nofollow))) ;; Set the mode. @@ -601,10 +601,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (copy-directory filename newname keep-date 'parents 'copy-contents) (unless (file-exists-p filename) - (tramp-compat-file-missing + (tramp-error (tramp-dissect-file-name (if (tramp-tramp-file-p filename) filename newname)) - filename)) + 'file-missing filename)) (if-let ((tmpfile (file-local-copy filename))) ;; Remote filename. @@ -644,8 +644,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))))) (defun tramp-smb-handle-delete-directory (directory &optional recursive trash) @@ -705,7 +704,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (let ((result (mapcar #'directory-file-name (file-name-all-completions "" directory)))) ;; Discriminate with regexp. @@ -975,7 +974,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name (file-truename filename) nil (unless (file-exists-p (file-truename filename)) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (with-tramp-progress-reporter v 3 (format "Fetching %s to tmp file %s" filename tmpfile) @@ -1040,8 +1039,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Like `file-writable-p' for Tramp files." (if (file-exists-p filename) (tramp-compat-string-search - "w" - (or (tramp-compat-file-attribute-modes (file-attributes filename)) "")) + "w" (or (file-attribute-modes (file-attributes filename)) "")) (let ((dir (file-name-directory filename))) (and (file-exists-p dir) (file-writable-p dir))))) @@ -1144,11 +1142,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (insert (format "%10s %3d %-8s %-8s %8s %s " - (or (tramp-compat-file-attribute-modes attr) (nth 1 x)) - (or (tramp-compat-file-attribute-link-number attr) 1) - (or (tramp-compat-file-attribute-user-id attr) "nobody") - (or (tramp-compat-file-attribute-group-id attr) "nogroup") - (or (tramp-compat-file-attribute-size attr) (nth 2 x)) + (or (file-attribute-modes attr) (nth 1 x)) + (or (file-attribute-link-number attr) 1) + (or (file-attribute-user-id attr) "nobody") + (or (file-attribute-group-id attr) "nogroup") + (or (file-attribute-size attr) (nth 2 x)) (format-time-string (if (time-less-p ;; Half a year. @@ -1170,8 +1168,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Insert symlink. (when (and (tramp-compat-string-search "l" switches) - (stringp (tramp-compat-file-attribute-type attr))) - (insert " -> " (tramp-compat-file-attribute-type attr)))) + (stringp (file-attribute-type attr))) + (insert " -> " (file-attribute-type attr)))) (insert "\n") (beginning-of-line))) @@ -1393,7 +1391,7 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name (if (tramp-tramp-file-p filename) filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -1646,8 +1644,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime - (or (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (or (file-attribute-modification-time (file-attributes filename)) (current-time)))) ;; Unlock file. diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 4bc804571e..fc77d998aa 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -83,6 +83,7 @@ (directory-files . tramp-fuse-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) + ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . tramp-sshfs-handle-exec-path) @@ -110,7 +111,7 @@ (file-notify-rm-watch . ignore) (file-notify-valid-p . ignore) (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-fuse-handle-file-readable-p) + (file-readable-p . tramp-handle-file-readable-p) (file-regular-p . tramp-handle-file-regular-p) (file-remote-p . tramp-handle-file-remote-p) (file-selinux-context . tramp-handle-file-selinux-context) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 48c81a5988..842990488e 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -75,6 +75,7 @@ See `tramp-actions-before-shell' for more info.") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) + ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (exec-path . ignore) @@ -232,7 +233,7 @@ absolute file names." (let ((t1 (tramp-sudoedit-file-name-p filename)) (t2 (tramp-sudoedit-file-name-p newname)) - (file-times (tramp-compat-file-attribute-modification-time + (file-times (file-attribute-modification-time (file-attributes filename))) (file-modes (tramp-default-file-modes filename)) (attributes (and preserve-extended-attributes @@ -246,7 +247,7 @@ absolute file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -720,11 +721,9 @@ ID-FORMAT valid values are `string' and `integer'." "Like `write-region' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (let* ((uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) + (let* ((uid (or (file-attribute-user-id (file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) + (gid (or (file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer))) (flag (and (eq mustbenew 'excl) 'nofollow)) (modes (tramp-default-file-modes filename flag)) @@ -735,10 +734,10 @@ ID-FORMAT valid values are `string' and `integer'." ;; Set the ownership, modes and extended attributes. This is ;; not performed in `tramp-handle-write-region'. - (unless (and (= (tramp-compat-file-attribute-user-id + (unless (and (= (file-attribute-user-id (file-attributes filename 'integer)) uid) - (= (tramp-compat-file-attribute-group-id + (= (file-attribute-group-id (file-attributes filename 'integer)) gid)) (tramp-set-file-uid-gid filename uid gid)) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 85effe1a04..f4493608a4 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -751,11 +751,11 @@ The answer will be provided by `tramp-action-process-alive', (defconst tramp-temp-name-prefix "tramp." "Prefix to use for temporary files. -If this is a relative file name (such as \"tramp.\"), it is considered -relative to the directory name returned by the function -`tramp-compat-temporary-file-directory' (which see). It may also be an -absolute file name; don't forget to include a prefix for the filename -part, though.") +If this is a relative file name (such as \"tramp.\"), it is +considered relative to the directory name returned by the +function `temporary-file-directory' (which see). It may also be +an absolute file name; don't forget to include a prefix for the +filename part, though.") (defconst tramp-temp-buffer-name " *tramp temp*" "Buffer name for a temporary buffer. @@ -822,11 +822,10 @@ to be set, depending on VALUE." (tramp-register-file-name-handlers)) ;; Initialize the Tramp syntax variables. We want to override initial -;; value of `tramp-file-name-regexp'. Other Tramp syntax variables -;; must be initialized as well to proper values. We do not call +;; value of `tramp-file-name-regexp'. We do not call ;; `custom-set-variable', this would load Tramp via custom.el. (tramp--with-startup - (tramp-set-syntax 'tramp-syntax (tramp-compat-tramp-syntax))) + (tramp-set-syntax 'tramp-syntax tramp-syntax)) (defun tramp-syntax-values () "Return possible values of `tramp-syntax', a list." @@ -836,9 +835,9 @@ to be set, depending on VALUE." values)) (defun tramp-lookup-syntax (alist) - "Look up a syntax string in ALIST according to `tramp-compat-tramp-syntax'. -Raise an error if `tramp-syntax' is invalid." - (or (cdr (assq (tramp-compat-tramp-syntax) alist)) + "Look up a syntax string in ALIST according to `tramp-syntax'. +Raise an error if it is invalid." + (or (cdr (assq tramp-syntax alist)) (error "Wrong `tramp-syntax' %s" tramp-syntax))) (defconst tramp-prefix-format-alist @@ -1409,8 +1408,7 @@ calling HANDLER.") ;; internal data structure. Convenience functions for internal ;; data structure. -;; The basic structure for remote file names. We use a list :type, -;; in order to be compatible with Emacs 25. +;; The basic structure for remote file names. (cl-defstruct (tramp-file-name (:type list) :named) method user domain host port localname hop) @@ -1522,7 +1520,7 @@ of `process-file', `start-file-process', or `shell-command'." (or (and (tramp-tramp-file-p name) (string-match (nth 0 tramp-file-name-structure) name) (match-string (nth 4 tramp-file-name-structure) name)) - (tramp-compat-file-local-name name))) + (file-local-name name))) ;; The localname can be quoted with "/:". Extract this. (defun tramp-unquote-file-local-name (name) @@ -1849,9 +1847,7 @@ from the default one." If connection-local variables are not supported by this Emacs version, the function does nothing." (with-current-buffer (tramp-get-connection-buffer vec) - ;; `hack-connection-local-variables-apply' exists since Emacs 26.1. - (tramp-compat-funcall - 'hack-connection-local-variables-apply + (hack-connection-local-variables-apply `(:application tramp :protocol ,(tramp-file-name-method vec) :user ,(tramp-file-name-user-domain vec) @@ -1862,9 +1858,7 @@ version, the function does nothing." If connection-local variables are not supported by this Emacs version, the function does nothing." (when (tramp-tramp-file-p default-directory) - ;; `hack-connection-local-variables-apply' exists since Emacs 26.1. - (tramp-compat-funcall - 'hack-connection-local-variables-apply + (hack-connection-local-variables-apply `(:application tramp :protocol ,(file-remote-p default-directory 'method) :user ,(file-remote-p default-directory 'user) @@ -2482,35 +2476,34 @@ Must be handled by the callers." '(access-file byte-compiler-base-file-name delete-directory delete-file diff-latest-backup-file directory-file-name directory-files directory-files-and-attributes - dired-compress-file dired-uncache file-acl - file-accessible-directory-p file-attributes - file-directory-p file-executable-p file-exists-p - file-local-copy file-modes file-name-as-directory + dired-uncache file-acl file-accessible-directory-p + file-attributes file-directory-p file-executable-p + file-exists-p file-local-copy file-modes + file-name-as-directory file-name-case-insensitive-p file-name-directory file-name-nondirectory file-name-sans-versions file-notify-add-watch file-ownership-preserved-p file-readable-p file-regular-p file-remote-p file-selinux-context file-symlink-p file-truename file-writable-p - find-backup-file-name get-file-buffer - insert-directory insert-file-contents load - make-directory make-directory-internal set-file-acl - set-file-modes set-file-selinux-context set-file-times + find-backup-file-name get-file-buffer insert-directory + insert-file-contents load make-directory + make-directory-internal set-file-acl set-file-modes + set-file-selinux-context set-file-times substitute-in-file-name unhandled-file-name-directory vc-registered - ;; Emacs 26+ only. - file-name-case-insensitive-p ;; Emacs 27+ only. file-system-info ;; Emacs 28+ only. file-locked-p lock-file make-lock-file-name unlock-file + ;; Starting with Emacs 29.1, `dired-compress-file' isn't + ;; magic anymore. + dired-compress-file ;; Tramp internal magic file name function. tramp-set-file-uid-gid)) (if (file-name-absolute-p (nth 0 args)) (nth 0 args) default-directory)) ;; STRING FILE. - ;; Starting with Emacs 26.1, just the 2nd argument of - ;; `make-symbolic-link' matters. ((eq operation 'make-symbolic-link) (nth 1 args)) ;; FILE DIRECTORY resp FILE1 FILE2. ((member operation @@ -2541,9 +2534,8 @@ Must be handled by the callers." (if (bufferp (nth 0 args)) (nth 0 args) (current-buffer)))) ;; COMMAND. ((member operation - '(process-file shell-command start-file-process - ;; Emacs 26+ only. - make-nearby-temp-file temporary-file-directory + '(make-nearby-temp-file process-file shell-command + start-file-process temporary-file-directory ;; Emacs 27+ only. exec-path make-process)) default-directory) @@ -3298,8 +3290,9 @@ User is always nil." filename) (tramp-error v 'file-error (format "%s: Permission denied, %s" string filename))) - (tramp-compat-file-missing - v (format "%s: No such file or directory, %s" string filename))))) + (tramp-error + v 'file-missing + (format "%s: No such file or directory, %s" string filename))))) (defun tramp-handle-add-name-to-file (filename newname &optional ok-if-already-exists) @@ -3333,7 +3326,7 @@ User is always nil." ;; `copy-directory' creates NEWNAME before running this check. So ;; we do it ourselves. (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) ;; We must do it file-wise. (tramp-run-real-handler #'copy-directory @@ -3354,7 +3347,7 @@ User is always nil." (defun tramp-handle-directory-files (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (let ((temp (nreverse (file-name-all-completions "" directory))) @@ -3420,9 +3413,7 @@ User is always nil." (defun tramp-handle-file-directory-p (filename) "Like `file-directory-p' for Tramp files." - (eq (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))) - t)) + (eq (file-attribute-type (file-attributes (file-truename filename))) t)) (defun tramp-handle-file-equal-p (filename1 filename2) "Like `file-equalp-p' for Tramp files." @@ -3454,7 +3445,7 @@ User is always nil." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) tmpfile))) @@ -3462,7 +3453,7 @@ User is always nil." (defun tramp-handle-file-modes (filename &optional flag) "Like `file-modes' for Tramp files." (when-let ((attrs (file-attributes filename)) - (mode-string (tramp-compat-file-attribute-modes attrs))) + (mode-string (file-attribute-modes attrs))) (if (and (not (eq flag 'nofollow)) (eq ?l (aref mode-string 0))) (file-modes (file-truename filename)) (tramp-mode-string-to-int mode-string)))) @@ -3515,16 +3506,13 @@ User is always nil." (directory-file-name (file-name-directory candidate)))) ;; Nothing found, so we must use a temporary file - ;; for comparison. `make-nearby-temp-file' is added - ;; to Emacs 26+ like `file-name-case-insensitive-p', - ;; so there is no compatibility problem calling it. + ;; for comparison. (unless (string-match-p "[[:lower:]]" (tramp-file-local-name candidate)) (setq tmpfile (let ((default-directory - (file-name-directory filename))) - (tramp-compat-funcall - 'make-nearby-temp-file "tramp.")) + (file-name-directory filename))) + (make-nearby-temp-file "tramp.")) candidate tmpfile)) ;; Check for the existence of the same file with ;; upper case letters. @@ -3585,9 +3573,8 @@ User is always nil." ((not (file-exists-p file1)) nil) ((not (file-exists-p file2)) t) (t (time-less-p - (tramp-compat-file-attribute-modification-time (file-attributes file2)) - (tramp-compat-file-attribute-modification-time - (file-attributes file1)))))) + (file-attribute-modification-time (file-attributes file2)) + (file-attribute-modification-time (file-attributes file1)))))) (defun tramp-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." @@ -3606,7 +3593,7 @@ User is always nil." ;; Sometimes, `file-attributes' does not return a proper value ;; even if `file-exists-p' does. (when-let ((attr (file-attributes filename))) - (eq ?- (aref (tramp-compat-file-attribute-modes attr) 0))))) + (eq ?- (aref (file-attribute-modes attr) 0))))) (defun tramp-handle-file-remote-p (filename &optional identification connected) "Like `file-remote-p' for Tramp files." @@ -3638,7 +3625,7 @@ User is always nil." (defun tramp-handle-file-symlink-p (filename) "Like `file-symlink-p' for Tramp files." - (let ((x (tramp-compat-file-attribute-type (file-attributes filename)))) + (let ((x (file-attribute-type (file-attributes filename)))) (and (stringp x) x))) (defun tramp-handle-file-truename (filename) @@ -3727,7 +3714,7 @@ User is always nil." (when (and (not tramp-allow-unsafe-temporary-files) (not backup-inhibited) (file-in-directory-p (car result) temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id + (zerop (or (file-attribute-user-id (file-attributes filename 'integer)) tramp-unknown-id-integer)) (not (with-tramp-connection-property @@ -3784,7 +3771,7 @@ User is always nil." (unwind-protect (if (not (file-exists-p filename)) (let ((tramp-verbose (if visit 0 tramp-verbose))) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (with-tramp-progress-reporter v 3 (format-message "Inserting `%s'" filename) @@ -3949,7 +3936,7 @@ Return nil when there is no lockfile." (when (and (not tramp-allow-unsafe-temporary-files) create-lockfiles (file-in-directory-p lockname temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id + (zerop (or (file-attribute-user-id (file-attributes file 'integer)) tramp-unknown-id-integer)) (not (with-tramp-connection-property @@ -4001,7 +3988,7 @@ Return nil when there is no lockfile." v 'file-error "File `%s' does not include a `.el' or `.elc' suffix" file))) (unless (or noerror (file-exists-p file)) - (tramp-compat-file-missing v file)) + (tramp-error v 'file-missing file)) (if (not (file-exists-p file)) nil (let ((signal-hook-function (unless noerror signal-hook-function)) @@ -4263,18 +4250,13 @@ substitution. SPEC-LIST is a list of char/value pairs used for p)))))) (defun tramp-handle-make-symbolic-link - (target linkname &optional ok-if-already-exists) + (_target linkname &optional _ok-if-already-exists) "Like `make-symbolic-link' for Tramp files. This is the fallback implementation for backends which do not support symbolic links." - (if (tramp-tramp-file-p (expand-file-name linkname)) - (tramp-error - (tramp-dissect-file-name (expand-file-name linkname)) 'file-error - "make-symbolic-link not supported") - ;; This is needed prior Emacs 26.1, where TARGET has also be - ;; checked for a file name handler. - (tramp-run-real-handler - #'make-symbolic-link (list target linkname ok-if-already-exists)))) + (tramp-error + (tramp-dissect-file-name (expand-file-name linkname)) 'file-error + "make-symbolic-link not supported")) (defun tramp-handle-shell-command (command &optional output-buffer error-buffer) "Like `shell-command' for Tramp files." @@ -4492,7 +4474,7 @@ BUFFER might be a list, in this case STDERR is separated." (unless time-list (let ((remote-file-name-inhibit-cache t)) (setq time-list - (or (tramp-compat-file-attribute-modification-time + (or (file-attribute-modification-time (file-attributes (buffer-file-name))) tramp-time-doesnt-exist)))) (unless (tramp-compat-time-equal-p time-list tramp-time-dont-know) @@ -4516,7 +4498,7 @@ of." t (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - (modtime (tramp-compat-file-attribute-modification-time attr)) + (modtime (file-attribute-modification-time attr)) (mt (visited-file-modtime))) (cond @@ -4547,11 +4529,9 @@ of." (tmpfile (tramp-compat-make-temp-file filename)) (modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) - (uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) + (uid (or (file-attribute-user-id (file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) + (gid (or (file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) ;; Lock file. @@ -4587,8 +4567,7 @@ of." ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime - (or (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (or (file-attribute-modification-time (file-attributes filename)) (current-time)))) ;; Set the ownership. @@ -5255,7 +5234,7 @@ If FILENAME is remote, a file name handler is called." (let* ((dir (file-name-directory filename)) (modes (file-modes dir))) (when (and modes (not (zerop (logand modes #o2000)))) - (setq gid (tramp-compat-file-attribute-group-id (file-attributes dir))))) + (setq gid (file-attribute-group-id (file-attributes dir))))) (if-let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid))) (funcall handler #'tramp-set-file-uid-gid filename uid gid) @@ -5284,8 +5263,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; `group-name' has been introduced with Emacs 27.1. ((and (fboundp 'group-name) (equal id-format 'string)) (tramp-compat-funcall 'group-name (group-gid))) - ((tramp-compat-file-attribute-group-id - (file-attributes "~/" id-format)))))) + ((file-attribute-group-id (file-attributes "~/" id-format)))))) (defun tramp-get-local-locale (&optional vec) "Determine locale, supporting UTF8 if possible. @@ -5340,31 +5318,22 @@ be granted." file-attr (or ;; Not a symlink. - (eq t (tramp-compat-file-attribute-type file-attr)) - (null (tramp-compat-file-attribute-type file-attr))) + (eq t (file-attribute-type file-attr)) + (null (file-attribute-type file-attr))) (or ;; World accessible. - (eq access - (aref (tramp-compat-file-attribute-modes file-attr) - (+ offset 6))) + (eq access (aref (file-attribute-modes file-attr) (+ offset 6))) ;; User accessible and owned by user. (and - (eq access - (aref (tramp-compat-file-attribute-modes file-attr) offset)) - (or (equal remote-uid - (tramp-compat-file-attribute-user-id file-attr)) - (equal unknown-id - (tramp-compat-file-attribute-user-id file-attr)))) + (eq access (aref (file-attribute-modes file-attr) offset)) + (or (equal remote-uid (file-attribute-user-id file-attr)) + (equal unknown-id (file-attribute-user-id file-attr)))) ;; Group accessible and owned by user's principal group. (and (eq access - (aref (tramp-compat-file-attribute-modes file-attr) - (+ offset 3))) - (or (equal remote-gid - (tramp-compat-file-attribute-group-id file-attr)) - (equal unknown-id - (tramp-compat-file-attribute-group-id - file-attr)))))))))))) + (aref (file-attribute-modes file-attr) (+ offset 3))) + (or (equal remote-gid (file-attribute-group-id file-attr)) + (equal unknown-id (file-attribute-group-id file-attr)))))))))))) (defun tramp-get-remote-uid (vec id-format) "The uid of the remote connection VEC, in ID-FORMAT. @@ -5505,7 +5474,7 @@ this file, if that variable is non-nil." (when (and (not tramp-allow-unsafe-temporary-files) auto-save-default (file-in-directory-p result temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id + (zerop (or (file-attribute-user-id (file-attributes filename 'integer)) tramp-unknown-id-integer)) (not (with-tramp-connection-property @@ -5541,8 +5510,7 @@ ALIST is of the form ((FROM . TO) ...)." (defun tramp-handle-make-nearby-temp-file (prefix &optional dir-flag suffix) "Like `make-nearby-temp-file' for Tramp files." - (let ((temporary-file-directory - (tramp-compat-temporary-file-directory-function))) + (let ((temporary-file-directory (temporary-file-directory))) (make-temp-file prefix dir-flag suffix))) ;;; Compatibility functions section: @@ -5712,15 +5680,12 @@ Invokes `password-read' if available, `read-passwd' else." (setq auth-passwd (funcall auth-passwd))) auth-passwd) - ;; Try the password cache. Exists since Emacs 26.1. + ;; Try the password cache. (progn (setq auth-passwd (password-read pw-prompt key) tramp-password-save-function (lambda () (password-cache-add key auth-passwd))) - auth-passwd) - - ;; Else, get the password interactively w/o cache. - (read-passwd pw-prompt)) + auth-passwd)) ;; Workaround. Prior Emacs 28.1, auth-source has saved ;; empty passwords. See discussion in Bug#50399. @@ -5832,13 +5797,11 @@ name of a process or buffer, or nil to default to the current buffer." (while (tramp-accept-process-output proc 0)) (not (process-live-p proc)))))) -;; `interrupt-process-functions' exists since Emacs 26.1. -(when (boundp 'interrupt-process-functions) - (add-hook 'interrupt-process-functions #'tramp-interrupt-process) - (add-hook - 'tramp-unload-hook - (lambda () - (remove-hook 'interrupt-process-functions #'tramp-interrupt-process)))) +(add-hook 'interrupt-process-functions #'tramp-interrupt-process) +(add-hook + 'tramp-unload-hook + (lambda () + (remove-hook 'interrupt-process-functions #'tramp-interrupt-process))) (defun tramp-get-remote-null-device (vec) "Return null device on the remote host identified by VEC. diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 8baf0780c2..226e9a34de 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,8 +7,8 @@ ;; Maintainer: Michael Albinus ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.5.2-pre -;; Package-Requires: ((emacs "25.1")) +;; Version: 2.6.0-pre +;; Package-Requires: ((emacs "26.1")) ;; Package-Type: multi ;; URL: https://www.gnu.org/software/tramp/ @@ -40,7 +40,7 @@ ;; ./configure" to change them. ;;;###tramp-autoload -(defconst tramp-version "2.5.2-pre" +(defconst tramp-version "2.6.0-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -74,9 +74,9 @@ "The repository revision of the Tramp sources.") ;; Check for Emacs version. -(let ((x (if (not (string-lessp emacs-version "25.1")) +(let ((x (if (not (string-version-lessp emacs-version "26.1")) "ok" - (format "Tramp 2.5.2-pre is not fit for %s" + (format "Tramp 2.6.0-pre is not fit for %s" (replace-regexp-in-string "\n" "" (emacs-version)))))) (unless (string-equal "ok" x) (error "%s" x))) diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 98012f4e90..a307a40157 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -122,12 +122,6 @@ the origin of the temporary TMPFILE, have no write permissions." (directory-files tmpfile 'full directory-files-no-dot-files-regexp)) (delete-directory tmpfile))) -(defun tramp-archive--test-emacs26-p () - "Check for Emacs version >= 26.1. -Some semantics has been changed for there, w/o new functions or -variables, so we check the Emacs version directly." - (>= emacs-major-version 26)) - (defun tramp-archive--test-emacs27-p () "Check for Emacs version >= 27.1. Some semantics has been changed for there, w/o new functions or @@ -265,21 +259,20 @@ variables, so we check the Emacs version directly." (concat (tramp-gvfs-url-file-name (tramp-make-tramp-file-name - tramp-archive-method - ;; User and Domain. - nil nil - ;; Host. - (url-hexify-string - (concat - "file://" - ;; `directory-file-name' does not leave file - ;; archive boundaries. So we must cut the - ;; trailing slash ourselves. - (substring - (file-name-directory - (tramp-archive-test-file-archive-hexlified)) - 0 -1))) - nil "/")) + (make-tramp-file-name + :method tramp-archive-method + :host + (url-hexify-string + (concat + "file://" + ;; `directory-file-name' does not leave file + ;; archive boundaries. So we must cut the + ;; trailing slash ourselves. + (substring + (file-name-directory + (tramp-archive-test-file-archive-hexlified)) + 0 -1))) + :localname "/"))) (file-name-nondirectory tramp-archive-test-file-archive))))) (should-not port) (should (string-equal localname "/bar")) @@ -434,7 +427,7 @@ This checks also `file-name-as-directory', `file-name-directory', (setq tmp-name (file-local-copy (expand-file-name "what" tramp-archive-test-archive))) - :type tramp-file-missing)) + :type 'file-missing)) ;; Cleanup. (ignore-errors (tramp-archive--test-delete tmp-name)) @@ -462,7 +455,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should-error (insert-file-contents (expand-file-name "what" tramp-archive-test-archive)) - :type tramp-file-missing)) + :type 'file-missing)) ;; Cleanup. (tramp-archive-cleanup-hash)))) @@ -553,11 +546,9 @@ This checks also `file-name-as-directory', `file-name-directory', (should (file-directory-p tmp-name2)) (should (file-exists-p tmp-name4)) ;; Target directory does exist already. - ;; This has been changed in Emacs 26.1. - (when (tramp-archive--test-emacs26-p) - (should-error - (copy-directory tmp-name1 tmp-name2) - :type 'file-error)) + (should-error + (copy-directory tmp-name1 tmp-name2) + :type 'file-error) (tramp-archive--test-delete tmp-name4) (copy-directory tmp-name1 (file-name-as-directory tmp-name2)) (should (file-directory-p tmp-name3)) @@ -622,13 +613,11 @@ This checks also `file-name-as-directory', `file-name-directory', (append '("LANG=C" "LANGUAGE=C" "LC_ALL=C") process-environment))) (unwind-protect (progn - ;; Due to Bug#29423, this works only since for Emacs 26.1. - (when nil ;; TODO (tramp-archive--test-emacs26-p) - (with-temp-buffer - (insert-directory tramp-archive-test-archive nil) - (goto-char (point-min)) - (should - (looking-at-p (regexp-quote tramp-archive-test-archive))))) + (with-temp-buffer + (insert-directory tramp-archive-test-archive nil) + (goto-char (point-min)) + (should + (looking-at-p (regexp-quote tramp-archive-test-archive)))) (with-temp-buffer (insert-directory tramp-archive-test-archive "-al") (goto-char (point-min)) @@ -656,7 +645,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should-error (insert-directory (expand-file-name "baz" tramp-archive-test-archive) nil) - :type tramp-file-missing))) + :type 'file-missing))) ;; Cleanup. (tramp-archive-cleanup-hash)))) @@ -716,7 +705,7 @@ This tests also `access-file', `file-readable-p' and `file-regular-p'." ;; Check error case. (should-error (access-file tmp-name4 "error") - :type tramp-file-missing)) + :type 'file-missing)) ;; Cleanup. (tramp-archive-cleanup-hash)))) @@ -855,38 +844,27 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." ;; Cleanup. (tramp-archive-cleanup-hash)))) -;; The functions were introduced in Emacs 26.1. (ert-deftest tramp-archive-test40-make-nearby-temp-file () "Check `make-nearby-temp-file' and `temporary-file-directory'." (skip-unless tramp-archive-enabled) - ;; Since Emacs 26.1. - (skip-unless - (and (fboundp 'make-nearby-temp-file) (fboundp 'temporary-file-directory))) - ;; `make-nearby-temp-file' and `temporary-file-directory' exists - ;; since Emacs 26.1. We don't want to see compiler warnings for - ;; older Emacsen. (let ((default-directory tramp-archive-test-archive) tmp-file) ;; The file archive shall know a temporary file directory. It is ;; not in the archive itself. - (should - (stringp (with-no-warnings (with-no-warnings (temporary-file-directory))))) - (should-not - (tramp-archive-file-name-p (with-no-warnings (temporary-file-directory)))) + (should (stringp (temporary-file-directory))) + (should-not (tramp-archive-file-name-p (temporary-file-directory))) ;; A temporary file or directory shall not be located in the ;; archive itself. - (setq tmp-file - (with-no-warnings (make-nearby-temp-file "tramp-archive-test"))) + (setq tmp-file (make-nearby-temp-file "tramp-archive-test")) (should (file-exists-p tmp-file)) (should (file-regular-p tmp-file)) (should-not (tramp-archive-file-name-p tmp-file)) (delete-file tmp-file) (should-not (file-exists-p tmp-file)) - (setq tmp-file - (with-no-warnings (make-nearby-temp-file "tramp-archive-test" 'dir))) + (setq tmp-file (make-nearby-temp-file "tramp-archive-test" 'dir)) (should (file-exists-p tmp-file)) (should (file-directory-p tmp-file)) (should-not (tramp-archive-file-name-p tmp-file)) @@ -910,7 +888,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (zerop (nth 1 fsi)) (zerop (nth 2 fsi)))))) -(ert-deftest tramp-archive-test45-auto-load () +(ert-deftest tramp-archive-test46-auto-load () "Check that `tramp-archive' autoloads properly." :tags '(:expensive-test) (skip-unless tramp-archive-enabled) @@ -950,7 +928,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument (format code file)))))))))) -(ert-deftest tramp-archive-test45-delay-load () +(ert-deftest tramp-archive-test46-delay-load () "Check that `tramp-archive' is loaded lazily, only when needed." :tags '(:expensive-test) (skip-unless tramp-archive-enabled) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index ffeb5420fe..397e707f13 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -43,8 +43,10 @@ (require 'cl-lib) (require 'dired) +(require 'dired-aux) (require 'ert) (require 'ert-x) +(require 'seq) ; For `seq-random-elt', autoloaded since Emacs 28.1 (require 'trace) (require 'tramp) (require 'vc) @@ -62,7 +64,6 @@ (declare-function tramp-list-tramp-buffers "tramp-cmds") (declare-function tramp-method-out-of-band-p "tramp-sh") (declare-function tramp-smb-get-localname "tramp-smb") -(declare-function dired-compress "dired-aux") (defvar ange-ftp-make-backup-files) (defvar auto-save-file-name-transforms) (defvar lock-file-name-transforms) @@ -76,11 +77,6 @@ (defvar tramp-remote-path) (defvar tramp-remote-process-environment) -;; Needed for Emacs 25. -(defvar connection-local-criteria-alist) -(defvar connection-local-profile-alist) -;; Needed for Emacs 26. -(defvar async-shell-command-width) ;; Needed for Emacs 27. (defvar process-file-return-signal-string) (defvar shell-command-dont-erase-buffer) @@ -2085,44 +2081,41 @@ Also see `ignore'." (substitute-in-file-name "/method:host:/:/path//foo") "/method:host:/:/path//foo")) - ;; Forwhatever reasons, the following tests let Emacs crash for - ;; Emacs 25, occasionally. No idea what's up. - (when (tramp--test-emacs26-p) - (should - (string-equal - (substitute-in-file-name (concat "/method:host://~" foo)) - (concat "/~" foo))) - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/~" foo)) - (concat "/method:host:/~" foo))) - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/path//~" foo)) - (concat "/~" foo))) - ;; (substitute-in-file-name "/path/~foo") expands only for a local - ;; user "foo" to "/~foo"". Otherwise, it doesn't expand. - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/path/~" foo)) - (concat "/method:host:/path/~" foo))) - ;; Quoting local part. - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/://~" foo)) - (concat "/method:host:/://~" foo))) - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/:/~" foo)) - (concat "/method:host:/:/~" foo))) - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/:/path//~" foo)) - (concat "/method:host:/:/path//~" foo))) - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/:/path/~" foo)) - (concat "/method:host:/:/path/~" foo)))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host://~" foo)) + (concat "/~" foo))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/~" foo)) + (concat "/method:host:/~" foo))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/path//~" foo)) + (concat "/~" foo))) + ;; (substitute-in-file-name "/path/~foo") expands only for a local + ;; user "foo" to "/~foo"". Otherwise, it doesn't expand. + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/path/~" foo)) + (concat "/method:host:/path/~" foo))) + ;; Quoting local part. + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/://~" foo)) + (concat "/method:host:/://~" foo))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/:/~" foo)) + (concat "/method:host:/:/~" foo))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/:/path//~" foo)) + (concat "/method:host:/:/path//~" foo))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/:/path/~" foo)) + (concat "/method:host:/:/path/~" foo))) (let (process-environment) (should @@ -2354,7 +2347,7 @@ This checks also `file-name-as-directory', `file-name-directory', (delete-file tmp-name2) (should-error (setq tmp-name2 (file-local-copy tmp-name1)) - :type tramp-file-missing)) + :type 'file-missing)) ;; Cleanup. (ignore-errors @@ -2393,7 +2386,7 @@ This checks also `file-name-as-directory', `file-name-directory', (delete-file tmp-name) (should-error (insert-file-contents tmp-name) - :type tramp-file-missing)) + :type 'file-missing)) ;; Cleanup. (ignore-errors (delete-file tmp-name)))))) @@ -2464,23 +2457,20 @@ This checks also `file-name-as-directory', `file-name-directory', (should (string-equal (buffer-string) "34"))) ;; Check message. - ;; Macro `ert-with-message-capture' was introduced in Emacs 26.1. - (with-no-warnings (when (symbol-plist 'ert-with-message-capture) - (let (inhibit-message) - (dolist - (noninteractive (unless (tramp--test-ange-ftp-p) '(nil t))) - (dolist (visit '(nil t "string" no-message)) - (ert-with-message-capture tramp--test-messages - (write-region "foo" nil tmp-name nil visit) - ;; We must check the last line. There could be - ;; other messages from the progress reporter. - (should - (string-match-p - (if (and (null noninteractive) - (or (eq visit t) (null visit) (stringp visit))) - (format "^Wrote %s\n\\'" (regexp-quote tmp-name)) - "^\\'") - tramp--test-messages)))))))) + (let (inhibit-message) + (dolist (noninteractive (unless (tramp--test-ange-ftp-p) '(nil t))) + (dolist (visit '(nil t "string" no-message)) + (ert-with-message-capture tramp--test-messages + (write-region "foo" nil tmp-name nil visit) + ;; We must check the last line. There could be + ;; other messages from the progress reporter. + (should + (string-match-p + (if (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (format "^Wrote %s\n\\'" (regexp-quote tmp-name)) + "^\\'") + tramp--test-messages)))))) ;; We do not test lockname here. See ;; `tramp-test39-make-lock-file-name'. @@ -2490,17 +2480,15 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Ange-FTP. ((symbol-function 'yes-or-no-p) #'tramp--test-always)) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) - ;; `mustbenew' is passed to Tramp since Emacs 26.1. - (when (tramp--test-emacs26-p) - (should-error - (cl-letf (((symbol-function #'y-or-n-p) #'ignore) - ;; Ange-FTP. - ((symbol-function #'yes-or-no-p) #'ignore)) - (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) - :type 'file-already-exists) - (should-error - (write-region "foo" nil tmp-name nil nil nil 'excl) - :type 'file-already-exists))) + (should-error + (cl-letf (((symbol-function #'y-or-n-p) #'ignore) + ;; Ange-FTP. + ((symbol-function #'yes-or-no-p) #'ignore)) + (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) + :type 'file-already-exists) + (should-error + (write-region "foo" nil tmp-name nil nil nil 'excl) + :type 'file-already-exists)) ;; Cleanup. (ignore-errors (delete-file tmp-name)))))) @@ -2563,7 +2551,7 @@ This checks also `file-name-as-directory', `file-name-directory', (progn (should-error (copy-file source target) - :type tramp-file-missing) + :type 'file-missing) (write-region "foo" nil source) (should (file-exists-p source)) (copy-file source target) @@ -2589,8 +2577,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should (file-exists-p source)) (make-directory target) (should (file-directory-p target)) - ;; This has been changed in Emacs 26.1. - (when (and (tramp--test-expensive-test) (tramp--test-emacs26-p)) + (when (tramp--test-expensive-test) (should-error (copy-file source target) :type 'file-already-exists) @@ -2675,7 +2662,7 @@ This checks also `file-name-as-directory', `file-name-directory', (progn (should-error (rename-file source target) - :type tramp-file-missing) + :type 'file-missing) (write-region "foo" nil source) (should (file-exists-p source)) (rename-file source target) @@ -2704,8 +2691,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should (file-exists-p source)) (make-directory target) (should (file-directory-p target)) - ;; This has been changed in Emacs 26.1. - (when (and (tramp--test-expensive-test) (tramp--test-emacs26-p)) + (when (tramp--test-expensive-test) (should-error (rename-file source target) :type 'file-already-exists) @@ -2883,7 +2869,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (ert-deftest tramp-test15-copy-directory () "Check `copy-directory'." (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) + (skip-unless (not (tramp--test-rclone-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) @@ -2900,7 +2886,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (progn (should-error (copy-directory tmp-name1 tmp-name2) - :type tramp-file-missing) + :type 'file-missing) ;; Copy empty directory. (make-directory tmp-name1) (write-region "foo" nil tmp-name4) @@ -2910,11 +2896,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (should (file-directory-p tmp-name2)) (should (file-exists-p tmp-name5)) ;; Target directory does exist already. - ;; This has been changed in Emacs 26.1. - (when (tramp--test-emacs26-p) - (should-error - (copy-directory tmp-name1 tmp-name2) - :type 'file-already-exists)) + (should-error + (copy-directory tmp-name1 tmp-name2) + :type 'file-already-exists) (copy-directory tmp-name1 (file-name-as-directory tmp-name2)) (should (file-directory-p tmp-name3)) (should (file-exists-p tmp-name6))) @@ -3004,7 +2988,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (progn (should-error (directory-files tmp-name1) - :type tramp-file-missing) + :type 'file-missing) (make-directory tmp-name1) (write-region "foo" nil tmp-name2) (write-region "bla" nil tmp-name3) @@ -3127,14 +3111,12 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (insert-directory tmp-name1 nil) (goto-char (point-min)) (should (looking-at-p (regexp-quote tmp-name1)))) - ;; This has been fixed in Emacs 26.1. See Bug#29423. - (when (tramp--test-emacs26-p) - (with-temp-buffer - (insert-directory (file-name-as-directory tmp-name1) nil) - (goto-char (point-min)) - (should - (looking-at-p - (regexp-quote (file-name-as-directory tmp-name1)))))) + (with-temp-buffer + (insert-directory (file-name-as-directory tmp-name1) nil) + (goto-char (point-min)) + (should + (looking-at-p + (regexp-quote (file-name-as-directory tmp-name1))))) (with-temp-buffer (insert-directory tmp-name1 "-al") (goto-char (point-min)) @@ -3166,7 +3148,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; modes are still "accessible". (not (tramp--test-sshfs-p)) ;; A directory is always accessible for user "root". - (not (zerop (tramp-compat-file-attribute-user-id + (not (zerop (file-attribute-user-id (file-attributes tmp-name1))))) (set-file-modes tmp-name1 0) (with-temp-buffer @@ -3178,7 +3160,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (with-temp-buffer (should-error (insert-directory tmp-name1 nil) - :type tramp-file-missing))) + :type 'file-missing))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)))))) @@ -3192,8 +3174,6 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (skip-unless (not (tramp--test-rsync-p))) ;; Wildcards are not supported in tramp-crypt.el. (skip-unless (not (tramp--test-crypt-p))) - ;; Since Emacs 26.1. - (skip-unless (fboundp 'insert-directory-wildcard-in-dir-p)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 @@ -3381,15 +3361,14 @@ This tests also `access-file', `file-readable-p', (file-modes tramp-test-temporary-file-directory)))) (write-region "foo" nil tmp-name1) (setq test-file-ownership-preserved-p - (= (tramp-compat-file-attribute-group-id - (file-attributes tmp-name1)) + (= (file-attribute-group-id (file-attributes tmp-name1)) (tramp-get-remote-gid tramp-test-vec 'integer))) (delete-file tmp-name1)) (when (tramp--test-supports-set-file-modes-p) (write-region "foo" nil tmp-name1) ;; A file is always accessible for user "root". - (when (not (zerop (tramp-compat-file-attribute-user-id + (when (not (zerop (file-attribute-user-id (file-attributes tmp-name1)))) (set-file-modes tmp-name1 0) (should-error @@ -3399,7 +3378,7 @@ This tests also `access-file', `file-readable-p', (delete-file tmp-name1)) (should-error (access-file tmp-name1 "error") - :type tramp-file-missing) + :type 'file-missing) ;; `file-ownership-preserved-p' should return t for ;; non-existing files. @@ -3416,33 +3395,29 @@ This tests also `access-file', `file-readable-p', ;; We do not test inodes and device numbers. (setq attr (file-attributes tmp-name1)) (should (consp attr)) - (should (null (tramp-compat-file-attribute-type attr))) - (should (numberp (tramp-compat-file-attribute-link-number attr))) - (should (numberp (tramp-compat-file-attribute-user-id attr))) - (should (numberp (tramp-compat-file-attribute-group-id attr))) + (should (null (file-attribute-type attr))) + (should (numberp (file-attribute-link-number attr))) + (should (numberp (file-attribute-user-id attr))) + (should (numberp (file-attribute-group-id attr))) (should - (stringp - (current-time-string - (tramp-compat-file-attribute-access-time attr)))) + (stringp (current-time-string (file-attribute-access-time attr)))) (should (stringp - (current-time-string - (tramp-compat-file-attribute-modification-time attr)))) + (current-time-string (file-attribute-modification-time attr)))) (should (stringp - (current-time-string - (tramp-compat-file-attribute-status-change-time attr)))) - (should (numberp (tramp-compat-file-attribute-size attr))) - (should (stringp (tramp-compat-file-attribute-modes attr))) + (current-time-string (file-attribute-status-change-time attr)))) + (should (numberp (file-attribute-size attr))) + (should (stringp (file-attribute-modes attr))) (setq attr (file-attributes tmp-name1 'string)) - (should (stringp (tramp-compat-file-attribute-user-id attr))) - (should (stringp (tramp-compat-file-attribute-group-id attr))) + (should (stringp (file-attribute-user-id attr))) + (should (stringp (file-attribute-group-id attr))) (tramp--test-ignore-make-symbolic-link-error (should-error (access-file tmp-name2 "error") - :type tramp-file-missing) + :type 'file-missing) (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name2 'group))) (make-symbolic-link tmp-name1 tmp-name2) @@ -3456,7 +3431,7 @@ This tests also `access-file', `file-readable-p', (string-equal (funcall (if quoted #'tramp-compat-file-name-quote #'identity) - (tramp-compat-file-attribute-type attr)) + (file-attribute-type attr)) (file-remote-p (file-truename tmp-name1) 'localname))) (delete-file tmp-name2)) @@ -3475,7 +3450,7 @@ This tests also `access-file', `file-readable-p', (setq attr (file-attributes tmp-name2)) (should (string-equal - (tramp-compat-file-attribute-type attr) + (file-attribute-type attr) (tramp-file-name-localname (tramp-dissect-file-name tmp-name3)))) (delete-file tmp-name2)) @@ -3491,7 +3466,7 @@ This tests also `access-file', `file-readable-p', (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name1 'group))) (setq attr (file-attributes tmp-name1)) - (should (eq (tramp-compat-file-attribute-type attr) t))) + (should (eq (file-attribute-type attr) t))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1)) @@ -3509,9 +3484,9 @@ They might differ only in time attributes or directory size." (start-time (- tramp--test-start-time 10))) ;; Link number. For directories, it includes the number of ;; subdirectories. Set it to 1. - (when (eq (tramp-compat-file-attribute-type attr1) t) + (when (eq (file-attribute-type attr1) t) (setcar (nthcdr 1 attr1) 1)) - (when (eq (tramp-compat-file-attribute-type attr2) t) + (when (eq (file-attribute-type attr2) t) (setcar (nthcdr 1 attr2) 1)) ;; Access time. (setcar (nthcdr 4 attr1) tramp-time-dont-know) @@ -3524,42 +3499,33 @@ They might differ only in time attributes or directory size." ;; order to compensate a possible timestamp resolution higher than ;; a second on the remote machine. (when (or (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time attr1) - tramp-time-dont-know) + (file-attribute-modification-time attr1) tramp-time-dont-know) (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time attr2) - tramp-time-dont-know)) + (file-attribute-modification-time attr2) tramp-time-dont-know)) (setcar (nthcdr 5 attr1) tramp-time-dont-know) (setcar (nthcdr 5 attr2) tramp-time-dont-know)) (when (< start-time - (float-time (tramp-compat-file-attribute-modification-time attr1))) + (float-time (file-attribute-modification-time attr1))) (setcar (nthcdr 5 attr1) tramp-time-dont-know)) (when (< start-time - (float-time (tramp-compat-file-attribute-modification-time attr2))) + (float-time (file-attribute-modification-time attr2))) (setcar (nthcdr 5 attr2) tramp-time-dont-know)) ;; Status change time. Ditto. (when (or (tramp-compat-time-equal-p - (tramp-compat-file-attribute-status-change-time attr1) - tramp-time-dont-know) + (file-attribute-status-change-time attr1) tramp-time-dont-know) (tramp-compat-time-equal-p - (tramp-compat-file-attribute-status-change-time attr2) - tramp-time-dont-know)) + (file-attribute-status-change-time attr2) tramp-time-dont-know)) (setcar (nthcdr 6 attr1) tramp-time-dont-know) (setcar (nthcdr 6 attr2) tramp-time-dont-know)) - (when - (< start-time - (float-time - (tramp-compat-file-attribute-status-change-time attr1))) + (when (< start-time (float-time (file-attribute-status-change-time attr1))) (setcar (nthcdr 6 attr1) tramp-time-dont-know)) - (when - (< start-time - (float-time (tramp-compat-file-attribute-status-change-time attr2))) + (when (< start-time (float-time (file-attribute-status-change-time attr2))) (setcar (nthcdr 6 attr2) tramp-time-dont-know)) ;; Size. Set it to 0 for directories, because it might have ;; changed. For example the upper directory "../". - (when (eq (tramp-compat-file-attribute-type attr1) t) + (when (eq (file-attribute-type attr1) t) (setcar (nthcdr 7 attr1) 0)) - (when (eq (tramp-compat-file-attribute-type attr2) t) + (when (eq (file-attribute-type attr2) t) (setcar (nthcdr 7 attr2) 0)) ;; The check. (unless (equal attr1 attr2) (tramp--test-message "%S\n%S" attr1 attr2)) @@ -3583,12 +3549,12 @@ They might differ only in time attributes or directory size." (progn (should-error (directory-files-and-attributes tmp-name1) - :type tramp-file-missing) + :type 'file-missing) (make-directory tmp-name1) (should (file-directory-p tmp-name1)) (setq tramp--test-start-time (float-time - (tramp-compat-file-attribute-modification-time + (file-attribute-modification-time (file-attributes tmp-name1)))) (make-directory tmp-name2) (should (file-directory-p tmp-name2)) @@ -3646,8 +3612,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (should (= (file-modes tmp-name1) #o444)) (should-not (file-executable-p tmp-name1)) ;; A file is always writable for user "root". - (unless (zerop (tramp-compat-file-attribute-user-id - (file-attributes tmp-name1))) + (unless (zerop (file-attribute-user-id (file-attributes tmp-name1))) (should-not (file-writable-p tmp-name1))) ;; Check the NOFOLLOW arg. It exists since Emacs 28. For ;; regular files, there shouldn't be a difference. @@ -3721,9 +3686,6 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." "Check `file-symlink-p'. This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) - ;; The semantics have changed heavily in Emacs 26.1. We cannot test - ;; older Emacsen, therefore. - (skip-unless (tramp--test-emacs26-p)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, @@ -3940,11 +3902,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (when (tramp--test-expensive-test) (should-error (with-temp-buffer (insert-file-contents tmp-name2)) - :type tramp-file-missing)) + :type 'file-missing)) (when (tramp--test-expensive-test) (should-error (with-temp-buffer (insert-file-contents tmp-name3)) - :type tramp-file-missing)) + :type 'file-missing)) ;; `directory-files' does not show symlinks to ;; non-existing targets in the "smb" case. So we remove ;; the symlinks manually. @@ -4005,7 +3967,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (progn (write-region "foo" nil tmp-name1) (should (file-exists-p tmp-name1)) - (should (consp (tramp-compat-file-attribute-modification-time + (should (consp (file-attribute-modification-time (file-attributes tmp-name1)))) ;; Skip the test, if the remote handler is not able to set ;; the correct time. @@ -4013,13 +3975,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Dumb remote shells without perl(1) or stat(1) are not ;; able to return the date correctly. They say "don't know". (unless (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time + (file-attribute-modification-time (file-attributes tmp-name1)) tramp-time-dont-know) (should (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time - (file-attributes tmp-name1)) + (file-attribute-modification-time (file-attributes tmp-name1)) (seconds-to-time 1))) (write-region "bla" nil tmp-name2) (should (file-exists-p tmp-name2)) @@ -4034,7 +3995,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (set-file-times tmp-name1 (seconds-to-time 1) 'nofollow) (should (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time + (file-attribute-modification-time (file-attributes tmp-name1)) (seconds-to-time 1))))))) @@ -4948,8 +4909,6 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-crypt-p))) - ;; Since Emacs 26.1. - (skip-unless (boundp 'interrupt-process-functions)) ;; We must use `file-truename' for the temporary directory, in ;; order to establish the connection prior running an asynchronous @@ -5364,9 +5323,6 @@ Use direct async.") ;; Since Emacs 27.1. (skip-unless (fboundp 'with-connection-local-variables)) - ;; `connection-local-set-profile-variables' and - ;; `connection-local-set-profiles' exist since Emacs 26.1. We don't - ;; want to see compiler warnings for older Emacsen. (let* ((default-directory tramp-test-temporary-file-directory) (tmp-name1 (tramp--test-make-temp-name)) (tmp-name2 (expand-file-name "foo" tmp-name1)) @@ -5382,23 +5338,22 @@ Use direct async.") ;; `local-variable' is buffer-local due to explicit setting. (with-no-warnings - (defvar-local local-variable 'buffer)) + (defvar-local local-variable 'buffer)) (with-temp-buffer (should (eq local-variable 'buffer))) ;; `local-variable' is connection-local due to Tramp. (write-region "foo" nil tmp-name2) (should (file-exists-p tmp-name2)) - (with-no-warnings - (connection-local-set-profile-variables - 'local-variable-profile - '((local-variable . connect))) - (connection-local-set-profiles - `(:application tramp - :protocol ,(file-remote-p default-directory 'method) - :user ,(file-remote-p default-directory 'user) - :machine ,(file-remote-p default-directory 'host)) - 'local-variable-profile)) + (connection-local-set-profile-variables + 'local-variable-profile + '((local-variable . connect))) + (connection-local-set-profiles + `(:application tramp + :protocol ,(file-remote-p default-directory 'method) + :user ,(file-remote-p default-directory 'user) + :machine ,(file-remote-p default-directory 'host)) + 'local-variable-profile) (with-current-buffer (find-file-noselect tmp-name2) (should (eq local-variable 'connect)) (kill-buffer (current-buffer))) @@ -5423,7 +5378,6 @@ Use direct async.") ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive))))) -;; The functions were introduced in Emacs 26.1. (ert-deftest tramp-test34-explicit-shell-file-name () "Check that connection-local `explicit-shell-file-name' is set." :tags '(:expensive-test) @@ -5433,13 +5387,7 @@ Use direct async.") ;; remote processes in Emacs. That doesn't work for tramp-adb.el. (when (tramp--test-adb-p) (skip-unless (tramp--test-emacs27-p))) - ;; Since Emacs 26.1. - (skip-unless (and (fboundp 'connection-local-set-profile-variables) - (fboundp 'connection-local-set-profiles))) - ;; `connection-local-set-profile-variables' and - ;; `connection-local-set-profiles' exist since Emacs 26.1. We don't - ;; want to see compiler warnings for older Emacsen. (let ((default-directory tramp-test-temporary-file-directory) explicit-shell-file-name kill-buffer-query-functions connection-local-profile-alist connection-local-criteria-alist) @@ -5448,19 +5396,16 @@ Use direct async.") ;; `shell-mode' would ruin our test, because it deletes all ;; buffer local variables. Not needed in Emacs 27.1. (put 'explicit-shell-file-name 'permanent-local t) - ;; Declare connection-local variables `explicit-shell-file-name' - ;; and `explicit-sh-args'. - (with-no-warnings - (connection-local-set-profile-variables - 'remote-sh - `((explicit-shell-file-name . ,(tramp--test-shell-file-name)) - (explicit-sh-args . ("-c" "echo foo")))) - (connection-local-set-profiles - `(:application tramp - :protocol ,(file-remote-p default-directory 'method) - :user ,(file-remote-p default-directory 'user) - :machine ,(file-remote-p default-directory 'host)) - 'remote-sh)) + (connection-local-set-profile-variables + 'remote-sh + `((explicit-shell-file-name . ,(tramp--test-shell-file-name)) + (explicit-sh-args . ("-c" "echo foo")))) + (connection-local-set-profiles + `(:application tramp + :protocol ,(file-remote-p default-directory 'method) + :user ,(file-remote-p default-directory 'user) + :machine ,(file-remote-p default-directory 'host)) + 'remote-sh) (put 'explicit-shell-file-name 'safe-local-variable #'identity) (put 'explicit-sh-args 'safe-local-variable #'identity) @@ -5763,7 +5708,7 @@ Use direct async.") ;; files, owned by root. (let ((tramp-auto-save-directory temporary-file-directory)) (write-region "foo" nil tmp-name1) - (when (zerop (or (tramp-compat-file-attribute-user-id + (when (zerop (or (file-attribute-user-id (file-attributes tmp-name1)) tramp-unknown-id-integer)) (with-temp-buffer @@ -5910,8 +5855,7 @@ Use direct async.") (let ((backup-directory-alist `(("." . ,temporary-file-directory))) tramp-backup-directory-alist) (write-region "foo" nil tmp-name1) - (when (zerop (or (tramp-compat-file-attribute-user-id - (file-attributes tmp-name1)) + (when (zerop (or (file-attribute-user-id (file-attributes tmp-name1)) tramp-unknown-id-integer)) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) @@ -6047,8 +5991,7 @@ Use direct async.") ;; files, owned by root. (let ((lock-file-name-transforms auto-save-file-name-transforms)) (write-region "foo" nil tmp-name1) - (when (zerop (or (tramp-compat-file-attribute-user-id - (file-attributes tmp-name1)) + (when (zerop (or (file-attribute-user-id (file-attributes tmp-name1)) tramp-unknown-id-integer)) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) @@ -6066,29 +6009,22 @@ Use direct async.") (ignore-errors (delete-file tmp-name1)) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password))))) -;; The functions were introduced in Emacs 26.1. (ert-deftest tramp-test40-make-nearby-temp-file () "Check `make-nearby-temp-file' and `temporary-file-directory'." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-ange-ftp-p))) - ;; Since Emacs 26.1. - (skip-unless - (and (fboundp 'make-nearby-temp-file) (fboundp 'temporary-file-directory))) - ;; `make-nearby-temp-file' and `temporary-file-directory' exists - ;; since Emacs 26.1. We don't want to see compiler warnings for - ;; older Emacsen. (let ((default-directory tramp-test-temporary-file-directory) tmp-file) ;; The remote host shall know a temporary file directory. - (should (stringp (with-no-warnings (temporary-file-directory)))) + (should (stringp (temporary-file-directory))) (should (string-equal (file-remote-p default-directory) - (file-remote-p (with-no-warnings (temporary-file-directory))))) + (file-remote-p (temporary-file-directory)))) ;; The temporary file shall be located on the remote host. - (setq tmp-file (with-no-warnings (make-nearby-temp-file "tramp-test"))) + (setq tmp-file (make-nearby-temp-file "tramp-test")) (should (file-exists-p tmp-file)) (should (file-regular-p tmp-file)) (should @@ -6098,18 +6034,12 @@ Use direct async.") (delete-file tmp-file) (should-not (file-exists-p tmp-file)) - (setq tmp-file (with-no-warnings (make-nearby-temp-file "tramp-test" 'dir))) + (setq tmp-file (make-nearby-temp-file "tramp-test" 'dir)) (should (file-exists-p tmp-file)) (should (file-directory-p tmp-file)) (delete-directory tmp-file) (should-not (file-exists-p tmp-file)))) -(defun tramp--test-emacs26-p () - "Check for Emacs version >= 26.1. -Some semantics has been changed for there, w/o new functions or -variables, so we check the Emacs version directly." - (>= emacs-major-version 26)) - (defun tramp--test-emacs27-p () "Check for Emacs version >= 27.1. Some semantics has been changed for there, w/o new functions or @@ -6122,6 +6052,12 @@ Some semantics has been changed for there, w/o new functions or variables, so we check the Emacs version directly." (>= emacs-major-version 28)) +(defun tramp--test-emacs29-p () + "Check for Emacs version >= 29.1. +Some semantics has been changed for there, w/o new functions or +variables, so we check the Emacs version directly." + (>= emacs-major-version 29)) + (defun tramp--test-adb-p () "Check, whether the remote host runs Android. This requires restrictions of file name syntax." @@ -6337,7 +6273,7 @@ This requires restrictions of file name syntax." (string-equal (funcall (if quoted #'tramp-compat-file-name-quote #'identity) - (tramp-compat-file-attribute-type (file-attributes file3))) + (file-attribute-type (file-attributes file3))) (file-remote-p (file-truename file1) 'localname))) ;; Check file contents. (with-temp-buffer @@ -6538,7 +6474,7 @@ This requires restrictions of file name syntax." (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 245s (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) + (skip-unless (not (tramp--test-rclone-p))) (tramp--test-special-characters)) @@ -6661,7 +6597,7 @@ Use the \"ls\" command." (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-gdrive-p))) (skip-unless (not (tramp--test-crypt-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) + (skip-unless (not (tramp--test-rclone-p))) (tramp--test-utf8)) @@ -6873,11 +6809,7 @@ process sentinels. They shall not disturb each other." (when buffers (let ((time (float-time)) (default-directory tmp-name) - (file - (buffer-name - ;; Use `seq-random-elt' once <26.1 support - ;; is dropped. - (nth (random (length buffers)) buffers))) + (file (buffer-name (seq-random-elt buffers))) ;; A remote operation in a timer could ;; confuse Tramp heavily. So we ignore this ;; error here. @@ -6942,8 +6874,7 @@ process sentinels. They shall not disturb each other." ;; the buffers. Mix with regular operation. (let ((buffers (copy-sequence buffers))) (while buffers - ;; Use `seq-random-elt' once <26.1 support is dropped. - (let* ((buf (nth (random (length buffers)) buffers)) + (let* ((buf (seq-random-elt buffers)) (proc (get-buffer-process buf)) (file (process-get proc 'foo)) (count (process-get proc 'bar))) @@ -7003,6 +6934,10 @@ process sentinels. They shall not disturb each other." "Check that Tramp (un)compresses normal files." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) + ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. + (skip-unless (not (tramp--test-emacs29-p))) + (let ((default-directory tramp-test-temporary-file-directory) (tmp-name (tramp--test-make-temp-name))) (write-region "foo" nil tmp-name) @@ -7019,6 +6954,10 @@ process sentinels. They shall not disturb each other." "Check that Tramp (un)compresses directories." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) + ;; Starting with Emacs 29.1, `dired-compress-file' isn't magic anymore. + (skip-unless (not (tramp--test-emacs29-p))) + (let ((default-directory tramp-test-temporary-file-directory) (tmp-name (tramp--test-make-temp-name))) (make-directory tmp-name) @@ -7060,10 +6999,6 @@ process sentinels. They shall not disturb each other." (ert-deftest tramp-test46-delay-load () "Check that Tramp is loaded lazily, only when needed." - ;; The autoloaded Tramp objects are different since Emacs 26.1. We - ;; cannot test older Emacsen, therefore. - (skip-unless (tramp--test-emacs26-p)) - ;; Tramp is neither loaded at Emacs startup, nor when completing a ;; non-Tramp file name like "/foo". Completing a Tramp-alike file ;; name like "/foo:" autoloads Tramp, when `tramp-mode' is t. @@ -7117,10 +7052,6 @@ process sentinels. They shall not disturb each other." (ert-deftest tramp-test46-remote-load-path () "Check that Tramp autoloads its packages with remote `load-path'." - ;; The autoloaded Tramp objects are different since Emacs 26.1. We - ;; cannot test older Emacsen, therefore. - (skip-unless (tramp--test-emacs26-p)) - ;; `tramp-cleanup-all-connections' is autoloaded from tramp-cmds.el. ;; It shall still work, when a remote file name is in the ;; `load-path'. @@ -7149,10 +7080,6 @@ process sentinels. They shall not disturb each other." Since it unloads Tramp, it shall be the last test to run." :tags '(:expensive-test) (skip-unless noninteractive) - ;; The autoloaded Tramp objects are different since Emacs 26.1. We - ;; cannot test older Emacsen, therefore. - (skip-unless (tramp--test-emacs26-p)) - ;; We have autoloaded objects from tramp.el and tramp-archive.el. ;; In order to remove them, we first need to load both packages. (require 'tramp) @@ -7212,8 +7139,7 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; TODO: -;; * dired-compress-file -;; * dired-uncache +;; * dired-uncache (partly done in other test functions) ;; * file-equal-p (partly done in `tramp-test21-file-links') ;; * file-in-directory-p ;; * file-name-case-insensitive-p commit 42d4e24ff3f13ccbd401d93d70ecdee99b88a26d Author: Stefan Kangas Date: Fri Nov 12 13:50:55 2021 +0100 ; Fix typos diff --git a/ChangeLog.3 b/ChangeLog.3 index 9ec19e91d7..ad659694a9 100644 --- a/ChangeLog.3 +++ b/ChangeLog.3 @@ -48398,10 +48398,10 @@ Impl. json-pretty-print with replace-region-contents + minimization * lisp/json.el (json-pretty-print): Use the new - replace-region-contents. Add prefix arg for minimzation. - (json-pretty-print-buffer): Add prefix arg for minimzation. - (json-pretty-print-buffer-ordered): Add prefix arg for minimzation. - (json-pretty-print-ordered): Add prefix arg for minimzation. + replace-region-contents. Add prefix arg for minimization. + (json-pretty-print-buffer): Add prefix arg for minimization. + (json-pretty-print-buffer-ordered): Add prefix arg for minimization. + (json-pretty-print-ordered): Add prefix arg for minimization. 2019-02-08 Tassilo Horn @@ -122196,7 +122196,7 @@ 2012-08-15 Tom Tromey - This parameterizes the GC a bit to make it thread-ready. + This parametrizes the GC a bit to make it thread-ready. The basic idea is that whenever a thread "exits lisp" -- that is, releases the global lock in favor of another thread -- it must save diff --git a/doc/misc/ChangeLog.1 b/doc/misc/ChangeLog.1 index c050e5d4cb..be2a7cad1b 100644 --- a/doc/misc/ChangeLog.1 +++ b/doc/misc/ChangeLog.1 @@ -5965,7 +5965,7 @@ names when publishing to the source directory. (Clean view): Document `org-indent-mode'. (Clocking work time): Add documentation for the - new :timetamp option when creating a clock report. + new :timestamp option when creating a clock report. (Paragraphs): Fix many typos. (Plain lists): Remove duplicate explanation about the `C-c *' command. diff --git a/doc/misc/efaq-w32.texi b/doc/misc/efaq-w32.texi index ba1077d0ac..a5b5251d6e 100644 --- a/doc/misc/efaq-w32.texi +++ b/doc/misc/efaq-w32.texi @@ -628,7 +628,7 @@ REGEDIT4 @node Swap Caps 98 @subsubsection Windows 95/98/ME -Microsoft has a tool called keyremap that is part of their Kernel Toys add ons +Microsoft has a tool called keyremap that is part of their Kernel Toys add-ons for Windows 95. The tool has also been confirmed to work on Windows 98. @node Make Emacs like a Windows app diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi index 309bed7760..f741ee5d72 100644 --- a/doc/misc/flymake.texi +++ b/doc/misc/flymake.texi @@ -218,7 +218,7 @@ can use the variables @code{flymake-mode-line-format} and @cindex disabled backends @cindex backends, disabled -As Flymake supports multiple simutaneously active external backends, +As Flymake supports multiple simultaneously active external backends, is becomes useful to monitor their status. For example, some backends may take longer than others to respond or complete, and some may decide to @emph{disable} themselves if they are not suitable for the @@ -343,7 +343,7 @@ The following sections discuss each approach in detail. To customize the appearance of error types, the user must set properties on the symbols associated with each diagnostic type. -The three standard diagnostic keyowrd symbols -- @code{:error}, +The three standard diagnostic keyword symbols -- @code{:error}, @code{:warning} and @code{:note} -- have pre-configured appearances. However a backend may define more (@pxref{Backend functions}). diff --git a/doc/misc/org.org b/doc/misc/org.org index 17fd2dc39f..df2724dd9c 100644 --- a/doc/misc/org.org +++ b/doc/misc/org.org @@ -16556,7 +16556,7 @@ identifying a reference in the bibliography. - Each key starts with the character =@=. - Each key can be qualified by a /prefix/ (e.g.\nbsp{}"see ") and/or - a /suffix/ (e.g.\nbsp{}"p.\nbsp{}123"), giving informations useful or necessary + a /suffix/ (e.g.\nbsp{}"p.\nbsp{}123"), giving information useful or necessary fo the comprehension of the citation but not included in the reference. diff --git a/etc/PROBLEMS b/etc/PROBLEMS index 9ab2caff75..f94d8492d5 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -2792,7 +2792,7 @@ its path available to Emacs. Errors such as: Error: Internal native compiler error failed to compile indicate Emacs can't find the library in running time. One can set -the "LIBRARY_PATH" environment variable in the early initalization +the "LIBRARY_PATH" environment variable in the early initialization file; for example: (setenv "LIBRARY_PATH" diff --git a/lisp/ChangeLog.12 b/lisp/ChangeLog.12 index 5d424570d8..d841a75c5d 100644 --- a/lisp/ChangeLog.12 +++ b/lisp/ChangeLog.12 @@ -182,7 +182,7 @@ 2007-04-19 Glenn Morris - * calendar/todo-mode.el: Fix typo: "threshhold" -> "threshold". + * calendar/todo-mode.el: Fix typo for "threshold". 2007-04-18 Glenn Morris diff --git a/lisp/cedet/ChangeLog.1 b/lisp/cedet/ChangeLog.1 index fb3dcd2396..0fe55739ef 100644 --- a/lisp/cedet/ChangeLog.1 +++ b/lisp/cedet/ChangeLog.1 @@ -1705,7 +1705,7 @@ 2012-07-29 Paul Eggert - inaccessable -> inaccessible spelling fix (Bug#10052) + "inaccessible" spelling fix (Bug#10052) * semantic/wisent/comp.el (wisent-inaccessible-symbols): Rename from wisent-inaccessable-symbols, fixing a misspelling. Caller changed. diff --git a/lisp/env.el b/lisp/env.el index 2f7cd9d3db..fc48059cfd 100644 --- a/lisp/env.el +++ b/lisp/env.el @@ -220,7 +220,7 @@ in the environment list of the selected frame." ;;;###autoload (defmacro with-environment-variables (variables &rest body) - "Set VARIABLES in the environent and execute BODY. + "Set VARIABLES in the environment and execute BODY. VARIABLES is a list of variable settings of the form (VAR VALUE), where VAR is the name of the variable (a string) and VALUE is its value (also a string). diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el index adb3f521cd..5e4cef5253 100644 --- a/lisp/erc/erc-services.el +++ b/lisp/erc/erc-services.el @@ -492,7 +492,7 @@ Returns t if the message could be sent, nil otherwise." Identification will either use NICK or the current nick if not provided, and some password obtained through `erc-nickserv-get-password' (which see). If no password can be -found, an error is reported trough `erc-error'. +found, an error is reported through `erc-error'. Interactively, the user will be prompted for NICK, an empty string meaning to default to the current nick. diff --git a/lisp/mh-e/ChangeLog.1 b/lisp/mh-e/ChangeLog.1 index b0fdd02e3b..e87bb343cf 100644 --- a/lisp/mh-e/ChangeLog.1 +++ b/lisp/mh-e/ChangeLog.1 @@ -10471,7 +10471,7 @@ mh-header-subject-font-lock instead of regexp for subject headers, which may go multiple lines. (mh-header-subject-font-lock): New function. - Fix typos (hightlight -> highlight). + Fix typos ("highlight"). 2001-12-04 Eric Ding @@ -10881,7 +10881,7 @@ loop in emacs20 font-locking. (mh-header-field-font-lock): Preventive fix with similar change. - * mh-comp.el (mh-reply-show-message-p): Typo. diplayed -> displayed. + * mh-comp.el (mh-reply-show-message-p): Fix typo for "displayed". * MH-E-NEWS: Same. * mh-e.el (mh-folder-tool-bar-map): Bug fix. I had diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 403925c855..4f9506c98b 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -332,7 +332,7 @@ retrieval with `flymake-diagnostic-data'. If LOCUS is a buffer BEG and END should be buffer positions inside it. If LOCUS designates a file, BEG and END should be a cons (LINE . COL) indicating a file position. In this second -case, END may be ommited in which case the region is computed +case, END may be omitted in which case the region is computed using `flymake-diag-region' if the diagnostic is appended to an actual buffer. @@ -870,7 +870,7 @@ and other buffers." (dolist (d diags) (setf (flymake--diag-backend d) backend)) (save-restriction (widen) - ;; First, clean up. Remove diagnostics from bookeeping lists and + ;; First, clean up. Remove diagnostics from bookkeeping lists and ;; their overlays from buffers. ;; (cond diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 46922a3f3b..492be9a104 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1001,7 +1001,7 @@ GROUP is a string for decoration purposes and XREF is an (run-hooks 'xref-after-update-hook)) (defun xref--group-name-for-display (group project-root) - "Return GROUP formatted in the prefered style. + "Return GROUP formatted in the preferred style. The style is determined by the value of `xref-file-name-display'. If GROUP looks like a file name, its value is formatted according diff --git a/lisp/xdg.el b/lisp/xdg.el index db890f9494..ee5d292ce6 100644 --- a/lisp/xdg.el +++ b/lisp/xdg.el @@ -106,7 +106,7 @@ According to the XDG Base Directory Specification version \"$XDG_CONFIG_DIRS defines the preference-ordered set of base directories to search for configuration files in addition to the $XDG_CONFIG_HOME base directory. The directories in - $XDG_CONFIG_DIRS should be seperated with a colon ':'. + $XDG_CONFIG_DIRS should be separated with a colon ':'. \"If $XDG_CONFIG_DIRS is either not set or empty, a value equal to /etc/xdg should be used.\"" @@ -124,7 +124,7 @@ According to the XDG Base Directory Specification version \"$XDG_DATA_DIRS defines the preference-ordered set of base directories to search for data files in addition to the $XDG_DATA_HOME base directory. The directories in - $XDG_DATA_DIRS should be seperated with a colon ':'. + $XDG_DATA_DIRS should be separated with a colon ':'. \"If $XDG_DATA_DIRS is either not set or empty, a value equal to /usr/local/share/:/usr/share/ should be used.\"" diff --git a/src/ChangeLog.11 b/src/ChangeLog.11 index 41c35babda..cf5e7b7a2a 100644 --- a/src/ChangeLog.11 +++ b/src/ChangeLog.11 @@ -22399,7 +22399,7 @@ * Makefile.in (${lispsource}international/charprop.el): Delete this target. - * search.c (boyer_moore): Fix incorrect synching of the trunk and + * search.c (boyer_moore): Fix incorrect syncing of the trunk and emacs-unicode-2. 2008-02-11 Stefan Monnier @@ -23177,7 +23177,7 @@ 2008-02-01 Kenichi Handa * xfaces.c (face_for_overlay_string): Call lookup_face with - correct arguments (fix of synching with the trunk). + correct arguments (fix of syncing with the trunk). 2008-02-01 Kenichi Handa diff --git a/test/lisp/mh-e/mh-utils-tests.el b/test/lisp/mh-e/mh-utils-tests.el index ed979232a4..d9a26e5895 100644 --- a/test/lisp/mh-e/mh-utils-tests.el +++ b/test/lisp/mh-e/mh-utils-tests.el @@ -152,7 +152,7 @@ select which." (defun mh-test-utils-setup () "Set dynamically bound variables needed by mock and/or variants. Call `mh-variant-set' to look through the directories named by -envionment variable `TEST_MH_PATH' (default: `mh-path' and `mh-sys-path') +environment variable `TEST_MH_PATH' (default: `mh-path' and `mh-sys-path') to find the MH variant to use, if any. Return the name of the root of the created directory tree, if any." (when (getenv "TEST_MH_PATH") commit 12d554e5c54487d753a133c048e262f3d54019bd Author: Po Lu Date: Fri Nov 12 20:17:28 2021 +0800 Fix typos in etc/PROBLEMS * etc/PROBLEMS (Internationalization problems): Fix typos. diff --git a/etc/PROBLEMS b/etc/PROBLEMS index 766e4e0d2c..9bd06ca352 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -1097,11 +1097,11 @@ this problem by switching to IBus, or by using a native Emacs input method and disabling XIM altogether. For example, you can add the following line: - Emacs.useXIM: false + Emacs.useXIM: false In your ~/.Xresources file, then run - $ xrdb + $ xrdb ~/.Xresources And restart Emacs. commit 449bc51dcd3d26bf81b4a239bf6279d955f487a9 Author: Po Lu Date: Fri Nov 12 20:15:50 2021 +0800 Document problem with fcitx and xwidgets * etc/PROBLEMS (Internationalization problems): Document buggy fcitx with xwidgets. diff --git a/etc/PROBLEMS b/etc/PROBLEMS index d8d4cf7a17..766e4e0d2c 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -1087,6 +1087,24 @@ The solution is to remove the corresponding lines from the appropriate 'fonts.alias' file, then run 'mkfontdir' in that directory, and then run 'xset fp rehash'. +** fcitx input methods don't work with xwidgets. + +fcitx-based input methods might not work when xwidgets are displayed, +such as inside an xwidget-webkit buffer. This manifests as the pre-edit +window of the input method disappearing, and the Emacs frame losing +input focus as soon as you try to type anything. You can work around +this problem by switching to IBus, or by using a native Emacs input +method and disabling XIM altogether. For example, you can add the +following line: + + Emacs.useXIM: false + +In your ~/.Xresources file, then run + + $ xrdb + +And restart Emacs. + * X runtime problems ** X keyboard problems commit 75e219167e137c558fbfb1cbe9a9bc3ca0bbb6bc Author: Michael Albinus Date: Fri Nov 12 13:05:54 2021 +0100 ; * etc/NEWS: Fix typos. diff --git a/etc/NEWS b/etc/NEWS index 0057fbdcbf..c362e56cee 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -52,7 +52,7 @@ time. *** Emacs will now use 24-bit colors on terminals that support "Tc" capability. This is in addition to previously-supported ways of discovering 24-bit color support: either via the "RGB" or "setf24" capabilities, or if -the COLORTERM environment variable is set to the value "truecolor". +the 'COLORTERM' environment variable is set to the value "truecolor". ** Emoji @@ -96,7 +96,7 @@ Jumping to source from "*Help*" buffer moves the point when the source buffer is already open. Now, the old point is pushed to mark ring. +++ -*** New key bindings in *Help* buffers: 'n' and 'p'. +*** New key bindings in "*Help*" buffers: 'n' and 'p'. These will take you (respectively) to the next and previous "page". --- @@ -138,9 +138,7 @@ LRI). The new command 'highlight-confusing-reorderings' finds and highlights segments of buffer text whose reordering for display is suspicious and could be malicious. - - -** Emacs server and client changes. +** Emacs server and client changes +++ *** New command-line option '-r' for emacsclient. @@ -221,10 +219,10 @@ info node. This command only works for the Emacs and Emacs Lisp manuals. --- *** 'C-x v v' on an unregistered file will now use the most specific backend. -Previously, if you had an SVN-covered ~/ directory, and a Git-covered -directory in ~/foo/bar, using 'C-x v v' on a new, unregistered file -~/foo/bar/zot would register it in the SVN repository in ~/ instead of -in the Git repository in ~/foo/bar. This makes this command +Previously, if you had an SVN-covered "~/" directory, and a Git-covered +directory in "~/foo/bar", using 'C-x v v' on a new, unregistered file +"~/foo/bar/zot" would register it in the SVN repository in "~/" instead of +in the Git repository in "~/foo/bar". This makes this command consistent with 'vc-responsible-backend'. ** Message @@ -239,7 +237,7 @@ If non-nil, 'C-c C-a' will put attached files at the end of the message. ** HTML Mode --- -*** HTML Mode now supports text/html and image/* yanking. +*** HTML Mode now supports "text/html" and "image/*" yanking. ** Texinfo Mode @@ -259,7 +257,7 @@ doesn't work on other systems. Also see etc/PROBLEMS. +++ *** New user option 'eww-url-transformers'. These are used to alter an URL before using it. By default it removes -the common utm_ trackers from URLs. +the common "utm_" trackers from URLs. ** Gnus @@ -375,7 +373,7 @@ The keybinding for 'image-transform-fit-to-width' is now 's i'. This works like 'image-transform-fit-to-window'. *** New user option 'image-auto-resize-max-scale-percent'. -The new 'fit-window' options will never scale an image more than this +The new 'fit-window' option will never scale an image more than this much (in percent). It is nil by default. ** Image-Dired @@ -405,13 +403,13 @@ external "exiftool" command to be available. The user options --- *** New command for the thumbnail buffer. The new command 'image-dired-unmark-all-marks' has been added. It is -bound to "U" in the thumbnail buffer. +bound to 'U' in the thumbnail buffer. --- *** Support Thumbnail Managing Standard v0.9.0 (Dec 2020). This standard allows sharing generated thumbnails across different programs. Version 0.9.0 adds two larger thumbnail sizes: 512x512 and -1024x1024 pixels. See the user option `image-dired-thumbnail-storage' +1024x1024 pixels. See the user option 'image-dired-thumbnail-storage' to use it; it is not enabled by default. --- @@ -463,7 +461,6 @@ If non-nil (which is the default), hitting 'RET' or 'mouse-1' on the directory components at the directory displayed at the start of the buffer will take you to that directory. - ** Exif *** New function 'exif-field'. @@ -480,7 +477,7 @@ named. +++ *** New minor mode 'xwidget-webkit-edit-mode'. When this mode is enabled, self-inserting characters and other common -web browser shotcut keys are redefined to send themselves to the +web browser shortcut keys are redefined to send themselves to the WebKit widget. +++ @@ -515,11 +512,11 @@ Emacs buffers, like indentation and the like. The new ert function ** Fonts --- -*** Emacs now supports `medium' fonts. -Emacs previously didn't distinguish between the `regular'/`normal' -weight and the `medium' weight, but it now also supports the (heavier) -`medium' weight. However, this means that if you previously specified -a weight of `normal' and the font doesn't have this weight, Emacs +*** Emacs now supports 'medium' fonts. +Emacs previously didn't distinguish between the 'regular'/'normal' +weight and the 'medium' weight, but it now also supports the (heavier) +'medium' weight. However, this means that if you previously specified +a weight of 'normal' and the font doesn't have this weight, Emacs won't find the font spec. In these cases, replacing ":weight 'normal" with ":weight 'medium" should fix the issue. @@ -593,7 +590,7 @@ Use 'exif-parse-file' and 'exif-field' instead. This returns a list of all the components of a file name. +++ -** New macro 'with-undo-amalgamate' +** New macro 'with-undo-amalgamate'. It records a particular sequence of operations as a single undo step. +++ @@ -616,7 +613,7 @@ searchable data, like image data) with a 'display' text property. +++ ** 'insert-image' now takes an INHIBIT-ISEARCH optional parameter. -It marks the image with the 'inhibit-isearch' text parameter, which +It marks the image with the 'inhibit-isearch' text property, which inhibits 'isearch' matching the STRING parameter. --- @@ -642,7 +639,7 @@ character. ** XDG support -*** New function 'xdg-state-home' returns $XDG_STATE_HOME. +*** New function 'xdg-state-home' returns 'XDG_STATE_HOME' environment variable. This new location, introduced in the XDG Base Directory Specification version 0.8 (8th May 2021), "contains state data that should persist between (application) restarts, but that is not important or portable @@ -656,7 +653,7 @@ the body takes longer to execute than the specified timeout. --- ** New function 'funcall-with-delayed-message'. This function is like 'funcall', but will output the specified message -is the function take longer to execute that the specified timeout. +if the function takes longer to execute than the specified timeout. ** Locale @@ -673,7 +670,7 @@ executing code. +++ *** A column can now be set to an image descriptor. -The `tabulated-list-entries' variable now supports using an image +The 'tabulated-list-entries' variable now supports using an image descriptor, which means to insert an image in that column instead of text. See the documentation string of that variable for details. @@ -756,9 +753,9 @@ an exact match, then the lowercased '[menu-bar foo\ bar]' and finally '[menu-bar foo-bar]'. This further improves backwards-compatibility when converting menus to use 'easy-menu-define'. -+++ ** xwidgets ++++ *** The function 'make-xwidget' now accepts an optional RELATED argument. This argument is used as another widget for the newly created WebKit widget to share settings and subprocesses with. It must be another commit 18eec5720e3b49c0f9efb646bb896ba4e9549ea0 Author: Stefan Kangas Date: Fri Nov 12 11:40:50 2021 +0100 * lisp/emacs-lisp/checkdoc.el (checkdoc-dired): Autoload. diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 7bb82c2e8b..ab2f34c310 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1116,6 +1116,7 @@ space at the end of each line." ";;; lisp/trampver.el. Generated from trampver.el.in by configure.")) "Regexp that when it matches tells `checkdoc-dired' to skip a file.") +;;;###autoload (defun checkdoc-dired (files) "In Dired, run `checkdoc' on marked files. Skip anything that doesn't have the Emacs Lisp library file commit 2803cabe890b3ec47f54ebaa63c84de588809a6f Author: Po Lu Date: Fri Nov 12 17:48:56 2021 +0800 Add support for input methods to xwidget-webkit-edit-mode * lisp/xwidget.el (xwidget-webkit--input-method-events): New variable. (xwidget-webkit-pass-command-event-with-input-method): New function. (xwidget-webkit-pass-command-event): Consult input method about key events if input method is enabled. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 3d4e96f92d..e98143b955 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -146,11 +146,36 @@ in `split-window-right' with a new xwidget webkit session." (declare-function xwidget-perform-lispy-event "xwidget.c") +(defvar xwidget-webkit--input-method-events nil + "Internal variable used to store input method events.") + +(defun xwidget-webkit-pass-command-event-with-input-method () + "Handle a `with-input-method' event." + (interactive) + (let ((key (pop unread-command-events))) + (setq xwidget-webkit--input-method-events + (funcall input-method-function key)) + (exit-minibuffer))) + (defun xwidget-webkit-pass-command-event () - "Pass `last-command-event' to the current buffer's WebKit widget." + "Pass `last-command-event' to the current buffer's WebKit widget. +If `current-input-method' is non-nil, consult `input-method-function' +for the actual events that will be sent." (interactive) - (xwidget-perform-lispy-event (xwidget-webkit-current-session) - last-command-event)) + (if (and current-input-method + (characterp last-command-event)) + (let ((xwidget-webkit--input-method-events nil) + (minibuffer-local-map (make-keymap))) + (define-key minibuffer-local-map [with-input-method] + 'xwidget-webkit-pass-command-event-with-input-method) + (push last-command-event unread-command-events) + (push 'with-input-method unread-command-events) + (read-from-minibuffer "" nil nil nil nil nil t) + (dolist (event xwidget-webkit--input-method-events) + (xwidget-perform-lispy-event (xwidget-webkit-current-session) + event))) + (xwidget-perform-lispy-event (xwidget-webkit-current-session) + last-command-event))) ;;todo. ;; - check that the webkit support is compiled in commit 00e3baf6e32d39c8434f50e1f0b0a83ad2ad3aeb Author: Noam Postavsky Date: Fri Nov 12 10:21:45 2021 +0100 Optimize admin/nt dependency computation admin/nt/dist-build/build-dep-zips.py (immediate_deps) (extract_deps): Gather package dependency info in batches, rather than one at a time. This reduces the number of invocations of 'pacman -Si ...' to the depth of the dependency tree, rather than the number of dependent packages. (top-level): Don't call 'extract_deps' when given the '-l' option (bug#40628). diff --git a/admin/nt/dist-build/build-dep-zips.py b/admin/nt/dist-build/build-dep-zips.py index 19168e7ff2..6bed191cae 100755 --- a/admin/nt/dist-build/build-dep-zips.py +++ b/admin/nt/dist-build/build-dep-zips.py @@ -20,6 +20,8 @@ import os import shutil import re +import functools +import operator from subprocess import check_output @@ -112,7 +114,7 @@ def ntldd_munge(out): ## Packages to fiddle with ## Source for gcc-libs is part of gcc SKIP_SRC_PKGS=["mingw-w64-gcc-libs"] -SKIP_DEP_PKGS=["mingw-w64-glib2"] +SKIP_DEP_PKGS=frozenset(["mingw-w64-x86_64-glib2"]) MUNGE_SRC_PKGS={"mingw-w64-libwinpthread-git":"mingw-w64-winpthreads-git"} MUNGE_DEP_PKGS={ "mingw-w64-x86_64-libwinpthread":"mingw-w64-x86_64-libwinpthread-git", @@ -124,16 +126,14 @@ def ntldd_munge(out): SRC_REPO="https://sourceforge.net/projects/msys2/files/REPOS/MINGW/Sources" -def immediate_deps(pkg): - package_info = check_output(["pacman", "-Si", pkg]).decode("utf-8").split("\n") +def immediate_deps(pkgs): + package_info = check_output(["pacman", "-Si"] + pkgs).decode("utf-8").splitlines() - ## Extract the "Depends On" line - depends_on = [x for x in package_info if x.startswith("Depends On")][0] - ## Remove "Depends On" prefix - dependencies = depends_on.split(":")[1] - - ## Split into dependencies - dependencies = dependencies.strip().split(" ") + ## Extract the packages listed for "Depends On:" lines. + dependencies = [line.split(":")[1].split() for line in package_info + if line.startswith("Depends On")] + ## Flatten dependency lists from multiple packages into one list. + dependencies = functools.reduce(operator.iconcat, dependencies, []) ## Remove > signs TODO can we get any other punctuation here? dependencies = [d.split(">")[0] for d in dependencies if d] @@ -149,16 +149,18 @@ def extract_deps(): print( "Extracting deps" ) # Get a list of all dependencies needed for packages mentioned above. - pkgs = PKG_REQ[:] - n = 0 - while n < len(pkgs): - subdeps = immediate_deps(pkgs[n]) - for p in subdeps: - if not (p in pkgs or p in SKIP_DEP_PKGS): - pkgs.append(p) - n = n + 1 + pkgs = set(PKG_REQ) + newdeps = pkgs + print("adding...") + while True: + subdeps = frozenset(immediate_deps(list(newdeps))) + newdeps = subdeps - SKIP_DEP_PKGS - pkgs + if not newdeps: + break + print('\n'.join(newdeps)) + pkgs |= newdeps - return sorted(pkgs) + return list(pkgs) def download_source(tarball): @@ -255,7 +257,7 @@ def clean(): if( args.l ): print("List of dependencies") - print( extract_deps() ) + print( deps ) exit(0) if args.s: commit 0d0125daaeb77af5aa6091059ff6d0c1ce9f6cff Author: Eli Zaretskii Date: Fri Nov 12 10:53:52 2021 +0200 Improve documentation of 'decode-coding-region' * src/coding.c (Fdecode_coding_region): Doc fix. * doc/lispref/nonascii.texi (Coding System Basics) (Explicit Encoding): Explain the significance of using 'undecided' in 'decode-coding-*' functions. diff --git a/doc/lispref/nonascii.texi b/doc/lispref/nonascii.texi index 6980920a7b..24117b5001 100644 --- a/doc/lispref/nonascii.texi +++ b/doc/lispref/nonascii.texi @@ -1048,9 +1048,9 @@ Alternativnyj, and KOI8. Every coding system specifies a particular set of character code conversions, but the coding system @code{undecided} is special: it leaves the choice unspecified, to be chosen heuristically for each -file, based on the file's data. The coding system @code{prefer-utf-8} -is like @code{undecided}, but it prefers to choose @code{utf-8} when -possible. +file or string, based on the file's or string's data, when they are +decoded or encoded. The coding system @code{prefer-utf-8} is like +@code{undecided}, but it prefers to choose @code{utf-8} when possible. In general, a coding system doesn't guarantee roundtrip identity: decoding a byte sequence using a coding system, then encoding the @@ -1921,9 +1921,24 @@ length of the decoded text. If that buffer is a unibyte buffer the decoded text (@pxref{Text Representations}) is inserted into the buffer as individual bytes. +@cindex @code{charset}, text property on buffer text This command puts a @code{charset} text property on the decoded text. The value of the property states the character set used to decode the original text. + +@cindex undecided coding-system, when decoding +This command detects the encoding of the text if necessary. If +@var{coding-system} is @code{undecided}, the command detects the +encoding of the text based on the byte sequences it finds in the text, +and also detects the type of end-of-line convention used by the text +(@pxref{Lisp and Coding Systems, eol type}). If @var{coding-system} +is @code{undecided-@var{eol-type}}, where @var{eol-type} is +@code{unix}, @code{dos}, or @code{mac}, then the command detects only +the encoding of the text. Any @var{coding-system} that doesn't +specify @var{eol-type}, as in @code{utf-8}, causes the command to +detect the end-of-line convention; specify the encoding completely, as +in @code{utf-8-unix}, if the EOL convention used by the text is known +in advance, to prevent any automatic detection. @end deffn @defun decode-coding-string string coding-system &optional nocopy buffer @@ -1936,13 +1951,16 @@ trivial. To make explicit decoding useful, the contents of values, but a multibyte string is also acceptable (assuming it contains 8-bit bytes in their multibyte form). +This function detects the encoding of the string if needed, like +@code{decode-coding-region} does. + If optional argument @var{buffer} specifies a buffer, the decoded text is inserted in that buffer after point (point does not move). In this case, the return value is the length of the decoded text. If that buffer is a unibyte buffer, the internal representation of the decoded text is inserted into it as individual bytes. -@cindex @code{charset}, text property +@cindex @code{charset}, text property on strings This function puts a @code{charset} text property on the decoded text. The value of the property states the character set used to decode the original text: diff --git a/src/coding.c b/src/coding.c index 7030a53869..02dccf5bdb 100644 --- a/src/coding.c +++ b/src/coding.c @@ -9455,11 +9455,12 @@ code_convert_region (Lisp_Object start, Lisp_Object end, DEFUN ("decode-coding-region", Fdecode_coding_region, Sdecode_coding_region, 3, 4, "r\nzCoding system: ", doc: /* Decode the current region from the specified coding system. +Interactively, prompt for the coding system to decode the region. -What's meant by \"decoding\" is transforming bytes into text -(characters). If, for instance, you have a region that contains data -that represents the two bytes #xc2 #xa9, after calling this function -with the utf-8 coding system, the region will contain the single +\"Decoding\" means transforming bytes into readable text (characters). +If, for instance, you have a region that contains data that represents +the two bytes #xc2 #xa9, after calling this function with the utf-8 +coding system, the region will contain the single character ?\\N{COPYRIGHT SIGN}. When called from a program, takes four arguments: commit 87e53578861a37748cdfc7cb017b73c2bcf572a4 Author: Rasmus Date: Fri Nov 12 09:02:28 2021 +0100 lisp/icomplete.el (icomplete-fido-backward-updir): Expand "~/" * lisp/icomplete.el (icomplete-fido-backward-updir): Expand "~/" (bug#43925). diff --git a/lisp/icomplete.el b/lisp/icomplete.el index a61c9d6354..f909a3b177 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -380,13 +380,17 @@ if that doesn't produce a completion match." (defun icomplete-fido-backward-updir () "Delete char before or go up directory, like `ido-mode'." (interactive) - (if (and (eq (char-before) ?/) - (eq (icomplete--category) 'file)) - (save-excursion - (goto-char (1- (point))) - (when (search-backward "/" (point-min) t) - (delete-region (1+ (point)) (point-max)))) - (call-interactively 'backward-delete-char))) + (cond ((and (eq (char-before) ?/) + (eq (icomplete--category) 'file)) + (when (string-equal (icomplete--field-string) "~/") + (delete-region (icomplete--field-beg) (icomplete--field-end)) + (insert (expand-file-name "~/")) + (goto-char (line-end-position))) + (save-excursion + (goto-char (1- (point))) + (when (search-backward "/" (point-min) t) + (delete-region (1+ (point)) (point-max))))) + (t (call-interactively 'backward-delete-char)))) (defvar icomplete-fido-mode-map (let ((map (make-sparse-keymap))) commit 81535cd8783d956cedd9a59263e77d2062c70197 Author: Lars Ingebrigtsen Date: Fri Nov 12 08:56:51 2021 +0100 Delete .tar.gz temp file after tramp test * test/lisp/net/tramp-tests.el () (tramp-test45-dired-compress-dir): Delete the temp file (bug#51690). diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 3d6ce963ee..ffeb5420fe 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -7029,7 +7029,8 @@ process sentinels. They shall not disturb each other." (should (string= (concat tmp-name ".tar.gz") (dired-get-filename))) (should-not (dired-compress)) (should (string= tmp-name (dired-get-filename))) - (delete-directory tmp-name))) + (delete-directory tmp-name) + (delete-file (concat tmp-name ".tar.gz")))) ;; This test is inspired by Bug#29163. (ert-deftest tramp-test46-auto-load () commit 0b7293a7883be5f3549770f453bc2562914dd963 Author: Eli Zaretskii Date: Fri Nov 12 09:50:43 2021 +0200 ; * lisp/startup.el (command-line-1): Fix a typo in a comment. diff --git a/lisp/startup.el b/lisp/startup.el index a911aed1cd..d4fa59925f 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -2530,7 +2530,7 @@ nil default-directory" name) (truename (file-truename file-ex))) ;; We want to use the truename here if we can, ;; because that makes `eval-after-load' work - ;; more reliably. But If the file is, for + ;; more reliably. But if the file is, for ;; instance, /dev/stdin, the truename doesn't ;; actually exist on some systems. (when (file-exists-p truename) commit 766f636a72d890c0304cbbf49b7e1391aba0f406 Author: Eli Zaretskii Date: Fri Nov 12 09:47:44 2021 +0200 ; * src/lread.c (safe_to_load_version, Fload): Fix coding style. diff --git a/src/lread.c b/src/lread.c index 39cab19fc0..3052bcbd06 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1054,7 +1054,7 @@ safe_to_load_version (Lisp_Object file, int fd) /* If the file is not regular, then we cannot safely seek it. Assume that it is not safe to load as a compiled file. */ - if (fstat(fd, &st) == 0 && !S_ISREG (st.st_mode)) + if (fstat (fd, &st) == 0 && !S_ISREG (st.st_mode)) return 0; /* Read the first few bytes from the file, and look for a line @@ -1418,11 +1418,8 @@ Return t if the file exists and loads successfully. */) struct stat s1, s2; int result; - if (version < 0 - && ! (version = safe_to_load_version (file, fd))) - { - error ("File `%s' was not compiled in Emacs", SDATA (found)); - } + if (version < 0 && !(version = safe_to_load_version (file, fd))) + error ("File `%s' was not compiled in Emacs", SDATA (found)); compiled = 1; commit 0c3bf6ce110eeaaf9dbb265b31598b837a257937 Author: Lars Ingebrigtsen Date: Fri Nov 12 08:23:41 2021 +0100 Remove unused xlfd_ enums * src/xfaces.c: Remove xlfd_weight, xlfd_swidth and xlfd_slant enums. These seem to be unused in the Emacs sources. diff --git a/src/xfaces.c b/src/xfaces.c index a8cbf34790..442fcf47d3 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -1416,52 +1416,6 @@ enum xlfd_field XLFD_LAST }; -/* An enumerator for each possible slant value of a font. Taken from - the XLFD specification. */ - -enum xlfd_slant -{ - XLFD_SLANT_UNKNOWN, - XLFD_SLANT_ROMAN, - XLFD_SLANT_ITALIC, - XLFD_SLANT_OBLIQUE, - XLFD_SLANT_REVERSE_ITALIC, - XLFD_SLANT_REVERSE_OBLIQUE, - XLFD_SLANT_OTHER -}; - -/* Relative font weight according to XLFD documentation. */ - -enum xlfd_weight -{ - XLFD_WEIGHT_UNKNOWN, - XLFD_WEIGHT_ULTRA_LIGHT, /* 10 */ - XLFD_WEIGHT_EXTRA_LIGHT, /* 20 */ - XLFD_WEIGHT_LIGHT, /* 30 */ - XLFD_WEIGHT_SEMI_LIGHT, /* 40: SemiLight, Book, ... */ - XLFD_WEIGHT_MEDIUM, /* 50: Medium, Normal, Regular, ... */ - XLFD_WEIGHT_SEMI_BOLD, /* 60: SemiBold, DemiBold, ... */ - XLFD_WEIGHT_BOLD, /* 70: Bold, ... */ - XLFD_WEIGHT_EXTRA_BOLD, /* 80: ExtraBold, Heavy, ... */ - XLFD_WEIGHT_ULTRA_BOLD /* 90: UltraBold, Black, ... */ -}; - -/* Relative proportionate width. */ - -enum xlfd_swidth -{ - XLFD_SWIDTH_UNKNOWN, - XLFD_SWIDTH_ULTRA_CONDENSED, /* 10 */ - XLFD_SWIDTH_EXTRA_CONDENSED, /* 20 */ - XLFD_SWIDTH_CONDENSED, /* 30: Condensed, Narrow, Compressed, ... */ - XLFD_SWIDTH_SEMI_CONDENSED, /* 40: semicondensed */ - XLFD_SWIDTH_MEDIUM, /* 50: Medium, Normal, Regular, ... */ - XLFD_SWIDTH_SEMI_EXPANDED, /* 60: SemiExpanded, DemiExpanded, ... */ - XLFD_SWIDTH_EXPANDED, /* 70: Expanded... */ - XLFD_SWIDTH_EXTRA_EXPANDED, /* 80: ExtraExpanded, Wide... */ - XLFD_SWIDTH_ULTRA_EXPANDED /* 90: UltraExpanded... */ -}; - /* Order by which font selection chooses fonts. The default values mean `first, find a best match for the font width, then for the font height, then for weight, then for slant.' This variable can be commit e9a68b1de5a4526427a5abf43f31ec8fe4e64956 Author: Po Lu Date: Fri Nov 12 14:29:40 2021 +0800 Remove obsolete comment The comment probably dated back to when xwidgets supported many other GTK+ widgets with other data. In the current implementation of xwidgets, everything that should be freed is already freed in `kill_buffer_xwidgets'. * src/xwidget.c (kill_buffer_xwidgets): Remove outdated TODO. diff --git a/src/xwidget.c b/src/xwidget.c index 02589ae192..c1fbfedc70 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -2654,7 +2654,6 @@ kill_buffer_xwidgets (Lisp_Object buffer) xwidget = XCAR (tail); internal_xwidget_list = Fdelq (xwidget, internal_xwidget_list); Vxwidget_list = Fcopy_sequence (internal_xwidget_list); - /* TODO free the GTK things in xw. */ { CHECK_LIVE_XWIDGET (xwidget); struct xwidget *xw = XXWIDGET (xwidget); commit dae3c4e89b27fa008d029a30cf7bd02fc3fbb6e2 Author: Lars Ingebrigtsen Date: Fri Nov 12 07:19:19 2021 +0100 Allow choosing regular-weighted fonts when medium-weighted exist * src/ftfont.c (ftfont_pattern_entity): Allow using both regular and medium-weighted fonts. diff --git a/src/ftfont.c b/src/ftfont.c index 12d0d72d27..03e44ec30e 100644 --- a/src/ftfont.c +++ b/src/ftfont.c @@ -225,8 +225,6 @@ ftfont_pattern_entity (FcPattern *p, Lisp_Object extra) } if (FcPatternGetInteger (p, FC_WEIGHT, 0, &numeric) == FcResultMatch) { - if (numeric >= FC_WEIGHT_REGULAR && numeric < FC_WEIGHT_MEDIUM) - numeric = FC_WEIGHT_MEDIUM; FONT_SET_STYLE (entity, FONT_WEIGHT_INDEX, make_fixnum (numeric)); } if (FcPatternGetInteger (p, FC_SLANT, 0, &numeric) == FcResultMatch) commit fc00fe53e189df04e6325e4f19edcb0c8612600f Merge: 070d6297ca a6905e90cc Author: Stefan Kangas Date: Fri Nov 12 07:17:11 2021 +0100 Merge from origin/emacs-28 a6905e90cc Fix problem with temp buffer killing in package-install-file 144ad77fda Fix Lisp Intro markup error 24b86cb4f7 Fix ACL errors with WebDAV volumes on MS-Windows commit 070d6297ca468b197744c94df0c17fb09f47f67a Author: Po Lu Date: Fri Nov 12 14:16:31 2021 +0800 Fix doc string for xwidget-webkit-load-html * src/xwidget.c (Fxwidget_webkit_load_html): Fix doc string. diff --git a/src/xwidget.c b/src/xwidget.c index 4d0bc44a15..02589ae192 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -2325,7 +2325,7 @@ DEFUN ("xwidget-webkit-load-html", Fxwidget_webkit_load_html, doc: /* Make XWIDGET's WebKit widget render TEXT. XWIDGET should be a WebKit xwidget, that will receive TEXT. TEXT should be a string that will be displayed by XWIDGET as HTML markup. -BASE_URI should be a string containing a URI that is used to locate +BASE-URI should be a string containing a URI that is used to locate resources with relative URLs, and if not specified, defaults to "about:blank". */) (Lisp_Object xwidget, Lisp_Object text, Lisp_Object base_uri) commit ea54498f3a65cc2d2d1da93610b1a1f6eccb9b10 Author: Po Lu Date: Fri Nov 12 14:04:38 2021 +0800 Add input method support for xwidget webkit isearch * lisp/xwidget.el (xwidget-webkit-isearch--read-string-buffer): New variable. (xwidget-webkit-isearch-printing-char-with-input-method) (xwidget-webkit-isearch-with-input-method): New function. (xwidget-webkit-isearch-printing-char): Add support for Emacs input methods. (bug#51781) diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 9bb2f11f41..3d4e96f92d 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -873,6 +873,8 @@ WebKit widget." "The current search query.") (defvar-local xwidget-webkit-isearch--is-reverse nil "Whether or not the current isearch should be reverse.") +(defvar xwidget-webkit-isearch--read-string-buffer nil + "The buffer we are reading input method text for, if any.") (defun xwidget-webkit-isearch--update (&optional only-message) "Update the current buffer's WebKit widget's search query. @@ -895,13 +897,43 @@ WebKit widget. The query will be set to the contents of (- (length xwidget-webkit-isearch--string) count)))) (xwidget-webkit-isearch--update)) +(defun xwidget-webkit-isearch-with-input-method () + "Handle a request to use the input method to modify the search query." + (interactive) + (let ((key (car unread-command-events)) + events) + (setq unread-command-events (cdr unread-command-events) + events (funcall input-method-function key)) + (dolist (k events) + (with-current-buffer xwidget-webkit-isearch--read-string-buffer + (setq xwidget-webkit-isearch--string + (concat xwidget-webkit-isearch--string + (char-to-string k))))) + (exit-minibuffer))) + +(defun xwidget-webkit-isearch-printing-char-with-input-method (char) + "Handle printing char CHAR with the current input method." + (let ((minibuffer-local-map (make-keymap)) + (xwidget-webkit-isearch--read-string-buffer (current-buffer))) + (define-key minibuffer-local-map [with-input-method] + 'xwidget-webkit-isearch-with-input-method) + (setq unread-command-events + (cons 'with-input-method + (cons char unread-command-events))) + (read-string "Search contents: " + xwidget-webkit-isearch--string + 'junk-hist nil t) + (xwidget-webkit-isearch--update))) + (defun xwidget-webkit-isearch-printing-char (char &optional count) "Add ordinary character CHAR to the search string and search. With argument, add COUNT copies of CHAR." (interactive (list last-command-event (prefix-numeric-value current-prefix-arg))) - (setq xwidget-webkit-isearch--string (concat xwidget-webkit-isearch--string - (make-string (or count 1) char))) + (if current-input-method + (xwidget-webkit-isearch-printing-char-with-input-method char) + (setq xwidget-webkit-isearch--string (concat xwidget-webkit-isearch--string + (make-string (or count 1) char)))) (xwidget-webkit-isearch--update)) (defun xwidget-webkit-isearch-forward (count) @@ -958,6 +990,7 @@ With argument, add COUNT copies of CHAR." (define-key xwidget-webkit-isearch-mode-map "\C-r" 'xwidget-webkit-isearch-backward) (define-key xwidget-webkit-isearch-mode-map "\C-s" 'xwidget-webkit-isearch-forward) (define-key xwidget-webkit-isearch-mode-map "\C-y" 'xwidget-webkit-isearch-yank-kill) +(define-key xwidget-webkit-isearch-mode-map "\C-\\" 'toggle-input-method) (define-key xwidget-webkit-isearch-mode-map "\t" 'xwidget-webkit-isearch-printing-char) (let ((meta-map (make-keymap))) commit 7fdac623dd36a56787ddb181fa1d06423a36bf5e Author: Stefan Kangas Date: Fri Nov 12 05:02:27 2021 +0100 image-dired: Quote function symbols as such * lisp/image-dired.el (image-dired-thumbnail-mode-line-up-map) (image-dired-thumbnail-mode-tag-map) (image-dired-thumbnail-mode-map, image-dired-minor-mode-map): Quote function symbols as such. diff --git a/lisp/image-dired.el b/lisp/image-dired.el index d57417b25b..852ef0f103 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -1527,68 +1527,68 @@ You probably want to use this together with (defvar image-dired-thumbnail-mode-line-up-map (let ((map (make-sparse-keymap))) ;; map it to "g" so that the user can press it more quickly - (define-key map "g" 'image-dired-line-up-dynamic) + (define-key map "g" #'image-dired-line-up-dynamic) ;; "f" for "fixed" number of thumbs per row - (define-key map "f" 'image-dired-line-up) + (define-key map "f" #'image-dired-line-up) ;; "i" for "interactive" - (define-key map "i" 'image-dired-line-up-interactive) + (define-key map "i" #'image-dired-line-up-interactive) map) "Keymap for line-up commands in `image-dired-thumbnail-mode'.") (defvar image-dired-thumbnail-mode-tag-map (let ((map (make-sparse-keymap))) ;; map it to "t" so that the user can press it more quickly - (define-key map "t" 'image-dired-tag-thumbnail) + (define-key map "t" #'image-dired-tag-thumbnail) ;; "r" for "remove" - (define-key map "r" 'image-dired-tag-thumbnail-remove) + (define-key map "r" #'image-dired-tag-thumbnail-remove) map) "Keymap for tag commands in `image-dired-thumbnail-mode'.") (defvar image-dired-thumbnail-mode-map (let ((map (make-sparse-keymap))) - (define-key map [right] 'image-dired-forward-image) - (define-key map [left] 'image-dired-backward-image) - (define-key map [up] 'image-dired-previous-line) - (define-key map [down] 'image-dired-next-line) - (define-key map "\C-f" 'image-dired-forward-image) - (define-key map "\C-b" 'image-dired-backward-image) - (define-key map "\C-p" 'image-dired-previous-line) - (define-key map "\C-n" 'image-dired-next-line) + (define-key map [right] #'image-dired-forward-image) + (define-key map [left] #'image-dired-backward-image) + (define-key map [up] #'image-dired-previous-line) + (define-key map [down] #'image-dired-next-line) + (define-key map "\C-f" #'image-dired-forward-image) + (define-key map "\C-b" #'image-dired-backward-image) + (define-key map "\C-p" #'image-dired-previous-line) + (define-key map "\C-n" #'image-dired-next-line) (define-key map "<" #'image-dired-beginning-of-buffer) (define-key map ">" #'image-dired-end-of-buffer) (define-key map (kbd "M-<") #'image-dired-beginning-of-buffer) (define-key map (kbd "M->") #'image-dired-end-of-buffer) - (define-key map "d" 'image-dired-flag-thumb-original-file) - (define-key map [delete] 'image-dired-flag-thumb-original-file) - (define-key map "m" 'image-dired-mark-thumb-original-file) - (define-key map "u" 'image-dired-unmark-thumb-original-file) - (define-key map "U" 'image-dired-unmark-all-marks) - (define-key map "." 'image-dired-track-original-file) - (define-key map [tab] 'image-dired-jump-original-dired-buffer) + (define-key map "d" #'image-dired-flag-thumb-original-file) + (define-key map [delete] #'image-dired-flag-thumb-original-file) + (define-key map "m" #'image-dired-mark-thumb-original-file) + (define-key map "u" #'image-dired-unmark-thumb-original-file) + (define-key map "U" #'image-dired-unmark-all-marks) + (define-key map "." #'image-dired-track-original-file) + (define-key map [tab] #'image-dired-jump-original-dired-buffer) ;; add line-up map (define-key map "g" image-dired-thumbnail-mode-line-up-map) ;; add tag map (define-key map "t" image-dired-thumbnail-mode-tag-map) - (define-key map "\C-m" 'image-dired-display-thumbnail-original-image) - (define-key map [C-return] 'image-dired-thumbnail-display-external) + (define-key map "\C-m" #'image-dired-display-thumbnail-original-image) + (define-key map [C-return] #'image-dired-thumbnail-display-external) - (define-key map "L" 'image-dired-rotate-original-left) - (define-key map "R" 'image-dired-rotate-original-right) + (define-key map "L" #'image-dired-rotate-original-left) + (define-key map "R" #'image-dired-rotate-original-right) - (define-key map "D" 'image-dired-thumbnail-set-image-description) + (define-key map "D" #'image-dired-thumbnail-set-image-description) (define-key map "S" #'image-dired-slideshow-start) - (define-key map "\C-d" 'image-dired-delete-char) - (define-key map " " 'image-dired-display-next-thumbnail-original) - (define-key map (kbd "DEL") 'image-dired-display-previous-thumbnail-original) - (define-key map "c" 'image-dired-comment-thumbnail) + (define-key map "\C-d" #'image-dired-delete-char) + (define-key map " " #'image-dired-display-next-thumbnail-original) + (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original) + (define-key map "c" #'image-dired-comment-thumbnail) ;; Mouse - (define-key map [mouse-2] 'image-dired-mouse-display-image) - (define-key map [mouse-1] 'image-dired-mouse-select-thumbnail) + (define-key map [mouse-2] #'image-dired-mouse-display-image) + (define-key map [mouse-1] #'image-dired-mouse-select-thumbnail) (define-key map [mouse-3] #'image-dired-mouse-select-thumbnail) (define-key map [down-mouse-1] #'image-dired-mouse-select-thumbnail) (define-key map [down-mouse-2] #'image-dired-mouse-select-thumbnail) @@ -1603,8 +1603,8 @@ You probably want to use this together with ;; C-down-mouse-1 to `image-dired-mouse-toggle-mark', I get a message ;; about C-mouse-1 not being defined afterwards. Annoying, but I ;; probably do not completely understand mouse events. - (define-key map [C-down-mouse-1] 'undefined) - (define-key map [C-mouse-1] 'image-dired-mouse-toggle-mark) + (define-key map [C-down-mouse-1] #'undefined) + (define-key map [C-mouse-1] #'image-dired-mouse-toggle-mark) map) "Keymap for `image-dired-thumbnail-mode'.") @@ -1683,23 +1683,23 @@ Resized or in full-size." ;; (set-keymap-parent map dired-mode-map) ;; Hijack previous and next line movement. Let C-p and C-b be ;; though... - (define-key map "p" 'image-dired-dired-previous-line) - (define-key map "n" 'image-dired-dired-next-line) - (define-key map [up] 'image-dired-dired-previous-line) - (define-key map [down] 'image-dired-dired-next-line) - - (define-key map (kbd "C-S-n") 'image-dired-next-line-and-display) - (define-key map (kbd "C-S-p") 'image-dired-previous-line-and-display) - (define-key map (kbd "C-S-m") 'image-dired-mark-and-display-next) - - (define-key map "\C-td" 'image-dired-display-thumbs) - (define-key map [tab] 'image-dired-jump-thumbnail-buffer) - (define-key map "\C-ti" 'image-dired-dired-display-image) - (define-key map "\C-tx" 'image-dired-dired-display-external) - (define-key map "\C-ta" 'image-dired-display-thumbs-append) - (define-key map "\C-t." 'image-dired-display-thumb) - (define-key map "\C-tc" 'image-dired-dired-comment-files) - (define-key map "\C-tf" 'image-dired-mark-tagged-files) + (define-key map "p" #'image-dired-dired-previous-line) + (define-key map "n" #'image-dired-dired-next-line) + (define-key map [up] #'image-dired-dired-previous-line) + (define-key map [down] #'image-dired-dired-next-line) + + (define-key map (kbd "C-S-n") #'image-dired-next-line-and-display) + (define-key map (kbd "C-S-p") #'image-dired-previous-line-and-display) + (define-key map (kbd "C-S-m") #'image-dired-mark-and-display-next) + + (define-key map "\C-td" #'image-dired-display-thumbs) + (define-key map [tab] #'image-dired-jump-thumbnail-buffer) + (define-key map "\C-ti" #'image-dired-dired-display-image) + (define-key map "\C-tx" #'image-dired-dired-display-external) + (define-key map "\C-ta" #'image-dired-display-thumbs-append) + (define-key map "\C-t." #'image-dired-display-thumb) + (define-key map "\C-tc" #'image-dired-dired-comment-files) + (define-key map "\C-tf" #'image-dired-mark-tagged-files) map) "Keymap for `image-dired-minor-mode'.") commit a6905e90cc3358a21726646c4ee9154e80fc96d6 Author: Lars Ingebrigtsen Date: Fri Nov 12 04:44:09 2021 +0100 Fix problem with temp buffer killing in package-install-file * lisp/emacs-lisp/package.el (package-install-file): Allow killing the temporary buffer without querying (bug#51769). diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 5445fa970f..2c37e19980 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2239,6 +2239,7 @@ directory." (dired-mode)) (insert-file-contents-literally file) (set-visited-file-name file) + (set-buffer-modified-p nil) (when (string-match "\\.tar\\'" file) (tar-mode))) (package-install-from-buffer))) commit 144ad77fdadd41888c9a715e25c2bc7c57753f74 Author: Lars Ingebrigtsen Date: Fri Nov 12 04:39:02 2021 +0100 Fix Lisp Intro markup error * doc/lispintro/emacs-lisp-intro.texi (Insert let): Fix @code markup error (bug#51777). diff --git a/doc/lispintro/emacs-lisp-intro.texi b/doc/lispintro/emacs-lisp-intro.texi index 308153f923..e306458058 100644 --- a/doc/lispintro/emacs-lisp-intro.texi +++ b/doc/lispintro/emacs-lisp-intro.texi @@ -5801,7 +5801,7 @@ written like this: @subsection The @code{let} Expression in @code{insert-buffer} After ensuring that the variable @code{buffer} refers to a buffer itself -and not just to the name of a buffer, the @code{insert-buffer function} +and not just to the name of a buffer, the @code{insert-buffer} function continues with a @code{let} expression. This specifies three local variables, @code{start}, @code{end}, and @code{newmark} and binds them to the initial value @code{nil}. These variables are used inside the commit 2d9e75088165672a7db5b5e67fbc3ebf17e08bb7 Author: Lars Ingebrigtsen Date: Fri Nov 12 04:31:33 2021 +0100 Move Info-goto-node-web to "G" * lisp/info.el (Info-mode-map): Change the Info-goto-node-web binding to "G" for symmetry with "Info-goto-node". diff --git a/etc/NEWS b/etc/NEWS index 5439964891..0057fbdcbf 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -213,7 +213,7 @@ change the terminal used on a remote host. ** Info --- -*** New command 'Info-goto-node-web' and key binding 'W'. +*** New command 'Info-goto-node-web' and key binding 'G'. This will take you to the gnu.org web server's version of the current info node. This command only works for the Emacs and Emacs Lisp manuals. diff --git a/lisp/info.el b/lisp/info.el index 28f25d0e0d..cd4c867f4e 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -4086,6 +4086,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'." (define-key map "e" 'end-of-buffer) (define-key map "f" 'Info-follow-reference) (define-key map "g" 'Info-goto-node) + (define-key map "G" 'Info-goto-node-web) (define-key map "h" 'Info-help) ;; This is for compatibility with standalone info (>~ version 5.2). ;; Though for some time, standalone info had H and h reversed. @@ -4107,7 +4108,6 @@ If FORK is non-nil, it is passed to `Info-goto-node'." (define-key map "T" 'Info-toc) (define-key map "u" 'Info-up) ;; `w' for consistency with `dired-copy-filename-as-kill'. - (define-key map "W" 'Info-goto-node-web) (define-key map "w" 'Info-copy-current-node-name) (define-key map "c" 'Info-copy-current-node-name) ;; `^' for consistency with `dired-up-directory'. commit c9914ba01b7c29f0ee5a2191f7c8a6577366b000 Author: Stefan Kangas Date: Fri Nov 12 04:27:11 2021 +0100 Make image-dired-thumbnail-mode non-interactive * lisp/image-dired.el (image-dired-thumbnail-mode): No longer interactive, as it only makes sense in a specially prepared buffer. diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 8e5a6d898c..d57417b25b 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -1660,6 +1660,7 @@ You probably want to use this together with special-mode "image-dired-thumbnail" "Browse and manipulate thumbnail images using Dired. Use `image-dired-minor-mode' to get a nice setup." + :interactive nil (buffer-disable-undo) (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t) (setq-local window-resize-pixelwise t) commit 1d95cef0feeb8276abda379d978aa4d40c4cddde Author: Stefan Kangas Date: Fri Nov 12 04:10:40 2021 +0100 image-dired: Revamp slideshow functionality * lisp/image-dired.el (image-dired-slideshow-delay): New defcustom. (image-dired--slideshow-initial): New defvar. (image-dired-slideshow-start): Don't show any prompts when starting a slideshow, unless user gave a negative prefix argument. Use the value of the above new defcustom as the default delay. (image-dired-slideshow-stop): Don't count number of images. Instead, continue the slideshow until the next command. (image-dired-slideshow-step): Use the correct buffer. (image-dired-slideshow-count, image-dired-slideshow-times): Make obsolete. (image-dired--slideshow-timer): Rename from 'image-dired-slideshow-timer'. Make the old name into an obsolete variable alias. (image-dired-display-image-mode-map) (image-dired-thumbnail-mode-map): Bind 'image-dired-slideshow-start' to "S". (image-dired-thumbnail-mode-menu): Add 'image-dired-slideshow-start'. diff --git a/etc/NEWS b/etc/NEWS index 4ec7743611..5439964891 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -425,6 +425,15 @@ If 'image-dired-thumb-mark' is non-nil (the default), this face is used for images that are flagged for deletion in the Dired buffer associated with Image-Dired. +--- +*** The 'image-dired-slideshow-start' command has been revamped. +It no longer inconveniently prompts for a number of images and a +delay: it runs indefinitely, but stops automatically on any command. +You can set the delay with a prefix argument, or a negative prefix +argument to prompt anyways. Customize the user option +'image-dired-slideshow-delay' to change the default, which is 5 +seconds. It is bound to 'S' in the thumbnail and display buffer. + --- *** Support for bookmark.el. The command 'bookmark-set' (bound to 'C-x r m') is now supported in diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 4015f42c6b..8e5a6d898c 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -1580,6 +1580,7 @@ You probably want to use this together with (define-key map "R" 'image-dired-rotate-original-right) (define-key map "D" 'image-dired-thumbnail-set-image-description) + (define-key map "S" #'image-dired-slideshow-start) (define-key map "\C-d" 'image-dired-delete-char) (define-key map " " 'image-dired-display-next-thumbnail-original) (define-key map (kbd "DEL") 'image-dired-display-previous-thumbnail-original) @@ -1627,6 +1628,7 @@ You probably want to use this together with ["Tag current or marked thumbnails" image-dired-tag-thumbnail] ["Remove tag from current or marked thumbnails" image-dired-tag-thumbnail-remove] + ["Start slideshow" image-dired-slideshow-start] "---" ("View Options" ["Toggle movement tracking" image-dired-toggle-movement-tracking @@ -1640,6 +1642,7 @@ You probably want to use this together with (defvar image-dired-display-image-mode-map (let ((map (make-sparse-keymap))) + (define-key map "S" #'image-dired-slideshow-start) ;; Disable keybindings from `image-mode-map' that doesn't make sense here. (define-key map "o" nil) ; image-save (define-key map "n" nil) ; image-next-file @@ -1755,44 +1758,60 @@ With prefix argument ARG, create thumbnails even if they already exist (image-dired-create-thumb curr-file thumb-name))))) -;;; Slideshow. +;;; Slideshow -(defvar image-dired-slideshow-timer nil - "Slideshow timer.") +(defcustom image-dired-slideshow-delay 5.0 + "Seconds to wait before showing the next image in a slideshow. +This is used by `image-dired-slideshow-start'." + :type 'float + :version "29.1") -(defvar image-dired-slideshow-count 0 - "Keeping track on number of images in slideshow.") +(define-obsolete-variable-alias 'image-dired-slideshow-timer + 'image-dired--slideshow-timer "29.1") +(defvar image-dired--slideshow-timer nil + "Slideshow timer.") -(defvar image-dired-slideshow-times 0 - "Number of pictures to display in slideshow.") +(defvar image-dired--slideshow-initial nil) (defun image-dired-slideshow-step () - "Step to next file, if `image-dired-slideshow-times' has not been reached." - (if (< image-dired-slideshow-count image-dired-slideshow-times) - (progn - (message "%s" (1+ image-dired-slideshow-count)) - (setq image-dired-slideshow-count (1+ image-dired-slideshow-count)) - (image-dired-next-line-and-display)) + "Step to next image in a slideshow." + (if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + (with-current-buffer buf + (image-dired-display-next-thumbnail-original)) (image-dired-slideshow-stop))) -(defun image-dired-slideshow-start () - "Start slideshow. -Ask user for number of images to show and the delay in between." - (interactive) - (setq image-dired-slideshow-count 0) - (setq image-dired-slideshow-times (string-to-number (read-string "How many: "))) - (let ((repeat (string-to-number - (read-string - "Delay, in seconds. Decimals are accepted : " "1")))) - (setq image-dired-slideshow-timer +(defun image-dired-slideshow-start (&optional arg) + "Start a slideshow. +Wait `image-dired-slideshow-delay' seconds before showing the +next image. + +With prefix argument ARG, wait that many seconds before going to +the next image. + +With a negative prefix argument, prompt user for the delay." + (interactive "P" image-dired-thumbnail-mode image-dired-display-image-mode) + (let ((delay (if (> arg 0) + arg + (string-to-number + (read-string + (let ((delay (number-to-string image-dired-slideshow-delay))) + (format-prompt "Delay, in seconds. Decimals are accepted" delay) delay)))))) + (setq image-dired--slideshow-timer (run-with-timer - 0 repeat - 'image-dired-slideshow-step)))) + 0 delay + 'image-dired-slideshow-step)) + (add-hook 'post-command-hook 'image-dired-slideshow-stop) + (setq image-dired--slideshow-initial t) + (message "Running slideshow; use any command to stop"))) (defun image-dired-slideshow-stop () "Cancel slideshow." - (interactive) - (cancel-timer image-dired-slideshow-timer)) + ;; Make sure we don't immediately stop after + ;; `image-dired-slideshow-start'. + (unless image-dired--slideshow-initial + (remove-hook 'post-command-hook 'image-dired-slideshow-stop) + (cancel-timer image-dired--slideshow-timer)) + (setq image-dired--slideshow-initial nil)) ;;; Thumbnail mode (cont. 3) @@ -2975,6 +2994,14 @@ Dired." (cons (list tag file) (cdr image-dired-tag-file-list)))) (setq image-dired-tag-file-list (list (list tag file)))))) +(defvar image-dired-slideshow-count 0 + "Keeping track on number of images in slideshow.") +(make-obsolete-variable 'image-dired-slideshow-count "no longer used." "29.1") + +(defvar image-dired-slideshow-times 0 + "Number of pictures to display in slideshow.") +(make-obsolete-variable 'image-dired-slideshow-times "no longer used." "29.1") + (define-obsolete-function-alias 'image-dired-create-display-image-buffer #'ignore "29.1") (define-obsolete-function-alias 'image-dired-create-gallery-lists commit 9ea7e7c4d4867422e4d4f94c764d529b96140f5d Author: Stefan Kangas Date: Fri Nov 12 03:51:21 2021 +0100 image-dired: Improve thumbnail mode menu * lisp/image-dired.el (image-dired-thumbnail-mode-menu): Improve menu with more logical ordering and better naming. diff --git a/lisp/image-dired.el b/lisp/image-dired.el index a2c37f00f2..4015f42c6b 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -1612,33 +1612,30 @@ You probably want to use this together with '("Image-Dired" ["Display image" image-dired-display-thumbnail-original-image] ["Display in external viewer" image-dired-thumbnail-display-external] + ["Jump to Dired buffer" image-dired-jump-original-dired-buffer] "---" - ["Mark original" image-dired-mark-thumb-original-file] - ["Unmark original" image-dired-unmark-thumb-original-file] - ["Flag original for deletion" image-dired-flag-thumb-original-file] - "---" - ["Track original" image-dired-track-original-file] - ["Jump to dired buffer" image-dired-jump-original-dired-buffer] - ["Toggle movement tracking on/off" image-dired-toggle-movement-tracking - :style toggle - :selected image-dired-track-movement] + ["Mark image" image-dired-mark-thumb-original-file] + ["Unmark image" image-dired-unmark-thumb-original-file] + ["Unmark all images" image-dired-unmark-all-marks] + ["Flag for deletion" image-dired-flag-thumb-original-file] + ["Delete marked images" image-dired-delete-marked] "---" ["Rotate original right" image-dired-rotate-original-right] ["Rotate original left" image-dired-rotate-original-left] "---" - ["Line up thumbnails" image-dired-line-up] - ["Dynamic line up" image-dired-line-up-dynamic] - ["Refresh thumb" image-dired-refresh-thumb] - "---" ["Comment thumbnail" image-dired-comment-thumbnail] ["Tag current or marked thumbnails" image-dired-tag-thumbnail] - "---" ["Remove tag from current or marked thumbnails" image-dired-tag-thumbnail-remove] - ["Unmark all marks" image-dired-unmark-all-marks] - ["Delete marked images" image-dired-delete-marked] - ["Delete thumbnail from buffer" image-dired-delete-char] "---" + ("View Options" + ["Toggle movement tracking" image-dired-toggle-movement-tracking + :style toggle + :selected image-dired-track-movement] + "---" + ["Line up thumbnails" image-dired-line-up] + ["Dynamic line up" image-dired-line-up-dynamic] + ["Refresh thumb" image-dired-refresh-thumb]) ["Quit" quit-window])) (defvar image-dired-display-image-mode-map commit 31279f92ae35f651d68104846268d64dadc6a943 Author: Bryan C. Mills Date: Fri Nov 12 04:26:28 2021 +0100 Make "emacs --script /dev/stdin work again when that's a pipe * src/lread.c (Fload): Adjust callers. * src/lread.c (safe_to_load_version): Check lseek errors (Bug#48940). Copyright-paperwork-exempt: yes diff --git a/src/lread.c b/src/lread.c index b3f9e6ff52..39cab19fc0 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1045,12 +1045,18 @@ lisp_file_lexically_bound_p (Lisp_Object readcharfun) safe to load. Only files compiled with Emacs can be loaded. */ static int -safe_to_load_version (int fd) +safe_to_load_version (Lisp_Object file, int fd) { + struct stat st; char buf[512]; int nbytes, i; int version = 1; + /* If the file is not regular, then we cannot safely seek it. + Assume that it is not safe to load as a compiled file. */ + if (fstat(fd, &st) == 0 && !S_ISREG (st.st_mode)) + return 0; + /* Read the first few bytes from the file, and look for a line specifying the byte compiler version used. */ nbytes = emacs_read_quit (fd, buf, sizeof buf); @@ -1068,7 +1074,9 @@ safe_to_load_version (int fd) version = 0; } - lseek (fd, 0, SEEK_SET); + if (lseek (fd, 0, SEEK_SET) < 0) + report_file_error ("Seeking to start of file", file); + return version; } @@ -1401,7 +1409,7 @@ Return t if the file exists and loads successfully. */) if (is_elc /* version = 1 means the file is empty, in which case we can treat it as not byte-compiled. */ - || (fd >= 0 && (version = safe_to_load_version (fd)) > 1)) + || (fd >= 0 && (version = safe_to_load_version (file, fd)) > 1)) /* Load .elc files directly, but not when they are remote and have no handler! */ { @@ -1411,7 +1419,7 @@ Return t if the file exists and loads successfully. */) int result; if (version < 0 - && ! (version = safe_to_load_version (fd))) + && ! (version = safe_to_load_version (file, fd))) { error ("File `%s' was not compiled in Emacs", SDATA (found)); } commit cd35c1c7cfc4823caf497af8eb0e840b4324dc97 Author: Lars Ingebrigtsen Date: Fri Nov 12 04:21:56 2021 +0100 Allow using /dev/stdin as a --script parameter again * lisp/startup.el (command-line-1): Fix breakage with (file-truename "/dev/stdin") => "/proc/227795/fd/pipe:[1381505]" when using /dev/stdin as a --script parameter. diff --git a/lisp/startup.el b/lisp/startup.el index 505d7b83f4..a911aed1cd 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -2526,7 +2526,15 @@ nil default-directory" name) (let* ((file (command-line-normalize-file-name (or argval (pop command-line-args-left)))) ;; Take file from default dir. - (file-ex (file-truename (expand-file-name file)))) + (file-ex (expand-file-name file)) + (truename (file-truename file-ex))) + ;; We want to use the truename here if we can, + ;; because that makes `eval-after-load' work + ;; more reliably. But If the file is, for + ;; instance, /dev/stdin, the truename doesn't + ;; actually exist on some systems. + (when (file-exists-p truename) + (setq file-ex truename)) (load file-ex nil t t))) ((equal argi "-insert") commit df2438d3695e065d4037e1c26a0c769c373f914c Author: Po Lu Date: Fri Nov 12 11:19:30 2021 +0800 Fix potential NULL dereference in xwidget-webkit-uri * src/xwidget.c (Fxwidget_webkit_uri): Don't assume webkit_web_view_get_uri will always return a valid string. diff --git a/src/xwidget.c b/src/xwidget.c index 7d5c49233c..4d0bc44a15 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -1725,7 +1725,10 @@ DEFUN ("xwidget-webkit-uri", WEBKIT_FN_INIT (); #ifdef USE_GTK WebKitWebView *wkwv = WEBKIT_WEB_VIEW (xw->widget_osr); - return build_string (webkit_web_view_get_uri (wkwv)); + const gchar *uri = webkit_web_view_get_uri (wkwv); + if (!uri) + return build_string (""); + return build_string (uri); #elif defined NS_IMPL_COCOA return nsxwidget_webkit_uri (xw); #endif commit 372824a8bf303421eaeff5b1cb8c289a3efa86b3 Author: Po Lu Date: Fri Nov 12 10:36:57 2021 +0800 Check for WebKit xwidgets inside all xwidget-webkit functions This is done in preparation for the introduction of other xwidgets, such as media xwidgets, even though there are only WebKit widgets at present. * src/xwidget.c (CHECK_WEBKIT_XWIDGET): New macro. (WEBKIT_FN_INIT): Use CHECK_WEBKIT_XWIDGET. (Fxwidget_webkit_search, Fxwidget_webkit_next_result) (Fxwidget_webkit_previous_result) (Fxwidget_webkit_finish_search) (Fxwidget_webkit_load_html): Check that xwidget is a WebKit widget. diff --git a/src/xwidget.c b/src/xwidget.c index 70e5769255..7d5c49233c 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -1706,26 +1706,15 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) #endif } -static bool -xwidget_is_web_view (struct xwidget *xw) -{ -#ifdef USE_GTK - return xw->widget_osr != NULL && WEBKIT_IS_WEB_VIEW (xw->widget_osr); -#elif defined NS_IMPL_COCOA - return nsxwidget_is_web_view (xw); -#endif -} +#define CHECK_WEBKIT_WIDGET(xw) \ + if (NILP (xw->buffer) || !EQ (xw->type, Qwebkit)) \ + error ("Not a WebKit widget") /* Macro that checks xwidget hold webkit web view first. */ #define WEBKIT_FN_INIT() \ CHECK_LIVE_XWIDGET (xwidget); \ struct xwidget *xw = XXWIDGET (xwidget); \ - if (!xwidget_is_web_view (xw)) \ - { \ - fputs ("ERROR xw->widget_osr does not hold a webkit instance\n", \ - stdout); \ - return Qnil; \ - } + CHECK_WEBKIT_WIDGET (xw) DEFUN ("xwidget-webkit-uri", Fxwidget_webkit_uri, Sxwidget_webkit_uri, @@ -2195,6 +2184,8 @@ with QUERY. */) #ifdef USE_GTK xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); + webview = WEBKIT_WEB_VIEW (xw->widget_osr); query = ENCODE_UTF_8 (query); opt = WEBKIT_FIND_OPTIONS_NONE; @@ -2237,6 +2228,7 @@ using `xwidget-webkit-search'. */) CHECK_LIVE_XWIDGET (xwidget); xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); if (!xw->find_text) error ("Widget has no ongoing search operation"); @@ -2269,6 +2261,7 @@ using `xwidget-webkit-search'. */) CHECK_LIVE_XWIDGET (xwidget); xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); if (!xw->find_text) error ("Widget has no ongoing search operation"); @@ -2301,6 +2294,7 @@ using `xwidget-webkit-search'. */) CHECK_LIVE_XWIDGET (xwidget); xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); if (!xw->find_text) error ("Widget has no ongoing search operation"); @@ -2347,6 +2341,7 @@ to "about:blank". */) base_uri = ENCODE_UTF_8 (base_uri); text = ENCODE_UTF_8 (text); xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); data = SSDATA (text); uri = SSDATA (base_uri); commit 71bf21f58b0579984d4420a6338dcf3508b26510 Author: Lars Ingebrigtsen Date: Fri Nov 12 03:31:48 2021 +0100 Fix image-animate declaration * lisp/net/shr.el (image-animate): Fix declaration. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 19d324b16f..fd7469389a 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1137,7 +1137,7 @@ the mouse click event." ;; Behind display-graphic-p test. (declare-function image-size "image.c" (spec &optional pixels frame)) -(declare-function image-animate "image" (image &optional index limit)) +(declare-function image-animate "image" (image &optional index limit position)) (defun shr-put-image (spec alt &optional flags) "Insert image SPEC with a string ALT. Return image. commit 35e3d002d6cae1d1b7fc620b5748ac656cca23e4 Author: Lars Ingebrigtsen Date: Fri Nov 12 03:29:51 2021 +0100 Make gnus-article-stop-animations obsolete * lisp/gnus/gnus-art.el (gnus-article-stop-animations): Make obsolete now that animated images stop themselves automatically. (gnus-article-setup-buffer): * lisp/gnus/gnus-sum.el (gnus-summary-exit) (gnus-summary-exit-no-update, gnus-summary-show-article): Remove callers. diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 89b4a63ad9..78ce89dde3 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -4579,7 +4579,6 @@ commands: (let ((summary gnus-summary-buffer)) (with-current-buffer name (setq-local gnus-article-edit-mode nil) - (gnus-article-stop-animations) (when gnus-article-mime-handles (mm-destroy-parts gnus-article-mime-handles) (setq gnus-article-mime-handles nil)) @@ -4605,6 +4604,7 @@ commands: (current-buffer)))))) (defun gnus-article-stop-animations () + (declare (obsolete nil "29.1")) (cancel-function-timers 'image-animate-timeout)) (defun gnus-stop-downloads () diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 3beeace897..f06661209b 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -7206,7 +7206,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-dribble-save))) (declare-function gnus-cache-write-active "gnus-cache" (&optional force)) -(declare-function gnus-article-stop-animations "gnus-art" ()) (defun gnus-summary-exit (&optional temporary leave-hidden) "Exit reading current newsgroup, and then return to group selection mode. @@ -7270,7 +7269,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (not (string= group (gnus-group-group-name)))) (gnus-group-next-unread-group 1)) (setq group-point (point)) - (gnus-article-stop-animations) (unless leave-hidden (gnus-configure-windows 'group 'force)) (if temporary @@ -7330,7 +7328,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (run-hooks 'gnus-summary-prepare-exit-hook) (when (gnus-buffer-live-p gnus-article-buffer) (with-current-buffer gnus-article-buffer - (gnus-article-stop-animations) (gnus-stop-downloads) (mm-destroy-parts gnus-article-mime-handles) ;; Set it to nil for safety reason. @@ -7362,7 +7359,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-group-update-group group nil t)) (when (gnus-group-goto-group group) (gnus-group-next-unread-group 1)) - (gnus-article-stop-animations) (when quit-config (gnus-handle-ephemeral-exit quit-config))))) @@ -9908,7 +9904,6 @@ article. Normally, the keystroke is `\\[universal-argument] \\[gnus-summary-sho ;; Destroy any MIME parts. (when (gnus-buffer-live-p gnus-article-buffer) (with-current-buffer gnus-article-buffer - (gnus-article-stop-animations) (gnus-stop-downloads) (mm-destroy-parts gnus-article-mime-handles) ;; Set it to nil for safety reason. commit a204b29d5ba01f382203686929fa367a9baa58d5 Author: Lars Ingebrigtsen Date: Fri Nov 12 03:27:23 2021 +0100 Allow stopping animations automatically when the image disappears * lisp/image.el (image-animate): Allow the animation to be stopped automatically when the image is removed from the buffer. (image-animate-timeout): Stop the animation if the image is removed (and that has been requested). * lisp/net/shr.el (shr-put-image): Stop animations if the image is removed. diff --git a/lisp/image.el b/lisp/image.el index a149caa1a9..edbf6c54df 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -836,15 +836,18 @@ in which case you might want to use `image-default-frame-delay'." (make-obsolete 'image-animated-p 'image-multi-frame-p "24.4") -;; "Destructively"? -(defun image-animate (image &optional index limit) +(defun image-animate (image &optional index limit position) "Start animating IMAGE. Animation occurs by destructively altering the IMAGE spec list. With optional INDEX, begin animating from that animation frame. LIMIT specifies how long to animate the image. If omitted or nil, play the animation until the end. If t, loop forever. If a -number, play until that number of seconds has elapsed." +number, play until that number of seconds has elapsed. + +If POSITION (which should be buffer position where the image is +displayed), stop the animation if the image is no longer +displayed." (let ((animation (image-multi-frame-p image)) timer) (when animation @@ -852,6 +855,9 @@ number, play until that number of seconds has elapsed." (cancel-timer timer)) (plist-put (cdr image) :animate-buffer (current-buffer)) (plist-put (cdr image) :animate-tardiness 0) + (when position + (plist-put (cdr image) :animate-position + (set-marker (make-marker) position (current-buffer)))) ;; Stash the data about the animation here so that we don't ;; trigger image recomputation unnecessarily later. (plist-put (cdr image) :animate-multi-frame-data animation) @@ -925,40 +931,54 @@ for the animation speed. A negative value means to animate in reverse." (plist-put (cdr image) :animate-tardiness (+ (* (plist-get (cdr image) :animate-tardiness) 0.9) (float-time (time-since target-time)))) - (when (and (buffer-live-p (plist-get (cdr image) :animate-buffer)) - ;; Cumulatively delayed two seconds more than expected. - (or (< (plist-get (cdr image) :animate-tardiness) 2) - (progn - (message "Stopping animation; animation possibly too big") - nil))) - (image-show-frame image n t) - (let* ((speed (image-animate-get-speed image)) - (time (current-time)) - (time-to-load-image (time-since time)) - (stated-delay-time - (/ (or (cdr (plist-get (cdr image) :animate-multi-frame-data)) - image-default-frame-delay) - (float (abs speed)))) - ;; Subtract off the time we took to load the image from the - ;; stated delay time. - (delay (max (float-time (time-subtract stated-delay-time - time-to-load-image)) - image-minimum-frame-delay)) - done) - (setq n (if (< speed 0) - (1- n) - (1+ n))) - (if limit - (cond ((>= n count) (setq n 0)) - ((< n 0) (setq n (1- count)))) - (and (or (>= n count) (< n 0)) (setq done t))) - (setq time-elapsed (+ delay time-elapsed)) - (if (numberp limit) - (setq done (>= time-elapsed limit))) - (unless done - (run-with-timer delay nil #'image-animate-timeout - image n count time-elapsed limit - (+ (float-time) delay)))))) + (let ((buffer (plist-get (cdr image) :animate-buffer)) + (position (plist-get (cdr image) :animate-position))) + (when (and (buffer-live-p buffer) + ;; If we have a :animate-position setting, the caller + ;; has requested that the animation be stopped if the + ;; image is no longer displayed in the buffer. + (or (null position) + (with-current-buffer buffer + (let ((disp (get-text-property position 'display))) + (and (consp disp) + (eq (car disp) 'image) + ;; We can't check `eq'-ness of the image + ;; itself, since that may change. + (eq position + (plist-get (cdr disp) :animate-position)))))) + ;; Cumulatively delayed two seconds more than expected. + (or (< (plist-get (cdr image) :animate-tardiness) 2) + (progn + (message "Stopping animation; animation possibly too big") + nil))) + (image-show-frame image n t) + (let* ((speed (image-animate-get-speed image)) + (time (current-time)) + (time-to-load-image (time-since time)) + (stated-delay-time + (/ (or (cdr (plist-get (cdr image) :animate-multi-frame-data)) + image-default-frame-delay) + (float (abs speed)))) + ;; Subtract off the time we took to load the image from the + ;; stated delay time. + (delay (max (float-time (time-subtract stated-delay-time + time-to-load-image)) + image-minimum-frame-delay)) + done) + (setq n (if (< speed 0) + (1- n) + (1+ n))) + (if limit + (cond ((>= n count) (setq n 0)) + ((< n 0) (setq n (1- count)))) + (and (or (>= n count) (< n 0)) (setq done t))) + (setq time-elapsed (+ delay time-elapsed)) + (if (numberp limit) + (setq done (>= time-elapsed limit))) + (unless done + (run-with-timer delay nil #'image-animate-timeout + image n count time-elapsed limit + (+ (float-time) delay))))))) (defvar imagemagick-types-inhibit) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 71c18ff994..19d324b16f 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1174,13 +1174,14 @@ element is the data blob and the second element is the content-type." (when (and (> (current-column) 0) (> (car (image-size image t)) 400)) (insert "\n")) - (if (eq size 'original) - (insert-sliced-image image (or alt "*") nil 20 1) - (insert-image image (or alt "*"))) - (put-text-property start (point) 'image-size size) - (when (and shr-image-animate - (cdr (image-multi-frame-p image))) - (image-animate image nil 60))) + (let ((image-pos (point))) + (if (eq size 'original) + (insert-sliced-image image (or alt "*") nil 20 1) + (insert-image image (or alt "*"))) + (put-text-property start (point) 'image-size size) + (when (and shr-image-animate + (cdr (image-multi-frame-p image))) + (image-animate image nil 60 image-pos)))) image) (insert (or alt "")))) commit fe0f7bddb648a75d1db4ea574536a207ea881712 Author: Po Lu Date: Fri Nov 12 09:53:30 2021 +0800 Prevent crashes from Lisp code modifying xwidget-list * src/xwidget.c (internal_xwidget_view_list) (internal_xwidget_list): New variable. (find_xwidget_for_offscreen_window) (define_cursors, offscreen_damage_event) (webkit_ready_to_show, xwidget_init_view) (Fxwidget_resize, Fdelete_xwidget_view) (Fxwidget_view_lookup, xwidget_spec_value) (lookup_xwidget, xwidget_end_redisplay) (kill_frame_xwidget_views, kill_buffer_xwidgets) (Fmake_xwidget, Fget_buffer_xwidgets): Use internal list. (syms_of_xwidget): Initialize internal xwidget lists. diff --git a/src/xwidget.c b/src/xwidget.c index d0cc3b987c..70e5769255 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -43,6 +43,8 @@ along with GNU Emacs. If not, see . */ #endif static Lisp_Object id_to_xwidget_map; +static Lisp_Object internal_xwidget_view_list; +static Lisp_Object internal_xwidget_list; static uint32_t xwidget_counter = 0; #ifdef USE_GTK @@ -144,7 +146,8 @@ fails. */) xw->width = XFIXNAT (width); xw->kill_without_query = false; XSETXWIDGET (val, xw); - Vxwidget_list = Fcons (val, Vxwidget_list); + internal_xwidget_list = Fcons (val, internal_xwidget_list); + Vxwidget_list = Fcopy_sequence (internal_xwidget_list); xw->plist = Qnil; xw->xwidget_id = ++xwidget_counter; xw->find_text = NULL; @@ -448,7 +451,7 @@ BUFFER may be a buffer or the name of one. */) xw_list = Qnil; - for (tail = Vxwidget_list; CONSP (tail); tail = XCDR (tail)) + for (tail = internal_xwidget_list; CONSP (tail); tail = XCDR (tail)) { xw = XCAR (tail); if (XWIDGETP (xw) && EQ (Fxwidget_buffer (xw), buffer)) @@ -498,7 +501,7 @@ find_xwidget_for_offscreen_window (GdkWindow *window) struct xwidget *xw; GdkWindow *w; - for (tem = Vxwidget_list; CONSP (tem); tem = XCDR (tem)) + for (tem = internal_xwidget_list; CONSP (tem); tem = XCDR (tem)) { if (XWIDGETP (XCAR (tem))) { @@ -750,7 +753,7 @@ define_cursors (struct xwidget *xw, WebKitHitTestResult *res) xw->hit_result = webkit_hit_test_result_get_context (res); - for (Lisp_Object tem = Vxwidget_view_list; CONSP (tem); + for (Lisp_Object tem = internal_xwidget_view_list; CONSP (tem); tem = XCDR (tem)) { if (XWIDGET_VIEW_P (XCAR (tem))) @@ -1020,7 +1023,7 @@ offscreen_damage_event (GtkWidget *widget, GdkEvent *event, { block_input (); - for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail); + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); tail = XCDR (tail)) { if (XWIDGET_VIEW_P (XCAR (tail))) @@ -1118,7 +1121,7 @@ webkit_ready_to_show (WebKitWebView *new_view, Lisp_Object tem; struct xwidget *xw; - for (tem = Vxwidget_list; CONSP (tem); tem = XCDR (tem)) + for (tem = internal_xwidget_list; CONSP (tem); tem = XCDR (tem)) { if (XWIDGETP (XCAR (tem))) { @@ -1485,7 +1488,8 @@ xwidget_init_view (struct xwidget *xww, Lisp_Object val; XSETXWIDGET_VIEW (val, xv); - Vxwidget_view_list = Fcons (val, Vxwidget_view_list); + internal_xwidget_view_list = Fcons (val, internal_xwidget_view_list); + Vxwidget_view_list = Fcopy_sequence (internal_xwidget_view_list); XSETWINDOW (xv->w, s->w); XSETXWIDGET (xv->model, xww); @@ -1916,7 +1920,8 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, nsxwidget_resize (xw); #endif - for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail); tail = XCDR (tail)) + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); + tail = XCDR (tail)) { if (XWIDGET_VIEW_P (XCAR (tail))) { @@ -2055,7 +2060,8 @@ DEFUN ("delete-xwidget-view", nsxwidget_delete_view (xv); #endif - Vxwidget_view_list = Fdelq (xwidget_view, Vxwidget_view_list); + internal_xwidget_view_list = Fdelq (xwidget_view, internal_xwidget_view_list); + Vxwidget_view_list = Fcopy_sequence (internal_xwidget_view_list); return Qnil; } @@ -2073,7 +2079,7 @@ Return nil if no association is found. */) window = Fselected_window (); CHECK_WINDOW (window); - for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail); + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); tail = XCDR (tail)) { Lisp_Object xwidget_view = XCAR (tail); @@ -2423,6 +2429,11 @@ syms_of_xwidget (void) QCweakness, Qvalue); staticpro (&id_to_xwidget_map); + internal_xwidget_list = Qnil; + staticpro (&internal_xwidget_list); + internal_xwidget_view_list = Qnil; + staticpro (&internal_xwidget_view_list); + #ifdef USE_GTK x_window_to_xwv_map = CALLN (Fmake_hash_table, QCtest, Qeq); @@ -2468,7 +2479,7 @@ void xwidget_view_delete_all_in_window (struct window *w) { struct xwidget_view *xv = NULL; - for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail); + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); tail = XCDR (tail)) { if (XWIDGET_VIEW_P (XCAR (tail))) @@ -2513,7 +2524,7 @@ lookup_xwidget (Lisp_Object spec) static void xwidget_start_redisplay (void) { - for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail); + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); tail = XCDR (tail)) { if (XWIDGET_VIEW_P (XCAR (tail))) @@ -2584,7 +2595,7 @@ xwidget_end_redisplay (struct window *w, struct glyph_matrix *matrix) } } - for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail); + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); tail = XCDR (tail)) { if (XWIDGET_VIEW_P (XCAR (tail))) @@ -2622,7 +2633,7 @@ kill_frame_xwidget_views (struct frame *f) { Lisp_Object rem = Qnil; - for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail); + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); tail = XCDR (tail)) { if (XWIDGET_VIEW_P (XCAR (tail)) @@ -2643,7 +2654,8 @@ kill_buffer_xwidgets (Lisp_Object buffer) for (tail = Fget_buffer_xwidgets (buffer); CONSP (tail); tail = XCDR (tail)) { xwidget = XCAR (tail); - Vxwidget_list = Fdelq (xwidget, Vxwidget_list); + internal_xwidget_list = Fdelq (xwidget, internal_xwidget_list); + Vxwidget_list = Fcopy_sequence (internal_xwidget_list); /* TODO free the GTK things in xw. */ { CHECK_LIVE_XWIDGET (xwidget); commit 554a875493680f8b52821267ee88e191d462ea36 Author: Po Lu Date: Fri Nov 12 08:17:41 2021 +0800 Prevent crashes in xwidgets whose buffers have been killed * doc/lispref/display.texi (Xwidgets): Explain meaning of killed xwidgets. * src/xwidget.c (Fxwidget_live_p): New function. (Fxwidget_perform_lispy_event, WEBKIT_FN_INIT) (Fxwidget_resize, Fxwidget_size_request) (Fxwidget_info, Fxwidget_plist) (Fset_xwidget_buffer, Fset_xwidget_plist) (Fset_xwidget_query_on_exit_flag) (Fxwidget_query_on_exit_flag) (Fxwidget_webkit_search) (Fxwidget_webkit_next_result) (Fxwidget_webkit_previous_result) (Fxwidget_webkit_finish_search) (Fxwidget_webkit_load_html): Check for live xwidgets instead of just xwidgets. (xwidget_button, xwidget_motion_or_crossing) (xv_do_draw, x_draw_xwidget_glyph_string) (Fdelete_xwidget_view): Ignore killed xwidgets. (syms_of_xwidget): Define new symbols and subrs and define appropriate weakness of id_to_xwidget map. (kill_buffer_xwidgets): Check live xwidgets instead of killed xwidgets, set xwidget buffer to nil, and rely on GC to free the hash table for us instead. * src/xwidget.h (XWIDGET_LIVE_P, CHECK_LIVE_XWIDGET): New macros. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index ad1077e0c4..a8a7837a4a 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -6804,6 +6804,12 @@ pixels, and @var{title}, a string, specifies its title. @var{related} is used internally by the WebKit widget, and specifies another WebKit widget that the newly created widget should share settings and subprocesses with. + +The xwidget that is returned will be killed alongside its buffer +(@pxref{Killing Buffers}). Once it is killed, the xwidget may +continue to exist as a Lisp object and act as a @code{display} +property until all references to it are gone, but most actions that +can be performed on live xwidgets will no longer be available. @end defun @defun xwidgetp object @@ -6811,6 +6817,11 @@ This function returns @code{t} if @var{object} is an xwidget, @code{nil} otherwise. @end defun +@defun xwidget-live-p object +This function returns @code{t} if @var{object} is an xwidget that +hasn't been killed, and @code{nil} otherwise. +@end defun + @defun xwidget-plist xwidget This function returns the property list of @var{xwidget}. @end defun @@ -6821,7 +6832,8 @@ property list given by @var{plist}. @end defun @defun xwidget-buffer xwidget -This function returns the buffer of @var{xwidget}. +This function returns the buffer of @var{xwidget}. If @var{xwidget} +has been killed, it returns @code{nil}. @end defun @defun set-xwidget-buffer xwidget buffer diff --git a/src/xwidget.c b/src/xwidget.c index fc05f4f570..d0cc3b987c 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -272,6 +272,16 @@ fails. */) return val; } +DEFUN ("xwidget-live-p", Fxwidget_live_p, Sxwidget_live_p, + 1, 1, 0, doc: /* Return t if OBJECT is an xwidget that has not been killed. +Value is nil if OBJECT is not an xwidget or if it has been killed. */) + (Lisp_Object object) +{ + return ((XWIDGETP (object) + && !NILP (XXWIDGET (object)->buffer)) + ? Qt : Qnil); +} + #ifdef USE_GTK static void set_widget_if_text_view (GtkWidget *widget, void *data) @@ -304,7 +314,7 @@ selected frame is not an X-Windows frame. */) GtkWidget *temp = NULL; #endif - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); xw = XXWIDGET (xwidget); if (!NILP (frame)) @@ -806,6 +816,9 @@ xwidget_button (struct xwidget_view *view, bool down_p, int x, int y, int button, int modifier_state, Time time) { + if (NILP (XXWIDGET (view->model)->buffer)) + return; + record_osr_embedder (view); if (button < 4 || button > 8) @@ -856,22 +869,29 @@ xwidget_button (struct xwidget_view *view, void xwidget_motion_or_crossing (struct xwidget_view *view, const XEvent *event) { - GdkEvent *xg_event = gdk_event_new (event->type == MotionNotify - ? GDK_MOTION_NOTIFY - : (event->type == LeaveNotify - ? GDK_LEAVE_NOTIFY - : GDK_ENTER_NOTIFY)); + GdkEvent *xg_event; struct xwidget *model = XXWIDGET (view->model); int x; int y; - GtkWidget *target = find_widget_at_pos (model->widgetwindow_osr, - (event->type == MotionNotify - ? event->xmotion.x + view->clip_left - : event->xcrossing.x + view->clip_left), - (event->type == MotionNotify - ? event->xmotion.y + view->clip_top - : event->xcrossing.y + view->clip_top), - &x, &y); + GtkWidget *target; + + if (NILP (model->buffer)) + return; + + xg_event = gdk_event_new (event->type == MotionNotify + ? GDK_MOTION_NOTIFY + : (event->type == LeaveNotify + ? GDK_LEAVE_NOTIFY + : GDK_ENTER_NOTIFY)); + + target = find_widget_at_pos (model->widgetwindow_osr, + (event->type == MotionNotify + ? event->xmotion.x + view->clip_left + : event->xcrossing.x + view->clip_left), + (event->type == MotionNotify + ? event->xmotion.y + view->clip_top + : event->xcrossing.y + view->clip_top), + &x, &y); if (!target) target = model->widget_osr; @@ -968,6 +988,13 @@ xv_do_draw (struct xwidget_view *xw, struct xwidget *w) { GtkOffscreenWindow *wnd; cairo_surface_t *surface; + + if (NILP (w->buffer)) + { + XClearWindow (xw->dpy, xw->wdesc); + return; + } + block_input (); wnd = GTK_OFFSCREEN_WINDOW (w->widgetwindow_osr); surface = gtk_offscreen_window_get_surface (wnd); @@ -1650,14 +1677,25 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) a redraw. It seems its possible to get out of sync with emacs redraws so emacs background sometimes shows up instead of the xwidgets background. It's just a visual glitch though. */ - if (!xwidget_hidden (xv)) + /* When xww->buffer is nil, that means the xwidget has been killed. */ + if (!NILP (xww->buffer)) { + if (!xwidget_hidden (xv)) + { #ifdef USE_GTK - gtk_widget_queue_draw (xww->widget_osr); + gtk_widget_queue_draw (xww->widget_osr); #elif defined NS_IMPL_COCOA - nsxwidget_set_needsdisplay (xv); + nsxwidget_set_needsdisplay (xv); #endif + } + } +#ifdef USE_GTK + else + { + XSetWindowBackground (xv->dpy, xv->wdesc, + FRAME_BACKGROUND_PIXEL (s->f)); } +#endif #ifdef USE_GTK unblock_input (); @@ -1676,7 +1714,7 @@ xwidget_is_web_view (struct xwidget *xw) /* Macro that checks xwidget hold webkit web view first. */ #define WEBKIT_FN_INIT() \ - CHECK_XWIDGET (xwidget); \ + CHECK_LIVE_XWIDGET (xwidget); \ struct xwidget *xw = XXWIDGET (xwidget); \ if (!xwidget_is_web_view (xw)) \ { \ @@ -1855,7 +1893,7 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, doc: /* Resize XWIDGET to NEW_WIDTH, NEW_HEIGHT. */ ) (Lisp_Object xwidget, Lisp_Object new_width, Lisp_Object new_height) { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); int w = check_integer_range (new_width, 0, INT_MAX); int h = check_integer_range (new_height, 0, INT_MAX); struct xwidget *xw = XXWIDGET (xwidget); @@ -1906,7 +1944,7 @@ This can be used to read the xwidget desired size, and resizes the Emacs allocated area accordingly. */) (Lisp_Object xwidget) { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); #ifdef USE_GTK GtkRequisition requisition; gtk_widget_size_request (XXWIDGET (xwidget)->widget_osr, &requisition); @@ -1941,7 +1979,7 @@ DEFUN ("xwidget-info", Currently [TYPE TITLE WIDTH HEIGHT]. */) (Lisp_Object xwidget) { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); struct xwidget *xw = XXWIDGET (xwidget); return CALLN (Fvector, xw->type, xw->title, make_fixed_natnum (xw->width), make_fixed_natnum (xw->height)); @@ -2004,7 +2042,7 @@ DEFUN ("delete-xwidget-view", unblock_input (); } - if (xw->embedder_view == xv) + if (xw->embedder_view == xv && !NILP (xw->buffer)) { w = gtk_widget_get_window (xw->widgetwindow_osr); @@ -2053,7 +2091,7 @@ DEFUN ("xwidget-plist", doc: /* Return the plist of XWIDGET. */) (Lisp_Object xwidget) { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); return XXWIDGET (xwidget)->plist; } @@ -2073,7 +2111,7 @@ DEFUN ("set-xwidget-buffer", doc: /* Set XWIDGET's buffer to BUFFER. */) (Lisp_Object xwidget, Lisp_Object buffer) { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); CHECK_BUFFER (buffer); XXWIDGET (xwidget)->buffer = buffer; @@ -2087,7 +2125,7 @@ DEFUN ("set-xwidget-plist", Returns PLIST. */) (Lisp_Object xwidget, Lisp_Object plist) { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); CHECK_LIST (plist); XXWIDGET (xwidget)->plist = plist; @@ -2103,7 +2141,7 @@ exiting or killing a buffer if XWIDGET is running. This function returns FLAG. */) (Lisp_Object xwidget, Lisp_Object flag) { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); XXWIDGET (xwidget)->kill_without_query = NILP (flag); return flag; } @@ -2114,7 +2152,7 @@ DEFUN ("xwidget-query-on-exit-flag", doc: /* Return the current value of the query-on-exit flag for XWIDGET. */) (Lisp_Object xwidget) { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); return (XXWIDGET (xwidget)->kill_without_query ? Qnil : Qt); } @@ -2147,7 +2185,7 @@ with QUERY. */) #endif CHECK_STRING (query); - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); #ifdef USE_GTK xw = XXWIDGET (xwidget); @@ -2191,7 +2229,7 @@ using `xwidget-webkit-search'. */) WebKitFindController *controller; #endif - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); xw = XXWIDGET (xwidget); if (!xw->find_text) @@ -2223,7 +2261,7 @@ using `xwidget-webkit-search'. */) WebKitFindController *controller; #endif - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); xw = XXWIDGET (xwidget); if (!xw->find_text) @@ -2255,7 +2293,7 @@ using `xwidget-webkit-search'. */) WebKitFindController *controller; #endif - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); xw = XXWIDGET (xwidget); if (!xw->find_text) @@ -2293,7 +2331,7 @@ to "about:blank". */) WebKitWebView *webview; char *data, *uri; - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); CHECK_STRING (text); if (NILP (base_uri)) base_uri = build_string ("about:blank"); @@ -2321,7 +2359,9 @@ syms_of_xwidget (void) { defsubr (&Smake_xwidget); defsubr (&Sxwidgetp); + defsubr (&Sxwidget_live_p); DEFSYM (Qxwidgetp, "xwidgetp"); + DEFSYM (Qxwidget_live_p, "xwidget-live-p"); defsubr (&Sxwidget_view_p); DEFSYM (Qxwidget_view_p, "xwidget-view-p"); defsubr (&Sxwidget_info); @@ -2379,7 +2419,8 @@ syms_of_xwidget (void) Fprovide (intern ("xwidget-internal"), Qnil); - id_to_xwidget_map = CALLN (Fmake_hash_table, QCtest, Qeq); + id_to_xwidget_map = CALLN (Fmake_hash_table, QCtest, Qeq, + QCweakness, Qvalue); staticpro (&id_to_xwidget_map); #ifdef USE_GTK @@ -2605,9 +2646,10 @@ kill_buffer_xwidgets (Lisp_Object buffer) Vxwidget_list = Fdelq (xwidget, Vxwidget_list); /* TODO free the GTK things in xw. */ { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); struct xwidget *xw = XXWIDGET (xwidget); - Fremhash (make_fixnum (xw->xwidget_id), id_to_xwidget_map); + xw->buffer = Qnil; + #ifdef USE_GTK if (xw->widget_osr && xw->widgetwindow_osr) { @@ -2624,6 +2666,10 @@ kill_buffer_xwidgets (Lisp_Object buffer) xfree (xmint_pointer (XCAR (cb))); ASET (xw->script_callbacks, idx, Qnil); } + + xw->widget_osr = NULL; + xw->widgetwindow_osr = NULL; + xw->find_text = NULL; #elif defined NS_IMPL_COCOA nsxwidget_kill (xw); #endif diff --git a/src/xwidget.h b/src/xwidget.h index 6e6b39c8b4..4377b50e84 100644 --- a/src/xwidget.h +++ b/src/xwidget.h @@ -138,9 +138,16 @@ struct xwidget_view #define XXWIDGET(a) (eassert (XWIDGETP (a)), \ XUNTAG (a, Lisp_Vectorlike, struct xwidget)) +#define XWIDGET_LIVE_P(w) (!NILP ((w)->buffer)) + #define CHECK_XWIDGET(x) \ CHECK_TYPE (XWIDGETP (x), Qxwidgetp, x) +#define CHECK_LIVE_XWIDGET(x) \ + CHECK_TYPE ((XWIDGETP (x) \ + && XWIDGET_LIVE_P (XXWIDGET (x))), \ + Qxwidget_live_p, x) + /* Test for xwidget_view pseudovector. */ #define XWIDGET_VIEW_P(x) PSEUDOVECTORP (x, PVEC_XWIDGET_VIEW) #define XXWIDGET_VIEW(a) (eassert (XWIDGET_VIEW_P (a)), \ commit a8fc08085110de00ebcbd67b5273a755a5cb8ea1 Author: Eli Zaretskii Date: Thu Dec 31 20:28:30 2020 +0200 Fix compilation on MS-Windows * src/callproc.c (emacs_spawn) : Define the label only if USABLE_POSIX_SPAWN is defined, to avoid a compiler warning. diff --git a/src/callproc.c b/src/callproc.c index 208a448135..c949fff4db 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -1601,7 +1601,9 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int std_err, vfork_error = pid < 0 ? errno : 0; +#if USABLE_POSIX_SPAWN fork_done: +#endif if (pid < 0) { eassert (0 < vfork_error); commit a60053f8368e058229721f1bf1567c2b1676b239 Author: Philipp Stephani Date: Wed Dec 30 14:42:01 2020 +0100 Use posix_spawn if possible. posix_spawn is less error-prone than vfork + execve, and can make better use of system-specific enhancements like 'clone' on Linux. Use it if we don't need to configure a pseudoterminal. * configure.ac (HAVE_SPAWN_H, HAVE_POSIX_SPAWN) (HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR) (HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP) (HAVE_POSIX_SPAWNATTR_SETFLAGS, HAVE_DECL_POSIX_SPAWN_SETSID): New configuration variables. * src/callproc.c (USABLE_POSIX_SPAWN): New configuration macro. (emacs_posix_spawn_init_actions) (emacs_posix_spawn_init_attributes, emacs_posix_spawn_init): New helper functions. (emacs_spawn): Use posix_spawn if possible. diff --git a/configure.ac b/configure.ac index 33e7037afe..c231c2ceae 100644 --- a/configure.ac +++ b/configure.ac @@ -4771,6 +4771,23 @@ dnl AC_CHECK_FUNCS_ONCE wouldn’t be right for snprintf, which needs dnl the current CFLAGS etc. AC_CHECK_FUNCS(snprintf) +dnl posix_spawn. The chdir and setsid functionality is relatively +dnl recent, so we check for it specifically. +AC_CHECK_HEADERS([spawn.h]) +AC_SUBST([HAVE_SPAWN_H]) +AC_CHECK_FUNCS([posix_spawn \ + posix_spawn_file_actions_addchdir \ + posix_spawn_file_actions_addchdir_np \ + posix_spawnattr_setflags]) +AC_SUBST([HAVE_POSIX_SPAWN]) +AC_SUBST([HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR]) +AC_SUBST([HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP]) +AC_SUBST([HAVE_POSIX_SPAWNATTR_SETFLAGS]) +AC_CHECK_DECLS([POSIX_SPAWN_SETSID], [], [], [[ + #include + ]]) +AC_SUBST([HAVE_DECL_POSIX_SPAWN_SETSID]) + dnl Check for glib. This differs from other library checks in that dnl Emacs need not link to glib unless some other library is already dnl linking to glib. Although glib provides no facilities that Emacs diff --git a/src/callproc.c b/src/callproc.c index fa43f97384..208a448135 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -28,6 +28,20 @@ along with GNU Emacs. If not, see . */ #include #include +/* In order to be able to use `posix_spawn', it needs to support some + variant of `chdir' as well as `setsid'. */ +#if defined HAVE_SPAWN_H && defined HAVE_POSIX_SPAWN \ + && defined HAVE_POSIX_SPAWNATTR_SETFLAGS \ + && (defined HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR \ + || defined HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP) \ + && defined HAVE_DECL_POSIX_SPAWN_SETSID \ + && HAVE_DECL_POSIX_SPAWN_SETSID == 1 +# include +# define USABLE_POSIX_SPAWN 1 +#else +# define USABLE_POSIX_SPAWN 0 +#endif + #include "lisp.h" #ifdef SETUP_SLAVE_PTY @@ -1247,6 +1261,130 @@ child_setup (int in, int out, int err, char **new_argv, char **env, #endif /* not WINDOWSNT */ } +#if USABLE_POSIX_SPAWN + +/* Set up ACTIONS and ATTRIBUTES for `posix_spawn'. Return an error + number. */ + +static int +emacs_posix_spawn_init_actions (posix_spawn_file_actions_t *actions, + int std_in, int std_out, int std_err, + const char *cwd) +{ + int error = posix_spawn_file_actions_init (actions); + if (error != 0) + return error; + + error = posix_spawn_file_actions_adddup2 (actions, std_in, + STDIN_FILENO); + if (error != 0) + goto out; + + error = posix_spawn_file_actions_adddup2 (actions, std_out, + STDOUT_FILENO); + if (error != 0) + goto out; + + error = posix_spawn_file_actions_adddup2 (actions, + std_err < 0 ? std_out + : std_err, + STDERR_FILENO); + if (error != 0) + goto out; + + error = +#ifdef HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR + posix_spawn_file_actions_addchdir +#else + posix_spawn_file_actions_addchdir_np +#endif + (actions, cwd); + if (error != 0) + goto out; + + out: + if (error != 0) + posix_spawn_file_actions_destroy (actions); + return error; +} + +static int +emacs_posix_spawn_init_attributes (posix_spawnattr_t *attributes) +{ + int error = posix_spawnattr_init (attributes); + if (error != 0) + return error; + + error = posix_spawnattr_setflags (attributes, + POSIX_SPAWN_SETSID + | POSIX_SPAWN_SETSIGDEF + | POSIX_SPAWN_SETSIGMASK); + if (error != 0) + goto out; + + sigset_t sigdefault; + sigemptyset (&sigdefault); + +#ifdef DARWIN_OS + /* Work around a macOS bug, where SIGCHLD is apparently + delivered to a vforked child instead of to its parent. See: + https://lists.gnu.org/r/emacs-devel/2017-05/msg00342.html + */ + sigaddset (&sigdefault, SIGCHLD); +#endif + + sigaddset (&sigdefault, SIGINT); + sigaddset (&sigdefault, SIGQUIT); +#ifdef SIGPROF + sigaddset (&sigdefault, SIGPROF); +#endif + + /* Emacs ignores SIGPIPE, but the child should not. */ + sigaddset (&sigdefault, SIGPIPE); + /* Likewise for SIGPROF. */ +#ifdef SIGPROF + sigaddset (&sigdefault, SIGPROF); +#endif + + error = posix_spawnattr_setsigdefault (attributes, &sigdefault); + if (error != 0) + goto out; + + /* Stop blocking SIGCHLD in the child. */ + sigset_t oldset; + error = pthread_sigmask (SIG_SETMASK, NULL, &oldset); + if (error != 0) + goto out; + error = posix_spawnattr_setsigmask (attributes, &oldset); + if (error != 0) + goto out; + + out: + if (error != 0) + posix_spawnattr_destroy (attributes); + + return error; +} + +static int +emacs_posix_spawn_init (posix_spawn_file_actions_t *actions, + posix_spawnattr_t *attributes, int std_in, + int std_out, int std_err, const char *cwd) +{ + int error = emacs_posix_spawn_init_actions (actions, std_in, + std_out, std_err, cwd); + if (error != 0) + return error; + + error = emacs_posix_spawn_init_attributes (attributes); + if (error != 0) + return error; + + return 0; +} + +#endif + /* Start a new asynchronous subprocess. If successful, return zero and store the process identifier of the new process in *NEWPID. Use STDIN, STDOUT, and STDERR as standard streams for the new @@ -1266,10 +1404,58 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int std_err, char **argv, char **envp, const char *cwd, const char *pty, const sigset_t *oldset) { +#if USABLE_POSIX_SPAWN + /* Prefer the simpler `posix_spawn' if available. `posix_spawn' + doesn't yet support setting up pseudoterminals, so we fall back + to `vfork' if we're supposed to use a pseudoterminal. */ + + bool use_posix_spawn = pty == NULL; + + posix_spawn_file_actions_t actions; + posix_spawnattr_t attributes; + + if (use_posix_spawn) + { + /* Initialize optional attributes before blocking. */ + int error + = emacs_posix_spawn_init (&actions, &attributes, std_in, + std_out, std_err, cwd); + if (error != 0) + return error; + } +#endif + int pid; + int vfork_error; eassert (input_blocked_p ()); +#if USABLE_POSIX_SPAWN + if (use_posix_spawn) + { + vfork_error = posix_spawn (&pid, argv[0], &actions, &attributes, + argv, envp); + if (vfork_error != 0) + pid = -1; + + int error = posix_spawn_file_actions_destroy (&actions); + if (error != 0) + { + errno = error; + emacs_perror ("posix_spawn_file_actions_destroy"); + } + + error = posix_spawnattr_destroy (&attributes); + if (error != 0) + { + errno = error; + emacs_perror ("posix_spawnattr_destroy"); + } + + goto fork_done; + } +#endif + #ifndef WINDOWSNT /* vfork, and prevent local vars from being clobbered by the vfork. */ pid_t *volatile newpid_volatile = newpid; @@ -1413,8 +1599,9 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int std_err, /* Back in the parent process. */ - int vfork_error = pid < 0 ? errno : 0; + vfork_error = pid < 0 ? errno : 0; + fork_done: if (pid < 0) { eassert (0 < vfork_error); commit 24b86cb4f7aa1e14dd9025428140c5fdae5c5227 Author: Eli Zaretskii Date: Thu Nov 11 21:41:10 2021 +0200 Fix ACL errors with WebDAV volumes on MS-Windows * src/w32.c (acl_get_file): Handle ERROR_INVALID_FUNCTION from WebDAV. Patch from Ioannis Kappas . (Bug#51773) diff --git a/src/w32.c b/src/w32.c index 9fe698d28d..80e42acf50 100644 --- a/src/w32.c +++ b/src/w32.c @@ -6595,7 +6595,8 @@ acl_get_file (const char *fname, acl_type_t type) xfree (psd); err = GetLastError (); if (err == ERROR_NOT_SUPPORTED - || err == ERROR_ACCESS_DENIED) + || err == ERROR_ACCESS_DENIED + || err == ERROR_INVALID_FUNCTION) errno = ENOTSUP; else if (err == ERROR_FILE_NOT_FOUND || err == ERROR_PATH_NOT_FOUND @@ -6614,10 +6615,11 @@ acl_get_file (const char *fname, acl_type_t type) || err == ERROR_INVALID_NAME) errno = ENOENT; else if (err == ERROR_NOT_SUPPORTED - /* ERROR_ACCESS_DENIED is what we get for a volume - mounted by WebDAV, which evidently doesn't - support ACLs. */ - || err == ERROR_ACCESS_DENIED) + /* ERROR_ACCESS_DENIED or ERROR_INVALID_FUNCTION is + what we get for a volume mounted by WebDAV, + which evidently doesn't support ACLs. */ + || err == ERROR_ACCESS_DENIED + || err == ERROR_INVALID_FUNCTION) errno = ENOTSUP; else errno = EIO; commit 6c9ac53249a1c1b05bbcc8e253f39fa8d1e319f6 Author: Jim Porter Date: Thu Nov 11 19:34:17 2021 +0100 Improve performance of 'file-name-case-insensitive-p' for Tramp files Previously, each function in 'tramp-foreign-file-name-handler-alist' would call 'tramp-dissect-file-name', resulting in it being called several times whenever 'tramp-find-foreign-file-name-handler' was called. Now, functions take the dissected file name to avoid this duplicated effort. (Bug#51699) * etc/NEWS: Announce this change. * lisp/net/tramp-adb.el (tramp-adb-file-name-p): * lisp/net/tramp-ftp.el (tramp-ftp-file-name-p): * lisp/net/tramp-gvfs.el (tramp-gvfs-file-name-p): * lisp/net/tramp-rclone.el (tramp-rclone-file-name-p): * lisp/net/tramp-smb.el (tramp-smb-file-name-p): * lisp/net/tramp-sshfs.el (tramp-sshfs-file-name-p): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-file-name-p): Accept dissected file names. * lisp/net/tramp.el (tramp-ensure-dissected-file-name): New function. (tramp-find-foreign-file-name-handler): Pass dissected file name to functions. (tramp-connectable-p): Use 'tramp-ensure-dissected-file-name'. diff --git a/etc/NEWS b/etc/NEWS index 1dfdf64062..4ec7743611 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -532,6 +532,12 @@ get proper locale-dependent downcasing, the string has to be converted to multibyte first. (This goes for the other case-changing functions, too.) +--- +** Functions in 'tramp-foreign-file-name-handler-alist' have changed. +Functions to determine which Tramp file name handler to use are now +passed a file name in dissected form (via 'tramp-dissect-file-name') +instead of in string form. + --- ** 'def' indentation changes. In 'emacs-lisp-mode', forms with a symbol with a name that start with diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 362a258f43..e7fe07e417 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -191,11 +191,10 @@ It is used for TCP/IP devices." ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-adb-file-name-p (filename) - "Check if it's a FILENAME for ADB." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-adb-method))) +(defsubst tramp-adb-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for ADB." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-adb-method))) ;;;###tramp-autoload (defun tramp-adb-file-name-handler (operation &rest args) diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index 11ccdc8a4c..f78c08ec41 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -175,11 +175,10 @@ pass to the OPERATION." ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-ftp-file-name-p (filename) - "Check if it's a FILENAME that should be forwarded to Ange-FTP." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-ftp-method))) +(defsubst tramp-ftp-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME that should be forwarded to Ange-FTP." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-ftp-method))) ;;;###tramp-autoload (tramp--with-startup diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index cab912bd93..1f9d9d9415 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -834,12 +834,11 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-gvfs-file-name-p (filename) - "Check if it's a FILENAME handled by the GVFS daemon." - (and (tramp-tramp-file-p filename) - (let ((method - (tramp-file-name-method (tramp-dissect-file-name filename)))) - (and (stringp method) (member method tramp-gvfs-methods))))) +(defsubst tramp-gvfs-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME handled by the GVFS daemon." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (let ((method (tramp-file-name-method vec))) + (and (stringp method) (member method tramp-gvfs-methods))))) ;;;###tramp-autoload (defun tramp-gvfs-file-name-handler (operation &rest args) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 812e06f3f1..64b0176d08 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -156,11 +156,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-rclone-file-name-p (filename) - "Check if it's a FILENAME for rclone." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-rclone-method))) +(defsubst tramp-rclone-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for rclone." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-rclone-method))) ;;;###tramp-autoload (defun tramp-rclone-file-name-handler (operation &rest args) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 49f049d3f3..aeabc69246 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -330,11 +330,10 @@ This can be used to disable echo etc." ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-smb-file-name-p (filename) - "Check if it's a FILENAME for SMB servers." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-smb-method))) +(defsubst tramp-smb-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for SMB servers." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-smb-method))) ;;;###tramp-autoload (defun tramp-smb-file-name-handler (operation &rest args) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index a100786345..4bc804571e 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -156,11 +156,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-sshfs-file-name-p (filename) - "Check if it's a FILENAME for sshfs." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-sshfs-method))) +(defsubst tramp-sshfs-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for sshfs." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-sshfs-method))) ;;;###tramp-autoload (defun tramp-sshfs-file-name-handler (operation &rest args) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 845f31d09b..48c81a5988 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -148,11 +148,10 @@ See `tramp-actions-before-shell' for more info.") ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-sudoedit-file-name-p (filename) - "Check if it's a FILENAME for SUDOEDIT." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-sudoedit-method))) +(defsubst tramp-sudoedit-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for SUDOEDIT." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-sudoedit-method))) ;;;###tramp-autoload (defun tramp-sudoedit-file-name-handler (operation &rest args) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index a8972ce69e..85effe1a04 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1669,6 +1669,16 @@ default values are used." (put #'tramp-dissect-file-name 'tramp-suppress-trace t) +(defun tramp-ensure-dissected-file-name (vec-or-filename) + "Return a `tramp-file-name' structure for VEC-OR-FILENAME. + +VEC-OR-FILENAME may be either a string or a `tramp-file-name'. +If it's not a Tramp filename, return nil." + (cond + ((tramp-file-name-p vec-or-filename) vec-or-filename) + ((tramp-tramp-file-p vec-or-filename) + (tramp-dissect-file-name vec-or-filename)))) + (defun tramp-dissect-hop-name (name &optional nodefault) "Return a `tramp-file-name' structure of `hop' part of NAME. See `tramp-dissect-file-name' for details." @@ -2552,11 +2562,14 @@ Must be handled by the callers." "Return foreign file name handler if exists." (when (tramp-tramp-file-p filename) (let ((handler tramp-foreign-file-name-handler-alist) + (vec (tramp-dissect-file-name filename)) elt res) (while handler (setq elt (car handler) handler (cdr handler)) - (when (funcall (car elt) filename) + ;; Previously, this function was called with FILENAME, but now + ;; it's called with the VEC. + (when (with-demoted-errors "Error: %S" (funcall (car elt) vec)) (setq handler nil res (cdr elt)))) res))) @@ -2755,8 +2768,9 @@ remote file names." (defun tramp-register-foreign-file-name-handler (func handler &optional append) "Register (FUNC . HANDLER) in `tramp-foreign-file-name-handler-alist'. -FUNC is the function, which determines whether HANDLER is to be called. -Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." +FUNC is the function, which takes a dissected filename and determines +whether HANDLER is to be called. Add operations defined in +`HANDLER-alist' to `tramp-file-name-handler'." (add-to-list 'tramp-foreign-file-name-handler-alist `(,func . ,handler) append) ;; Mark `operations' the handler is responsible for. @@ -2814,11 +2828,7 @@ They are completed by \"M-x TAB\" only if the current buffer is remote." This is true, if either the remote host is already connected, or if we are not in completion mode." (let ((tramp-verbose 0) - (vec - (cond - ((tramp-file-name-p vec-or-filename) vec-or-filename) - ((tramp-tramp-file-p vec-or-filename) - (tramp-dissect-file-name vec-or-filename))))) + (vec (tramp-ensure-dissected-file-name vec-or-filename))) (or ;; We check this for the process related to ;; `tramp-buffer-name'; otherwise `start-file-process' ;; wouldn't run ever when `non-essential' is non-nil. commit 585e2103df144664921670878fc273eee817b0ba Author: Stefan Kangas Date: Thu Nov 11 18:39:19 2021 +0100 erc: Don't announce broken functionality in /query docstring * lisp/erc/erc.el (erc-cmd-QUERY): Be less enthusiastic about announcing missing/broken functionality. The comment "except this is broken right now" has been there since 2008, and it's not obvious to me that we should ever re-add it. diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 3028568753..abb1f64a82 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -3606,11 +3606,13 @@ other people should be displayed." (defun erc-cmd-QUERY (&optional user) "Open a query with USER. -The type of query window/frame/etc will depend on the value of -`erc-query-display'. - -If USER is omitted, close the current query buffer if one exists -- except this is broken now ;-)" +How the query is displayed (in a new window, frame, etc.) depends +on the value of `erc-query-display'." + ;; FIXME: The doc string used to say at the end: + ;; "If USER is omitted, close the current query buffer if one exists + ;; - except this is broken now ;-)" + ;; Does it make sense to have that functionality? What's wrong with + ;; `kill-buffer'? If it makes sense, re-add it. -- SK @ 2021-11-11 (interactive (list (read-string "Start a query with: "))) (let ((session-buffer (erc-server-buffer)) commit e30cb92db6b09cffc69c02b8d8b13342d5739af2 Author: Filipp Gunbin Date: Thu Nov 11 19:44:27 2021 +0300 * lisp/subr.el (add-hook): Fix adding into hook--depth-alist (bug#51620). diff --git a/lisp/subr.el b/lisp/subr.el index 5a5842d428..3902251586 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2042,7 +2042,7 @@ performance impact when running `add-hook' and `remove-hook'." (when (or (get hook 'hook--depth-alist) (not (zerop depth))) ;; Note: The main purpose of the above `when' test is to avoid running ;; this `setf' before `gv' is loaded during bootstrap. - (push (cons function depth) (get hook 'hook--depth-alist))) + (setf (alist-get function (get hook 'hook--depth-alist) 0) depth)) (setq hook-value (if (< 0 depth) (append hook-value (list function)) commit 2c082ce800db92ffd41381dbd9cc2879b4308ebf Author: Eli Zaretskii Date: Thu Nov 11 16:58:47 2021 +0200 ; * src/term.c (init_tty): Fix last change. diff --git a/src/term.c b/src/term.c index fd8db5349d..b4f3dfc25e 100644 --- a/src/term.c +++ b/src/term.c @@ -4155,7 +4155,7 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ /* Fall back to xterm+direct (semicolon version) if Tc is set (de-facto standard introduced by tmux) or if requested by the COLORTERM environment variable. */ - else if ((tigetflag ("Tc") != -1) + else if ((tigetflag ("Tc") > 0) || ((bg = getenv ("COLORTERM")) != NULL && strcasecmp (bg, "truecolor") == 0)) { commit 4a261ce91dbb6a0cfcbce47428a777147bb86c6d Author: Eli Zaretskii Date: Thu Nov 11 16:56:46 2021 +0200 ; * src/term.c (init_tty): Fix style of parentheses. diff --git a/src/term.c b/src/term.c index 51fcef6f1e..fd8db5349d 100644 --- a/src/term.c +++ b/src/term.c @@ -4155,9 +4155,9 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ /* Fall back to xterm+direct (semicolon version) if Tc is set (de-facto standard introduced by tmux) or if requested by the COLORTERM environment variable. */ - else if ((tigetflag("Tc") != -1) - || ((bg = getenv("COLORTERM")) != NULL - && strcasecmp(bg, "truecolor") == 0)) + else if ((tigetflag ("Tc") != -1) + || ((bg = getenv ("COLORTERM")) != NULL + && strcasecmp (bg, "truecolor") == 0)) { tty->TS_set_foreground = "\033[%?%p1%{8}%<%t3%p1%d%e38;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m"; tty->TS_set_background = "\033[%?%p1%{8}%<%t4%p1%d%e48;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m"; commit 386289bdc8461898b05f318b77e0bedf2509537d Author: Eli Zaretskii Date: Thu Nov 11 16:55:11 2021 +0200 Fix 8-color PuTTY -nw sessions broken by a recent commit * src/term.c (init_tty): Fix the change which introduced support for the terminfo Tc flag. The code as installed broke colors in PuTTY -nw sessions, because 'tigetflag' returned -1, which is non-zero, so it was treated as the sign that true color is supported. But if the value returned by 'tigetflag' is -1, it means the capability is not a boolean one, so that's not to be used as a valid support for 24-bit color. (Bug#44950) diff --git a/src/term.c b/src/term.c index d86ae12ba8..51fcef6f1e 100644 --- a/src/term.c +++ b/src/term.c @@ -4155,7 +4155,7 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ /* Fall back to xterm+direct (semicolon version) if Tc is set (de-facto standard introduced by tmux) or if requested by the COLORTERM environment variable. */ - else if (tigetflag("Tc") + else if ((tigetflag("Tc") != -1) || ((bg = getenv("COLORTERM")) != NULL && strcasecmp(bg, "truecolor") == 0)) { commit d75558f11c802dddc9b173f85b1c07aff7c9c3bd Author: Lars Ingebrigtsen Date: Thu Nov 11 13:20:34 2021 +0100 Fix problem with non-absolute names * lisp/files.el (file-name-split): Fix problem with non-absolute names. diff --git a/lisp/files.el b/lisp/files.el index c694df3826..3490d0428a 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -5069,7 +5069,7 @@ On most systems, this will be true: (setq filename (and dir (directory-file-name dir))) ;; If there's nothing left to peel off, we're at the root and ;; we can stop. - (when (equal dir filename) + (when (and dir (equal dir filename)) (push "" components) (setq filename nil)))) components)) diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 787e6390a6..d00f1ce326 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -1806,7 +1806,7 @@ Prompt users for any modified buffer with `buffer-offer-save' non-nil." ;; `save-some-buffers-default-predicate' (i.e. the 2nd element) is ignored. (nil save-some-buffers-root ,nb-might-save)))))) -(defun test-file-name-split () +(ert-deftest test-file-name-split () (should (equal (file-name-split "foo/bar") '("foo" "bar"))) (should (equal (file-name-split "/foo/bar") '("" "foo" "bar"))) (should (equal (file-name-split "/foo/bar/zot") '("" "foo" "bar" "zot"))) commit bf9364a56e618277fe72c90b3a741ade8bc0d205 Author: Lars Ingebrigtsen Date: Thu Nov 11 08:09:59 2021 +0100 Add a command to go the gnu.org version of the info page * lisp/info.el (Info-url-for-node): (Info-goto-node-web): New function (bug#44895). Based on code from Drew Adams . diff --git a/etc/NEWS b/etc/NEWS index 20e6b7da7b..1dfdf64062 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -210,6 +210,13 @@ change the terminal used on a remote host. * Changes in Specialized Modes and Packages in Emacs 29.1 +** Info + +--- +*** New command 'Info-goto-node-web' and key binding 'W'. +This will take you to the gnu.org web server's version of the current +info node. This command only works for the Emacs and Emacs Lisp manuals. + ** vc --- diff --git a/lisp/info.el b/lisp/info.el index 41889d6de1..28f25d0e0d 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -1792,7 +1792,46 @@ of NODENAME; if none is found it then tries a case-insensitive match (if trim (setq nodename (substring nodename 0 trim)))) (if transient-mark-mode (deactivate-mark)) (Info-find-node (if (equal filename "") nil filename) - (if (equal nodename "") "Top" nodename) nil strict-case))) + (if (equal nodename "") "Top" nodename) nil strict-case))) + +(defun Info-goto-node-web (node) + "Use `browse-url' to go to the gnu.org web server's version of NODE. +By default, go to the current Info node." + (interactive (list (Info-read-node-name + "Go to node (default current page): " Info-current-node)) + Info-mode) + (browse-url-button-open-url + (Info-url-for-node (format "(%s)%s" (file-name-sans-extension + (file-name-nondirectory + Info-current-file)) + node)))) + +(defun Info-url-for-node (node) + "Return a URL for NODE, a node in the GNU Emacs or Elisp manual. +NODE should be a string on the form \"(manual)Node\". Only emacs +and elisp manuals are supported." + (unless (string-match "\\`(\\(.+\\))\\(.+\\)\\'" node) + (error "Invalid node name %s" node)) + (let ((manual (match-string 1 node)) + (node (match-string 2 node))) + (unless (member manual '("emacs" "elisp")) + (error "Only emacs/elisp manuals are supported")) + ;; Encode a bunch of characters the way that makeinfo does. + (setq node + (mapconcat (lambda (ch) + (if (or (< ch 32) ; ^@^A-^Z^[^\^]^^^- + (<= 33 ch 47) ; !"#$%&'()*+,-./ + (<= 58 ch 64) ; :;<=>?@ + (<= 91 ch 96) ; [\]_` + (<= 123 ch 127)) ; {|}~ DEL + (format "_00%x" ch) + (char-to-string ch))) + node + "")) + (concat "https://www.gnu.org/software/emacs/manual/html_node/" + manual "/" + (url-hexify-string (string-replace " " "-" node)) + ".html"))) (defvar Info-read-node-completion-table) @@ -1877,7 +1916,7 @@ See `completing-read' for a description of arguments and usage." code Info-read-node-completion-table string predicate)))) ;; Arrange to highlight the proper letters in the completion list buffer. -(defun Info-read-node-name (prompt) +(defun Info-read-node-name (prompt &optional default) "Read an Info node name with completion, prompting with PROMPT. A node name can have the form \"NODENAME\", referring to a node in the current Info file, or \"(FILENAME)NODENAME\", referring to @@ -1885,7 +1924,8 @@ a node in FILENAME. \"(FILENAME)\" is a short format to go to the Top node in FILENAME." (let* ((completion-ignore-case t) (Info-read-node-completion-table (Info-build-node-completions)) - (nodename (completing-read prompt #'Info-read-node-name-1 nil t))) + (nodename (completing-read prompt #'Info-read-node-name-1 nil t nil + 'Info-minibuf-history default))) (if (equal nodename "") (Info-read-node-name prompt) nodename))) @@ -4067,6 +4107,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'." (define-key map "T" 'Info-toc) (define-key map "u" 'Info-up) ;; `w' for consistency with `dired-copy-filename-as-kill'. + (define-key map "W" 'Info-goto-node-web) (define-key map "w" 'Info-copy-current-node-name) (define-key map "c" 'Info-copy-current-node-name) ;; `^' for consistency with `dired-up-directory'. diff --git a/test/lisp/info-tests.el b/test/lisp/info-tests.el new file mode 100644 index 0000000000..3e2aa3e089 --- /dev/null +++ b/test/lisp/info-tests.el @@ -0,0 +1,39 @@ +;;; info-tests.el --- Tests for info.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 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 'info) +(require 'ert) +(require 'ert-x) + +(ert-deftest test-info-urls () + (should (equal (Info-url-for-node "(emacs)Minibuffer") + "https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer.html")) + (should (equal (Info-url-for-node "(emacs)Minibuffer File") + "https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer-File.html")) + (should (equal (Info-url-for-node "(elisp)Backups and Auto-Saving") + "https://www.gnu.org/software/emacs/manual/html_node/elisp/Backups-and-Auto_002dSaving.html")) + (should-error (Info-url-for-node "(gnus)Minibuffer File"))) + +;;; info-tests.el ends here commit 997ca88ef44f5833f1a9a55fc3be863e7cc07a4b Author: Eli Zaretskii Date: Thu Nov 11 13:12:50 2021 +0200 ; * lisp/server.el (server-stop-automatically): Doc fix. diff --git a/lisp/server.el b/lisp/server.el index deaaf07da8..2f003a380a 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -1791,24 +1791,26 @@ only these files will be asked to be saved." ;;;###autoload (defun server-stop-automatically (arg) - "Automatically stop server when possible. + "Automatically stop server as specified by ARG. -When ARG is 'empty, the server is stopped when it has no remaining -clients, no remaining unsaved file-visiting buffers, and no -running processes with a query-on-exit flag. +If ARG is the symbol `empty', stop the server when it has no +remaining clients, no remaining unsaved file-visiting buffers, +and no running processes with a `query-on-exit' flag. -When ARG is 'delete-frame, the user is asked when the last frame is -being closed whether each unsaved file-visiting buffer must be -saved and each running process with a query-on-exit flag can be -stopped, and if so, the server itself is stopped. +If ARG is the symbol `delete-frame', ask the user when the last +frame is deleted whether each unsaved file-visiting buffer must +be saved and each running process with a `query-on-exit' flag +can be stopped, and if so, stop the server itself. -When ARG is 'kill-terminal, the user is asked when the last frame -is being close with \\[save-buffers-kill-terminal] \ +If ARG is the symbol `kill-terminal', ask the user when the +terminal is killed with \\[save-buffers-kill-terminal] \ whether each unsaved file-visiting -buffer must be saved and each running process with a query-on-exit -flag can be stopped, and if so, the server itself is stopped. +buffer must be saved and each running process with a `query-on-exit' +flag can be stopped, and if so, stop the server itself. -This function is meant to be put in init files." +Any other value of ARG will cause this function to signal an error. + +This function is meant to be called from the user init file." (when (daemonp) (setq server-stop-automatically arg) (cond commit 51e3625deceacb21186e8caa7c664d584f60f723 Author: Eli Zaretskii Date: Thu Nov 11 12:58:58 2021 +0200 ; * etc/NEWS: Improve a recently added entry. diff --git a/etc/NEWS b/etc/NEWS index 2ce76769fe..20e6b7da7b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -49,7 +49,10 @@ time. ** Terminal Emacs --- -*** Emacs will now use 24-bit colors on terminal that support "Tc". +*** Emacs will now use 24-bit colors on terminals that support "Tc" capability. +This is in addition to previously-supported ways of discovering 24-bit +color support: either via the "RGB" or "setf24" capabilities, or if +the COLORTERM environment variable is set to the value "truecolor". ** Emoji commit 7aad73febfd10627996edb1d6264e2abac4d2c65 Merge: 9a59d9017b 6dae01ad6d Author: Michael Albinus Date: Thu Nov 11 11:55:15 2021 +0100 Merge from origin/emacs-28 6dae01ad6d Fix tramp-compat-file-name-concat (Bug#51754) commit 6dae01ad6da1bcbced062c0d46a6759c7a0570e4 Author: Aleksandr Vityazev Date: Thu Nov 11 11:53:41 2021 +0100 Fix tramp-compat-file-name-concat (Bug#51754) * lisp/net/tramp-compat.el: Make `tramp-compat-file-name-concat' work like file-name-concat. (Bug#51754) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 213ab5857c..fbc3d684ce 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -386,14 +386,17 @@ CONDITION can also be a list of error conditions." (if (fboundp 'file-name-concat) #'file-name-concat (lambda (directory &rest components) - (unless (null directory) - (let ((components (delq nil components)) - file-name-handler-alist) - (if (null components) - directory - (tramp-compat-file-name-concat - (concat (file-name-as-directory directory) (car components)) - (cdr components)))))))) + (let ((components (cl-remove-if (lambda (el) + (or (null el) (equal "" el))) + components)) + file-name-handler-alist) + (if (null components) + directory + (apply #'tramp-compat-file-name-concat + (concat (unless (or (equal "" directory) (null directory)) + (file-name-as-directory directory)) + (car components)) + (cdr components))))))) (dolist (elt (all-completions "tramp-compat-" obarray 'functionp)) (put (intern elt) 'tramp-suppress-trace t)) commit 9a59d9017bf50f41dc1aa0778d0b350040866eb1 Author: Po Lu Date: Thu Nov 11 18:45:52 2021 +0800 Add URI as a valid spec for xwidget-webkit-buffer-name-format * lisp/xwidget.el (xwidget-webkit-buffer-name-format): Update doc string. (xwidget-webkit-callback): Add a format spec %U, which stands for the current URI of the widget. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 8078f1d01b..9bb2f11f41 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -100,7 +100,8 @@ This returns the result of `make-xwidget'." "Template for naming `xwidget-webkit' buffers. It can use the following special constructs: - %T -- the title of the Web page loaded by the xwidget." + %T -- the title of the Web page loaded by the xwidget. + %U -- the URI of the Web page loaded by the xwidget." :type 'string :version "29.1") @@ -362,7 +363,8 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." (xwidget-log "error: callback called for xwidget with dead buffer") (cond ((eq xwidget-event-type 'load-changed) - (let ((title (xwidget-webkit-title xwidget))) + (let ((title (xwidget-webkit-title xwidget)) + (uri (xwidget-webkit-uri xwidget))) ;; This funciton will be called multi times, so only ;; change buffer name when the load actually completes ;; this can limit buffer-name flicker in mode-line. @@ -379,7 +381,8 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." (rename-buffer (format-spec xwidget-webkit-buffer-name-format - `((?T . ,title))) + `((?T . ,title) + (?U . ,uri))) t))))) ((eq xwidget-event-type 'decide-policy) (let ((strarg (nth 3 last-input-event))) commit f69a808ddcf7b2fd8cc2eacf99dd98248b9c455a Author: Feng Shu Date: Thu Nov 11 18:24:49 2021 +0800 xwidget: Add xwidget-webkit-buffer-name-format. * lisp/xwidget.el (xwidget-webkit-buffer-name-prefix): Remove variable. (xwidget-webkit-buffer-name-format): New variable. (xwidget-webkit-callback): Use xwidget-webkit-buffer-name-format instead. (format-spec): required. * etc/NEWS: Note xwidget-webkit-buffer-name-format. diff --git a/etc/NEWS b/etc/NEWS index e0b1c35d81..2ce76769fe 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -454,8 +454,9 @@ This is a convenience function to extract the field data from ** Xwidgets --- -*** New user option 'xwidget-webkit-buffer-name-prefix'. -This allows the user to change the webkit buffer names. +*** New user option 'xwidget-webkit-buffer-name-format'. +Using this option you can control how the xwidget-webkit buffers are +named. +++ *** New minor mode 'xwidget-webkit-edit-mode'. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 2c7b4dd83d..8078f1d01b 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -33,6 +33,7 @@ (require 'cl-lib) (require 'bookmark) +(require 'format-spec) (declare-function make-xwidget "xwidget.c" (type title width height arguments &optional buffer related)) @@ -95,8 +96,11 @@ This returns the result of `make-xwidget'." :group 'web :prefix "xwidget-webkit-") -(defcustom xwidget-webkit-buffer-name-prefix "*xwidget-webkit: " - "Buffer name prefix used by `xwidget-webkit' buffers." +(defcustom xwidget-webkit-buffer-name-format "*xwidget-webkit: %T*" + "Template for naming `xwidget-webkit' buffers. +It can use the following special constructs: + + %T -- the title of the Web page loaded by the xwidget." :type 'string :version "29.1") @@ -372,9 +376,11 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." ;; Do not adjust webkit size to window here, the ;; selected window can be the mini-buffer window ;; unwantedly. - (rename-buffer (concat xwidget-webkit-buffer-name-prefix - title "*") - t))))) + (rename-buffer + (format-spec + xwidget-webkit-buffer-name-format + `((?T . ,title))) + t))))) ((eq xwidget-event-type 'decide-policy) (let ((strarg (nth 3 last-input-event))) (if (string-match ".*#\\(.*\\)" strarg) commit 12a638d845ec19f632f4257fbeaf00c9a87f7d54 Author: Stefan Kangas Date: Thu Nov 11 10:22:05 2021 +0100 ; * admin/gitmerge.el: Fix typos. diff --git a/admin/gitmerge.el b/admin/gitmerge.el index adb13fc4e2..67fca87c11 100644 --- a/admin/gitmerge.el +++ b/admin/gitmerge.el @@ -37,10 +37,10 @@ ;; up-to-date). ;; - Mark commits you'd like to skip, meaning to only merge their ;; metadata (merge strategy 'ours'). -;; - Hit 'm' to start merging. Skipped commits will be merged separately. +;; - Hit 'm' to start merging. Skipped commits will be merged separately. ;; - If conflicts cannot be resolved automatically, you'll have to do -;; it manually. In that case, resolve the conflicts and restart -;; gitmerge, which will automatically resume. It will add resolved +;; it manually. In that case, resolve the conflicts and restart +;; gitmerge, which will automatically resume. It will add resolved ;; files, commit the pending merge and continue merging the rest. ;; - Inspect master branch, and if everything looks OK, push. @@ -129,7 +129,7 @@ If nil, the function `gitmerge-default-branch' guesses.") (string-to-number (match-string 1)))) (defun gitmerge-default-branch () - "Default for branch that should be merged; eg \"origin/emacs-26\"." + "Default for branch that should be merged; e.g. \"origin/emacs-28\"." (or gitmerge-default-branch (format "origin/emacs-%s" (1- (gitmerge-emacs-version))))) @@ -472,7 +472,7 @@ Throw an user-error if we cannot resolve automatically." (if (not (zerop (call-process "git" nil t nil "diff" "--name-only" "--diff-filter=U"))) - (error "Error listing unmerged files. Resolve manually.") + (error "Error listing unmerged files. Resolve manually.") (goto-char (point-min)) (while (not (eobp)) (push (buffer-substring (point) (line-end-position)) files) commit 3020791e77872dbc757beb0ebdd8dbcb5b565f88 Author: Eli Zaretskii Date: Thu Nov 11 10:58:10 2021 +0200 Fix files-tests on MS-Windows * lisp/ls-lisp.el (ls-lisp--insert-directory): Fix free disk space calculation. (Bug#50630) * test/lisp/files-tests.el (files-tests-revert-buffer) (files-tests-revert-buffer-with-fine-grain): Disable locking files. diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el index 82153ff0ad..eea8089daa 100644 --- a/lisp/ls-lisp.el +++ b/lisp/ls-lisp.el @@ -343,7 +343,7 @@ are also supported; unsupported long options are silently ignored." (goto-char (point-min)) ;; First find the line to put it on. (when (re-search-forward "^total" nil t) - (let ((available (get-free-disk-space "."))) + (let ((available (get-free-disk-space orig-file))) (when available ;; Replace "total" with "total used", to avoid confusion. (replace-match "total used in directory") diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index d66ed62e28..787e6390a6 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -1531,10 +1531,13 @@ The door of all subtleties! (ert-with-temp-file temp-file-name (with-temp-buffer (insert files-tests-lao) - (write-file temp-file-name) - (erase-buffer) - (insert files-tests-tzu) - (revert-buffer t t t) + ;; Disable lock files, since that barfs in + ;; userlock--check-content-unchanged on MS-Windows. + (let (create-lockfiles) + (write-file temp-file-name) + (erase-buffer) + (insert files-tests-tzu) + (revert-buffer t t t)) (should (compare-strings files-tests-lao nil nil (buffer-substring (point-min) (point-max)) nil nil))))) @@ -1544,10 +1547,13 @@ The door of all subtleties! (ert-with-temp-file temp-file-name (with-temp-buffer (insert files-tests-lao) - (write-file temp-file-name) - (erase-buffer) - (insert files-tests-tzu) - (should (revert-buffer-with-fine-grain t t)) + ;; Disable lock files, since that barfs in + ;; userlock--check-content-unchanged on MS-Windows. + (let (create-lockfiles) + (write-file temp-file-name) + (erase-buffer) + (insert files-tests-tzu) + (should (revert-buffer-with-fine-grain t t))) (should (compare-strings files-tests-lao nil nil (buffer-substring (point-min) (point-max)) nil nil))))) commit f96380eb80c81824a2710b7d9846dd91b816abad Author: Po Lu Date: Thu Nov 11 14:54:58 2021 +0800 Fix documentation in xwidget.el * src/xwidget.el (xwidget-webkit-isearch-mode): Reword documentation. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 19b95066b0..2c7b4dd83d 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -983,7 +983,7 @@ Press \\\\[xwidget-webkit-isearch-exit] to exit (xwidget-webkit-finish-search (xwidget-webkit-current-session)))) (defun xwidget-webkit-isearch-yank-kill () - "Pull string from kill ring and append it to the current query." + "Append the most recent kill from `kill-ring' to the current query." (interactive) (unless xwidget-webkit-isearch-mode (xwidget-webkit-isearch-mode t)) commit 195f5a0dfa8152771a47c899fab5ba2fe2ed00fb Author: Po Lu Date: Thu Nov 11 10:13:42 2021 +0800 Switch to xwidget webkit buffer even if a session already exists * lisp/xwidget.el (xwidget-webkit-goto-url): Make behavior when there is an existing session consistent. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index cc149cf197..19b95066b0 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -762,7 +762,8 @@ Return the buffer." "Goto URL with xwidget webkit." (if (xwidget-webkit-current-session) (progn - (xwidget-webkit-goto-uri (xwidget-webkit-current-session) url)) + (xwidget-webkit-goto-uri (xwidget-webkit-current-session) url) + (switch-to-buffer (xwidget-buffer (xwidget-webkit-current-session)))) (xwidget-webkit-new-session url))) (defun xwidget-webkit-back () commit 3e234943940534cc55062b04db41000531f02615 Merge: f30f531159 2963de6540 Author: Stefan Kangas Date: Thu Nov 11 07:17:56 2021 +0100 Merge from origin/emacs-28 2963de6540 * lisp/vc/vc-git.el (vc-git-mergebase): More meaningful er... a9148cdee5 ; Fix heading in etc/NEWS 9623342216 ; * etc/NEWS: Move a bookmark related item further down. # Conflicts: # etc/NEWS commit f30f53115928fd65d066944d53d07742b0807670 Author: Tim Ruffing Date: Thu Nov 11 07:14:57 2021 +0100 Support Tc terminfo flag for 24-bit color support in terminal * src/term.c (init_tty): Use the Tc flag (bug#44950). Copyright-paperwork-exempt: yes diff --git a/etc/NEWS b/etc/NEWS index e32446997b..e0b1c35d81 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -46,6 +46,11 @@ time. * Changes in Emacs 29.1 +** Terminal Emacs + +--- +*** Emacs will now use 24-bit colors on terminal that support "Tc". + ** Emoji +++ diff --git a/src/term.c b/src/term.c index 6f0b827cfc..d86ae12ba8 100644 --- a/src/term.c +++ b/src/term.c @@ -4152,10 +4152,12 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ could return 32767. */ tty->TN_max_colors = 16777216; } - /* Fall back to xterm+direct (semicolon version) if requested - by the COLORTERM environment variable. */ - else if ((bg = getenv("COLORTERM")) != NULL - && strcasecmp(bg, "truecolor") == 0) + /* Fall back to xterm+direct (semicolon version) if Tc is set + (de-facto standard introduced by tmux) or if requested by + the COLORTERM environment variable. */ + else if (tigetflag("Tc") + || ((bg = getenv("COLORTERM")) != NULL + && strcasecmp(bg, "truecolor") == 0)) { tty->TS_set_foreground = "\033[%?%p1%{8}%<%t3%p1%d%e38;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m"; tty->TS_set_background = "\033[%?%p1%{8}%<%t4%p1%d%e48;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m"; commit 894dd18804ef766a87ffa4b4109125b4661651be Author: Gregory Heytings Date: Thu Nov 11 06:43:10 2021 +0100 Options to automatically stop the Emacs server * doc/emacs/misc.texi (Emacs Server): Document the new function. Also mention that an Emacs server can be started with emacsclient. * etc/NEWS: Describe the new function (bug#51377). * lisp/server.el (server-stop-automatically): New function. (server-stop-automatically): New auxiliary variable. (server-stop-automatically--maybe-kill-emacs) (server-stop-automatically--handle-delete-frame): New auxiliary functions. (server-save-buffers-kill-terminal): Call the new auxiliary function when necessary. diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index 4b3c2ea4bd..3d423d7675 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -1703,6 +1703,11 @@ options. @xref{Initial Options}. When Emacs is started this way, it calls @code{server-start} after initialization and does not open an initial frame. It then waits for edit requests from clients. +@item +Run the command @code{emacsclient} with the @samp{--alternate-editor=""} +command-line option. This starts an Emacs daemon only if no Emacs daemon +is already running. + @cindex systemd unit file @item If your operating system uses @command{systemd} to manage startup, @@ -1769,6 +1774,32 @@ you can give each daemon its own server name like this: emacs --daemon=foo @end example +@findex server-stop-automatically + The Emacs server can optionally be stopped automatically when +certain conditions are met. To do this, call the function +@code{server-stop-automatically} in your init file (@pxref{Init +File}), with one of the following arguments: + +@itemize +@item +With the argument @code{empty}, the server is stopped when it has no +clients, no unsaved file-visiting buffers and no running processes +anymore. + +@item +With the argument @code{delete-frame}, when the last client frame is +being closed, you are asked whether each unsaved file-visiting buffer +must be saved and each unfinished process can be stopped, and if so, +the server is stopped. + +@item +With the argument @code{kill-terminal}, when the last client frame is +being closed with @kbd{C-x C-c} (@code{save-buffers-kill-terminal}), +you are asked whether each unsaved file-visiting buffer must be saved +and each unfinished process can be stopped, and if so, the server is +stopped. +@end itemize + @findex server-eval-at If you have defined a server by a unique server name, it is possible to connect to the server from another Emacs instance and evaluate Lisp diff --git a/etc/NEWS b/etc/NEWS index 78ce3c067f..e32446997b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -139,6 +139,12 @@ suspicious and could be malicious. With this command-line option, Emacs reuses an existing graphical client frame if one exists; otherwise it creates a new frame. ++++ +*** 'server-stop-automatically' can be used to automatically stop the server. +The Emacs server will be automatically stopped when certain conditions +are met. The conditions are given by the argument, which can be +'empty', 'delete-frame' or 'kill-terminal'. + * Editing Changes in Emacs 29.1 --- diff --git a/lisp/server.el b/lisp/server.el index d998656237..deaaf07da8 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -1716,6 +1716,9 @@ be a cons cell (LINENUMBER . COLUMNNUMBER)." (when server-raise-frame (select-frame-set-input-focus (window-frame))))) +(defvar server-stop-automatically nil + "Internal status variable for `server-stop-automatically'.") + ;;;###autoload (defun server-save-buffers-kill-terminal (arg) ;; Called from save-buffers-kill-terminal in files.el. @@ -1724,27 +1727,101 @@ With ARG non-nil, silently save all file-visiting buffers, then kill. If emacsclient was started with a list of filenames to edit, then only these files will be asked to be saved." - (let ((proc (frame-parameter nil 'client))) - (cond ((eq proc 'nowait) - ;; Nowait frames have no client buffer list. - (if (cdr (frame-list)) - (progn (save-some-buffers arg) - (delete-frame)) - ;; If we're the last frame standing, kill Emacs. - (save-buffers-kill-emacs arg))) - ((processp proc) - (let ((buffers (process-get proc 'buffers))) - (save-some-buffers - arg (if buffers - ;; Only files from emacsclient file list. - (lambda () (memq (current-buffer) buffers)) - ;; No emacsclient file list: don't override - ;; `save-some-buffers-default-predicate' (unless - ;; ARG is non-nil), since we're not killing - ;; Emacs (unlike `save-buffers-kill-emacs'). - (and arg t))) - (server-delete-client proc))) - (t (error "Invalid client frame"))))) + (if server-stop-automatically + (server-stop-automatically--handle-delete-frame (selected-frame)) + (let ((proc (frame-parameter nil 'client))) + (cond ((eq proc 'nowait) + ;; Nowait frames have no client buffer list. + (if (cdr (frame-list)) + (progn (save-some-buffers arg) + (delete-frame)) + ;; If we're the last frame standing, kill Emacs. + (save-buffers-kill-emacs arg))) + ((processp proc) + (let ((buffers (process-get proc 'buffers))) + (save-some-buffers + arg (if buffers + ;; Only files from emacsclient file list. + (lambda () (memq (current-buffer) buffers)) + ;; No emacsclient file list: don't override + ;; `save-some-buffers-default-predicate' (unless + ;; ARG is non-nil), since we're not killing + ;; Emacs (unlike `save-buffers-kill-emacs'). + (and arg t))) + (server-delete-client proc))) + (t (error "Invalid client frame")))))) + +(defun server-stop-automatically--handle-delete-frame (frame) + "Handle deletion of FRAME when `server-stop-automatically' is used." + (when server-stop-automatically + (if (if (and (processp (frame-parameter frame 'client)) + (eq this-command 'save-buffers-kill-terminal)) + (progn + (dolist (f (frame-list)) + (when (and (eq (frame-parameter frame 'client) + (frame-parameter f 'client)) + (not (eq frame f))) + (set-frame-parameter f 'client nil) + (let ((server-stop-automatically nil)) + (delete-frame f)))) + (if (cddr (frame-list)) + (let ((server-stop-automatically nil)) + (delete-frame frame) + nil) + t)) + (null (cddr (frame-list)))) + (let ((server-stop-automatically nil)) + (save-buffers-kill-emacs) + (delete-frame frame))))) + +(defun server-stop-automatically--maybe-kill-emacs () + "Handle closing of Emacs daemon when `server-stop-automatically' is used." + (unless (cdr (frame-list)) + (when (and + (not (memq t (mapcar (lambda (b) + (and (buffer-file-name b) + (buffer-modified-p b))) + (buffer-list)))) + (not (memq t (mapcar (lambda (p) + (and (memq (process-status p) + '(run stop open listen)) + (process-query-on-exit-flag p))) + (process-list))))) + (kill-emacs)))) + +;;;###autoload +(defun server-stop-automatically (arg) + "Automatically stop server when possible. + +When ARG is 'empty, the server is stopped when it has no remaining +clients, no remaining unsaved file-visiting buffers, and no +running processes with a query-on-exit flag. + +When ARG is 'delete-frame, the user is asked when the last frame is +being closed whether each unsaved file-visiting buffer must be +saved and each running process with a query-on-exit flag can be +stopped, and if so, the server itself is stopped. + +When ARG is 'kill-terminal, the user is asked when the last frame +is being close with \\[save-buffers-kill-terminal] \ +whether each unsaved file-visiting +buffer must be saved and each running process with a query-on-exit +flag can be stopped, and if so, the server itself is stopped. + +This function is meant to be put in init files." + (when (daemonp) + (setq server-stop-automatically arg) + (cond + ((eq arg 'empty) + (setq server-stop-automatically nil) + (run-with-timer 10 2 + #'server-stop-automatically--maybe-kill-emacs)) + ((eq arg 'delete-frame) + (add-hook 'delete-frame-functions + #'server-stop-automatically--handle-delete-frame)) + ((eq arg 'kill-terminal)) + (t + (error "Unexpected argument"))))) (define-key ctl-x-map "#" 'server-edit) commit 0a93fb499b8885ffd87338f1ccc9cb5093f567c1 Author: Miha Rihtaršič Date: Thu Nov 11 06:16:52 2021 +0100 Set `minibuffer-completion-*` variables locally in more places * lisp/calc/calc-store.el (calc-read-var-name): * lisp/emacs-lisp/crm.el (completing-read-multiple): * lisp/progmodes/cc-styles.el (c-read-offset): * lisp/window.el (read-buffer-to-switch): Set `minibuffer-completion-*` variables buffer-locally instead of using a global let-binding (bug#48925). Follow-up to commit 2021-05-01 "* lisp/minibuffer.el (completing-read-default): Fix bug#45474" diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el index b3968555b6..de2f18f394 100644 --- a/lisp/calc/calc-store.el +++ b/lisp/calc/calc-store.el @@ -188,12 +188,15 @@ (let* ((calc-store-opers store-opers) (var (concat "var-" - (let ((minibuffer-completion-table - (mapcar (lambda (x) (substring x 4)) - (all-completions "var-" obarray))) - (minibuffer-completion-predicate - (lambda (x) (boundp (intern (concat "var-" x))))) - (minibuffer-completion-confirm t)) + (minibuffer-with-setup-hook + (lambda () + (setq-local minibuffer-completion-table + (mapcar (lambda (x) (substring x 4)) + (all-completions "var-" obarray))) + (setq-local minibuffer-completion-predicate + (lambda (x) + (boundp (intern (concat "var-" x))))) + (setq-local minibuffer-completion-confirm t)) (read-from-minibuffer prompt nil calc-var-name-map nil 'calc-read-var-name-history))))) diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index d24ea355a5..59cbc0e50d 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -244,30 +244,29 @@ contents of the minibuffer are \"alice,bob,eve\" and point is between This function returns a list of the strings that were read, with empty strings removed." - (unwind-protect - (progn - (add-hook 'choose-completion-string-functions - 'crm--choose-completion-string) - (let* ((minibuffer-completion-table #'crm--collection-fn) - (minibuffer-completion-predicate predicate) - ;; see completing_read in src/minibuf.c - (minibuffer-completion-confirm - (unless (eq require-match t) require-match)) - (crm-completion-table table) - (map (if require-match - crm-local-must-match-map - crm-local-completion-map)) - ;; If the user enters empty input, `read-from-minibuffer' - ;; returns the empty string, not DEF. - (input (read-from-minibuffer - prompt initial-input map - nil hist def inherit-input-method))) - (when (and def (string-equal input "")) - (setq input (if (consp def) (car def) def))) - ;; Remove empty strings in the list of read strings. - (split-string input crm-separator t))) - (remove-hook 'choose-completion-string-functions - 'crm--choose-completion-string))) + (let* ((map (if require-match + crm-local-must-match-map + crm-local-completion-map)) + input) + (minibuffer-with-setup-hook + (lambda () + (add-hook 'choose-completion-string-functions + 'crm--choose-completion-string nil 'local) + (setq-local minibuffer-completion-table #'crm--collection-fn) + (setq-local minibuffer-completion-predicate predicate) + ;; see completing_read in src/minibuf.c + (setq-local minibuffer-completion-confirm + (unless (eq require-match t) require-match)) + (setq-local crm-completion-table table)) + (setq input (read-from-minibuffer + prompt initial-input map + nil hist def inherit-input-method))) + ;; If the user enters empty input, `read-from-minibuffer' + ;; returns the empty string, not DEF. + (when (and def (string-equal input "")) + (setq input (if (consp def) (car def) def))) + ;; Remove empty strings in the list of read strings. + (split-string input crm-separator t))) ;; testing and debugging ;; (defun crm-init-test-environ () diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el index c6b6be5b39..4d518838d1 100644 --- a/lisp/progmodes/cc-styles.el +++ b/lisp/progmodes/cc-styles.el @@ -444,17 +444,19 @@ STYLE using `c-set-style' if the optional SET-P flag is non-nil." defstr)) (prompt (concat symname " offset " defstr)) (keymap (make-sparse-keymap)) - (minibuffer-completion-table obarray) - (minibuffer-completion-predicate 'fboundp) offset input) ;; In principle completing-read is used here, but SPC is unbound ;; to make it less annoying to enter lists. (set-keymap-parent keymap minibuffer-local-completion-map) (define-key keymap " " 'self-insert-command) (while (not offset) - (setq input (read-from-minibuffer prompt nil keymap t - 'c-read-offset-history - (format "%s" oldoff))) + (minibuffer-with-setup-hook + (lambda () + (setq-local minibuffer-completion-table obarray) + (setq-local minibuffer-completion-predicate 'fboundp)) + (setq input (read-from-minibuffer prompt nil keymap t + 'c-read-offset-history + (format "%s" oldoff)))) (if (c-valid-offset input) (setq offset input) ;; error, but don't signal one, keep trying diff --git a/lisp/window.el b/lisp/window.el index 2582743679..0f17bb28b4 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -8574,7 +8574,7 @@ from the list of completions and default values." (let ((rbts-completion-table (internal-complete-buffer-except))) (minibuffer-with-setup-hook (lambda () - (setq minibuffer-completion-table rbts-completion-table) + (setq-local minibuffer-completion-table rbts-completion-table) ;; Since rbts-completion-table is built dynamically, we ;; can't just add it to the default value of ;; icomplete-with-completion-tables, so we add it commit 396355f46b964d6a63ced9fe48fb6c7fb43d8f06 Author: Lars Ingebrigtsen Date: Thu Nov 11 05:22:02 2021 +0100 Re-fix charset issues when yanking non-plain-text elements * lisp/select.el (gui-get-selection): Make (gui-get-selection 'CLIPBOARD 'text/html) get decoded correctly (bug#31149), but still avoid the logic on Windows. diff --git a/lisp/select.el b/lisp/select.el index 3c9f961f6d..43424d94b3 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -304,22 +304,32 @@ the formats available in the clipboard if TYPE is `CLIPBOARD'." (let ((data (gui-backend-get-selection (or type 'PRIMARY) (or data-type 'STRING)))) (when (and (stringp data) - (setq data-type (get-text-property 0 'foreign-selection data))) + ;; If this text property is set, then the data needs to + ;; be decoded -- otherwise it has already been decoded + ;; by the lower level functions. + (get-text-property 0 'foreign-selection data)) (let ((coding (or next-selection-coding-system selection-coding-system (pcase data-type ('UTF8_STRING 'utf-8) ('COMPOUND_TEXT 'compound-text-with-extensions) ('C_STRING nil) - ('STRING 'iso-8859-1) - (_ (error "Unknown selection data type: %S" - type)))))) - (setq data (if coding (decode-coding-string data coding) - ;; This is for C_STRING case. + ('STRING 'iso-8859-1))))) + (setq data + (cond (coding (decode-coding-string data coding)) ;; We want to convert each non-ASCII byte to the ;; corresponding eight-bit character, which has ;; a codepoint >= #x3FFF00. - (string-to-multibyte data)))) + ((eq data-type 'C_STRING) + (string-to-multibyte data)) + ;; Guess at the charset for types like text/html + ;; -- it can be anything, and different + ;; applications use different encodings. + ((string-match-p "\\`text/" (symbol-name data-type)) + (decode-coding-string + data (car (detect-coding-string data)))) + ;; Do nothing. + (t data)))) (setq next-selection-coding-system nil) (put-text-property 0 (length data) 'foreign-selection data-type data)) data)) commit 42037d8948f0209a88c64949adf5016229e4beec Author: Lars Ingebrigtsen Date: Thu Nov 11 05:04:31 2021 +0100 Don't save places in literally-visited files * lisp/saveplace.el (save-places-to-alist): Don't save places in literally-visited files (bug#51740). diff --git a/lisp/saveplace.el b/lisp/saveplace.el index 4191a3fa62..3eff816fa0 100644 --- a/lisp/saveplace.el +++ b/lisp/saveplace.el @@ -328,11 +328,18 @@ may have changed) back to `save-place-alist'." (with-current-buffer (car buf-list) ;; save-place checks buffer-file-name too, but we can avoid ;; overhead of function call by checking here too. - (and (or buffer-file-name (and (derived-mode-p 'dired-mode) - (boundp 'dired-subdir-alist) - dired-subdir-alist - (dired-current-directory))) - (save-place-to-alist)) + (when (and (or buffer-file-name + (and (derived-mode-p 'dired-mode) + (boundp 'dired-subdir-alist) + dired-subdir-alist + (dired-current-directory))) + ;; Don't save place in literally-visited file + ;; because this will commonly differ from the place + ;; when visiting literally (and + ;; `find-file-literally' always places point at the + ;; start of the buffer). + (not find-file-literally)) + (save-place-to-alist)) (setq buf-list (cdr buf-list)))))) (defun save-place-find-file-hook () commit 9b80fe55f9725a039a2f367ffccea164c6ca9cf9 Author: John Cummings Date: Thu Nov 11 04:37:46 2021 +0100 Add tests for 'insert-directory' * test/lisp/files-tests.el: Add 'insert-directory' tests. * test/lisp/files-resources/insert-directory/: Create directories and files to use for testing 'insert-directory'. Add tests for 'insert-directory' base functionality and regression tests for the issue where free space was reported for the current directory instead of the target of 'list-directory' (Bug#50630). diff --git a/test/lisp/files-resources/insert-directory/test_dir/bar b/test/lisp/files-resources/insert-directory/test_dir/bar new file mode 100644 index 0000000000..e69de29bb2 diff --git a/test/lisp/files-resources/insert-directory/test_dir/foo b/test/lisp/files-resources/insert-directory/test_dir/foo new file mode 100644 index 0000000000..e69de29bb2 diff --git a/test/lisp/files-resources/insert-directory/test_dir_other/bar b/test/lisp/files-resources/insert-directory/test_dir_other/bar new file mode 100644 index 0000000000..e69de29bb2 diff --git a/test/lisp/files-resources/insert-directory/test_dir_other/foo b/test/lisp/files-resources/insert-directory/test_dir_other/foo new file mode 100644 index 0000000000..e69de29bb2 diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 1e20317739..d66ed62e28 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -1807,5 +1807,79 @@ Prompt users for any modified buffer with `buffer-offer-save' non-nil." (should (equal (file-name-split "/foo/bar/") '("" "foo" "bar" ""))) (should (equal (file-name-split "foo/bar/") '("foo" "bar" "")))) +;; `insert-directory' output tests. +(let* ((data-dir "insert-directory") + (test-dir (file-name-as-directory + (ert-resource-file + (concat data-dir "/test_dir")))) + (test-dir-other (file-name-as-directory + (ert-resource-file + (concat data-dir "/test_dir_other")))) + (test-files `(,test-dir "foo" "bar")) ;expected files to be found + ;; Free space test data for `insert-directory'. + ;; Meaning: (path free-space-bytes-to-stub expected-free-space-string) + (free-data `((,test-dir 10 "available 10 B") + (,test-dir-other 100 "available 100 B") + (:default 999 "available 999 B")))) + + + (defun files-tests--look-up-free-data (path) + "Look up free space test data, with a default for unspecified paths." + (let ((path (file-name-as-directory path))) + (cdr (or (assoc path free-data) + (assoc :default free-data))))) + + (defun files-tests--make-file-system-info-stub (&optional static-path) + "Return a stub for `file-system-info' using dynamic or static test data. +If that data should be static, pass STATIC-PATH to choose which +path's data to use." + (lambda (path) + (let* ((path (cond (static-path) + ;; file-system-info knows how to handle ".", so we + ;; do the same thing + ((equal "." path) default-directory) + (path))) + (return-size + (car (files-tests--look-up-free-data path)))) + (list return-size return-size return-size)))) + + (defun files-tests--insert-directory-output (dir &optional verbose) + "Run `insert-directory' and return its output." + (with-current-buffer-window "files-tests--insert-directory" nil nil + (insert-directory dir "-l" nil t) + (buffer-substring-no-properties (point-min) (point-max)))) + + (ert-deftest files-tests-insert-directory-shows-files () + "Verify `insert-directory' reports the files in the directory." + (let* ((test-dir (car test-files)) + (files (cdr test-files)) + (output (files-tests--insert-directory-output test-dir))) + (dolist (file files) + (should (string-match-p file output))))) + + (defun files-tests--insert-directory-shows-given-free (dir &optional + info-func) + "Run `insert-directory' and verify it reports the correct available space. +Stub `file-system-info' to ensure the available space is consistent, +either with the given stub function or a default one using test data." + (cl-letf (((symbol-function 'file-system-info) + (or info-func + (files-tests--make-file-system-info-stub)))) + (should (string-match-p (cadr + (files-tests--look-up-free-data dir)) + (files-tests--insert-directory-output dir t))))) + + (ert-deftest files-tests-insert-directory-shows-free () + "Test that verbose `insert-directory' shows the correct available space." + (files-tests--insert-directory-shows-given-free + test-dir + (files-tests--make-file-system-info-stub test-dir))) + + (ert-deftest files-tests-bug-50630 () + "Verify verbose `insert-directory' shows free space of the target directory. +The current directory at call time should not affect the result (Bug#50630)." + (let ((default-directory test-dir-other)) + (files-tests--insert-directory-shows-given-free test-dir)))) + (provide 'files-tests) ;;; files-tests.el ends here commit 6c405b7a4915bd3604d6591ff9156cf1cf77fecb Author: Lars Ingebrigtsen Date: Thu Nov 11 04:08:51 2021 +0100 Note that loaddefs.el is copied to ldefs-boot.el * lisp/emacs-lisp/autoload.el (autoload-rubric): Add a comment to the file noting what'll happen to it. diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index aaacba2c8e..148fb70981 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -393,6 +393,8 @@ FILE's name." (concat ";;; " basename " --- automatically extracted " (or type "autoloads") " -*- lexical-binding: t -*-\n" + (when (equal basename "loaddefs.el") + ";; This file will be copied to ldefs-boot.el and checked in periodically.\n") ";;\n" ";;; Code:\n\n" (if lp commit b73e90407056fc20c5fd60ae4f5b4fdbb73f4998 Author: Lars Ingebrigtsen Date: Thu Nov 11 04:02:43 2021 +0100 Re-generated to get autoloads additions in emoji.el diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 4b9505a135..2eae134e3d 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -10510,6 +10510,40 @@ Emerge two RCS revisions of a file, with another revision as ancestor. (register-definition-prefixes "emerge" '("emerge-")) +;;;*** + +;;;### (autoloads nil "emoji" "international/emoji.el" (0 0 0 0)) +;;; Generated autoloads from international/emoji.el + +(autoload 'emoji-insert "emoji" "\ +Choose and insert an emoji glyph. +If TEXT (interactively, the prefix), use a textual search instead +of a visual interface. + +\(fn &optional TEXT)" t nil) + +(autoload 'emoji-recent "emoji" "\ +Choose and insert a recently used emoji glyph." t nil) + +(autoload 'emoji-search "emoji" "\ +Choose and insert an emoji glyph by searching for an emoji name." t nil) + +(autoload 'emoji-list "emoji" "\ +List emojis and insert the one that's selected. +The character will be inserted into the buffer that was selected +when the command was issued." t nil) + +(autoload 'emoji-describe "emoji" "\ +Say what the name of the composed grapheme cluster GLYPH is. +If it's not known, this function returns nil. + +Interactively, it will message what the name of the emoji (or +character) under point is. + +\(fn GLYPH &optional INTERACTIVE)" t nil) + +(register-definition-prefixes "emoji" '("emoji-")) + ;;;*** ;;;### (autoloads nil "enriched" "textmodes/enriched.el" (0 0 0 0)) @@ -11997,14 +12031,14 @@ Fetch URL and render the page. If the input doesn't look like an URL or a domain name, the word(s) will be searched for via `eww-search-prefix'. -If called with a prefix ARG, use a new buffer instead of reusing -the default EWW buffer. +If NEW-BUFFER is non-nil (interactively, the prefix arg), use a +new buffer instead of reusing the default EWW buffer. If BUFFER, the data to be rendered is in that buffer. In that case, this function doesn't actually fetch URL. BUFFER will be killed after rendering. -\(fn URL &optional ARG BUFFER)" t nil) +\(fn URL &optional NEW-BUFFER BUFFER)" t nil) (defalias 'browse-web 'eww) (autoload 'eww-open-file "eww" "\ @@ -18302,7 +18336,11 @@ specifying the X and Y positions and WIDTH and HEIGHT of image area to insert. A float value 0.0 - 1.0 means relative to the width or height of the image; integer values are taken as pixel values. -\(fn IMAGE &optional STRING AREA SLICE)" nil nil) +Normally `isearch' is able to search for STRING in the buffer +even if it's hidden behind a displayed image. If INHIBIT-ISEARCH +is non-nil, this is inhibited. + +\(fn IMAGE &optional STRING AREA SLICE INHIBIT-ISEARCH)" nil nil) (autoload 'insert-sliced-image "image" "\ Insert IMAGE into current buffer at point. @@ -18487,7 +18525,7 @@ Jump to thumbnail buffer." t nil) (autoload 'image-dired-minor-mode "image-dired" "\ Setup easy-to-use keybindings for the commands to be used in Dired mode. Note that n, p and and will be hijacked and bound to -`image-dired-dired-x-line'. +`image-dired-dired-next-line' and `image-dired-dired-previous-line'. This is a minor mode. If called interactively, toggle the `Image-Dired minor mode' mode. If the prefix argument is positive, @@ -20982,6 +21020,12 @@ current header, calls `mail-complete-function' and passes prefix ARG if any. ;;;### (autoloads nil "mailcap" "net/mailcap.el" (0 0 0 0)) ;;; Generated autoloads from net/mailcap.el +(autoload 'mailcap-mime-type-to-extension "mailcap" "\ +Return a file name extension based on a mime type. +For instance, `image/png' will result in `png'. + +\(fn MIME-TYPE)" nil nil) + (register-definition-prefixes "mailcap" '("mailcap-")) ;;;*** @@ -22274,6 +22318,8 @@ specifies how the attachment is intended to be displayed. It can be either \"inline\" (displayed automatically within the message body) or \"attachment\" (separate from the body). +Also see the `mml-attach-file-at-the-end' variable. + If given a prefix interactively, no prompting will be done for the TYPE, DESCRIPTION or DISPOSITION values. Instead defaults will be computed and used. @@ -25930,10 +25976,26 @@ Prettify the current buffer with printed representation of a Lisp object." t nil Output the pretty-printed representation of OBJECT, any Lisp object. Quoting characters are printed as needed to make output that `read' can handle, whenever this is possible. + +This function does not apply special formatting rules for Emacs +Lisp code. See `pp-emacs-lisp-code' instead. + +By default, this function won't limit the line length of lists +and vectors. Bind `pp-use-max-width' to a non-nil value to do so. + Output stream is STREAM, or value of `standard-output' (which see). \(fn OBJECT &optional STREAM)" nil nil) +(autoload 'pp-display-expression "pp" "\ +Prettify and display EXPRESSION in an appropriate way, depending on length. +If LISP, format with `pp-emacs-lisp-code'; use `pp' otherwise. + +If a temporary buffer is needed for representation, it will be named +after OUT-BUFFER-NAME. + +\(fn EXPRESSION OUT-BUFFER-NAME &optional LISP)" nil nil) + (autoload 'pp-eval-expression "pp" "\ Evaluate EXPRESSION and pretty-print its value. Also add the value to the front of the list in the variable `values'. @@ -25959,6 +26021,12 @@ Ignores leading comment characters. \(fn ARG)" t nil) +(autoload 'pp-emacs-lisp-code "pp" "\ +Insert SEXP into the current buffer, formatted as Emacs Lisp code. +Use the `pp-max-width' variable to control the desired line length. + +\(fn SEXP)" nil nil) + (register-definition-prefixes "pp" '("pp-")) ;;;*** @@ -32419,14 +32487,14 @@ If OMIT-NULLS, empty lines will be removed from the results. \(fn STRING &optional OMIT-NULLS)" nil nil) (autoload 'ensure-empty-lines "subr-x" "\ -Ensure that there's LINES number of empty lines before point. -If LINES is nil or missing, a this ensures that there's a single -empty line before point. +Ensure that there are LINES number of empty lines before point. +If LINES is nil or omitted, ensure that there is a single empty +line before point. -Interactively, this command uses the numerical prefix for LINES. +If called interactively, LINES is given by the prefix argument. -If there's already more empty lines before point than LINES, the -number of blank lines will be reduced. +If there are more than LINES empty lines before point, the number +of empty lines is reduced to LINES. If point is not at the beginning of a line, a newline character is inserted before adjusting the number of empty lines. @@ -36539,6 +36607,10 @@ For old-style locking-based version control systems, like RCS: If every file is locked by you and unchanged, unlock them. If every file is locked by someone else, offer to steal the lock. +When using this command to register a new file (or files), it +will automatically deduce which VC repository to register it +with, using the most specific one. + \(fn VERBOSE)" t nil) (autoload 'vc-register "vc" "\ @@ -39345,7 +39417,7 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT. (autoload 'xref-find-backend "xref" nil nil nil) -(defalias 'xref-pop-marker-stack #'xref-go-back) +(define-obsolete-function-alias 'xref-pop-marker-stack #'xref-go-back "29.1") (autoload 'xref-go-back "xref" "\ Go back to the previous position in xref history. @@ -39523,6 +39595,33 @@ Interactively, URL defaults to the string looking like a url around point. (register-definition-prefixes "xwidget" '("xwidget-")) +;;;*** + +;;;### (autoloads nil "yank-media" "yank-media.el" (0 0 0 0)) +;;; Generated autoloads from yank-media.el + +(autoload 'yank-media "yank-media" "\ +Yank media (images, HTML and the like) from the clipboard. +This command depends on the current major mode having support for +accepting the media type. The mode has to register itself using +the `yank-media-handler' mechanism. + +Also see `yank-media-types' for a command that lets you explore +all the different selection types." t nil) + +(autoload 'yank-media-handler "yank-media" "\ +Register HANDLER for dealing with `yank-media' actions for TYPES. +TYPES should be a MIME media type symbol, a regexp, or a list +that can contain both symbols and regexps. + +HANDLER is a function that will be called with two arguments: The +MIME type (a symbol on the form `image/png') and the selection +data (a string). + +\(fn TYPES HANDLER)" nil nil) + +(register-definition-prefixes "yank-media" '("yank-media-")) + ;;;*** ;;;### (autoloads nil "yenc" "mail/yenc.el" (0 0 0 0)) @@ -39558,57 +39657,59 @@ Zone out, completely." t nil) ;;;*** ;;;### (autoloads nil nil ("abbrev.el" "bindings.el" "buff-menu.el" -;;;;;; "button.el" "calc/calc-aent.el" "calc/calc-embed.el" "calc/calc-misc.el" -;;;;;; "calc/calc-yank.el" "calendar/cal-loaddefs.el" "calendar/diary-loaddefs.el" -;;;;;; "calendar/hol-loaddefs.el" "case-table.el" "cedet/ede/base.el" -;;;;;; "cedet/ede/config.el" "cedet/ede/cpp-root.el" "cedet/ede/custom.el" -;;;;;; "cedet/ede/dired.el" "cedet/ede/emacs.el" "cedet/ede/files.el" -;;;;;; "cedet/ede/generic.el" "cedet/ede/linux.el" "cedet/ede/locate.el" -;;;;;; "cedet/ede/make.el" "cedet/ede/shell.el" "cedet/ede/speedbar.el" -;;;;;; "cedet/ede/system.el" "cedet/ede/util.el" "cedet/semantic/analyze.el" -;;;;;; "cedet/semantic/analyze/complete.el" "cedet/semantic/analyze/refs.el" -;;;;;; "cedet/semantic/bovine.el" "cedet/semantic/bovine/c-by.el" -;;;;;; "cedet/semantic/bovine/c.el" "cedet/semantic/bovine/el.el" -;;;;;; "cedet/semantic/bovine/gcc.el" "cedet/semantic/bovine/make-by.el" -;;;;;; "cedet/semantic/bovine/make.el" "cedet/semantic/bovine/scm-by.el" -;;;;;; "cedet/semantic/bovine/scm.el" "cedet/semantic/complete.el" -;;;;;; "cedet/semantic/ctxt.el" "cedet/semantic/db-file.el" "cedet/semantic/db-find.el" -;;;;;; "cedet/semantic/db-global.el" "cedet/semantic/db-mode.el" -;;;;;; "cedet/semantic/db-typecache.el" "cedet/semantic/db.el" "cedet/semantic/debug.el" -;;;;;; "cedet/semantic/decorate/include.el" "cedet/semantic/decorate/mode.el" -;;;;;; "cedet/semantic/dep.el" "cedet/semantic/doc.el" "cedet/semantic/edit.el" -;;;;;; "cedet/semantic/find.el" "cedet/semantic/format.el" "cedet/semantic/grammar-wy.el" +;;;;;; "button.el" "calc/calc-aent.el" "calc/calc-embed.el" "calc/calc-loaddefs.el" +;;;;;; "calc/calc-misc.el" "calc/calc-yank.el" "calendar/cal-loaddefs.el" +;;;;;; "calendar/diary-loaddefs.el" "calendar/hol-loaddefs.el" "case-table.el" +;;;;;; "cedet/ede/cpp-root.el" "cedet/ede/custom.el" "cedet/ede/dired.el" +;;;;;; "cedet/ede/emacs.el" "cedet/ede/files.el" "cedet/ede/generic.el" +;;;;;; "cedet/ede/linux.el" "cedet/ede/loaddefs.el" "cedet/ede/locate.el" +;;;;;; "cedet/ede/make.el" "cedet/ede/speedbar.el" "cedet/ede/system.el" +;;;;;; "cedet/ede/util.el" "cedet/semantic/analyze.el" "cedet/semantic/analyze/complete.el" +;;;;;; "cedet/semantic/analyze/refs.el" "cedet/semantic/bovine.el" +;;;;;; "cedet/semantic/bovine/c-by.el" "cedet/semantic/bovine/c.el" +;;;;;; "cedet/semantic/bovine/el.el" "cedet/semantic/bovine/gcc.el" +;;;;;; "cedet/semantic/bovine/make-by.el" "cedet/semantic/bovine/make.el" +;;;;;; "cedet/semantic/bovine/scm-by.el" "cedet/semantic/bovine/scm.el" +;;;;;; "cedet/semantic/complete.el" "cedet/semantic/ctxt.el" "cedet/semantic/db-file.el" +;;;;;; "cedet/semantic/db-find.el" "cedet/semantic/db-global.el" +;;;;;; "cedet/semantic/db-mode.el" "cedet/semantic/db-typecache.el" +;;;;;; "cedet/semantic/db.el" "cedet/semantic/debug.el" "cedet/semantic/decorate/include.el" +;;;;;; "cedet/semantic/decorate/mode.el" "cedet/semantic/dep.el" +;;;;;; "cedet/semantic/doc.el" "cedet/semantic/edit.el" "cedet/semantic/find.el" +;;;;;; "cedet/semantic/format.el" "cedet/semantic/grammar-wy.el" ;;;;;; "cedet/semantic/grm-wy-boot.el" "cedet/semantic/html.el" ;;;;;; "cedet/semantic/ia-sb.el" "cedet/semantic/ia.el" "cedet/semantic/idle.el" ;;;;;; "cedet/semantic/imenu.el" "cedet/semantic/lex-spp.el" "cedet/semantic/lex.el" -;;;;;; "cedet/semantic/mru-bookmark.el" "cedet/semantic/scope.el" -;;;;;; "cedet/semantic/senator.el" "cedet/semantic/sort.el" "cedet/semantic/symref.el" -;;;;;; "cedet/semantic/symref/cscope.el" "cedet/semantic/symref/global.el" -;;;;;; "cedet/semantic/symref/grep.el" "cedet/semantic/symref/idutils.el" -;;;;;; "cedet/semantic/symref/list.el" "cedet/semantic/tag-file.el" -;;;;;; "cedet/semantic/tag-ls.el" "cedet/semantic/tag-write.el" +;;;;;; "cedet/semantic/loaddefs.el" "cedet/semantic/mru-bookmark.el" +;;;;;; "cedet/semantic/scope.el" "cedet/semantic/senator.el" "cedet/semantic/sort.el" +;;;;;; "cedet/semantic/symref.el" "cedet/semantic/symref/cscope.el" +;;;;;; "cedet/semantic/symref/global.el" "cedet/semantic/symref/grep.el" +;;;;;; "cedet/semantic/symref/idutils.el" "cedet/semantic/symref/list.el" +;;;;;; "cedet/semantic/tag-file.el" "cedet/semantic/tag-ls.el" "cedet/semantic/tag-write.el" ;;;;;; "cedet/semantic/tag.el" "cedet/semantic/texi.el" "cedet/semantic/util-modes.el" ;;;;;; "cedet/semantic/wisent/java-tags.el" "cedet/semantic/wisent/javascript.el" ;;;;;; "cedet/semantic/wisent/javat-wy.el" "cedet/semantic/wisent/js-wy.el" ;;;;;; "cedet/semantic/wisent/python-wy.el" "cedet/semantic/wisent/python.el" ;;;;;; "cedet/srecode/compile.el" "cedet/srecode/cpp.el" "cedet/srecode/document.el" ;;;;;; "cedet/srecode/el.el" "cedet/srecode/expandproto.el" "cedet/srecode/getset.el" -;;;;;; "cedet/srecode/insert.el" "cedet/srecode/java.el" "cedet/srecode/map.el" -;;;;;; "cedet/srecode/mode.el" "cedet/srecode/srt-wy.el" "cedet/srecode/srt.el" -;;;;;; "cedet/srecode/template.el" "cedet/srecode/texi.el" "composite.el" -;;;;;; "cus-face.el" "cus-start.el" "custom.el" "dired-aux.el" "dired-x.el" +;;;;;; "cedet/srecode/insert.el" "cedet/srecode/java.el" "cedet/srecode/loaddefs.el" +;;;;;; "cedet/srecode/map.el" "cedet/srecode/mode.el" "cedet/srecode/srt-wy.el" +;;;;;; "cedet/srecode/srt.el" "cedet/srecode/template.el" "cedet/srecode/texi.el" +;;;;;; "composite.el" "cus-face.el" "cus-load.el" "cus-start.el" +;;;;;; "custom.el" "dired-aux.el" "dired-loaddefs.el" "dired-x.el" ;;;;;; "electric.el" "emacs-lisp/backquote.el" "emacs-lisp/byte-run.el" -;;;;;; "emacs-lisp/cl-extra.el" "emacs-lisp/cl-macs.el" "emacs-lisp/cl-preloaded.el" -;;;;;; "emacs-lisp/cl-seq.el" "emacs-lisp/easymenu.el" "emacs-lisp/eieio-compat.el" -;;;;;; "emacs-lisp/eieio-custom.el" "emacs-lisp/eieio-opt.el" "emacs-lisp/float-sup.el" -;;;;;; "emacs-lisp/lisp-mode.el" "emacs-lisp/lisp.el" "emacs-lisp/macroexp.el" -;;;;;; "emacs-lisp/map-ynp.el" "emacs-lisp/nadvice.el" "emacs-lisp/shorthands.el" -;;;;;; "emacs-lisp/syntax.el" "emacs-lisp/timer.el" "env.el" "epa-hook.el" -;;;;;; "erc/erc-autoaway.el" "erc/erc-button.el" "erc/erc-capab.el" -;;;;;; "erc/erc-compat.el" "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" +;;;;;; "emacs-lisp/cl-extra.el" "emacs-lisp/cl-loaddefs.el" "emacs-lisp/cl-macs.el" +;;;;;; "emacs-lisp/cl-preloaded.el" "emacs-lisp/cl-seq.el" "emacs-lisp/easymenu.el" +;;;;;; "emacs-lisp/eieio-compat.el" "emacs-lisp/eieio-custom.el" +;;;;;; "emacs-lisp/eieio-loaddefs.el" "emacs-lisp/eieio-opt.el" +;;;;;; "emacs-lisp/float-sup.el" "emacs-lisp/lisp-mode.el" "emacs-lisp/lisp.el" +;;;;;; "emacs-lisp/macroexp.el" "emacs-lisp/map-ynp.el" "emacs-lisp/nadvice.el" +;;;;;; "emacs-lisp/shorthands.el" "emacs-lisp/syntax.el" "emacs-lisp/timer.el" +;;;;;; "env.el" "epa-hook.el" "erc/erc-autoaway.el" "erc/erc-button.el" +;;;;;; "erc/erc-capab.el" "erc/erc-compat.el" "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" ;;;;;; "erc/erc-ezbounce.el" "erc/erc-fill.el" "erc/erc-identd.el" -;;;;;; "erc/erc-imenu.el" "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el" -;;;;;; "erc/erc-match.el" "erc/erc-menu.el" "erc/erc-netsplit.el" +;;;;;; "erc/erc-imenu.el" "erc/erc-join.el" "erc/erc-list.el" "erc/erc-loaddefs.el" +;;;;;; "erc/erc-log.el" "erc/erc-match.el" "erc/erc-menu.el" "erc/erc-netsplit.el" ;;;;;; "erc/erc-notify.el" "erc/erc-page.el" "erc/erc-pcomplete.el" ;;;;;; "erc/erc-replace.el" "erc/erc-ring.el" "erc/erc-services.el" ;;;;;; "erc/erc-sound.el" "erc/erc-speedbar.el" "erc/erc-spelling.el" @@ -39619,13 +39720,25 @@ Zone out, completely." t nil) ;;;;;; "eshell/em-ls.el" "eshell/em-pred.el" "eshell/em-prompt.el" ;;;;;; "eshell/em-rebind.el" "eshell/em-script.el" "eshell/em-smart.el" ;;;;;; "eshell/em-term.el" "eshell/em-tramp.el" "eshell/em-unix.el" -;;;;;; "eshell/em-xtra.el" "faces.el" "files.el" "font-core.el" -;;;;;; "font-lock.el" "format.el" "frame.el" "help.el" "hfy-cmap.el" -;;;;;; "ibuf-ext.el" "indent.el" "international/characters.el" "international/charscript.el" -;;;;;; "international/cp51932.el" "international/emoji-zwj.el" "international/eucjp-ms.el" +;;;;;; "eshell/em-xtra.el" "eshell/esh-groups.el" "faces.el" "files.el" +;;;;;; "finder-inf.el" "font-core.el" "font-lock.el" "format.el" +;;;;;; "frame.el" "help.el" "hfy-cmap.el" "htmlfontify-loaddefs.el" +;;;;;; "ibuf-ext.el" "ibuffer-loaddefs.el" "indent.el" "international/characters.el" +;;;;;; "international/charprop.el" "international/charscript.el" +;;;;;; "international/cp51932.el" "international/emoji-labels.el" +;;;;;; "international/emoji-zwj.el" "international/eucjp-ms.el" ;;;;;; "international/iso-transl.el" "international/mule-cmds.el" -;;;;;; "international/mule-conf.el" "international/mule.el" "isearch.el" -;;;;;; "jit-lock.el" "jka-cmpr-hook.el" "language/burmese.el" "language/cham.el" +;;;;;; "international/mule-conf.el" "international/mule.el" "international/uni-bidi.el" +;;;;;; "international/uni-brackets.el" "international/uni-category.el" +;;;;;; "international/uni-combining.el" "international/uni-comment.el" +;;;;;; "international/uni-decimal.el" "international/uni-decomposition.el" +;;;;;; "international/uni-digit.el" "international/uni-lowercase.el" +;;;;;; "international/uni-mirrored.el" "international/uni-name.el" +;;;;;; "international/uni-numeric.el" "international/uni-old-name.el" +;;;;;; "international/uni-special-lowercase.el" "international/uni-special-titlecase.el" +;;;;;; "international/uni-special-uppercase.el" "international/uni-titlecase.el" +;;;;;; "international/uni-uppercase.el" "isearch.el" "jit-lock.el" +;;;;;; "jka-cmpr-hook.el" "language/burmese.el" "language/cham.el" ;;;;;; "language/chinese.el" "language/cyrillic.el" "language/czech.el" ;;;;;; "language/english.el" "language/ethiopic.el" "language/european.el" ;;;;;; "language/georgian.el" "language/greek.el" "language/hebrew.el" @@ -39652,30 +39765,33 @@ Zone out, completely." t nil) ;;;;;; "leim/quail/sgml-input.el" "leim/quail/slovak.el" "leim/quail/symbol-ksc.el" ;;;;;; "leim/quail/tamil-dvorak.el" "leim/quail/tsang-b5.el" "leim/quail/tsang-cns.el" ;;;;;; "leim/quail/vntelex.el" "leim/quail/vnvni.el" "leim/quail/welsh.el" -;;;;;; "loadup.el" "mail/blessmail.el" "mail/rmailedit.el" "mail/rmailkwd.el" -;;;;;; "mail/rmailmm.el" "mail/rmailmsc.el" "mail/rmailsort.el" -;;;;;; "mail/rmailsum.el" "mail/undigest.el" "menu-bar.el" "mh-e/mh-gnus.el" -;;;;;; "mh-e/mh-loaddefs.el" "minibuffer.el" "mouse.el" "net/tramp-loaddefs.el" -;;;;;; "newcomment.el" "obarray.el" "org/ob-core.el" "org/ob-lob.el" -;;;;;; "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el" "org/ol-bbdb.el" -;;;;;; "org/ol-irc.el" "org/ol.el" "org/org-archive.el" "org/org-attach.el" -;;;;;; "org/org-clock.el" "org/org-colview.el" "org/org-compat.el" -;;;;;; "org/org-datetree.el" "org/org-duration.el" "org/org-element.el" -;;;;;; "org/org-feed.el" "org/org-footnote.el" "org/org-goto.el" -;;;;;; "org/org-id.el" "org/org-indent.el" "org/org-install.el" -;;;;;; "org/org-keys.el" "org/org-lint.el" "org/org-list.el" "org/org-macs.el" +;;;;;; "loadup.el" "mail/blessmail.el" "mail/rmail-loaddefs.el" +;;;;;; "mail/rmailedit.el" "mail/rmailkwd.el" "mail/rmailmm.el" +;;;;;; "mail/rmailmsc.el" "mail/rmailsort.el" "mail/rmailsum.el" +;;;;;; "mail/undigest.el" "menu-bar.el" "mh-e/mh-gnus.el" "mh-e/mh-loaddefs.el" +;;;;;; "minibuffer.el" "mouse.el" "net/tramp-loaddefs.el" "newcomment.el" +;;;;;; "obarray.el" "org/ob-core.el" "org/ob-lob.el" "org/ob-matlab.el" +;;;;;; "org/ob-tangle.el" "org/ob.el" "org/ol-bbdb.el" "org/ol-irc.el" +;;;;;; "org/ol.el" "org/org-archive.el" "org/org-attach.el" "org/org-clock.el" +;;;;;; "org/org-colview.el" "org/org-compat.el" "org/org-datetree.el" +;;;;;; "org/org-duration.el" "org/org-element.el" "org/org-feed.el" +;;;;;; "org/org-footnote.el" "org/org-goto.el" "org/org-id.el" "org/org-indent.el" +;;;;;; "org/org-install.el" "org/org-keys.el" "org/org-lint.el" +;;;;;; "org/org-list.el" "org/org-loaddefs.el" "org/org-macs.el" ;;;;;; "org/org-mobile.el" "org/org-num.el" "org/org-plot.el" "org/org-refile.el" ;;;;;; "org/org-table.el" "org/org-timer.el" "org/ox-ascii.el" "org/ox-beamer.el" ;;;;;; "org/ox-html.el" "org/ox-icalendar.el" "org/ox-latex.el" ;;;;;; "org/ox-md.el" "org/ox-odt.el" "org/ox-org.el" "org/ox-publish.el" ;;;;;; "org/ox-texinfo.el" "org/ox.el" "paren.el" "progmodes/elisp-mode.el" -;;;;;; "progmodes/prog-mode.el" "ps-mule.el" "register.el" "replace.el" -;;;;;; "rfn-eshadow.el" "select.el" "simple.el" "startup.el" "subdirs.el" -;;;;;; "subr.el" "tab-bar.el" "textmodes/fill.el" "textmodes/makeinfo.el" -;;;;;; "textmodes/page.el" "textmodes/paragraphs.el" "textmodes/reftex-auc.el" -;;;;;; "textmodes/reftex-cite.el" "textmodes/reftex-dcr.el" "textmodes/reftex-global.el" -;;;;;; "textmodes/reftex-index.el" "textmodes/reftex-parse.el" "textmodes/reftex-ref.el" -;;;;;; "textmodes/reftex-sel.el" "textmodes/reftex-toc.el" "textmodes/texnfo-upd.el" +;;;;;; "progmodes/prog-mode.el" "ps-mule.el" "ps-print-loaddefs.el" +;;;;;; "register.el" "replace.el" "rfn-eshadow.el" "select.el" "simple.el" +;;;;;; "startup.el" "subdirs.el" "subr.el" "tab-bar.el" "textmodes/fill.el" +;;;;;; "textmodes/makeinfo.el" "textmodes/page.el" "textmodes/paragraphs.el" +;;;;;; "textmodes/reftex-auc.el" "textmodes/reftex-cite.el" "textmodes/reftex-dcr.el" +;;;;;; "textmodes/reftex-global.el" "textmodes/reftex-index.el" +;;;;;; "textmodes/reftex-loaddefs.el" "textmodes/reftex-parse.el" +;;;;;; "textmodes/reftex-ref.el" "textmodes/reftex-sel.el" "textmodes/reftex-toc.el" +;;;;;; "textmodes/texinfo-loaddefs.el" "textmodes/texnfo-upd.el" ;;;;;; "textmodes/text-mode.el" "uniquify.el" "vc/ediff-hook.el" ;;;;;; "vc/vc-hooks.el" "version.el" "widget.el" "window.el") (0 ;;;;;; 0 0 0)) commit 3d253fa3aa7316adcc69864c6c1cd0f9bd7a18cb Author: Po Lu Date: Wed Nov 10 21:01:40 2021 +0800 Add `xwidget-webkit-load-html' * doc/lispref/display.texi (Xwidgets): Document new function. * etc/NEWS: Announce new function. * src/xwidget.c (Fxwidget_webkit_load_html): New function. (syms_of_xwidget): Define new subr. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index b6bd14f887..ad1077e0c4 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -6943,6 +6943,16 @@ Finish a search operation started with @code{xwidget-webkit-search} in signals an error. @end defun +@defun xwidget-webkit-load-html xwidget text &optional base-uri +Load @var{text}, a string, into @var{xwidget}, which should be a +WebKit xwidget. Any HTML markup in @var{text} will be processed +by @var{xwidget} while rendering the text. + +Optional argument @var{base-uri}, which should be a string, specifies +the absolute location of the web resources referenced by @var{text}, +to be used for resolving relative links in @var{text}. +@end defun + @node Buttons @section Buttons @cindex buttons in buffers diff --git a/etc/NEWS b/etc/NEWS index b403be65da..78ce3c067f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -735,6 +735,13 @@ what the widget will actually receive. On GTK+, only key and function key events are implemented. ++++ +*** New function 'xwidget-webkit-load-html'. +This function is used to load HTML text into WebKit xwidgets +directly, in contrast to creating a temporary file to hold the +markup, and passing the URI of the file as an argument to +'xwidget-webkit-goto-uri'. + +++ *** New functions for performing searches on WebKit xwidgets. Some new functions, such as 'xwidget-webkit-search', have been added diff --git a/src/xwidget.c b/src/xwidget.c index 2ae635092d..fc05f4f570 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -2278,6 +2278,44 @@ using `xwidget-webkit-search'. */) return Qnil; } +#ifdef USE_GTK +DEFUN ("xwidget-webkit-load-html", Fxwidget_webkit_load_html, + Sxwidget_webkit_load_html, 2, 3, 0, + doc: /* Make XWIDGET's WebKit widget render TEXT. +XWIDGET should be a WebKit xwidget, that will receive TEXT. TEXT +should be a string that will be displayed by XWIDGET as HTML markup. +BASE_URI should be a string containing a URI that is used to locate +resources with relative URLs, and if not specified, defaults +to "about:blank". */) + (Lisp_Object xwidget, Lisp_Object text, Lisp_Object base_uri) +{ + struct xwidget *xw; + WebKitWebView *webview; + char *data, *uri; + + CHECK_XWIDGET (xwidget); + CHECK_STRING (text); + if (NILP (base_uri)) + base_uri = build_string ("about:blank"); + else + CHECK_STRING (base_uri); + + base_uri = ENCODE_UTF_8 (base_uri); + text = ENCODE_UTF_8 (text); + xw = XXWIDGET (xwidget); + + data = SSDATA (text); + uri = SSDATA (base_uri); + webview = WEBKIT_WEB_VIEW (xw->widget_osr); + + block_input (); + webkit_web_view_load_html (webview, data, uri); + unblock_input (); + + return Qnil; +} +#endif + void syms_of_xwidget (void) { @@ -2316,6 +2354,9 @@ syms_of_xwidget (void) defsubr (&Sxwidget_webkit_next_result); defsubr (&Sxwidget_webkit_previous_result); defsubr (&Sset_xwidget_buffer); +#ifdef USE_GTK + defsubr (&Sxwidget_webkit_load_html); +#endif DEFSYM (QCxwidget, ":xwidget"); DEFSYM (QCtitle, ":title"); commit d3ccf0895dbb18ac04e1e2e0c6624af43d467c1b Author: Filipp Gunbin Date: Wed Nov 10 23:00:56 2021 +0300 ; Refer to Repeating from compare-windows info node * doc/emacs/files.texi (Comparing Files): C-x z (`repeat') is very convenient to use with compare-windows, so refer to its node. diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi index 3e0788307a..b7016b0057 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -1476,8 +1476,8 @@ characters that don't match. Then the command exits. If point in the two windows is followed by non-matching text when the command starts, @kbd{M-x compare-windows} tries heuristically to advance up to matching text in the two windows, and then exits. So if -you use @kbd{M-x compare-windows} repeatedly, each time it either -skips one matching range or finds the start of another. +you use @kbd{M-x compare-windows} repeatedly (@pxref{Repeating}), each +time it either skips one matching range or finds the start of another. @vindex compare-ignore-case @vindex compare-ignore-whitespace commit 2963de6540a1dc57399eaf530d8e12c794137a84 Author: Juri Linkov Date: Wed Nov 10 20:41:19 2021 +0200 * lisp/vc/vc-git.el (vc-git-mergebase): More meaningful error message. Display a readable error message instead of signaling an error on nil value. diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 3f89fad235..2d35061b26 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1256,7 +1256,10 @@ log entries." (defun vc-git-mergebase (rev1 &optional rev2) (unless rev2 (setq rev2 "HEAD")) - (string-trim-right (vc-git--run-command-string nil "merge-base" rev1 rev2))) + (let ((base (vc-git--run-command-string nil "merge-base" rev1 rev2))) + (if base + (string-trim-right base) + (error "No common ancestor for merge base")))) (defvar log-view-message-re) (defvar log-view-file-re) commit b7e212aca475b3496ca0600a42ab55dc3ebeb319 Author: Juri Linkov Date: Wed Nov 10 20:36:41 2021 +0200 * etc/NEWS.28: Add changes omitted while merging from emacs-28 NEWS. diff --git a/etc/NEWS.28 b/etc/NEWS.28 index a7b4dc6378..d415a242fc 100644 --- a/etc/NEWS.28 +++ b/etc/NEWS.28 @@ -486,6 +486,7 @@ command 'other-tab-prefix'. +++ *** New command 'C-x t C-r' to open file read-only in the other tab. ++++ *** The tab bar now supports more mouse commands. Clicking 'mouse-2' closes the tab, 'mouse-3' displays the context menu with items that operate on the clicked tab. Dragging the tab with @@ -506,7 +507,7 @@ frame regardless of the values of 'tab-bar-mode' and 'tab-bar-show'. This allows enabling/disabling the tab bar independently on different frames. ---- ++++ *** New user option 'tab-bar-format' defines a list of tab bar items. When it contains 'tab-bar-format-global' (possibly appended after 'tab-bar-format-align-right'), then after enabling 'display-time-mode' @@ -515,14 +516,14 @@ aligned to the right on the tab bar instead of on the mode line. When 'tab-bar-format-tabs' is replaced with 'tab-bar-format-tabs-groups', the tab bar displays tab groups. ---- ++++ *** New optional key binding for 'tab-last'. If you customize the user option 'tab-bar-select-tab-modifiers' to allow selecting tabs using their index numbers, the '-9' key is bound to 'tab-last', and switches to the last tab. Here is any of the modifiers in the list that is the value of -'tab-bar-select-tab-modifiers'. You can also use negative indices, -which count from the last tab: -1 is the last tab, -2 the one before +'tab-bar-select-tab-modifiers'. You can also use positive indices, +which count from the last tab: 1 is the last tab, 2 the one before that, etc. --- commit cb6cd6c8a2628ae64c931b5c3dbd86c148212421 Author: Juri Linkov Date: Wed Nov 10 20:23:16 2021 +0200 * etc/NEWS: Remove old news accidentally merged from emacs-28. diff --git a/etc/NEWS b/etc/NEWS index 2bc43f5a6c..b403be65da 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -257,78 +257,6 @@ representation as emojis. +++ *** 'slot-value' can now be used to read slots of 'cl-defstruct' objects. -** Tab Bars and Tab Lines - -+++ -*** New command 'C-x t C-r' to open file read-only in the other tab. - -+++ -*** The tab bar now supports more mouse commands. -Clicking 'mouse-2' closes the tab, 'mouse-3' displays the context menu -with items that operate on the clicked tab. Dragging the tab with -'mouse-1' moves it to another position on the tab bar. Mouse wheel -scrolling switches to the previous/next tab, and holding the Shift key -during scrolling moves the tab to the left/right. - -+++ -*** Frame-specific appearance of the tab bar when 'tab-bar-show' is a number. -When 'tab-bar-show' is a number, the tab bar on different frames can -be shown or hidden independently, as determined by the number of tabs -on each frame compared to the numerical value of 'tab-bar-show'. - -+++ -*** New command 'toggle-frame-tab-bar'. -It can be used to enable/disable the tab bar on the currently selected -frame regardless of the values of 'tab-bar-mode' and 'tab-bar-show'. -This allows enabling/disabling the tab bar independently on different -frames. - -+++ -*** New user option 'tab-bar-format' defines a list of tab bar items. -When it contains 'tab-bar-format-global' (possibly appended after -'tab-bar-format-align-right'), then after enabling 'display-time-mode' -(or any other mode that uses 'global-mode-string') it displays time -aligned to the right on the tab bar instead of on the mode line. -When 'tab-bar-format-tabs' is replaced with 'tab-bar-format-tabs-groups', -the tab bar displays tab groups. - -+++ -*** New optional key binding for 'tab-last'. -If you customize the user option 'tab-bar-select-tab-modifiers' to -allow selecting tabs using their index numbers, the '-9' key -is bound to 'tab-last', and switches to the last tab. Here -is any of the modifiers in the list that is the value of -'tab-bar-select-tab-modifiers'. You can also use positive indices, -which count from the last tab: 1 is the last tab, 2 the one before -that, etc. - ---- -*** New command 'tab-duplicate' bound to 'C-x t n'. - ---- -*** 'C-x t N' creates a new tab at the specified absolute position. -The position is provided as prefix arg, and specifies an index that -starts at 1. Negative values count from the end of the tab bar. - ---- -*** 'C-x t M' moves the current tab to the specified absolute position. -The position is provided as prefix arg, whose interpretation is as in -'C-x t N'. - ---- -*** 'C-x t G' assigns a tab to a named group of tabs. -'tab-close-group' closes all tabs that belong to the selected group. -The user option 'tab-bar-new-tab-group' defines the default group of -new tabs. After customizing 'tab-bar-tab-post-change-group-functions' -to 'tab-bar-move-tab-to-group', changing the group of a tab will also -move it closer to other tabs in the same group. - ---- -*** New user option 'tab-bar-tab-name-format-function'. - ---- -*** New user option 'tab-line-tab-name-format-function'. - ** align --- commit 32086ea233b5f68c4fc2d90a05ef9a20d09b8f71 Author: Eli Zaretskii Date: Wed Nov 10 20:17:33 2021 +0200 Fix font weights on MS-Windows * src/w32font.c (w32_decode_weight, w32_encode_weight) (w32_to_fc_weight): Adjust weight translations to match those in font.c and gtkutil.c:xg_weight_to_symbol. (Bug#51704) diff --git a/src/w32font.c b/src/w32font.c index 4ceb4302ce..752acdc904 100644 --- a/src/w32font.c +++ b/src/w32font.c @@ -1974,10 +1974,11 @@ w32_decode_weight (int fnweight) if (fnweight >= FW_EXTRABOLD) return 205; if (fnweight >= FW_BOLD) return 200; if (fnweight >= FW_SEMIBOLD) return 180; - if (fnweight >= FW_NORMAL) return 100; - if (fnweight >= FW_LIGHT) return 50; - if (fnweight >= FW_EXTRALIGHT) return 40; - if (fnweight > FW_THIN) return 20; + if (fnweight >= FW_MEDIUM) return 100; + if (fnweight >= FW_NORMAL) return 80; + if (fnweight >= FW_LIGHT) return 50; + if (fnweight >= FW_EXTRALIGHT) return 40; + if (fnweight >= FW_THIN) return 20; return 0; } @@ -1988,10 +1989,11 @@ w32_encode_weight (int n) if (n >= 205) return FW_EXTRABOLD; if (n >= 200) return FW_BOLD; if (n >= 180) return FW_SEMIBOLD; - if (n >= 100) return FW_NORMAL; - if (n >= 50) return FW_LIGHT; - if (n >= 40) return FW_EXTRALIGHT; - if (n >= 20) return FW_THIN; + if (n >= 100) return FW_MEDIUM; + if (n >= 80) return FW_NORMAL; + if (n >= 50) return FW_LIGHT; + if (n >= 40) return FW_EXTRALIGHT; + if (n >= 20) return FW_THIN; return 0; } @@ -2000,14 +2002,15 @@ w32_encode_weight (int n) static Lisp_Object w32_to_fc_weight (int n) { - if (n >= FW_HEAVY) return Qblack; - if (n >= FW_EXTRABOLD) return Qextra_bold; - if (n >= FW_BOLD) return Qbold; - if (n >= FW_SEMIBOLD) return intern ("demibold"); - if (n >= FW_NORMAL) return Qmedium; - if (n >= FW_LIGHT) return Qlight; + if (n >= FW_HEAVY) return Qblack; + if (n >= FW_EXTRABOLD) return Qextra_bold; + if (n >= FW_BOLD) return Qbold; + if (n >= FW_SEMIBOLD) return Qsemi_bold; + if (n >= FW_MEDIUM) return Qmedium; + if (n >= FW_NORMAL) return Qnormal; + if (n >= FW_LIGHT) return Qlight; if (n >= FW_EXTRALIGHT) return Qextra_light; - return intern ("thin"); + return Qthin; } /* Fill in all the available details of LOGFONT from FONT_SPEC. */ commit a491b73c765adde894acdbafc6fd97edd4343c2c Author: Robert Pluim Date: Wed Nov 10 17:42:30 2021 +0100 Improve 'ensure-empty-lines' docstring * lisp/emacs-lisp/subr-x.el (ensure-empty-lines): Fix typo and improve wording. diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index e3caf88c2f..f336799040 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -416,14 +416,14 @@ and return the value found in PLACE instead." ;;;###autoload (defun ensure-empty-lines (&optional lines) - "Ensure that there's LINES number of empty lines before point. -If LINES is nil or missing, a this ensures that there's a single -empty line before point. + "Ensure that there are LINES number of empty lines before point. +If LINES is nil or omitted, ensure that there is a single empty +line before point. -Interactively, this command uses the numerical prefix for LINES. +If called interactively, LINES is given by the prefix argument. -If there's already more empty lines before point than LINES, the -number of blank lines will be reduced. +If there are more than LINES empty lines before point, the number +of empty lines is reduced to LINES. If point is not at the beginning of a line, a newline character is inserted before adjusting the number of empty lines." commit c5e7a0225b0771fb0a27b9380706fb3ceabc0f85 Author: Robert Pluim Date: Wed Nov 10 16:25:55 2021 +0100 ; * etc/NEWS: Improve some entries. diff --git a/etc/NEWS b/etc/NEWS index 22fc0fdf6d..2bc43f5a6c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -99,7 +99,7 @@ These will take you (respectively) to the next and previous "page". +++ *** New user option 'outline-minor-mode-use-buttons'. If non-nil, Outline Minor Mode will use buttons to hide/show outlines -in addition to the ellipsis. +in addition to the ellipsis. Default nil. --- *** New user option 'outline-minor-mode-buttons'. @@ -115,8 +115,12 @@ Image specifiers can now use ':type webp'. +++ *** 'display-buffer' now can set up the body size of the chosen window. -For example, an alist entry as '(window-width . (body-columns . 40))' -will make the body of the chosen window 40 columns wide. +For example, a 'display-buffer-alist' entry of + + '(window-width . (body-columns . 40))' + +will make the body of the chosen window 40 columns wide. For the +height use 'window-height' in combination with 'body-lines'. ** Better detection of text suspiciously reordered on display. The function 'bidi-find-overridden-directionality' has been extended @@ -128,7 +132,7 @@ suspicious and could be malicious. -** Emacs server and client changes +** Emacs server and client changes. +++ *** New command-line option '-r' for emacsclient. @@ -170,7 +174,7 @@ effectively dragged. --- ** New user option 'yank-menu-max-items'. -Customize this option to limit the amount of entries in the menu +Customize this option to limit the number of entries in the menu "Edit->Paste from Kill Menu". The default is 60. ** show-paren-mode @@ -179,7 +183,7 @@ Customize this option to limit the amount of entries in the menu *** New user option 'show-paren-context-when-offscreen'. When non-nil, if the point is in a closing delimiter and the opening delimiter is offscreen, shows some context around the opening -delimiter in the echo area. +delimiter in the echo area. Default nil. ** Comint @@ -211,6 +215,8 @@ If non-nil, 'C-c C-a' will put attached files at the end of the message. --- *** Message Mode now supports image yanking. +** HTML Mode + --- *** HTML Mode now supports text/html and image/* yanking. @@ -239,7 +245,7 @@ the common utm_ trackers from URLs. +++ *** New user option 'gnus-treat-emojize-symbols'. If non-nil, symbols that have an emoji representation will be -displayed as emojis. +displayed as emojis. Default nil. +++ *** New command 'gnus-article-emojize-symbols'. @@ -249,7 +255,7 @@ representation as emojis. ** EIEIO +++ -*** 'slot-value' can now be used to read slots of 'cl-defstruct' objects +*** 'slot-value' can now be used to read slots of 'cl-defstruct' objects. ** Tab Bars and Tab Lines @@ -345,10 +351,10 @@ default, no automatic renaming is performed. ** Help *** New user option 'help-link-key-to-documentation'. -When this option is non-nil, key bindings displayed in the "*Help*" -buffer will be linked to the documentation for the command they are -bound to. This does not affect listings of key bindings and -functions (such as 'C-h b'). +When this option is non-nil (which is the default), key bindings +displayed in the "*Help*" buffer will be linked to the documentation +for the command they are bound to. This does not affect listings of +key bindings and functions (such as 'C-h b'). ** info-look @@ -618,54 +624,54 @@ Use 'exif-parse-file' and 'exif-field' instead. * Lisp Changes in Emacs 29.1 +++ -*** New function 'file-name-split'. +** New function 'file-name-split'. This returns a list of all the components of a file name. +++ -*** New macro 'with-undo-amalgamate' -It records a particular sequence of operations as a single undo step +** New macro 'with-undo-amalgamate' +It records a particular sequence of operations as a single undo step. +++ -*** New command 'yank-media'. +** New command 'yank-media'. This command supports yanking non-plain-text media like images and HTML from other applications into Emacs. It is only supported in modes that have registered support for it, and only on capable platforms. +++ -*** New command 'yank-media-types'. +** New command 'yank-media-types'. This command lets you examine all data in the current selection and the clipboard, and insert it into the buffer. +++ -*** New text property 'inhibit-isearch'. +** New text property 'inhibit-isearch'. If set, 'isearch' will skip these areas, which can be useful (for instance) when covering huge amounts of data (that has no meaningful searchable data, like image data) with a 'display' text property. +++ -*** 'insert-image' now takes an INHIBIT-ISEARCH optional parameter. +** 'insert-image' now takes an INHIBIT-ISEARCH optional parameter. It marks the image with the 'inhibit-isearch' text parameter, which inhibits 'isearch' matching the STRING parameter. --- -*** New user option 'pp-use-max-width'. +** New user option 'pp-use-max-width'. If non-nil, 'pp' will attempt to limit the line length when formatting long lists and vectors. --- -*** New function 'pp-emacs-lisp-code'. +** New function 'pp-emacs-lisp-code'. 'pp' formats general Lisp sexps. This function does much the same, but applies formatting rules appropriate for Emacs Lisp code. +++ -*** New function 'file-has-changed-p'. +** New function 'file-has-changed-p'. This convenience function is useful when writing code that parses files at run-time, and allows Lisp programs to re-parse files only when they have changed. --- -*** New function 'font-has-char-p'. +** New function 'font-has-char-p'. This can be used to check whether a specific font has a glyph for a character. @@ -774,7 +780,7 @@ separate glyphs. This takes into account combining characters and grapheme clusters. --- -** 'lookup-key' is more allowing when searching for extended menu items. +** 'lookup-key' is more permissive when searching for extended menu items. In Emacs 28.1, the behavior of 'lookup-key' was changed: when looking for a menu item '[menu-bar Foo-Bar]', first try to find an exact match, then look for the lowercased '[menu-bar foo-bar]'. commit bf4151c65dd794e95be7c72035a590684b059aed Author: Robert Pluim Date: Wed Nov 10 17:03:32 2021 +0100 ; * etc/NEWS: Fix merge error diff --git a/etc/NEWS b/etc/NEWS index 9e3320dba3..22fc0fdf6d 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -248,6 +248,7 @@ representation as emojis. ** EIEIO ++++ *** 'slot-value' can now be used to read slots of 'cl-defstruct' objects ** Tab Bars and Tab Lines commit 77aff4c56e3b91ee6529369349c7795380703242 Author: Robert Pluim Date: Wed Nov 10 16:45:47 2021 +0100 ; * etc/NEWS: Fix merge error diff --git a/etc/NEWS b/etc/NEWS index 3cad0995ac..9e3320dba3 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -248,6 +248,10 @@ representation as emojis. ** EIEIO +*** 'slot-value' can now be used to read slots of 'cl-defstruct' objects + +** Tab Bars and Tab Lines + +++ *** New command 'C-x t C-r' to open file read-only in the other tab. commit 4424970b2b624888468cbea80f8aa4c121f60152 Author: Stefan Kangas Date: Wed Nov 10 16:37:47 2021 +0100 * admin/update_autogen: Remove unused variables. diff --git a/admin/update_autogen b/admin/update_autogen index 11c4313ae3..a54c5ace1d 100755 --- a/admin/update_autogen +++ b/admin/update_autogen @@ -248,7 +248,7 @@ info_dir () rm -f $outfile cp $basefile $outfile - local topic file dircat dirent + local topic file dircat ## FIXME inefficient looping. for topic in "Texinfo documentation system" "Emacs" "GNU Emacs Lisp" \ @@ -292,8 +292,6 @@ EOF [ "$autogendir" ] && { - oldpwd=$PWD - cp $genfiles $autogendir/ cd $autogendir || die "cd error for $autogendir" commit 3aad70326db4b654c836be97f7b96bb71e10202a Author: Stefan Kangas Date: Wed Nov 10 16:30:50 2021 +0100 Use "grep -E" instead of deprecated "egrep" * admin/emake: * test/lisp/so-long-tests/so-long-tests.el: Use "grep -E" instead of deprecated "egrep". diff --git a/admin/emake b/admin/emake index 8c37c16055..2ff553289d 100755 --- a/admin/emake +++ b/admin/emake @@ -13,7 +13,7 @@ cores=1 # Determine the number of cores. if [ -f /proc/cpuinfo ]; then - cores=$(($(egrep "^physical id|^cpu cores" /proc/cpuinfo |\ + cores=$(($(grep -E "^physical id|^cpu cores" /proc/cpuinfo |\ awk '{ print $4; }' |\ sed '$!N;s/\n/ /' |\ uniq |\ @@ -30,7 +30,7 @@ s#^Configured for # Configured for # s#^./temacs.*# \\& # s#^make.*Error# \\& # ' | \ -egrep --line-buffered -v "^make|\ +grep -E --line-buffered -v "^make|\ ^Loading|\ SCRAPE|\ INFO.*Scraping.*[.] ?\$|\ @@ -93,4 +93,4 @@ done # changed since last time. make -j$cores check-maybe 2>&1 | \ sed -n '/contained unexpected results/,$p' | \ - egrep --line-buffered -v "^make" + grep -E --line-buffered -v "^make" diff --git a/test/lisp/so-long-tests/so-long-tests.el b/test/lisp/so-long-tests/so-long-tests.el index 7eee345aad..cda5ae497f 100644 --- a/test/lisp/so-long-tests/so-long-tests.el +++ b/test/lisp/so-long-tests/so-long-tests.el @@ -32,7 +32,7 @@ ;; Running manually: ;; ;; for test in lisp/so-long-tests/*-tests.el; do make ${test%.el}; done \ -;; 2>&1 | egrep -v '^(Loading|Source file|make|Changed to so-long-mode)' +;; 2>&1 | grep -E -v '^(Loading|Source file|make|Changed to so-long-mode)' ;; ;; Which is equivalent to: ;; @@ -41,7 +41,7 @@ ;; "../src/emacs" --no-init-file --no-site-file --no-site-lisp \ ;; -L ":." -l ert -l "$test" --batch --eval \ ;; '(ert-run-tests-batch-and-exit (quote (not (tag :unstable))))'; \ -;; done 2>&1 | egrep -v '^(Loading|Source file|Changed to so-long-mode)' +;; done 2>&1 | grep -E -v '^(Loading|Source file|Changed to so-long-mode)' ;; ;; See also `ert-run-tests-batch-and-exit'. commit 810fa21d26453f898de9747ece7205dfe6de9d08 Author: Stefan Kangas Date: Wed Nov 10 15:15:09 2021 +0100 Avoid another byte-compiler warning in package-quickstart.el * lisp/emacs-lisp/package.el (package-quickstart-refresh): Avoid byte-compiler warning "assignment to free variable" in package-quickstart.el. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 55378ef8bd..27eaa484f9 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4178,6 +4178,7 @@ activations need to be changed, such as when `package-load-list' is modified." (replace-match (if (match-end 1) "" pfile) t t))) (unless (bolp) (insert "\n")) (insert ")\n"))) + (pp `(defvar package-activated-list) (current-buffer)) (pp `(setq package-activated-list (append ',(mapcar #'package-desc-name package--quickstart-pkgs) package-activated-list)) commit 1e7720d39afa9b86c5c1bf4bfded994fa6e48aff Author: Stefan Kangas Date: Wed Nov 10 14:49:44 2021 +0100 Avoid spurious byte-compiler warnings in package-quickstart.el * lisp/emacs-lisp/package.el (package-quickstart-refresh): Disable the "`make-variable-buffer-local' not called at toplevel" byte-compiler warnings. Given that we wrap it all in a let-form, these are mostly false positives and not helpful. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 4761a3d82b..55378ef8bd 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4195,6 +4195,7 @@ activations need to be changed, such as when `package-load-list' is modified." ;; Local\sVariables: ;; version-control: never ;; no-update-autoloads: t +;; byte-compile-warnings: (not make-local) ;; End: ")) ;; FIXME: Do it asynchronously in an Emacs subprocess, and commit a9148cdee563e8d73512830684c923e4ab1e97de Author: Michael Albinus Date: Wed Nov 10 13:40:44 2021 +0100 ; Fix heading in etc/NEWS diff --git a/etc/NEWS b/etc/NEWS index 88f666ff92..8e38c3690c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1399,7 +1399,6 @@ keys, add the following to your init file: Using it instead of 'read-char-choice' allows using 'C-x o' to switch to the help window displayed after typing 'C-h'. - +++ ** Emacs 28.1 comes with Org v9.5. See the file ORG-NEWS for user-visible changes in Org. @@ -1855,7 +1854,7 @@ The command 'next-error-no-select' is now bound to 'n' and 'previous-error-no-select' is bound to 'p'. --- -*** The new command 'recenter-current-error'. +*** New command 'recenter-current-error'. It is bound to 'l' in Occur or compilation buffers, and recenters the current displayed occurrence/error. commit 9623342216baa911f21b347820d1e1c3cbbe58e1 Author: Stefan Kangas Date: Wed Nov 10 13:17:14 2021 +0100 ; * etc/NEWS: Move a bookmark related item further down. diff --git a/etc/NEWS b/etc/NEWS index d415a242fc..88f666ff92 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1532,16 +1532,6 @@ used instead. When the bookmark.el library is loaded, a customize choice is added to 'tab-bar-new-tab-choice' for new tabs to show the bookmark list. ---- -*** The 'list-bookmarks' menu is now based on 'tabulated-list-mode'. -The interactive bookmark list will now benefit from features in -'tabulated-list-mode' like sorting columns or changing column width. - -Support for the optional "inline" header line, allowing for a header -without using 'header-line-format', has been dropped. Consequently, -the variables 'bookmark-bmenu-use-header-line' and -'bookmark-bmenu-inline-header-height' are now declared obsolete. - --- *** New user option 'bookmark-set-fringe-mark'. If non-nil, setting a bookmark will set a fringe mark on the current @@ -1555,6 +1545,16 @@ that have been marked for deletion. However, if this new option is non-nil then Emacs will require confirmation with 'yes-or-no-p' before deleting. +--- +*** The 'list-bookmarks' menu is now based on 'tabulated-list-mode'. +The interactive bookmark list will now benefit from features in +'tabulated-list-mode' like sorting columns or changing column width. + +Support for the optional "inline" header line, allowing for a +header without using 'header-line-format', has been dropped. +The variables 'bookmark-bmenu-use-header-line' and +'bookmark-bmenu-inline-header-height' are now obsolete. + ** Recentf --- commit e3f5f5d8672567d0b29dd83005bd5a399cab90c3 Author: Stefan Kangas Date: Wed Nov 10 13:06:24 2021 +0100 * admin/automerge: Fix quoting of some variables. diff --git a/admin/automerge b/admin/automerge index 7d71f29008..227a404b7a 100755 --- a/admin/automerge +++ b/admin/automerge @@ -37,7 +37,7 @@ die () # write error to stderr and exit { - [ $# -gt 0 ] && echo "$PN: $@" >&2 + [ $# -gt 0 ] && echo "$PN: $*" >&2 exit 1 } @@ -133,7 +133,7 @@ else tempfile=/tmp/$PN.$$ fi -trap "rm -f $tempfile 2> /dev/null" EXIT +trap 'rm -f $tempfile 2> /dev/null' EXIT [ -e Makefile ] && [ "$build" ] && { @@ -153,7 +153,7 @@ trap "rm -f $tempfile 2> /dev/null" EXIT rev=$(git rev-parse HEAD) -[ $(git rev-parse @{u}) = $rev ] || die "Local state does not match origin" +[ "$(git rev-parse @{u})" = "$rev" ] || die "Local state does not match origin" merge () @@ -162,12 +162,12 @@ merge () if $emacs --batch -Q -l ./admin/gitmerge.el \ --eval "(setq gitmerge-minimum-missing $nmin)" -f gitmerge \ - >| $tempfile 2>&1; then + >| "$tempfile" 2>&1; then echo "merged ok" return 0 else - grep -E "Nothing to merge|Number of missing commits" $tempfile && \ + grep -E "Nothing to merge|Number of missing commits" "$tempfile" && \ exit 0 cat "$tempfile" 1>&2 @@ -191,13 +191,13 @@ git diff --stat --cached origin/master | grep -q "etc/NEWS " && \ echo "Running autoreconf..." -autoreconf -i -I m4 2>| $tempfile +autoreconf -i -I m4 2>| "$tempfile" retval=$? ## Annoyingly, autoreconf puts the "installing `./foo' messages on stderr. if [ "$quiet" ]; then - grep -v 'installing `\.' $tempfile 1>&2 + grep -v 'installing `\.' "$tempfile" 1>&2 else cat "$tempfile" 1>&2 fi @@ -236,7 +236,7 @@ echo "Tests finished ok" echo "Checking for remote changes..." git fetch || die "fetch error" -[ $(git rev-parse @{u}) = $rev ] || { +[ "$(git rev-parse @{u})" = "$rev" ] || { echo "Upstream has changed" @@ -245,7 +245,7 @@ git fetch || die "fetch error" ## Ref eg https://lists.gnu.org/r/emacs-devel/2014-12/msg01435.html ## Instead, we throw away what we just did, and do the merge again. echo "Resetting..." - git reset --hard $rev + git reset --hard "$rev" echo "Pulling..." git pull --ff-only || die "pull error" commit 99abafdd0d77aa53f9d4d24c543d5aca54f9c8a1 Author: Stefan Kangas Date: Wed Nov 10 13:01:30 2021 +0100 * admin/automerge: Use mktemp if it exists. diff --git a/admin/automerge b/admin/automerge index d54f6cb4ac..7d71f29008 100755 --- a/admin/automerge +++ b/admin/automerge @@ -127,7 +127,11 @@ OPTIND=1 [ "$test" ] && build=1 -tempfile=/tmp/$PN.$$ +if [ -x "$(command -v mktemp)" ]; then + tempfile=$(mktemp "/tmp/$PN.XXXXXXXXXX") +else + tempfile=/tmp/$PN.$$ +fi trap "rm -f $tempfile 2> /dev/null" EXIT commit 4d99388c165e131667c7111b17cdf4ea9059b95e Author: Po Lu Date: Wed Nov 10 19:40:23 2021 +0800 Prevent GDK warning about missing event devices in most cases * src/xwidget.c (synthesize_focus_in_event): Set event device to selected frame's pointer if it's an X frame. diff --git a/src/xwidget.c b/src/xwidget.c index f303ed2426..2ae635092d 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -920,6 +920,11 @@ synthesize_focus_in_event (GtkWidget *offscreen_window) focus_event = gdk_event_new (GDK_FOCUS_CHANGE); focus_event->any.window = wnd; focus_event->focus_change.in = TRUE; + + if (FRAME_WINDOW_P (SELECTED_FRAME ())) + gdk_event_set_device (focus_event, + find_suitable_pointer (SELECTED_FRAME ())); + g_object_ref (wnd); gtk_main_do_event (focus_event); commit 4ab7a22abe9230a6374dbf3d892148ad099a96a8 Author: Po Lu Date: Wed Nov 10 18:13:22 2021 +0800 Add `xwidget-webkit-isearch-yank-kill' * lisp/xwidget.el: Bind C-y to xwidget-webkit-yank-kill in incremental search. (xwidget-webkit-isearch-mode): Update doc string. (xwidget-webkit-yank-kill): New function. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index cad464b5b2..cc149cf197 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -947,6 +947,7 @@ With argument, add COUNT copies of CHAR." (define-key xwidget-webkit-isearch-mode-map "\C-g" 'xwidget-webkit-isearch-exit) (define-key xwidget-webkit-isearch-mode-map "\C-r" 'xwidget-webkit-isearch-backward) (define-key xwidget-webkit-isearch-mode-map "\C-s" 'xwidget-webkit-isearch-forward) +(define-key xwidget-webkit-isearch-mode-map "\C-y" 'xwidget-webkit-isearch-yank-kill) (define-key xwidget-webkit-isearch-mode-map "\t" 'xwidget-webkit-isearch-printing-char) (let ((meta-map (make-keymap))) @@ -968,6 +969,9 @@ To navigate around the search results, type \\\\[xwidget-webkit-isearch-forward] to move forward, and \\\\[xwidget-webkit-isearch-backward] to move backward. +To insert the string at the front of the kill ring into the +search query, type \\\\[xwidget-webkit-isearch-yank-kill]. + Press \\\\[xwidget-webkit-isearch-exit] to exit incremental search." :keymap xwidget-webkit-isearch-mode-map (if xwidget-webkit-isearch-mode @@ -977,6 +981,15 @@ Press \\\\[xwidget-webkit-isearch-exit] to exit (xwidget-webkit-isearch--update)) (xwidget-webkit-finish-search (xwidget-webkit-current-session)))) +(defun xwidget-webkit-isearch-yank-kill () + "Pull string from kill ring and append it to the current query." + (interactive) + (unless xwidget-webkit-isearch-mode + (xwidget-webkit-isearch-mode t)) + (setq xwidget-webkit-isearch--string + (concat xwidget-webkit-isearch--string + (current-kill 0))) + (xwidget-webkit-isearch--update)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar xwidget-view-list) ; xwidget.c commit acf408934d771fe652fbd5a73e96cc12d93362c0 Merge: d7e7f92fc3 8d81ab374d Author: Stefan Kangas Date: Wed Nov 10 12:12:30 2021 +0100 Merge from origin/emacs-28 8d81ab374d time-stamp: %F is "file name" not "pathname" + other doc beaa7e14f3 ; Fix typos in CONTRIBUTE, ELisp manual, ediff 747a1ae4ac * doc/misc/eww.texi (Advanced): Fix missed variable name e... 52fe2340b8 * doc/emacs/windows.texi (Window Convenience): Use @code f... 7d3a654e2a * doc/emacs/maintaining.texi (Basic VC Editing): Mention D... aeb19af4b5 ; * doc/emacs/building.texi (Lisp Libraries): Fix a typo. ... # Conflicts: # etc/NEWS commit d7e7f92fc3752ab3db64bb72321d76dc9e6b43e4 Merge: 1bb3fb4e45 a83ccc46fa Author: Stefan Kangas Date: Wed Nov 10 12:12:29 2021 +0100 ; Merge from origin/emacs-28 The following commit was skipped: a83ccc46fa * lisp/progmodes/prog-mode.el (prog-context-menu): Use "Go... commit 1bb3fb4e45a14c7ebeead655ed3fb58b361787b0 Merge: b1de4a2ede 2782bc113e Author: Stefan Kangas Date: Wed Nov 10 12:12:29 2021 +0100 Merge from origin/emacs-28 2782bc113e Revert "Fix localized display of date and time in the NS p... commit b1de4a2ede9ccf0144eca637a46a3b4fcfedc5f7 Author: Po Lu Date: Wed Nov 10 17:53:13 2021 +0800 Prevent skipping results while changing search direction * lisp/xwidget.el (xwidget-webkit-isearch-forward) (xwidget-webkit-isearch-backward): Avoid moving to the next result one too many times. diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 905327083b..cad464b5b2 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -900,7 +900,8 @@ With argument, add COUNT copies of CHAR." (let ((was-reverse xwidget-webkit-isearch--is-reverse)) (setq xwidget-webkit-isearch--is-reverse nil) (when was-reverse - (xwidget-webkit-isearch--update))) + (xwidget-webkit-isearch--update) + (setq count (1- count)))) (let ((i 0)) (while (< i count) (xwidget-webkit-next-result (xwidget-webkit-current-session)) @@ -913,7 +914,8 @@ With argument, add COUNT copies of CHAR." (let ((was-reverse xwidget-webkit-isearch--is-reverse)) (setq xwidget-webkit-isearch--is-reverse t) (unless was-reverse - (xwidget-webkit-isearch--update))) + (xwidget-webkit-isearch--update) + (setq count (1- count)))) (let ((i 0)) (while (< i count) (xwidget-webkit-previous-result (xwidget-webkit-current-session)) commit 754810add1bf4e05089d11b697f9c1d253c1d0ab Author: Benj Date: Wed Nov 10 10:07:04 2021 +0100 Make the python missing-readline warning more helpful * lisp/progmodes/python.el (python-shell-completion-native-turn-on-maybe): Mention the "readline" package (bug#48998). Copyright-paperwork-exempt: yes diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index b12f5ddc0d..b12b22e992 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -3758,7 +3758,8 @@ With argument MSG show activation/deactivation message." (format "was t and %S is not part of the " (file-name-nondirectory python-shell-interpreter)) "`python-shell-completion-native-disabled-interpreters' " - "list. Native completions have been disabled locally. ")) + "list. Native completions have been disabled locally. " + "Consider installing the python package \"readline\". ")) (python-shell-completion-native-turn-off msg)))))) (defun python-shell-completion-native-turn-on-maybe-with-msg () commit 5a58b2f58c2b8411d593f6ea5a157c20a1176aaf Author: Robert Pluim Date: Wed Nov 10 08:56:03 2021 +0100 ; * doc/lispref/files.texi: Fix typo. diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index dd058b1215..d93770a0d2 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -2246,7 +2246,7 @@ and @code{file-name-nondirectory}. For example, @defun file-name-split filename This function splits a file name into its components, and can be -thought of as the inverse of @code{string-joing} with the appropriate +thought of as the inverse of @code{string-join} with the appropriate directory separator. For example, @example commit f7c08c8b4199974825d1769faf501746a5124799 Author: Lars Ingebrigtsen Date: Wed Nov 10 08:52:10 2021 +0100 Make `C-c C-c' in erts-mode work with Point-Char elems * lisp/progmodes/erts-mode.el (erts-mode--preceding-spec): Factor out into own function (bug#51680). (erts-run-test): Respect Point-Char settings. diff --git a/lisp/progmodes/erts-mode.el b/lisp/progmodes/erts-mode.el index 8a271ec318..a12c964c25 100644 --- a/lisp/progmodes/erts-mode.el +++ b/lisp/progmodes/erts-mode.el @@ -153,6 +153,18 @@ If NAME is nil or the empty string, a name will be auto-generated." (insert "Name: " name "\n\n") (insert "=-=\n"))) +(defun erts-mode--preceding-spec (name) + (save-excursion + ;; Find the name, but skip if it's in a test. + (while (and (re-search-backward (format "^%s:" name) nil t) + (erts-mode--in-test-p (point)))) + (and (not (erts-mode--in-test-p (point))) + (re-search-forward "^=-=$" nil t) + (progn + (goto-char (match-beginning 0)) + (cdr (assq (intern (downcase name)) + (ert--erts-specifications (point)))))))) + (defun erts-run-test (test-function &optional verbose) "Run the current test. If the current erts file doesn't define a test function, the user @@ -161,16 +173,8 @@ will be prompted for one. If VERBOSE (interactively, the prefix), display a diff of the expected results and the actual results in a separate buffer." (interactive - (list (save-excursion - ;; Find the preceding Code spec. - (while (and (re-search-backward "^Code:" nil t) - (erts-mode--in-test-p (point)))) - (if (and (not (erts-mode--in-test-p (point))) - (re-search-forward "^=-=$" nil t)) - (progn - (goto-char (match-beginning 0)) - (cdr (assq 'code (ert--erts-specifications (point))))) - (read-string "Transformation function: "))) + (list (or (erts-mode--preceding-spec "Code") + (read-string "Transformation function: ")) current-prefix-arg) erts-mode) (save-excursion @@ -178,7 +182,8 @@ expected results and the actual results in a separate buffer." (condition-case arg (ert-test--erts-test (list (cons 'dummy t) - (cons 'code (car (read-from-string test-function)))) + (cons 'code (car (read-from-string test-function))) + (cons 'point-char (erts-mode--preceding-spec "Point-Char"))) (buffer-file-name)) (:success (message "Test successful")) (ert-test-failed commit 32d1a735ce6f57fc6052998adf56cf51c12e6aae Author: Po Lu Date: Wed Nov 10 15:47:56 2021 +0800 Remove obsolete limitation * src/xwidget.c (Fxwidget_webkit_goto_history): Accept any fixnum as REL-POS, to be consistent with docstring. diff --git a/src/xwidget.c b/src/xwidget.c index 034989b339..f303ed2426 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -1740,9 +1740,7 @@ REL-POSth element around the current spot in the load history. */) (Lisp_Object xwidget, Lisp_Object rel_pos) { WEBKIT_FN_INIT (); - /* Should be one of -1, 0, 1 */ - if (XFIXNUM (rel_pos) < -1 || XFIXNUM (rel_pos) > 1) - args_out_of_range_3 (rel_pos, make_fixnum (-1), make_fixnum (1)); + CHECK_FIXNUM (rel_pos); #ifdef USE_GTK WebKitWebView *wkwv = WEBKIT_WEB_VIEW (xw->widget_osr); commit 465ec29926d2fd873a22e26f3a8b395a527ba2f5 Author: Po Lu Date: Wed Nov 10 14:29:54 2021 +0800 Fix incorrect offset calculation for clipped xwidget views * src/xwidget.c (from_embedder, to_embedder): Remove incorrect adjustment of position by view clipping. diff --git a/src/xwidget.c b/src/xwidget.c index 4da5318706..034989b339 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -530,8 +530,8 @@ from_embedder (GdkWindow *window, double x, double y, FRAME_GTK_OUTER_WIDGET (xvw->frame), 0, 0, &xoff, &yoff); - *xout = x - (xvw->x + xvw->clip_left) - xoff; - *yout = y - (xvw->y + xvw->clip_top) - yoff; + *xout = x - xvw->x - xoff; + *yout = y - xvw->y - yoff; } } @@ -562,8 +562,8 @@ to_embedder (GdkWindow *window, double x, double y, FRAME_GTK_OUTER_WIDGET (xvw->frame), 0, 0, &xoff, &yoff); - *xout = x + xvw->x + xvw->clip_left + xoff; - *yout = y + xvw->y + xvw->clip_top + yoff; + *xout = x + xvw->x + xoff; + *yout = y + xvw->y + yoff; } } commit 9653cbf3558df7c7318cac551e8e5d7ac8e669e2 Author: Po Lu Date: Wed Nov 10 14:19:15 2021 +0800 Fix invisible content in WebKit dialogs * src/xwidget.c (webkit_script_dialog_cb): Use custom label instead of dialog box title to display message. diff --git a/src/xwidget.c b/src/xwidget.c index 278dc96323..4da5318706 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -1375,6 +1375,8 @@ webkit_script_dialog_cb (WebKitWebView *webview, GtkWidget *dialog; GtkWidget *entry; GtkWidget *content_area; + GtkWidget *box; + GtkWidget *label; const gchar *content; const gchar *message; gint result; @@ -1390,23 +1392,32 @@ webkit_script_dialog_cb (WebKitWebView *webview, content = webkit_script_dialog_get_message (script_dialog); if (type == WEBKIT_SCRIPT_DIALOG_ALERT) - dialog = gtk_dialog_new_with_buttons (content, GTK_WINDOW (widget), + dialog = gtk_dialog_new_with_buttons ("Alert", GTK_WINDOW (widget), GTK_DIALOG_MODAL, "Dismiss", 1, NULL); else - dialog = gtk_dialog_new_with_buttons (content, GTK_WINDOW (widget), + dialog = gtk_dialog_new_with_buttons ("Question", GTK_WINDOW (widget), GTK_DIALOG_MODAL, "OK", 0, "Cancel", 1, NULL); + box = gtk_box_new (GTK_ORIENTATION_VERTICAL, 8); + label = gtk_label_new (content); + content_area = gtk_dialog_get_content_area (GTK_DIALOG (dialog)); + gtk_container_add (GTK_CONTAINER (content_area), box); + + gtk_widget_show (box); + gtk_widget_show (label); + + gtk_box_pack_start (GTK_BOX (box), label, TRUE, TRUE, 0); + if (type == WEBKIT_SCRIPT_DIALOG_PROMPT) { entry = gtk_entry_new (); message = webkit_script_dialog_prompt_get_default_text (script_dialog); - content_area = gtk_dialog_get_content_area (GTK_DIALOG (dialog)); gtk_widget_show (entry); gtk_entry_set_text (GTK_ENTRY (entry), message); - gtk_container_add (GTK_CONTAINER (content_area), entry); + gtk_box_pack_end (GTK_BOX (box), entry, TRUE, TRUE, 0); } result = gtk_dialog_run (GTK_DIALOG (dialog)); commit 1e5eb566cc33ae8b38b7d500c17e6912956e947c Author: Po Lu Date: Wed Nov 10 09:22:38 2021 +0800 Set embedder correctly to fix menus appearing in the wrong location * src/xwidget.c (record_osr_embedder, from_embedder, to_embedder): New functions. (Fmake_xwidget): Attach from-embedder and to-embedder signals. (find_widget_for_offscreen_window): New function. (xwidget_button, xwidget_motion_or_crossing): Set embedder on event. (Fdelete_xwidget_view): Remove embedder status if applicable. * src/xwidget.h (struct xwidget): New fields `embedder' and `embedder-view'. diff --git a/src/xwidget.c b/src/xwidget.c index fc76ce307e..278dc96323 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -52,6 +52,9 @@ static void synthesize_focus_in_event (GtkWidget *); static GdkDevice *find_suitable_keyboard (struct frame *); static gboolean webkit_script_dialog_cb (WebKitWebView *, WebKitScriptDialog *, gpointer); +static void record_osr_embedder (struct xwidget_view *); +static void from_embedder (GdkWindow *, double, double, gpointer, gpointer, gpointer); +static void to_embedder (GdkWindow *, double, double, gpointer, gpointer, gpointer); #endif static struct xwidget * @@ -215,6 +218,12 @@ fails. */) gtk_widget_show (xw->widgetwindow_osr); synthesize_focus_in_event (xw->widgetwindow_osr); + + g_signal_connect (G_OBJECT (gtk_widget_get_window (xw->widgetwindow_osr)), + "from-embedder", G_CALLBACK (from_embedder), NULL); + g_signal_connect (G_OBJECT (gtk_widget_get_window (xw->widgetwindow_osr)), + "to-embedder", G_CALLBACK (to_embedder), NULL); + /* Store some xwidget data in the gtk widgets for convenient retrieval in the event handlers. */ g_object_set_data (G_OBJECT (xw->widget_osr), XG_XWIDGET, xw); @@ -457,6 +466,106 @@ xwidget_from_id (uint32_t id) } #ifdef USE_GTK +static void +record_osr_embedder (struct xwidget_view *view) +{ + struct xwidget *xw; + GdkWindow *window, *embedder; + + xw = XXWIDGET (view->model); + window = gtk_widget_get_window (xw->widgetwindow_osr); + embedder = gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (view->frame)); + + gdk_offscreen_window_set_embedder (window, embedder); + xw->embedder = view->frame; + xw->embedder_view = view; +} + +static struct xwidget * +find_xwidget_for_offscreen_window (GdkWindow *window) +{ + Lisp_Object tem; + struct xwidget *xw; + GdkWindow *w; + + for (tem = Vxwidget_list; CONSP (tem); tem = XCDR (tem)) + { + if (XWIDGETP (XCAR (tem))) + { + xw = XXWIDGET (XCAR (tem)); + w = gtk_widget_get_window (xw->widgetwindow_osr); + + if (w == window) + return xw; + } + } + + return NULL; +} + +static void +from_embedder (GdkWindow *window, double x, double y, + gpointer x_out_ptr, gpointer y_out_ptr, + gpointer user_data) +{ + double *xout = x_out_ptr; + double *yout = y_out_ptr; + struct xwidget *xw = find_xwidget_for_offscreen_window (window); + struct xwidget_view *xvw; + gint xoff, yoff; + + if (!xw) + emacs_abort (); + + xvw = xw->embedder_view; + + if (!xvw) + { + *xout = x; + *yout = y; + } + else + { + gtk_widget_translate_coordinates (FRAME_GTK_WIDGET (xvw->frame), + FRAME_GTK_OUTER_WIDGET (xvw->frame), + 0, 0, &xoff, &yoff); + + *xout = x - (xvw->x + xvw->clip_left) - xoff; + *yout = y - (xvw->y + xvw->clip_top) - yoff; + } +} + +static void +to_embedder (GdkWindow *window, double x, double y, + gpointer x_out_ptr, gpointer y_out_ptr, + gpointer user_data) +{ + double *xout = x_out_ptr; + double *yout = y_out_ptr; + struct xwidget *xw = find_xwidget_for_offscreen_window (window); + struct xwidget_view *xvw; + gint xoff, yoff; + + if (!xw) + emacs_abort (); + + xvw = xw->embedder_view; + + if (!xvw) + { + *xout = x; + *yout = y; + } + else + { + gtk_widget_translate_coordinates (FRAME_GTK_WIDGET (xvw->frame), + FRAME_GTK_OUTER_WIDGET (xvw->frame), + 0, 0, &xoff, &yoff); + + *xout = x + xvw->x + xvw->clip_left + xoff; + *yout = y + xvw->y + xvw->clip_top + yoff; + } +} static GdkDevice * find_suitable_pointer (struct frame *f) @@ -697,6 +806,8 @@ xwidget_button (struct xwidget_view *view, bool down_p, int x, int y, int button, int modifier_state, Time time) { + record_osr_embedder (view); + if (button < 4 || button > 8) xwidget_button_1 (view, down_p, x, y, button, modifier_state, time); else @@ -765,6 +876,7 @@ xwidget_motion_or_crossing (struct xwidget_view *view, const XEvent *event) if (!target) target = model->widget_osr; + record_osr_embedder (view); xg_event->any.window = gtk_widget_get_window (target); g_object_ref (xg_event->any.window); /* The window will be unrefed later by gdk_event_free. */ @@ -1865,6 +1977,9 @@ DEFUN ("delete-xwidget-view", CHECK_XWIDGET_VIEW (xwidget_view); struct xwidget_view *xv = XXWIDGET_VIEW (xwidget_view); #ifdef USE_GTK + struct xwidget *xw = XXWIDGET (xv->model); + GdkWindow *w; + if (xv->wdesc != None) { block_input (); @@ -1874,6 +1989,16 @@ DEFUN ("delete-xwidget-view", Fremhash (make_fixnum (xv->wdesc), x_window_to_xwv_map); unblock_input (); } + + if (xw->embedder_view == xv) + { + w = gtk_widget_get_window (xw->widgetwindow_osr); + + XXWIDGET (xv->model)->embedder_view = NULL; + XXWIDGET (xv->model)->embedder = NULL; + + gdk_offscreen_window_set_embedder (w, NULL); + } #elif defined NS_IMPL_COCOA nsxwidget_delete_view (xv); #endif diff --git a/src/xwidget.h b/src/xwidget.h index ad8b7c039c..6e6b39c8b4 100644 --- a/src/xwidget.h +++ b/src/xwidget.h @@ -68,6 +68,8 @@ struct xwidget /* For offscreen widgets, unused if not osr. */ GtkWidget *widget_osr; GtkWidget *widgetwindow_osr; + struct frame *embedder; + struct xwidget_view *embedder_view; guint hit_result; #elif defined (NS_IMPL_COCOA) # ifdef __OBJC__ commit e27ca55ecbfef414411b4a12ba911eb76ce09b4a Author: Po Lu Date: Wed Nov 10 14:04:26 2021 +0800 Revert "Fix mouse face in NS port" This reverts commit 278e4fc9c6353068334dd39d45334b1df82a6cee. diff --git a/src/nsterm.m b/src/nsterm.m index 3727f861ac..ed0e7a2aae 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -3976,19 +3976,6 @@ Function modeled after x_draw_glyph_string_box (). NSRect r[2]; int n; char box_drawn_p = 0; - - struct face *face = s->face; - if (s->hl == DRAW_MOUSE_FACE) - { - face - = FACE_FROM_ID_OR_NULL (s->f, - MOUSE_HL_INFO (s->f)->mouse_face_face_id); - if (!face) - face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); - } - - s->face = face; - struct font *font = s->face->font; if (! font) font = FRAME_FONT (s->f); commit 2e2260427e9a47d2f91655ae1147631e92a99713 Author: Po Lu Date: Wed Nov 10 14:04:25 2021 +0800 Revert "*** empty log message ***" This reverts commit 68a2a3307d1703ac8abe4b54c8e1ef9dda677c12. diff --git a/src/nsterm.m b/src/nsterm.m index ed0e7a2aae..3727f861ac 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -3976,6 +3976,19 @@ Function modeled after x_draw_glyph_string_box (). NSRect r[2]; int n; char box_drawn_p = 0; + + struct face *face = s->face; + if (s->hl == DRAW_MOUSE_FACE) + { + face + = FACE_FROM_ID_OR_NULL (s->f, + MOUSE_HL_INFO (s->f)->mouse_face_face_id); + if (!face) + face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + } + + s->face = face; + struct font *font = s->face->font; if (! font) font = FRAME_FONT (s->f); commit b21f1cabd833aaa370fb0572cfaac2af83856ad5 Author: Po Lu Date: Wed Nov 10 14:04:24 2021 +0800 Revert "Add support for event processing via XInput 2" This reverts commit 346cfc81247e6bf8e727a27b42f44f2389bd1269. diff --git a/configure.ac b/configure.ac index a243efdd43..33e7037afe 100644 --- a/configure.ac +++ b/configure.ac @@ -487,7 +487,6 @@ OPTION_DEFAULT_ON([modules],[don't compile with dynamic modules support]) OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support]) OPTION_DEFAULT_OFF([native-compilation],[compile with Emacs Lisp native compiler support]) OPTION_DEFAULT_OFF([cygwin32-native-compilation],[use native compilation on 32-bit Cygwin]) -OPTION_DEFAULT_OFF([xinput2],[use version 2.0 the X Input Extension for input]) AC_ARG_WITH([file-notification],[AS_HELP_STRING([--with-file-notification=LIB], [use a file notification library (LIB one of: yes, inotify, kqueue, gfile, w32, no)])], @@ -4238,26 +4237,6 @@ fi AC_SUBST(XFIXES_CFLAGS) AC_SUBST(XFIXES_LIBS) -## Use XInput 2.0 if available -HAVE_XINPUT2=no -if test "${HAVE_X11}" = "yes" && test "${with_xinput2}" != "no"; then - EMACS_CHECK_MODULES([XINPUT], [xi]) - if test $HAVE_XINPUT = yes; then - # Now check for XInput2.h - AC_CHECK_HEADER(X11/extensions/XInput2.h, - [AC_CHECK_LIB(Xi, XIGrabButton, HAVE_XINPUT2=yes)]) - fi - if test $HAVE_XINPUT2 = yes; then - AC_DEFINE(HAVE_XINPUT2, 1, [Define to 1 if the X Input Extension version 2.0 is present.]) - if test "$USE_GTK_TOOLKIT" = "GTK2"; then - AC_MSG_WARN([You are building Emacs with GTK+ 2 and the X Input Extension version 2. -This might lead to problems if your version of GTK+ is not built with support for XInput 2.]) - fi - fi -fi -AC_SUBST(XINPUT_CFLAGS) -AC_SUBST(XINPUT_LIBS) - ### Use Xdbe (-lXdbe) if available HAVE_XDBE=no if test "${HAVE_X11}" = "yes"; then @@ -6015,7 +5994,6 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D Does Emacs support legacy unexec dumping? ${with_unexec} Which dumping strategy does Emacs use? ${with_dumping} Does Emacs have native lisp compiler? ${HAVE_NATIVE_COMP} - Does Emacs use version 2 of the the X Input Extension? ${HAVE_XINPUT2} "]) if test -n "${EMACSDATA}"; then diff --git a/src/Makefile.in b/src/Makefile.in index 4795ade3ea..4c5535f8ad 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -258,9 +258,6 @@ XINERAMA_CFLAGS = @XINERAMA_CFLAGS@ XFIXES_LIBS = @XFIXES_LIBS@ XFIXES_CFLAGS = @XFIXES_CFLAGS@ -XINPUT_LIBS = @XINPUT_LIBS@ -XINPUT_CFLAGS = @XINPUT_CFLAGS@ - XDBE_LIBS = @XDBE_LIBS@ XDBE_CFLAGS = @XDBE_CFLAGS@ @@ -377,7 +374,7 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \ $(GNUSTEP_CFLAGS) $(CFLAGS_SOUND) $(RSVG_CFLAGS) $(IMAGEMAGICK_CFLAGS) \ $(PNG_CFLAGS) $(LIBXML2_CFLAGS) $(LIBGCCJIT_CFLAGS) $(DBUS_CFLAGS) \ $(XRANDR_CFLAGS) $(XINERAMA_CFLAGS) $(XFIXES_CFLAGS) $(XDBE_CFLAGS) \ - $(WEBKIT_CFLAGS) $(WEBP_CFLAGS) $(LCMS2_CFLAGS) $(XINPUT_CFLAGS) \ + $(WEBKIT_CFLAGS) $(WEBP_CFLAGS) $(LCMS2_CFLAGS) \ $(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \ $(HARFBUZZ_CFLAGS) $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) \ @@ -527,7 +524,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(HARFBUZZ_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \ $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ - $(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT_LIBS) $(XINPUT_LIBS) + $(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT_LIBS) ## FORCE it so that admin/unidata can decide whether this file is ## up-to-date. Although since charprop depends on bootstrap-emacs, diff --git a/src/gtkutil.c b/src/gtkutil.c index 9e676cd025..a9eabf47d8 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -47,10 +47,6 @@ along with GNU Emacs. If not, see . */ #include -#ifdef HAVE_XINPUT2 -#include -#endif - #ifdef HAVE_XFT #include #endif @@ -843,23 +839,6 @@ my_log_handler (const gchar *log_domain, GLogLevelFlags log_level, } #endif -#if defined HAVE_GTK3 && defined HAVE_XINPUT2 -bool -xg_is_menu_window (Display *dpy, Window wdesc) -{ - GtkWidget *gwdesc = xg_win_to_widget (dpy, wdesc); - - if (GTK_IS_WINDOW (gwdesc)) - { - GtkWidget *fw = gtk_bin_get_child (GTK_BIN (gwdesc)); - if (GTK_IS_MENU (fw)) - return true; - } - - return false; -} -#endif - /* Make a geometry string and pass that to GTK. It seems this is the only way to get geometry position right if the user explicitly asked for a position when starting Emacs. @@ -3610,18 +3589,6 @@ xg_event_is_for_menubar (struct frame *f, const XEvent *event) if (! x->menubar_widget) return 0; -#ifdef HAVE_XINPUT2 - XIDeviceEvent *xev = (XIDeviceEvent *) event->xcookie.data; - if (event->type == GenericEvent) /* XI_ButtonPress or XI_ButtonRelease */ - { - if (! (xev->event_x >= 0 - && xev->event_x < FRAME_PIXEL_WIDTH (f) - && xev->event_y >= 0 - && xev->event_y < FRAME_MENUBAR_HEIGHT (f))) - return 0; - } - else -#endif if (! (event->xbutton.x >= 0 && event->xbutton.x < FRAME_PIXEL_WIDTH (f) && event->xbutton.y >= 0 @@ -3630,12 +3597,7 @@ xg_event_is_for_menubar (struct frame *f, const XEvent *event) return 0; gdpy = gdk_x11_lookup_xdisplay (FRAME_X_DISPLAY (f)); -#ifdef HAVE_XINPUT2 - if (event->type == GenericEvent) - gw = gdk_x11_window_lookup_for_display (gdpy, xev->event); - else -#endif - gw = gdk_x11_window_lookup_for_display (gdpy, event->xbutton.window); + gw = gdk_x11_window_lookup_for_display (gdpy, event->xbutton.window); if (! gw) return 0; gevent.any.window = gw; gevent.any.type = GDK_NOTHING; @@ -4282,20 +4244,7 @@ xg_event_is_for_scrollbar (struct frame *f, const XEvent *event) { bool retval = 0; -#ifdef HAVE_XINPUT2 - XIDeviceEvent *xev = (XIDeviceEvent *) event->xcookie.data; - if (f && ((FRAME_DISPLAY_INFO (f)->supports_xi2 - && event->type == GenericEvent - && (event->xgeneric.extension - == FRAME_DISPLAY_INFO (f)->xi2_opcode) - && ((event->xgeneric.evtype == XI_ButtonPress - && xev->detail < 4) - || (event->xgeneric.evtype == XI_Motion))) - || (event->type == ButtonPress - && event->xbutton.button < 4))) -#else if (f && event->type == ButtonPress && event->xbutton.button < 4) -#endif /* HAVE_XINPUT2 */ { /* Check if press occurred outside the edit widget. */ GdkDisplay *gdpy = gdk_x11_lookup_xdisplay (FRAME_X_DISPLAY (f)); @@ -4313,29 +4262,10 @@ xg_event_is_for_scrollbar (struct frame *f, const XEvent *event) gwin = gdk_display_get_window_at_pointer (gdpy, NULL, NULL); #endif retval = gwin != gtk_widget_get_window (f->output_data.x->edit_widget); -#ifdef HAVE_XINPUT2 - GtkWidget *grab = gtk_grab_get_current (); - if (event->type == GenericEvent - && event->xgeneric.evtype == XI_Motion) - retval = retval || (grab && GTK_IS_SCROLLBAR (grab)); -#endif } -#ifdef HAVE_XINPUT2 - else if (f && ((FRAME_DISPLAY_INFO (f)->supports_xi2 - && event->type == GenericEvent - && (event->xgeneric.extension - == FRAME_DISPLAY_INFO (f)->xi2_opcode) - && ((event->xgeneric.evtype == XI_ButtonRelease - && xev->detail < 4) - || (event->xgeneric.evtype == XI_Motion))) - || ((event->type == ButtonRelease - && event->xbutton.button < 4) - || event->type == MotionNotify))) -#else else if (f && ((event->type == ButtonRelease && event->xbutton.button < 4) || event->type == MotionNotify)) -#endif /* HAVE_XINPUT2 */ { /* If we are releasing or moving the scroll bar, it has the grab. */ GtkWidget *w = gtk_grab_get_current (); diff --git a/src/gtkutil.h b/src/gtkutil.h index 95dd75b7fa..31a12cd5d3 100644 --- a/src/gtkutil.h +++ b/src/gtkutil.h @@ -192,10 +192,6 @@ extern Lisp_Object xg_get_page_setup (void); extern void xg_print_frames_dialog (Lisp_Object); #endif -#if defined HAVE_GTK3 && defined HAVE_XINPUT2 -extern bool xg_is_menu_window (Display *dpy, Window); -#endif - /* Mark all callback data that are Lisp_object:s during GC. */ extern void xg_mark_data (void); diff --git a/src/xfns.c b/src/xfns.c index c792826e6b..785ae3baca 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -57,10 +57,6 @@ along with GNU Emacs. If not, see . */ #include #endif -#ifdef HAVE_XINPUT2 -#include -#endif - #ifdef USE_X_TOOLKIT #include @@ -3078,43 +3074,6 @@ x_window (struct frame *f, long window_prompting) class_hints.res_class = SSDATA (Vx_resource_class); XSetClassHint (FRAME_X_DISPLAY (f), XtWindow (shell_widget), &class_hints); -#ifdef HAVE_XINPUT2 - if (FRAME_DISPLAY_INFO (f)->supports_xi2) - { - XIEventMask mask; - ptrdiff_t l = XIMaskLen (XI_LASTEVENT); - unsigned char *m; - mask.mask = m = alloca (l); - memset (m, 0, l); - mask.mask_len = l; - mask.deviceid = XIAllMasterDevices; - - XISetMask (m, XI_ButtonPress); - XISetMask (m, XI_ButtonRelease); - XISetMask (m, XI_KeyPress); - XISetMask (m, XI_KeyRelease); - XISetMask (m, XI_Motion); - XISetMask (m, XI_Enter); - XISetMask (m, XI_Leave); - XISetMask (m, XI_FocusIn); - XISetMask (m, XI_FocusOut); - XISetMask (m, XI_DeviceChanged); - - XISelectEvents (FRAME_X_DISPLAY (f), - FRAME_X_WINDOW (f), - &mask, 1); - - mask.deviceid = XIAllDevices; - memset (m, 0, l); - XISetMask (m, XI_PropertyEvent); - XISetMask (m, XI_HierarchyChanged); - - XISelectEvents (FRAME_X_DISPLAY (f), - FRAME_X_WINDOW (f), - &mask, 1); - } -#endif - #ifdef HAVE_X_I18N FRAME_XIC (f) = NULL; if (use_xim) @@ -3295,43 +3254,6 @@ x_window (struct frame *f) } #endif /* HAVE_X_I18N */ -#ifdef HAVE_XINPUT2 - if (FRAME_DISPLAY_INFO (f)->supports_xi2) - { - XIEventMask mask; - ptrdiff_t l = XIMaskLen (XI_LASTEVENT); - unsigned char *m; - mask.mask = m = alloca (l); - memset (m, 0, l); - mask.mask_len = l; - mask.deviceid = XIAllMasterDevices; - - XISetMask (m, XI_ButtonPress); - XISetMask (m, XI_ButtonRelease); - XISetMask (m, XI_KeyPress); - XISetMask (m, XI_KeyRelease); - XISetMask (m, XI_Motion); - XISetMask (m, XI_Enter); - XISetMask (m, XI_Leave); - XISetMask (m, XI_FocusIn); - XISetMask (m, XI_FocusOut); - XISetMask (m, XI_DeviceChanged); - - XISelectEvents (FRAME_X_DISPLAY (f), - FRAME_X_WINDOW (f), - &mask, 1); - - mask.deviceid = XIAllDevices; - memset (m, 0, l); - XISetMask (m, XI_PropertyEvent); - XISetMask (m, XI_HierarchyChanged); - - XISelectEvents (FRAME_X_DISPLAY (f), - FRAME_X_WINDOW (f), - &mask, 1); - } -#endif - validate_x_resource_name (); class_hints.res_name = SSDATA (Vx_resource_name); diff --git a/src/xmenu.c b/src/xmenu.c index 07255911f9..ea2cbab203 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -105,11 +105,7 @@ along with GNU Emacs. If not, see . */ /* Flag which when set indicates a dialog or menu has been posted by Xt on behalf of one of the widget sets. */ -#ifndef HAVE_XINPUT2 static int popup_activated_flag; -#else -int popup_activated_flag; -#endif #ifdef USE_X_TOOLKIT diff --git a/src/xterm.c b/src/xterm.c index d0da6ad6a6..172abe919d 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -42,10 +42,6 @@ along with GNU Emacs. If not, see . */ #include #endif -#ifdef HAVE_XINPUT2 -#include -#endif - /* Load sys/types.h if not already loaded. In some systems loading it twice is suicidal. */ #ifndef makedev @@ -227,15 +223,9 @@ static bool x_handle_net_wm_state (struct frame *, const XPropertyEvent *); static void x_check_fullscreen (struct frame *); static void x_check_expected_move (struct frame *, int, int); static void x_sync_with_move (struct frame *, int, int, bool); -#ifndef HAVE_XINPUT2 static int handle_one_xevent (struct x_display_info *, const XEvent *, int *, struct input_event *); -#else -static int handle_one_xevent (struct x_display_info *, - XEvent *, int *, - struct input_event *); -#endif #if ! (defined USE_X_TOOLKIT || defined USE_MOTIF) && defined USE_GTK static int x_dispatch_event (XEvent *, Display *); #endif @@ -345,156 +335,6 @@ x_extension_initialize (struct x_display_info *dpyinfo) dpyinfo->ext_codes = ext_codes; } - -#ifdef HAVE_XINPUT2 - -/* Free all XI2 devices on dpyinfo. */ -static void -x_free_xi_devices (struct x_display_info *dpyinfo) -{ - block_input (); - - if (dpyinfo->num_devices) - { - for (int i = 0; i < dpyinfo->num_devices; ++i) - xfree (dpyinfo->devices[i].valuators); - - xfree (dpyinfo->devices); - dpyinfo->devices = NULL; - dpyinfo->num_devices = 0; - } - - unblock_input (); -} - -/* Setup valuator tracking for XI2 master devices on - DPYINFO->display. */ - -static void -x_init_master_valuators (struct x_display_info *dpyinfo) -{ - int ndevices; - XIDeviceInfo *infos; - - block_input (); - x_free_xi_devices (dpyinfo); - infos = XIQueryDevice (dpyinfo->display, - XIAllMasterDevices, - &ndevices); - - if (!ndevices) - { - XIFreeDeviceInfo (infos); - unblock_input (); - return; - } - - int actual_devices = 0; - dpyinfo->devices = xmalloc (sizeof *dpyinfo->devices * ndevices); - - for (int i = 0; i < ndevices; ++i) - { - XIDeviceInfo *device = &infos[i]; - - if (device->enabled) - { - int actual_valuator_count = 0; - struct xi_device_t *xi_device = - &dpyinfo->devices[actual_devices++]; - xi_device->device_id = device->deviceid; - xi_device->valuators = - xmalloc (sizeof *xi_device->valuators * device->num_classes); - - for (int c = 0; c < device->num_classes; ++c) - { - switch (device->classes[c]->type) - { -#ifdef XIScrollClass /* XInput 2.1 */ - case XIScrollClass: - { - XIScrollClassInfo *info = - (XIScrollClassInfo *) device->classes[c]; - struct xi_scroll_valuator_t *valuator = - &xi_device->valuators[actual_valuator_count++]; - - valuator->horizontal = (info->scroll_type == XIScrollTypeHorizontal); - valuator->invalid_p = true; - valuator->emacs_value = DBL_MIN; - valuator->increment = info->increment; - valuator->number = info->number; - break; - } -#endif - default: - break; - } - } - xi_device->scroll_valuator_count = actual_valuator_count; - } - } - - dpyinfo->num_devices = actual_devices; - XIFreeDeviceInfo (infos); - unblock_input (); -} - -/* Return the delta of the scroll valuator VALUATOR_NUMBER under - DEVICE_ID in the display DPYINFO with VALUE. The valuator's - valuator will be set to VALUE afterwards. In case no scroll - valuator is found, or if device_id is not known to Emacs, DBL_MAX - is returned. Otherwise, the valuator is returned in - VALUATOR_RETURN. */ -static double -x_get_scroll_valuator_delta (struct x_display_info *dpyinfo, int device_id, - int valuator_number, double value, - struct xi_scroll_valuator_t **valuator_return) -{ - block_input (); - - for (int i = 0; i < dpyinfo->num_devices; ++i) - { - struct xi_device_t *device = &dpyinfo->devices[i]; - - if (device->device_id == device_id) - { - for (int j = 0; j < device->scroll_valuator_count; ++j) - { - struct xi_scroll_valuator_t *sv = &device->valuators[j]; - - if (sv->number == valuator_number) - { - if (sv->invalid_p) - { - sv->current_value = value; - sv->invalid_p = false; - *valuator_return = sv; - - unblock_input (); - return 0.0; - } - else - { - double delta = sv->current_value - value; - sv->current_value = value; - *valuator_return = sv; - - unblock_input (); - return delta / sv->increment; - } - } - } - - unblock_input (); - return DBL_MAX; - } - } - - unblock_input (); - return DBL_MAX; -} - -#endif - void x_cr_destroy_frame_context (struct frame *f) { @@ -4928,16 +4768,7 @@ static struct frame * x_menubar_window_to_frame (struct x_display_info *dpyinfo, const XEvent *event) { - Window wdesc; -#ifdef HAVE_XINPUT2 - if (event->type == GenericEvent - && dpyinfo->supports_xi2 - && (event->xcookie.evtype == XI_ButtonPress - || event->xcookie.evtype == XI_ButtonRelease)) - wdesc = ((XIDeviceEvent *) event->xcookie.data)->event; - else -#endif - wdesc = event->xany.window; + Window wdesc = event->xany.window; Lisp_Object tail, frame; struct frame *f; struct x_output *x; @@ -5040,29 +4871,6 @@ x_detect_focus_change (struct x_display_info *dpyinfo, struct frame *frame, } break; -#ifdef HAVE_XINPUT2 - case GenericEvent: - { - XIEvent *xi_event = (XIEvent *) event; - - struct frame *focus_frame = dpyinfo->x_focus_event_frame; - int focus_state - = focus_frame ? focus_frame->output_data.x->focus_state : 0; - - if (!((xi_event->evtype == XI_Enter - || xi_event->evtype == XI_Leave) - && (focus_state & FOCUS_EXPLICIT))) - x_focus_changed ((xi_event->evtype == XI_Enter - || xi_event->evtype == XI_FocusIn - ? FocusIn : FocusOut), - (xi_event->evtype == XI_Enter - || xi_event->evtype == XI_Leave - ? FOCUS_IMPLICIT : FOCUS_EXPLICIT), - dpyinfo, frame, bufp); - break; - } -#endif - case FocusIn: case FocusOut: /* Ignore transient focus events from hotkeys, window manager @@ -8167,11 +7975,7 @@ mouse_or_wdesc_frame (struct x_display_info *dpyinfo, int wdesc) static int handle_one_xevent (struct x_display_info *dpyinfo, -#ifndef HAVE_XINPUT2 const XEvent *event, -#else - XEvent *event, -#endif int *finish, struct input_event *hold_quit) { union buffered_input_event inev; @@ -8197,14 +8001,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, inev.ie.kind = NO_EVENT; inev.ie.arg = Qnil; -#ifdef HAVE_XINPUT2 - if (event->type != GenericEvent) -#endif - any = x_any_window_to_frame (dpyinfo, event->xany.window); -#ifdef HAVE_XINPUT2 - else - any = NULL; -#endif + any = x_any_window_to_frame (dpyinfo, event->xany.window); if (any && any->wait_event_type == event->type) any->wait_event_type = 0; /* Indicates we got it. */ @@ -8683,10 +8480,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto OTHER; case MapNotify: -#if defined HAVE_XINPUT2 && defined HAVE_GTK3 - if (xg_is_menu_window (dpyinfo->display, event->xmap.window)) - popup_activated_flag = 1; -#endif /* We use x_top_window_to_frame because map events can come for sub-windows and they don't mean that the frame is visible. */ @@ -9725,832 +9518,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, case DestroyNotify: xft_settings_event (dpyinfo, event); break; -#ifdef HAVE_XINPUT2 - case GenericEvent: - { - if (!dpyinfo->supports_xi2) - goto OTHER; - if (event->xgeneric.extension != dpyinfo->xi2_opcode) - /* Not an XI2 event. */ - goto OTHER; - bool must_free_data = false; - XIEvent *xi_event = (XIEvent *) event->xcookie.data; - /* Sometimes the event is already claimed by GTK, which - will free its data in due course. */ - if (!xi_event && XGetEventData (dpyinfo->display, &event->xcookie)) - { - must_free_data = true; - xi_event = (XIEvent *) event->xcookie.data; - } - - XIDeviceEvent *xev = (XIDeviceEvent *) xi_event; - XILeaveEvent *leave = (XILeaveEvent *) xi_event; - XIEnterEvent *enter = (XIEnterEvent *) xi_event; - XIFocusInEvent *focusin = (XIFocusInEvent *) xi_event; - XIFocusOutEvent *focusout = (XIFocusOutEvent *) xi_event; - XIValuatorState *states; - double *values; - bool found_valuator = false; - - /* A fake XMotionEvent for x_note_mouse_movement. */ - XMotionEvent ev; - /* A fake XButtonEvent for x_construct_mouse_click. */ - XButtonEvent bv; - - if (!xi_event) - { - eassert (!must_free_data); - goto OTHER; - } - - switch (event->xcookie.evtype) - { - case XI_FocusIn: - any = x_any_window_to_frame (dpyinfo, focusin->event); -#ifndef USE_GTK - /* Some WMs (e.g. Mutter in Gnome Shell), don't unmap - minimized/iconified windows; thus, for those WMs we won't get - a MapNotify when unminimizing/deconifying. Check here if we - are deiconizing a window (Bug42655). - - But don't do that on GTK since it may cause a plain invisible - frame get reported as iconified, compare - https://lists.gnu.org/archive/html/emacs-devel/2017-02/msg00133.html. - That is fixed above but bites us here again. */ - f = any; - if (f && FRAME_ICONIFIED_P (f)) - { - SET_FRAME_VISIBLE (f, 1); - SET_FRAME_ICONIFIED (f, false); - f->output_data.x->has_been_visible = true; - inev.ie.kind = DEICONIFY_EVENT; - XSETFRAME (inev.ie.frame_or_window, f); - } -#endif /* USE_GTK */ - x_detect_focus_change (dpyinfo, any, event, &inev.ie); - goto XI_OTHER; - case XI_FocusOut: - any = x_any_window_to_frame (dpyinfo, focusout->event); - x_detect_focus_change (dpyinfo, any, event, &inev.ie); - goto XI_OTHER; - case XI_Enter: - any = x_any_window_to_frame (dpyinfo, enter->event); - ev.x = lrint (enter->event_x); - ev.y = lrint (enter->event_y); - ev.window = leave->event; - - x_display_set_last_user_time (dpyinfo, xi_event->time); - x_detect_focus_change (dpyinfo, any, event, &inev.ie); - f = any; - - if (f && x_mouse_click_focus_ignore_position) - ignore_next_mouse_click_timeout = xi_event->time + 200; - - /* EnterNotify counts as mouse movement, - so update things that depend on mouse position. */ - if (f && !f->output_data.x->hourglass_p) - x_note_mouse_movement (f, &ev); -#ifdef USE_GTK - /* We may get an EnterNotify on the buttons in the toolbar. In that - case we moved out of any highlighted area and need to note this. */ - if (!f && dpyinfo->last_mouse_glyph_frame) - x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev); -#endif - goto XI_OTHER; - case XI_Leave: - ev.x = lrint (leave->event_x); - ev.y = lrint (leave->event_y); - ev.window = leave->event; - any = x_any_window_to_frame (dpyinfo, leave->event); - - x_display_set_last_user_time (dpyinfo, xi_event->time); - x_detect_focus_change (dpyinfo, any, event, &inev.ie); - - f = x_top_window_to_frame (dpyinfo, leave->event); - if (f) - { - if (f == hlinfo->mouse_face_mouse_frame) - { - /* If we move outside the frame, then we're - certainly no longer on any text in the frame. */ - clear_mouse_face (hlinfo); - hlinfo->mouse_face_mouse_frame = 0; - } - - /* Generate a nil HELP_EVENT to cancel a help-echo. - Do it only if there's something to cancel. - Otherwise, the startup message is cleared when - the mouse leaves the frame. */ - if (any_help_event_p) - do_help = -1; - } -#ifdef USE_GTK - /* See comment in EnterNotify above */ - else if (dpyinfo->last_mouse_glyph_frame) - x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev); -#endif - goto XI_OTHER; - case XI_Motion: - /* First test if there is some kind of scroll event - here! */ - states = &xev->valuators; - values = states->values; - - x_display_set_last_user_time (dpyinfo, xi_event->time); - - for (int i = 0; i < states->mask_len * 8; i++) - { - if (XIMaskIsSet (states->mask, i)) - { - block_input (); - - struct xi_scroll_valuator_t *val; - double delta = - x_get_scroll_valuator_delta (dpyinfo, xev->deviceid, - i, *values, &val); - - if (delta != DBL_MAX) - { - /* TODO: Figure out how pixelwise scrolling should work. - Until that happens, this will have to do. */ - delta *= 10; - - f = mouse_or_wdesc_frame (dpyinfo, xev->event); - found_valuator = true; - if (signbit (delta) != signbit (val->emacs_value)) - val->emacs_value = DBL_MIN; - - val->emacs_value += delta; - - if (!f) - { - f = x_any_window_to_frame (dpyinfo, xev->event); - - if (!f) - { - unblock_input (); - goto XI_OTHER; - } - } - - if ((val->horizontal - && fabs (val->emacs_value) >= FRAME_COLUMN_WIDTH (f)) - || (!val->horizontal - && fabs (val->emacs_value) >= FRAME_LINE_HEIGHT (f))) - { - Lisp_Object tab_bar_arg = Qnil; - bool tab_bar_p = false; - bool tool_bar_p = false; - bool s = signbit (val->emacs_value); - - bv.button = !val->horizontal ? (s ? 5 : 4) : (s ? 7 : 6); - bv.type = ButtonPress; - - bv.x = lrint (xev->event_x); - bv.y = lrint (xev->event_y); - bv.window = xev->event; - bv.state = xev->mods.base - | xev->mods.effective - | xev->mods.latched - | xev->mods.locked; - - /* Is this in the tab-bar? */ - if (WINDOWP (f->tab_bar_window) - && WINDOW_TOTAL_LINES (XWINDOW (f->tab_bar_window))) - { - Lisp_Object window; - int x = bv.x; - int y = bv.y; - - window = window_from_coordinates (f, x, y, 0, true, true); - tab_bar_p = EQ (window, f->tab_bar_window); - - if (tab_bar_p) - { - tab_bar_arg = handle_tab_bar_click - (f, x, y, true, x_x_to_emacs_modifiers (dpyinfo, bv.state)); - tab_bar_arg = handle_tab_bar_click - (f, x, y, false, x_x_to_emacs_modifiers (dpyinfo, bv.state)); - } - } - - if (!NILP (tab_bar_arg)) - inev.ie.arg = tab_bar_arg; - - if (!tool_bar_p && !(NILP (tab_bar_arg) && tab_bar_p)) - { - if (ignore_next_mouse_click_timeout) - { - if (xev->time > ignore_next_mouse_click_timeout) - { - /* XXX: Wouldn't it be better - to just use wheel events - instead of pretending to be - X here? */ - x_construct_mouse_click (&inev.ie, &bv, f); - if (!NILP (tab_bar_arg)) - inev.ie.arg = tab_bar_arg; - kbd_buffer_store_event (&inev.ie); - inev.ie.modifiers &= ~down_modifier; - inev.ie.modifiers |= up_modifier; - kbd_buffer_store_event (&inev.ie); - } - ignore_next_mouse_click_timeout = 0; - } - else - { - x_construct_mouse_click (&inev.ie, &bv, f); - kbd_buffer_store_event (&inev.ie); - inev.ie.modifiers &= ~down_modifier; - inev.ie.modifiers |= up_modifier; - kbd_buffer_store_event (&inev.ie); - } - } - - val->emacs_value = DBL_MIN; - } - } - unblock_input (); - values++; - } - - inev.ie.kind = NO_EVENT; - } - - if (found_valuator) - goto XI_OTHER; - - ev.x = lrint (xev->event_x); - ev.y = lrint (xev->event_y); - ev.window = xev->event; - - previous_help_echo_string = help_echo_string; - help_echo_string = Qnil; - - if (hlinfo->mouse_face_hidden) - { - hlinfo->mouse_face_hidden = false; - clear_mouse_face (hlinfo); - } - - f = mouse_or_wdesc_frame (dpyinfo, xev->event); - -#ifdef USE_GTK - if (f && xg_event_is_for_scrollbar (f, event)) - f = 0; -#endif - if (f) - { - /* Maybe generate a SELECT_WINDOW_EVENT for - `mouse-autoselect-window' but don't let popup menus - interfere with this (Bug#1261). */ - if (!NILP (Vmouse_autoselect_window) - && !popup_activated () - /* Don't switch if we're currently in the minibuffer. - This tries to work around problems where the - minibuffer gets unselected unexpectedly, and where - you then have to move your mouse all the way down to - the minibuffer to select it. */ - && !MINI_WINDOW_P (XWINDOW (selected_window)) - /* With `focus-follows-mouse' non-nil create an event - also when the target window is on another frame. */ - && (f == XFRAME (selected_frame) - || !NILP (focus_follows_mouse))) - { - static Lisp_Object last_mouse_window; - Lisp_Object window = window_from_coordinates (f, ev.x, ev.y, 0, false, false); - - /* A window will be autoselected only when it is not - selected now and the last mouse movement event was - not in it. The remainder of the code is a bit vague - wrt what a "window" is. For immediate autoselection, - the window is usually the entire window but for GTK - where the scroll bars don't count. For delayed - autoselection the window is usually the window's text - area including the margins. */ - if (WINDOWP (window) - && !EQ (window, last_mouse_window) - && !EQ (window, selected_window)) - { - inev.ie.kind = SELECT_WINDOW_EVENT; - inev.ie.frame_or_window = window; - } - - /* Remember the last window where we saw the mouse. */ - last_mouse_window = window; - } - - if (!x_note_mouse_movement (f, &ev)) - help_echo_string = previous_help_echo_string; - } - else - { -#ifndef USE_TOOLKIT_SCROLL_BARS - struct scroll_bar *bar - = x_window_to_scroll_bar (xi_event->display, xev->event, 2); - - if (bar) - x_scroll_bar_note_movement (bar, &ev); -#endif /* USE_TOOLKIT_SCROLL_BARS */ - - /* If we move outside the frame, then we're - certainly no longer on any text in the frame. */ - clear_mouse_face (hlinfo); - } - - /* If the contents of the global variable help_echo_string - has changed, generate a HELP_EVENT. */ - if (!NILP (help_echo_string) - || !NILP (previous_help_echo_string)) - do_help = 1; - goto XI_OTHER; - case XI_ButtonRelease: - case XI_ButtonPress: - { - /* If we decide we want to generate an event to be seen - by the rest of Emacs, we put it here. */ - Lisp_Object tab_bar_arg = Qnil; - bool tab_bar_p = false; - bool tool_bar_p = false; - - /* Ignore emulated scroll events when XI2 native - scroll events are present. */ - if (dpyinfo->xi2_version >= 1 && xev->detail >= 4 - && xev->detail <= 8) - goto XI_OTHER; - - bv.button = xev->detail; - bv.type = xev->evtype == XI_ButtonPress ? ButtonPress : ButtonRelease; - bv.x = lrint (xev->event_x); - bv.y = lrint (xev->event_y); - bv.window = xev->event; - bv.state = xev->mods.base - | xev->mods.effective - | xev->mods.latched - | xev->mods.locked; - - memset (&compose_status, 0, sizeof (compose_status)); - dpyinfo->last_mouse_glyph_frame = NULL; - x_display_set_last_user_time (dpyinfo, xev->time); - - f = mouse_or_wdesc_frame (dpyinfo, xev->event); - - if (f && xev->evtype == XI_ButtonPress - && !popup_activated () - && !x_window_to_scroll_bar (xev->display, xev->event, 2) - && !FRAME_NO_ACCEPT_FOCUS (f)) - { - /* When clicking into a child frame or when clicking - into a parent frame with the child frame selected and - `no-accept-focus' is not set, select the clicked - frame. */ - struct frame *hf = dpyinfo->highlight_frame; - - if (FRAME_PARENT_FRAME (f) || (hf && frame_ancestor_p (f, hf))) - { - block_input (); - XSetInputFocus (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), - RevertToParent, CurrentTime); - if (FRAME_PARENT_FRAME (f)) - XRaiseWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f)); - unblock_input (); - } - } - -#ifdef USE_GTK - if (f && xg_event_is_for_scrollbar (f, event)) - f = 0; -#endif - - if (f) - { - /* Is this in the tab-bar? */ - if (WINDOWP (f->tab_bar_window) - && WINDOW_TOTAL_LINES (XWINDOW (f->tab_bar_window))) - { - Lisp_Object window; - int x = bv.x; - int y = bv.y; - - window = window_from_coordinates (f, x, y, 0, true, true); - tab_bar_p = EQ (window, f->tab_bar_window); - - if (tab_bar_p) - tab_bar_arg = handle_tab_bar_click - (f, x, y, xev->evtype == XI_ButtonPress, - x_x_to_emacs_modifiers (dpyinfo, bv.state)); - } - -#if ! defined (USE_GTK) - /* Is this in the tool-bar? */ - if (WINDOWP (f->tool_bar_window) - && WINDOW_TOTAL_LINES (XWINDOW (f->tool_bar_window))) - { - Lisp_Object window; - int x = bv.x; - int y = bv.y; - - window = window_from_coordinates (f, x, y, 0, true, true); - tool_bar_p = EQ (window, f->tool_bar_window); - - if (tool_bar_p && xev->detail < 4) - handle_tool_bar_click - (f, x, y, xev->evtype == XI_ButtonPress, - x_x_to_emacs_modifiers (dpyinfo, bv.state)); - } -#endif /* !USE_GTK */ - - if (!(tab_bar_p && NILP (tab_bar_arg)) && !tool_bar_p) -#if defined (USE_X_TOOLKIT) || defined (USE_GTK) - if (! popup_activated ()) -#endif - { - if (ignore_next_mouse_click_timeout) - { - if (xev->evtype == XI_ButtonPress - && xev->time > ignore_next_mouse_click_timeout) - { - ignore_next_mouse_click_timeout = 0; - x_construct_mouse_click (&inev.ie, &bv, f); - } - if (xev->evtype == XI_ButtonRelease) - ignore_next_mouse_click_timeout = 0; - } - else - x_construct_mouse_click (&inev.ie, &bv, f); - - if (!NILP (tab_bar_arg)) - inev.ie.arg = tab_bar_arg; - } - if (FRAME_X_EMBEDDED_P (f)) - xembed_send_message (f, xev->time, - XEMBED_REQUEST_FOCUS, 0, 0, 0); - } - - if (xev->evtype == XI_ButtonPress) - { - dpyinfo->grabbed |= (1 << xev->detail); - dpyinfo->last_mouse_frame = f; - if (f && !tab_bar_p) - f->last_tab_bar_item = -1; -#if ! defined (USE_GTK) - if (f && !tool_bar_p) - f->last_tool_bar_item = -1; -#endif /* not USE_GTK */ - - } - else - dpyinfo->grabbed &= ~(1 << xev->detail); - - if (f) - f->mouse_moved = false; - -#if defined (USE_GTK) - /* No Xt toolkit currently available has support for XI2. - So the code here assumes use of GTK. */ - f = x_menubar_window_to_frame (dpyinfo, event); - if (f /* Gtk+ menus only react to the first three buttons. */ - && xev->detail < 3) - { - /* What is done with Core Input ButtonPressed is not - possible here, because GenericEvents cannot be saved. */ - bool was_waiting_for_input = waiting_for_input; - /* This hack was adopted from the NS port. Whether - or not it is actually safe is a different story - altogether. */ - if (waiting_for_input) - waiting_for_input = 0; - set_frame_menubar (f, true); - waiting_for_input = was_waiting_for_input; - } -#endif - goto XI_OTHER; - } - case XI_KeyPress: - { - int state = xev->mods.base - | xev->mods.effective - | xev->mods.latched - | xev->mods.locked; - Lisp_Object c; -#ifdef HAVE_XKB - unsigned int mods_rtrn; -#endif - int keycode = xev->detail; - KeySym keysym; - char copy_buffer[81]; - char *copy_bufptr = copy_buffer; - unsigned char *copy_ubufptr; -#ifdef HAVE_XKB - int copy_bufsiz = sizeof (copy_buffer); -#endif - ptrdiff_t i; - int nchars, len; - -#ifdef HAVE_XKB - if (dpyinfo->xkb_desc) - { - if (!XkbTranslateKeyCode (dpyinfo->xkb_desc, keycode, - state, &mods_rtrn, &keysym)) - goto XI_OTHER; - } - else - { -#endif - int keysyms_per_keycode_return; - KeySym *ksms = XGetKeyboardMapping (dpyinfo->display, keycode, 1, - &keysyms_per_keycode_return); - if (!(keysym = ksms[0])) - { - XFree (ksms); - goto XI_OTHER; - } - XFree (ksms); -#ifdef HAVE_XKB - } -#endif - - if (keysym == NoSymbol) - goto XI_OTHER; - - x_display_set_last_user_time (dpyinfo, xev->time); - ignore_next_mouse_click_timeout = 0; - -#if defined (USE_X_TOOLKIT) || defined (USE_GTK) - /* Dispatch XI_KeyPress events when in menu. */ - if (popup_activated ()) - goto XI_OTHER; -#endif - - f = x_any_window_to_frame (dpyinfo, xev->event); - - /* If mouse-highlight is an integer, input clears out - mouse highlighting. */ - if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight) - && (f == 0 -#if ! defined (USE_GTK) - || !EQ (f->tool_bar_window, hlinfo->mouse_face_window) -#endif - || !EQ (f->tab_bar_window, hlinfo->mouse_face_window)) - ) - { - clear_mouse_face (hlinfo); - hlinfo->mouse_face_hidden = true; - } - - if (f != 0) - { -#ifdef USE_GTK - /* Don't pass keys to GTK. A Tab will shift focus to the - tool bar in GTK 2.4. Keys will still go to menus and - dialogs because in that case popup_activated is nonzero - (see above). */ - *finish = X_EVENT_DROP; -#endif - /* If not using XIM/XIC, and a compose sequence is in progress, - we break here. Otherwise, chars_matched is always 0. */ - if (compose_status.chars_matched > 0 && nbytes == 0) - goto XI_OTHER; - - memset (&compose_status, 0, sizeof (compose_status)); - - XSETFRAME (inev.ie.frame_or_window, f); - inev.ie.modifiers - = x_x_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), state); - inev.ie.timestamp = xev->time; - - /* First deal with keysyms which have defined - translations to characters. */ - if (keysym >= 32 && keysym < 128) - /* Avoid explicitly decoding each ASCII character. */ - { - inev.ie.kind = ASCII_KEYSTROKE_EVENT; - inev.ie.code = keysym; - - goto xi_done_keysym; - } - - /* Keysyms directly mapped to Unicode characters. */ - if (keysym >= 0x01000000 && keysym <= 0x0110FFFF) - { - if (keysym < 0x01000080) - inev.ie.kind = ASCII_KEYSTROKE_EVENT; - else - inev.ie.kind = MULTIBYTE_CHAR_KEYSTROKE_EVENT; - inev.ie.code = keysym & 0xFFFFFF; - goto xi_done_keysym; - } - - /* Now non-ASCII. */ - if (HASH_TABLE_P (Vx_keysym_table) - && (c = Fgethash (make_fixnum (keysym), - Vx_keysym_table, - Qnil), - FIXNATP (c))) - { - inev.ie.kind = (SINGLE_BYTE_CHAR_P (XFIXNAT (c)) - ? ASCII_KEYSTROKE_EVENT - : MULTIBYTE_CHAR_KEYSTROKE_EVENT); - inev.ie.code = XFIXNAT (c); - goto xi_done_keysym; - } - - /* Random non-modifier sorts of keysyms. */ - if (((keysym >= XK_BackSpace && keysym <= XK_Escape) - || keysym == XK_Delete -#ifdef XK_ISO_Left_Tab - || (keysym >= XK_ISO_Left_Tab - && keysym <= XK_ISO_Enter) -#endif - || IsCursorKey (keysym) /* 0xff50 <= x < 0xff60 */ - || IsMiscFunctionKey (keysym) /* 0xff60 <= x < VARIES */ -#ifdef HPUX - /* This recognizes the "extended function - keys". It seems there's no cleaner way. - Test IsModifierKey to avoid handling - mode_switch incorrectly. */ - || (XK_Select <= keysym && keysym < XK_KP_Space) -#endif -#ifdef XK_dead_circumflex - || keysym == XK_dead_circumflex -#endif -#ifdef XK_dead_grave - || keysym == XK_dead_grave -#endif -#ifdef XK_dead_tilde - || keysym == XK_dead_tilde -#endif -#ifdef XK_dead_diaeresis - || keysym == XK_dead_diaeresis -#endif -#ifdef XK_dead_macron - || keysym == XK_dead_macron -#endif -#ifdef XK_dead_degree - || keysym == XK_dead_degree -#endif -#ifdef XK_dead_acute - || keysym == XK_dead_acute -#endif -#ifdef XK_dead_cedilla - || keysym == XK_dead_cedilla -#endif -#ifdef XK_dead_breve - || keysym == XK_dead_breve -#endif -#ifdef XK_dead_ogonek - || keysym == XK_dead_ogonek -#endif -#ifdef XK_dead_caron - || keysym == XK_dead_caron -#endif -#ifdef XK_dead_doubleacute - || keysym == XK_dead_doubleacute -#endif -#ifdef XK_dead_abovedot - || keysym == XK_dead_abovedot -#endif - || IsKeypadKey (keysym) /* 0xff80 <= x < 0xffbe */ - || IsFunctionKey (keysym) /* 0xffbe <= x < 0xffe1 */ - /* Any "vendor-specific" key is ok. */ - || (keysym & (1 << 28)) - || (keysym != NoSymbol && nbytes == 0)) - && ! (IsModifierKey (keysym) - /* The symbols from XK_ISO_Lock - to XK_ISO_Last_Group_Lock - don't have real modifiers but - should be treated similarly to - Mode_switch by Emacs. */ -#if defined XK_ISO_Lock && defined XK_ISO_Last_Group_Lock - || (XK_ISO_Lock <= keysym - && keysym <= XK_ISO_Last_Group_Lock) -#endif - )) - { - STORE_KEYSYM_FOR_DEBUG (keysym); - /* make_lispy_event will convert this to a symbolic - key. */ - inev.ie.kind = NON_ASCII_KEYSTROKE_EVENT; - inev.ie.code = keysym; - goto xi_done_keysym; - } - -#ifdef HAVE_XKB - int overflow = 0; - KeySym sym = keysym; - - if (dpyinfo->xkb_desc) - { - if (!(nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, - state & ~mods_rtrn, copy_bufptr, - copy_bufsiz, &overflow))) - goto XI_OTHER; - } - else -#else - { - block_input (); - char *str = XKeysymToString (keysym); - if (!str) - { - unblock_input (); - goto XI_OTHER; - } - nbytes = strlen (str) + 1; - copy_bufptr = alloca (nbytes); - strcpy (copy_bufptr, str); - unblock_input (); - } -#endif -#ifdef HAVE_XKB - if (overflow) - { - overflow = 0; - copy_bufptr = alloca (copy_bufsiz + overflow); - keysym = sym; - if (!(nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, - state & ~mods_rtrn, copy_bufptr, - copy_bufsiz + overflow, &overflow))) - goto XI_OTHER; - - if (overflow) - goto XI_OTHER; - } -#endif - - for (i = 0, nchars = 0; i < nbytes; i++) - { - if (ASCII_CHAR_P (copy_bufptr[i])) - nchars++; - STORE_KEYSYM_FOR_DEBUG (copy_bufptr[i]); - } - - if (nchars < nbytes) - { - /* Decode the input data. */ - - setup_coding_system (Vlocale_coding_system, &coding); - coding.src_multibyte = false; - coding.dst_multibyte = true; - /* The input is converted to events, thus we can't - handle composition. Anyway, there's no XIM that - gives us composition information. */ - coding.common_flags &= ~CODING_ANNOTATION_MASK; - - SAFE_NALLOCA (coding.destination, MAX_MULTIBYTE_LENGTH, - nbytes); - coding.dst_bytes = MAX_MULTIBYTE_LENGTH * nbytes; - coding.mode |= CODING_MODE_LAST_BLOCK; - decode_coding_c_string (&coding, (unsigned char *) copy_bufptr, nbytes, Qnil); - nbytes = coding.produced; - nchars = coding.produced_char; - copy_bufptr = (char *) coding.destination; - } - - copy_ubufptr = (unsigned char *) copy_bufptr; - - /* Convert the input data to a sequence of - character events. */ - for (i = 0; i < nbytes; i += len) - { - int ch; - if (nchars == nbytes) - ch = copy_ubufptr[i], len = 1; - else - ch = string_char_and_length (copy_ubufptr + i, &len); - inev.ie.kind = (SINGLE_BYTE_CHAR_P (ch) - ? ASCII_KEYSTROKE_EVENT - : MULTIBYTE_CHAR_KEYSTROKE_EVENT); - inev.ie.code = ch; - kbd_buffer_store_buffered_event (&inev, hold_quit); - } - - inev.ie.kind = NO_EVENT; - goto xi_done_keysym; - } - goto XI_OTHER; - } - case XI_KeyRelease: - x_display_set_last_user_time (dpyinfo, xev->time); - goto XI_OTHER; - case XI_PropertyEvent: - case XI_HierarchyChanged: - case XI_DeviceChanged: - x_init_master_valuators (dpyinfo); - goto XI_OTHER; - default: - goto XI_OTHER; - } - xi_done_keysym: - if (must_free_data) - XFreeEventData (dpyinfo->display, &event->xcookie); - goto done_keysym; - XI_OTHER: - if (must_free_data) - XFreeEventData (dpyinfo->display, &event->xcookie); - goto OTHER; - } -#endif default: OTHER: @@ -14225,40 +13192,6 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) dpyinfo->supports_xdbe = true; #endif -#ifdef HAVE_XINPUT2 - dpyinfo->supports_xi2 = false; - int rc; - int major = 2; -#ifdef XI_BarrierHit /* XInput 2.3 */ - int minor = 3; -#elif defined XI_TouchBegin /* XInput 2.2 */ - int minor = 2; -#elif defined XIScrollClass /* XInput 1.1 */ - int minor = 1; -#else /* Some old version of XI2 we're not interested in. */ - int minor = 0; -#endif - int fer, fee; - - if (XQueryExtension (dpyinfo->display, "XInputExtension", - &dpyinfo->xi2_opcode, &fer, &fee)) - { - rc = XIQueryVersion (dpyinfo->display, &major, &minor); - if (rc == Success) - { - dpyinfo->supports_xi2 = true; - x_init_master_valuators (dpyinfo); - } - } - dpyinfo->xi2_version = minor; -#endif - -#ifdef HAVE_XKB - dpyinfo->xkb_desc = XkbGetMap (dpyinfo->display, - XkbAllComponentsMask, - XkbUseCoreKbd); -#endif - #if defined USE_CAIRO || defined HAVE_XFT { /* If we are using Xft, the following precautions should be made: @@ -14691,14 +13624,6 @@ x_delete_terminal (struct terminal *terminal) XrmDestroyDatabase (dpyinfo->rdb); #endif -#ifdef HAVE_XKB - 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 @@ -14858,12 +13783,9 @@ x_initialize (void) void init_xterm (void) { -#ifndef HAVE_XINPUT2 - /* Emacs can handle only core input events when built without XI2 - support, so make sure Gtk doesn't use Xinput or Xinput2 - extensions. */ + /* Emacs can handle only core input events, so make sure + Gtk doesn't use Xinput or Xinput2 extensions. */ xputenv ("GDK_CORE_DEVICE_EVENTS=1"); -#endif } #endif diff --git a/src/xterm.h b/src/xterm.h index 25eddf8bf2..9d9534dd62 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -88,10 +88,6 @@ typedef GtkWidget *xt_or_gtk_widget; #include #endif -#ifdef HAVE_XKB -#include -#endif - #include "dispextern.h" #include "termhooks.h" @@ -167,26 +163,6 @@ struct color_name_cache_entry char *name; }; -#ifdef HAVE_XINPUT2 -struct xi_scroll_valuator_t -{ - bool invalid_p; - double current_value; - double emacs_value; - double increment; - - int number; - int horizontal; -}; - -struct xi_device_t -{ - int device_id; - int scroll_valuator_count; - struct xi_scroll_valuator_t *valuators; -}; -#endif - Status x_parse_color (struct frame *f, const char *color_name, XColor *color); @@ -498,19 +474,6 @@ struct x_display_info #ifdef HAVE_XDBE bool supports_xdbe; #endif - -#ifdef HAVE_XINPUT2 - bool supports_xi2; - int xi2_version; - int xi2_opcode; - - int num_devices; - struct xi_device_t *devices; -#endif - -#ifdef HAVE_XKB - XkbDescPtr xkb_desc; -#endif }; #ifdef HAVE_X_I18N @@ -518,11 +481,6 @@ struct x_display_info extern bool use_xim; #endif -#ifdef HAVE_XINPUT2 -/* Defined in xmenu.c. */ -extern int popup_activated_flag; -#endif - /* This is a chain of structures for all the X displays currently in use. */ extern struct x_display_info *x_display_list; commit 12beb77ec83fdda5caf793d724f991b068979006 Author: Po Lu Date: Wed Nov 10 14:04:22 2021 +0800 Revert "Fix erasing cursor on top of raised boxes in NS port" This reverts commit 2b5a2ab50b7817f84ae38f84b4ea36ea38cd5a3b. diff --git a/src/nsterm.m b/src/nsterm.m index 8ee5c03b97..ed0e7a2aae 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -3510,12 +3510,6 @@ larger if there are taller display elements (e.g., characters [(raised_p ? lightCol : darkCol) set]; - if (top_p) - { - NSRectFill (NSMakeRect (NSMinX (outer), NSMinY (outer), - NSWidth (outer), hthickness)); - } - if (top_p || left_p) { NSBezierPath *p = [NSBezierPath bezierPath]; @@ -3555,12 +3549,6 @@ larger if there are taller display elements (e.g., characters [p closePath]; [p fill]; } - - if (bottom_p) - { - NSRectFill (NSMakeRect (NSMinX (outer), NSMaxY (inner), - NSWidth (outer), hthickness)); - } } commit da5de19423af672925ff5f257c26f13635d431cb Author: Po Lu Date: Wed Nov 10 14:04:21 2021 +0800 Revert "Revert "Fix erasing cursor on top of raised boxes in NS port"" This reverts commit 7117bbc7aa905ae785fa564cb24c3fc75ef1d543. diff --git a/src/nsterm.m b/src/nsterm.m index ed0e7a2aae..8ee5c03b97 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -3510,6 +3510,12 @@ larger if there are taller display elements (e.g., characters [(raised_p ? lightCol : darkCol) set]; + if (top_p) + { + NSRectFill (NSMakeRect (NSMinX (outer), NSMinY (outer), + NSWidth (outer), hthickness)); + } + if (top_p || left_p) { NSBezierPath *p = [NSBezierPath bezierPath]; @@ -3549,6 +3555,12 @@ larger if there are taller display elements (e.g., characters [p closePath]; [p fill]; } + + if (bottom_p) + { + NSRectFill (NSMakeRect (NSMinX (outer), NSMaxY (inner), + NSWidth (outer), hthickness)); + } } commit e9b954f0fdc91eaad32d853e82ad8cb4c53c69d2 Author: Po Lu Date: Wed Nov 10 14:04:05 2021 +0800 Revert "Support opening the toolkit menu bar on NS" This reverts commit ff9cf991c1608cd2578a66cba41e654a2b5d9144. diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index e50d4fee48..1a81f1a3d0 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -2665,10 +2665,9 @@ first TTY menu-bar menu to be dropped down. Interactively, this is the numeric argument to the command. This function decides which method to use to access the menu depending on FRAME's terminal device. On X displays, it calls -`x-menu-bar-open'; on Windows, `w32-menu-bar-open'; -on NS, `ns-menu-bar-open'; otherwise it calls either `popup-menu' -or `tmm-menubar' depending on whether `tty-menu-open-use-tmm' -is nil or not. +`x-menu-bar-open'; on Windows, `w32-menu-bar-open'; otherwise it +calls either `popup-menu' or `tmm-menubar' depending on whether +`tty-menu-open-use-tmm' is nil or not. If FRAME is nil or not given, use the selected frame." (interactive @@ -2677,7 +2676,6 @@ If FRAME is nil or not given, use the selected frame." (cond ((eq type 'x) (x-menu-bar-open frame)) ((eq type 'w32) (w32-menu-bar-open frame)) - ((eq type 'ns) (ns-menu-bar-open frame)) ((and (null tty-menu-open-use-tmm) (not (zerop (or (frame-parameter nil 'menu-bar-lines) 0)))) ;; Make sure the menu bar is up to date. One situation where diff --git a/src/nsmenu.m b/src/nsmenu.m index b93d3a79bd..29201e6907 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -439,44 +439,6 @@ ns_update_menubar (f, deep_p); } -void -ns_activate_menubar (struct frame *frame) -{ - if (frame != SELECTED_FRAME () - || !FRAME_EXTERNAL_MENU_BAR (frame)) - return; - - block_input (); - NSApplication *app = [NSApplication sharedApplication]; - NSMenu *menu = [app mainMenu]; - for (NSMenuItem *item in [menu itemArray]) - { - if ([item hasSubmenu]) - { -#ifdef NS_IMPL_GNUSTEP - [[item submenu] display]; -#else - NSWindow *window = [FRAME_NS_VIEW (frame) window]; - NSScreen *screen = [window screen]; - - NSRect screen_frame = [screen frame]; - [app postEvent: [NSEvent mouseEventWithType: NSLeftMouseDown - location: NSMakePoint (NSMinX (screen_frame), - NSMinY (screen_frame) + 10) - modifierFlags: 0 - timestamp: 0 - windowNumber: [window windowNumber] - context: [NSGraphicsContext currentContext] - eventNumber: 0 - clickCount: 1 - pressure: 1.0f] - atStart: YES]; -#endif - break; - } - } - unblock_input (); -} /* ========================================================================== @@ -1954,22 +1916,6 @@ - (Lisp_Object)runDialogAt: (NSPoint)p return popup_activated () ? Qt : Qnil; } -DEFUN ("ns-menu-bar-open", Fns_menu_bar_open, Sns_menu_bar_open, 0, 1, "i", - doc: /* Start key navigation of the menu bar in FRAME. -This initially opens the first menu bar item and you can then navigate with the -arrow keys, select a menu entry with the return key or cancel with the -escape key. If FRAME has no menu bar this function does nothing. - -If FRAME is nil or not given, use the selected frame. */) - (Lisp_Object frame) -{ - struct frame *f = decode_window_system_frame (frame); - - ns_activate_menubar (f); - - return Qnil; -} - /* ========================================================================== Lisp interface declaration @@ -1981,7 +1927,6 @@ - (Lisp_Object)runDialogAt: (NSPoint)p { defsubr (&Sns_reset_menu); defsubr (&Smenu_or_popup_active_p); - defsubr (&Sns_menu_bar_open); DEFSYM (Qdebug_on_next_call, "debug-on-next-call"); } diff --git a/src/nsterm.m b/src/nsterm.m index 4e84e130b8..ed0e7a2aae 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -5067,7 +5067,6 @@ static Lisp_Object ns_new_font (struct frame *f, Lisp_Object font_object, terminal->delete_frame_hook = ns_destroy_window; terminal->delete_terminal_hook = ns_delete_terminal; terminal->change_tab_bar_height_hook = ns_change_tab_bar_height; - terminal->activate_menubar_hook = ns_activate_menubar; /* Other hooks are NULL by default. */ return terminal; commit ff9cf991c1608cd2578a66cba41e654a2b5d9144 Author: oldosfan Date: Wed Oct 20 10:54:27 2021 +0800 Support opening the toolkit menu bar on NS * src/nsmenu.m (ns_activate_menubar, Fns_open_menubar): New functions. * src/nsterm.m (ns_create_terminal): Add activate_menubar_hook. * lisp/menu-bar.el (menu-bar-open): Use ns-menu-bar-open on Nextstep. diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index 1a81f1a3d0..e50d4fee48 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -2665,9 +2665,10 @@ first TTY menu-bar menu to be dropped down. Interactively, this is the numeric argument to the command. This function decides which method to use to access the menu depending on FRAME's terminal device. On X displays, it calls -`x-menu-bar-open'; on Windows, `w32-menu-bar-open'; otherwise it -calls either `popup-menu' or `tmm-menubar' depending on whether -`tty-menu-open-use-tmm' is nil or not. +`x-menu-bar-open'; on Windows, `w32-menu-bar-open'; +on NS, `ns-menu-bar-open'; otherwise it calls either `popup-menu' +or `tmm-menubar' depending on whether `tty-menu-open-use-tmm' +is nil or not. If FRAME is nil or not given, use the selected frame." (interactive @@ -2676,6 +2677,7 @@ If FRAME is nil or not given, use the selected frame." (cond ((eq type 'x) (x-menu-bar-open frame)) ((eq type 'w32) (w32-menu-bar-open frame)) + ((eq type 'ns) (ns-menu-bar-open frame)) ((and (null tty-menu-open-use-tmm) (not (zerop (or (frame-parameter nil 'menu-bar-lines) 0)))) ;; Make sure the menu bar is up to date. One situation where diff --git a/src/nsmenu.m b/src/nsmenu.m index 29201e6907..b93d3a79bd 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -439,6 +439,44 @@ ns_update_menubar (f, deep_p); } +void +ns_activate_menubar (struct frame *frame) +{ + if (frame != SELECTED_FRAME () + || !FRAME_EXTERNAL_MENU_BAR (frame)) + return; + + block_input (); + NSApplication *app = [NSApplication sharedApplication]; + NSMenu *menu = [app mainMenu]; + for (NSMenuItem *item in [menu itemArray]) + { + if ([item hasSubmenu]) + { +#ifdef NS_IMPL_GNUSTEP + [[item submenu] display]; +#else + NSWindow *window = [FRAME_NS_VIEW (frame) window]; + NSScreen *screen = [window screen]; + + NSRect screen_frame = [screen frame]; + [app postEvent: [NSEvent mouseEventWithType: NSLeftMouseDown + location: NSMakePoint (NSMinX (screen_frame), + NSMinY (screen_frame) + 10) + modifierFlags: 0 + timestamp: 0 + windowNumber: [window windowNumber] + context: [NSGraphicsContext currentContext] + eventNumber: 0 + clickCount: 1 + pressure: 1.0f] + atStart: YES]; +#endif + break; + } + } + unblock_input (); +} /* ========================================================================== @@ -1916,6 +1954,22 @@ - (Lisp_Object)runDialogAt: (NSPoint)p return popup_activated () ? Qt : Qnil; } +DEFUN ("ns-menu-bar-open", Fns_menu_bar_open, Sns_menu_bar_open, 0, 1, "i", + doc: /* Start key navigation of the menu bar in FRAME. +This initially opens the first menu bar item and you can then navigate with the +arrow keys, select a menu entry with the return key or cancel with the +escape key. If FRAME has no menu bar this function does nothing. + +If FRAME is nil or not given, use the selected frame. */) + (Lisp_Object frame) +{ + struct frame *f = decode_window_system_frame (frame); + + ns_activate_menubar (f); + + return Qnil; +} + /* ========================================================================== Lisp interface declaration @@ -1927,6 +1981,7 @@ - (Lisp_Object)runDialogAt: (NSPoint)p { defsubr (&Sns_reset_menu); defsubr (&Smenu_or_popup_active_p); + defsubr (&Sns_menu_bar_open); DEFSYM (Qdebug_on_next_call, "debug-on-next-call"); } diff --git a/src/nsterm.m b/src/nsterm.m index ed0e7a2aae..4e84e130b8 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -5067,6 +5067,7 @@ static Lisp_Object ns_new_font (struct frame *f, Lisp_Object font_object, terminal->delete_frame_hook = ns_destroy_window; terminal->delete_terminal_hook = ns_delete_terminal; terminal->change_tab_bar_height_hook = ns_change_tab_bar_height; + terminal->activate_menubar_hook = ns_activate_menubar; /* Other hooks are NULL by default. */ return terminal; commit 7117bbc7aa905ae785fa564cb24c3fc75ef1d543 Author: oldosfan Date: Mon Oct 18 08:09:40 2021 +0800 Revert "Fix erasing cursor on top of raised boxes in NS port" This reverts commit 960f0eb9ab657af85c532574b937d8851049b178. diff --git a/src/nsterm.m b/src/nsterm.m index 8ee5c03b97..ed0e7a2aae 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -3510,12 +3510,6 @@ larger if there are taller display elements (e.g., characters [(raised_p ? lightCol : darkCol) set]; - if (top_p) - { - NSRectFill (NSMakeRect (NSMinX (outer), NSMinY (outer), - NSWidth (outer), hthickness)); - } - if (top_p || left_p) { NSBezierPath *p = [NSBezierPath bezierPath]; @@ -3555,12 +3549,6 @@ larger if there are taller display elements (e.g., characters [p closePath]; [p fill]; } - - if (bottom_p) - { - NSRectFill (NSMakeRect (NSMinX (outer), NSMaxY (inner), - NSWidth (outer), hthickness)); - } } commit 2b5a2ab50b7817f84ae38f84b4ea36ea38cd5a3b Author: oldosfan Date: Sun Oct 17 21:12:03 2021 +0800 Fix erasing cursor on top of raised boxes in NS port * src/nsterm.m (ns_draw_relief): Clear top and bottom line areas first, if required. diff --git a/src/nsterm.m b/src/nsterm.m index ed0e7a2aae..8ee5c03b97 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -3510,6 +3510,12 @@ larger if there are taller display elements (e.g., characters [(raised_p ? lightCol : darkCol) set]; + if (top_p) + { + NSRectFill (NSMakeRect (NSMinX (outer), NSMinY (outer), + NSWidth (outer), hthickness)); + } + if (top_p || left_p) { NSBezierPath *p = [NSBezierPath bezierPath]; @@ -3549,6 +3555,12 @@ larger if there are taller display elements (e.g., characters [p closePath]; [p fill]; } + + if (bottom_p) + { + NSRectFill (NSMakeRect (NSMinX (outer), NSMaxY (inner), + NSWidth (outer), hthickness)); + } } commit 346cfc81247e6bf8e727a27b42f44f2389bd1269 Author: oldosfan Date: Mon Nov 1 08:19:32 2021 +0800 Add support for event processing via XInput 2 * configure.ac: Add an option to use XInput 2 if available * src/Makefile.in (XINPUT_LIBS, XINPUT_CFLAGS): New variables (EMACS_CFLAGS): Add Xinput CFLAGS (LIBES): Add XInput libs * src/xmenu.c (popup_activated_flag): Expose flag if XInput 2 is available * src/xfns.c (x_window): Set XInput 2 event mask * src/xterm.c (x_detect_focus_change): Handle XInput 2 GenericEvents (handle_one_xevent): Handle XInput 2 events (x_term_init): Ask the server for XInput 2 support and set xkb_desc if available (x_delete_terminal): Free XKB kb desc if it exists, and free XI2 devices if they exist (x_free_xi_devices, x_init_master_valuators): New functions (x_get_scroll_valuator_delta): New function (init_xterm): Don't tell GTK to only use Core Input when built with XInput 2 support * src/xterm.h (struct x_display_info): Add fields for XKB and XI2 support * src/gtkutil.c (xg_event_is_for_menubar): Handle XIDeviceEvents (xg_is_menu_window): New function (xg_event_is_for_scrollbar): Handle XIDeviceEvents diff --git a/configure.ac b/configure.ac index 33e7037afe..a243efdd43 100644 --- a/configure.ac +++ b/configure.ac @@ -487,6 +487,7 @@ OPTION_DEFAULT_ON([modules],[don't compile with dynamic modules support]) OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support]) OPTION_DEFAULT_OFF([native-compilation],[compile with Emacs Lisp native compiler support]) OPTION_DEFAULT_OFF([cygwin32-native-compilation],[use native compilation on 32-bit Cygwin]) +OPTION_DEFAULT_OFF([xinput2],[use version 2.0 the X Input Extension for input]) AC_ARG_WITH([file-notification],[AS_HELP_STRING([--with-file-notification=LIB], [use a file notification library (LIB one of: yes, inotify, kqueue, gfile, w32, no)])], @@ -4237,6 +4238,26 @@ fi AC_SUBST(XFIXES_CFLAGS) AC_SUBST(XFIXES_LIBS) +## Use XInput 2.0 if available +HAVE_XINPUT2=no +if test "${HAVE_X11}" = "yes" && test "${with_xinput2}" != "no"; then + EMACS_CHECK_MODULES([XINPUT], [xi]) + if test $HAVE_XINPUT = yes; then + # Now check for XInput2.h + AC_CHECK_HEADER(X11/extensions/XInput2.h, + [AC_CHECK_LIB(Xi, XIGrabButton, HAVE_XINPUT2=yes)]) + fi + if test $HAVE_XINPUT2 = yes; then + AC_DEFINE(HAVE_XINPUT2, 1, [Define to 1 if the X Input Extension version 2.0 is present.]) + if test "$USE_GTK_TOOLKIT" = "GTK2"; then + AC_MSG_WARN([You are building Emacs with GTK+ 2 and the X Input Extension version 2. +This might lead to problems if your version of GTK+ is not built with support for XInput 2.]) + fi + fi +fi +AC_SUBST(XINPUT_CFLAGS) +AC_SUBST(XINPUT_LIBS) + ### Use Xdbe (-lXdbe) if available HAVE_XDBE=no if test "${HAVE_X11}" = "yes"; then @@ -5994,6 +6015,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D Does Emacs support legacy unexec dumping? ${with_unexec} Which dumping strategy does Emacs use? ${with_dumping} Does Emacs have native lisp compiler? ${HAVE_NATIVE_COMP} + Does Emacs use version 2 of the the X Input Extension? ${HAVE_XINPUT2} "]) if test -n "${EMACSDATA}"; then diff --git a/src/Makefile.in b/src/Makefile.in index 4c5535f8ad..4795ade3ea 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -258,6 +258,9 @@ XINERAMA_CFLAGS = @XINERAMA_CFLAGS@ XFIXES_LIBS = @XFIXES_LIBS@ XFIXES_CFLAGS = @XFIXES_CFLAGS@ +XINPUT_LIBS = @XINPUT_LIBS@ +XINPUT_CFLAGS = @XINPUT_CFLAGS@ + XDBE_LIBS = @XDBE_LIBS@ XDBE_CFLAGS = @XDBE_CFLAGS@ @@ -374,7 +377,7 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \ $(GNUSTEP_CFLAGS) $(CFLAGS_SOUND) $(RSVG_CFLAGS) $(IMAGEMAGICK_CFLAGS) \ $(PNG_CFLAGS) $(LIBXML2_CFLAGS) $(LIBGCCJIT_CFLAGS) $(DBUS_CFLAGS) \ $(XRANDR_CFLAGS) $(XINERAMA_CFLAGS) $(XFIXES_CFLAGS) $(XDBE_CFLAGS) \ - $(WEBKIT_CFLAGS) $(WEBP_CFLAGS) $(LCMS2_CFLAGS) \ + $(WEBKIT_CFLAGS) $(WEBP_CFLAGS) $(LCMS2_CFLAGS) $(XINPUT_CFLAGS) \ $(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \ $(HARFBUZZ_CFLAGS) $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) \ @@ -524,7 +527,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(HARFBUZZ_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \ $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ - $(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT_LIBS) + $(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT_LIBS) $(XINPUT_LIBS) ## FORCE it so that admin/unidata can decide whether this file is ## up-to-date. Although since charprop depends on bootstrap-emacs, diff --git a/src/gtkutil.c b/src/gtkutil.c index a9eabf47d8..9e676cd025 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -47,6 +47,10 @@ along with GNU Emacs. If not, see . */ #include +#ifdef HAVE_XINPUT2 +#include +#endif + #ifdef HAVE_XFT #include #endif @@ -839,6 +843,23 @@ my_log_handler (const gchar *log_domain, GLogLevelFlags log_level, } #endif +#if defined HAVE_GTK3 && defined HAVE_XINPUT2 +bool +xg_is_menu_window (Display *dpy, Window wdesc) +{ + GtkWidget *gwdesc = xg_win_to_widget (dpy, wdesc); + + if (GTK_IS_WINDOW (gwdesc)) + { + GtkWidget *fw = gtk_bin_get_child (GTK_BIN (gwdesc)); + if (GTK_IS_MENU (fw)) + return true; + } + + return false; +} +#endif + /* Make a geometry string and pass that to GTK. It seems this is the only way to get geometry position right if the user explicitly asked for a position when starting Emacs. @@ -3589,6 +3610,18 @@ xg_event_is_for_menubar (struct frame *f, const XEvent *event) if (! x->menubar_widget) return 0; +#ifdef HAVE_XINPUT2 + XIDeviceEvent *xev = (XIDeviceEvent *) event->xcookie.data; + if (event->type == GenericEvent) /* XI_ButtonPress or XI_ButtonRelease */ + { + if (! (xev->event_x >= 0 + && xev->event_x < FRAME_PIXEL_WIDTH (f) + && xev->event_y >= 0 + && xev->event_y < FRAME_MENUBAR_HEIGHT (f))) + return 0; + } + else +#endif if (! (event->xbutton.x >= 0 && event->xbutton.x < FRAME_PIXEL_WIDTH (f) && event->xbutton.y >= 0 @@ -3597,7 +3630,12 @@ xg_event_is_for_menubar (struct frame *f, const XEvent *event) return 0; gdpy = gdk_x11_lookup_xdisplay (FRAME_X_DISPLAY (f)); - gw = gdk_x11_window_lookup_for_display (gdpy, event->xbutton.window); +#ifdef HAVE_XINPUT2 + if (event->type == GenericEvent) + gw = gdk_x11_window_lookup_for_display (gdpy, xev->event); + else +#endif + gw = gdk_x11_window_lookup_for_display (gdpy, event->xbutton.window); if (! gw) return 0; gevent.any.window = gw; gevent.any.type = GDK_NOTHING; @@ -4244,7 +4282,20 @@ xg_event_is_for_scrollbar (struct frame *f, const XEvent *event) { bool retval = 0; +#ifdef HAVE_XINPUT2 + XIDeviceEvent *xev = (XIDeviceEvent *) event->xcookie.data; + if (f && ((FRAME_DISPLAY_INFO (f)->supports_xi2 + && event->type == GenericEvent + && (event->xgeneric.extension + == FRAME_DISPLAY_INFO (f)->xi2_opcode) + && ((event->xgeneric.evtype == XI_ButtonPress + && xev->detail < 4) + || (event->xgeneric.evtype == XI_Motion))) + || (event->type == ButtonPress + && event->xbutton.button < 4))) +#else if (f && event->type == ButtonPress && event->xbutton.button < 4) +#endif /* HAVE_XINPUT2 */ { /* Check if press occurred outside the edit widget. */ GdkDisplay *gdpy = gdk_x11_lookup_xdisplay (FRAME_X_DISPLAY (f)); @@ -4262,10 +4313,29 @@ xg_event_is_for_scrollbar (struct frame *f, const XEvent *event) gwin = gdk_display_get_window_at_pointer (gdpy, NULL, NULL); #endif retval = gwin != gtk_widget_get_window (f->output_data.x->edit_widget); +#ifdef HAVE_XINPUT2 + GtkWidget *grab = gtk_grab_get_current (); + if (event->type == GenericEvent + && event->xgeneric.evtype == XI_Motion) + retval = retval || (grab && GTK_IS_SCROLLBAR (grab)); +#endif } +#ifdef HAVE_XINPUT2 + else if (f && ((FRAME_DISPLAY_INFO (f)->supports_xi2 + && event->type == GenericEvent + && (event->xgeneric.extension + == FRAME_DISPLAY_INFO (f)->xi2_opcode) + && ((event->xgeneric.evtype == XI_ButtonRelease + && xev->detail < 4) + || (event->xgeneric.evtype == XI_Motion))) + || ((event->type == ButtonRelease + && event->xbutton.button < 4) + || event->type == MotionNotify))) +#else else if (f && ((event->type == ButtonRelease && event->xbutton.button < 4) || event->type == MotionNotify)) +#endif /* HAVE_XINPUT2 */ { /* If we are releasing or moving the scroll bar, it has the grab. */ GtkWidget *w = gtk_grab_get_current (); diff --git a/src/gtkutil.h b/src/gtkutil.h index 31a12cd5d3..95dd75b7fa 100644 --- a/src/gtkutil.h +++ b/src/gtkutil.h @@ -192,6 +192,10 @@ extern Lisp_Object xg_get_page_setup (void); extern void xg_print_frames_dialog (Lisp_Object); #endif +#if defined HAVE_GTK3 && defined HAVE_XINPUT2 +extern bool xg_is_menu_window (Display *dpy, Window); +#endif + /* Mark all callback data that are Lisp_object:s during GC. */ extern void xg_mark_data (void); diff --git a/src/xfns.c b/src/xfns.c index 785ae3baca..c792826e6b 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -57,6 +57,10 @@ along with GNU Emacs. If not, see . */ #include #endif +#ifdef HAVE_XINPUT2 +#include +#endif + #ifdef USE_X_TOOLKIT #include @@ -3074,6 +3078,43 @@ x_window (struct frame *f, long window_prompting) class_hints.res_class = SSDATA (Vx_resource_class); XSetClassHint (FRAME_X_DISPLAY (f), XtWindow (shell_widget), &class_hints); +#ifdef HAVE_XINPUT2 + if (FRAME_DISPLAY_INFO (f)->supports_xi2) + { + XIEventMask mask; + ptrdiff_t l = XIMaskLen (XI_LASTEVENT); + unsigned char *m; + mask.mask = m = alloca (l); + memset (m, 0, l); + mask.mask_len = l; + mask.deviceid = XIAllMasterDevices; + + XISetMask (m, XI_ButtonPress); + XISetMask (m, XI_ButtonRelease); + XISetMask (m, XI_KeyPress); + XISetMask (m, XI_KeyRelease); + XISetMask (m, XI_Motion); + XISetMask (m, XI_Enter); + XISetMask (m, XI_Leave); + XISetMask (m, XI_FocusIn); + XISetMask (m, XI_FocusOut); + XISetMask (m, XI_DeviceChanged); + + XISelectEvents (FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), + &mask, 1); + + mask.deviceid = XIAllDevices; + memset (m, 0, l); + XISetMask (m, XI_PropertyEvent); + XISetMask (m, XI_HierarchyChanged); + + XISelectEvents (FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), + &mask, 1); + } +#endif + #ifdef HAVE_X_I18N FRAME_XIC (f) = NULL; if (use_xim) @@ -3254,6 +3295,43 @@ x_window (struct frame *f) } #endif /* HAVE_X_I18N */ +#ifdef HAVE_XINPUT2 + if (FRAME_DISPLAY_INFO (f)->supports_xi2) + { + XIEventMask mask; + ptrdiff_t l = XIMaskLen (XI_LASTEVENT); + unsigned char *m; + mask.mask = m = alloca (l); + memset (m, 0, l); + mask.mask_len = l; + mask.deviceid = XIAllMasterDevices; + + XISetMask (m, XI_ButtonPress); + XISetMask (m, XI_ButtonRelease); + XISetMask (m, XI_KeyPress); + XISetMask (m, XI_KeyRelease); + XISetMask (m, XI_Motion); + XISetMask (m, XI_Enter); + XISetMask (m, XI_Leave); + XISetMask (m, XI_FocusIn); + XISetMask (m, XI_FocusOut); + XISetMask (m, XI_DeviceChanged); + + XISelectEvents (FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), + &mask, 1); + + mask.deviceid = XIAllDevices; + memset (m, 0, l); + XISetMask (m, XI_PropertyEvent); + XISetMask (m, XI_HierarchyChanged); + + XISelectEvents (FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), + &mask, 1); + } +#endif + validate_x_resource_name (); class_hints.res_name = SSDATA (Vx_resource_name); diff --git a/src/xmenu.c b/src/xmenu.c index ea2cbab203..07255911f9 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -105,7 +105,11 @@ along with GNU Emacs. If not, see . */ /* Flag which when set indicates a dialog or menu has been posted by Xt on behalf of one of the widget sets. */ +#ifndef HAVE_XINPUT2 static int popup_activated_flag; +#else +int popup_activated_flag; +#endif #ifdef USE_X_TOOLKIT diff --git a/src/xterm.c b/src/xterm.c index 172abe919d..d0da6ad6a6 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -42,6 +42,10 @@ along with GNU Emacs. If not, see . */ #include #endif +#ifdef HAVE_XINPUT2 +#include +#endif + /* Load sys/types.h if not already loaded. In some systems loading it twice is suicidal. */ #ifndef makedev @@ -223,9 +227,15 @@ static bool x_handle_net_wm_state (struct frame *, const XPropertyEvent *); static void x_check_fullscreen (struct frame *); static void x_check_expected_move (struct frame *, int, int); static void x_sync_with_move (struct frame *, int, int, bool); +#ifndef HAVE_XINPUT2 static int handle_one_xevent (struct x_display_info *, const XEvent *, int *, struct input_event *); +#else +static int handle_one_xevent (struct x_display_info *, + XEvent *, int *, + struct input_event *); +#endif #if ! (defined USE_X_TOOLKIT || defined USE_MOTIF) && defined USE_GTK static int x_dispatch_event (XEvent *, Display *); #endif @@ -335,6 +345,156 @@ x_extension_initialize (struct x_display_info *dpyinfo) dpyinfo->ext_codes = ext_codes; } + +#ifdef HAVE_XINPUT2 + +/* Free all XI2 devices on dpyinfo. */ +static void +x_free_xi_devices (struct x_display_info *dpyinfo) +{ + block_input (); + + if (dpyinfo->num_devices) + { + for (int i = 0; i < dpyinfo->num_devices; ++i) + xfree (dpyinfo->devices[i].valuators); + + xfree (dpyinfo->devices); + dpyinfo->devices = NULL; + dpyinfo->num_devices = 0; + } + + unblock_input (); +} + +/* Setup valuator tracking for XI2 master devices on + DPYINFO->display. */ + +static void +x_init_master_valuators (struct x_display_info *dpyinfo) +{ + int ndevices; + XIDeviceInfo *infos; + + block_input (); + x_free_xi_devices (dpyinfo); + infos = XIQueryDevice (dpyinfo->display, + XIAllMasterDevices, + &ndevices); + + if (!ndevices) + { + XIFreeDeviceInfo (infos); + unblock_input (); + return; + } + + int actual_devices = 0; + dpyinfo->devices = xmalloc (sizeof *dpyinfo->devices * ndevices); + + for (int i = 0; i < ndevices; ++i) + { + XIDeviceInfo *device = &infos[i]; + + if (device->enabled) + { + int actual_valuator_count = 0; + struct xi_device_t *xi_device = + &dpyinfo->devices[actual_devices++]; + xi_device->device_id = device->deviceid; + xi_device->valuators = + xmalloc (sizeof *xi_device->valuators * device->num_classes); + + for (int c = 0; c < device->num_classes; ++c) + { + switch (device->classes[c]->type) + { +#ifdef XIScrollClass /* XInput 2.1 */ + case XIScrollClass: + { + XIScrollClassInfo *info = + (XIScrollClassInfo *) device->classes[c]; + struct xi_scroll_valuator_t *valuator = + &xi_device->valuators[actual_valuator_count++]; + + valuator->horizontal = (info->scroll_type == XIScrollTypeHorizontal); + valuator->invalid_p = true; + valuator->emacs_value = DBL_MIN; + valuator->increment = info->increment; + valuator->number = info->number; + break; + } +#endif + default: + break; + } + } + xi_device->scroll_valuator_count = actual_valuator_count; + } + } + + dpyinfo->num_devices = actual_devices; + XIFreeDeviceInfo (infos); + unblock_input (); +} + +/* Return the delta of the scroll valuator VALUATOR_NUMBER under + DEVICE_ID in the display DPYINFO with VALUE. The valuator's + valuator will be set to VALUE afterwards. In case no scroll + valuator is found, or if device_id is not known to Emacs, DBL_MAX + is returned. Otherwise, the valuator is returned in + VALUATOR_RETURN. */ +static double +x_get_scroll_valuator_delta (struct x_display_info *dpyinfo, int device_id, + int valuator_number, double value, + struct xi_scroll_valuator_t **valuator_return) +{ + block_input (); + + for (int i = 0; i < dpyinfo->num_devices; ++i) + { + struct xi_device_t *device = &dpyinfo->devices[i]; + + if (device->device_id == device_id) + { + for (int j = 0; j < device->scroll_valuator_count; ++j) + { + struct xi_scroll_valuator_t *sv = &device->valuators[j]; + + if (sv->number == valuator_number) + { + if (sv->invalid_p) + { + sv->current_value = value; + sv->invalid_p = false; + *valuator_return = sv; + + unblock_input (); + return 0.0; + } + else + { + double delta = sv->current_value - value; + sv->current_value = value; + *valuator_return = sv; + + unblock_input (); + return delta / sv->increment; + } + } + } + + unblock_input (); + return DBL_MAX; + } + } + + unblock_input (); + return DBL_MAX; +} + +#endif + void x_cr_destroy_frame_context (struct frame *f) { @@ -4768,7 +4928,16 @@ static struct frame * x_menubar_window_to_frame (struct x_display_info *dpyinfo, const XEvent *event) { - Window wdesc = event->xany.window; + Window wdesc; +#ifdef HAVE_XINPUT2 + if (event->type == GenericEvent + && dpyinfo->supports_xi2 + && (event->xcookie.evtype == XI_ButtonPress + || event->xcookie.evtype == XI_ButtonRelease)) + wdesc = ((XIDeviceEvent *) event->xcookie.data)->event; + else +#endif + wdesc = event->xany.window; Lisp_Object tail, frame; struct frame *f; struct x_output *x; @@ -4871,6 +5040,29 @@ x_detect_focus_change (struct x_display_info *dpyinfo, struct frame *frame, } break; +#ifdef HAVE_XINPUT2 + case GenericEvent: + { + XIEvent *xi_event = (XIEvent *) event; + + struct frame *focus_frame = dpyinfo->x_focus_event_frame; + int focus_state + = focus_frame ? focus_frame->output_data.x->focus_state : 0; + + if (!((xi_event->evtype == XI_Enter + || xi_event->evtype == XI_Leave) + && (focus_state & FOCUS_EXPLICIT))) + x_focus_changed ((xi_event->evtype == XI_Enter + || xi_event->evtype == XI_FocusIn + ? FocusIn : FocusOut), + (xi_event->evtype == XI_Enter + || xi_event->evtype == XI_Leave + ? FOCUS_IMPLICIT : FOCUS_EXPLICIT), + dpyinfo, frame, bufp); + break; + } +#endif + case FocusIn: case FocusOut: /* Ignore transient focus events from hotkeys, window manager @@ -7975,7 +8167,11 @@ mouse_or_wdesc_frame (struct x_display_info *dpyinfo, int wdesc) static int handle_one_xevent (struct x_display_info *dpyinfo, +#ifndef HAVE_XINPUT2 const XEvent *event, +#else + XEvent *event, +#endif int *finish, struct input_event *hold_quit) { union buffered_input_event inev; @@ -8001,7 +8197,14 @@ handle_one_xevent (struct x_display_info *dpyinfo, inev.ie.kind = NO_EVENT; inev.ie.arg = Qnil; - any = x_any_window_to_frame (dpyinfo, event->xany.window); +#ifdef HAVE_XINPUT2 + if (event->type != GenericEvent) +#endif + any = x_any_window_to_frame (dpyinfo, event->xany.window); +#ifdef HAVE_XINPUT2 + else + any = NULL; +#endif if (any && any->wait_event_type == event->type) any->wait_event_type = 0; /* Indicates we got it. */ @@ -8480,6 +8683,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto OTHER; case MapNotify: +#if defined HAVE_XINPUT2 && defined HAVE_GTK3 + if (xg_is_menu_window (dpyinfo->display, event->xmap.window)) + popup_activated_flag = 1; +#endif /* We use x_top_window_to_frame because map events can come for sub-windows and they don't mean that the frame is visible. */ @@ -9518,6 +9725,832 @@ handle_one_xevent (struct x_display_info *dpyinfo, case DestroyNotify: xft_settings_event (dpyinfo, event); break; +#ifdef HAVE_XINPUT2 + case GenericEvent: + { + if (!dpyinfo->supports_xi2) + goto OTHER; + if (event->xgeneric.extension != dpyinfo->xi2_opcode) + /* Not an XI2 event. */ + goto OTHER; + bool must_free_data = false; + XIEvent *xi_event = (XIEvent *) event->xcookie.data; + /* Sometimes the event is already claimed by GTK, which + will free its data in due course. */ + if (!xi_event && XGetEventData (dpyinfo->display, &event->xcookie)) + { + must_free_data = true; + xi_event = (XIEvent *) event->xcookie.data; + } + + XIDeviceEvent *xev = (XIDeviceEvent *) xi_event; + XILeaveEvent *leave = (XILeaveEvent *) xi_event; + XIEnterEvent *enter = (XIEnterEvent *) xi_event; + XIFocusInEvent *focusin = (XIFocusInEvent *) xi_event; + XIFocusOutEvent *focusout = (XIFocusOutEvent *) xi_event; + XIValuatorState *states; + double *values; + bool found_valuator = false; + + /* A fake XMotionEvent for x_note_mouse_movement. */ + XMotionEvent ev; + /* A fake XButtonEvent for x_construct_mouse_click. */ + XButtonEvent bv; + + if (!xi_event) + { + eassert (!must_free_data); + goto OTHER; + } + + switch (event->xcookie.evtype) + { + case XI_FocusIn: + any = x_any_window_to_frame (dpyinfo, focusin->event); +#ifndef USE_GTK + /* Some WMs (e.g. Mutter in Gnome Shell), don't unmap + minimized/iconified windows; thus, for those WMs we won't get + a MapNotify when unminimizing/deconifying. Check here if we + are deiconizing a window (Bug42655). + + But don't do that on GTK since it may cause a plain invisible + frame get reported as iconified, compare + https://lists.gnu.org/archive/html/emacs-devel/2017-02/msg00133.html. + That is fixed above but bites us here again. */ + f = any; + if (f && FRAME_ICONIFIED_P (f)) + { + SET_FRAME_VISIBLE (f, 1); + SET_FRAME_ICONIFIED (f, false); + f->output_data.x->has_been_visible = true; + inev.ie.kind = DEICONIFY_EVENT; + XSETFRAME (inev.ie.frame_or_window, f); + } +#endif /* USE_GTK */ + x_detect_focus_change (dpyinfo, any, event, &inev.ie); + goto XI_OTHER; + case XI_FocusOut: + any = x_any_window_to_frame (dpyinfo, focusout->event); + x_detect_focus_change (dpyinfo, any, event, &inev.ie); + goto XI_OTHER; + case XI_Enter: + any = x_any_window_to_frame (dpyinfo, enter->event); + ev.x = lrint (enter->event_x); + ev.y = lrint (enter->event_y); + ev.window = leave->event; + + x_display_set_last_user_time (dpyinfo, xi_event->time); + x_detect_focus_change (dpyinfo, any, event, &inev.ie); + f = any; + + if (f && x_mouse_click_focus_ignore_position) + ignore_next_mouse_click_timeout = xi_event->time + 200; + + /* EnterNotify counts as mouse movement, + so update things that depend on mouse position. */ + if (f && !f->output_data.x->hourglass_p) + x_note_mouse_movement (f, &ev); +#ifdef USE_GTK + /* We may get an EnterNotify on the buttons in the toolbar. In that + case we moved out of any highlighted area and need to note this. */ + if (!f && dpyinfo->last_mouse_glyph_frame) + x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev); +#endif + goto XI_OTHER; + case XI_Leave: + ev.x = lrint (leave->event_x); + ev.y = lrint (leave->event_y); + ev.window = leave->event; + any = x_any_window_to_frame (dpyinfo, leave->event); + + x_display_set_last_user_time (dpyinfo, xi_event->time); + x_detect_focus_change (dpyinfo, any, event, &inev.ie); + + f = x_top_window_to_frame (dpyinfo, leave->event); + if (f) + { + if (f == hlinfo->mouse_face_mouse_frame) + { + /* If we move outside the frame, then we're + certainly no longer on any text in the frame. */ + clear_mouse_face (hlinfo); + hlinfo->mouse_face_mouse_frame = 0; + } + + /* Generate a nil HELP_EVENT to cancel a help-echo. + Do it only if there's something to cancel. + Otherwise, the startup message is cleared when + the mouse leaves the frame. */ + if (any_help_event_p) + do_help = -1; + } +#ifdef USE_GTK + /* See comment in EnterNotify above */ + else if (dpyinfo->last_mouse_glyph_frame) + x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev); +#endif + goto XI_OTHER; + case XI_Motion: + /* First test if there is some kind of scroll event + here! */ + states = &xev->valuators; + values = states->values; + + x_display_set_last_user_time (dpyinfo, xi_event->time); + + for (int i = 0; i < states->mask_len * 8; i++) + { + if (XIMaskIsSet (states->mask, i)) + { + block_input (); + + struct xi_scroll_valuator_t *val; + double delta = + x_get_scroll_valuator_delta (dpyinfo, xev->deviceid, + i, *values, &val); + + if (delta != DBL_MAX) + { + /* TODO: Figure out how pixelwise scrolling should work. + Until that happens, this will have to do. */ + delta *= 10; + + f = mouse_or_wdesc_frame (dpyinfo, xev->event); + found_valuator = true; + if (signbit (delta) != signbit (val->emacs_value)) + val->emacs_value = DBL_MIN; + + val->emacs_value += delta; + + if (!f) + { + f = x_any_window_to_frame (dpyinfo, xev->event); + + if (!f) + { + unblock_input (); + goto XI_OTHER; + } + } + + if ((val->horizontal + && fabs (val->emacs_value) >= FRAME_COLUMN_WIDTH (f)) + || (!val->horizontal + && fabs (val->emacs_value) >= FRAME_LINE_HEIGHT (f))) + { + Lisp_Object tab_bar_arg = Qnil; + bool tab_bar_p = false; + bool tool_bar_p = false; + bool s = signbit (val->emacs_value); + + bv.button = !val->horizontal ? (s ? 5 : 4) : (s ? 7 : 6); + bv.type = ButtonPress; + + bv.x = lrint (xev->event_x); + bv.y = lrint (xev->event_y); + bv.window = xev->event; + bv.state = xev->mods.base + | xev->mods.effective + | xev->mods.latched + | xev->mods.locked; + + /* Is this in the tab-bar? */ + if (WINDOWP (f->tab_bar_window) + && WINDOW_TOTAL_LINES (XWINDOW (f->tab_bar_window))) + { + Lisp_Object window; + int x = bv.x; + int y = bv.y; + + window = window_from_coordinates (f, x, y, 0, true, true); + tab_bar_p = EQ (window, f->tab_bar_window); + + if (tab_bar_p) + { + tab_bar_arg = handle_tab_bar_click + (f, x, y, true, x_x_to_emacs_modifiers (dpyinfo, bv.state)); + tab_bar_arg = handle_tab_bar_click + (f, x, y, false, x_x_to_emacs_modifiers (dpyinfo, bv.state)); + } + } + + if (!NILP (tab_bar_arg)) + inev.ie.arg = tab_bar_arg; + + if (!tool_bar_p && !(NILP (tab_bar_arg) && tab_bar_p)) + { + if (ignore_next_mouse_click_timeout) + { + if (xev->time > ignore_next_mouse_click_timeout) + { + /* XXX: Wouldn't it be better + to just use wheel events + instead of pretending to be + X here? */ + x_construct_mouse_click (&inev.ie, &bv, f); + if (!NILP (tab_bar_arg)) + inev.ie.arg = tab_bar_arg; + kbd_buffer_store_event (&inev.ie); + inev.ie.modifiers &= ~down_modifier; + inev.ie.modifiers |= up_modifier; + kbd_buffer_store_event (&inev.ie); + } + ignore_next_mouse_click_timeout = 0; + } + else + { + x_construct_mouse_click (&inev.ie, &bv, f); + kbd_buffer_store_event (&inev.ie); + inev.ie.modifiers &= ~down_modifier; + inev.ie.modifiers |= up_modifier; + kbd_buffer_store_event (&inev.ie); + } + } + + val->emacs_value = DBL_MIN; + } + } + unblock_input (); + values++; + } + + inev.ie.kind = NO_EVENT; + } + + if (found_valuator) + goto XI_OTHER; + + ev.x = lrint (xev->event_x); + ev.y = lrint (xev->event_y); + ev.window = xev->event; + + previous_help_echo_string = help_echo_string; + help_echo_string = Qnil; + + if (hlinfo->mouse_face_hidden) + { + hlinfo->mouse_face_hidden = false; + clear_mouse_face (hlinfo); + } + + f = mouse_or_wdesc_frame (dpyinfo, xev->event); + +#ifdef USE_GTK + if (f && xg_event_is_for_scrollbar (f, event)) + f = 0; +#endif + if (f) + { + /* Maybe generate a SELECT_WINDOW_EVENT for + `mouse-autoselect-window' but don't let popup menus + interfere with this (Bug#1261). */ + if (!NILP (Vmouse_autoselect_window) + && !popup_activated () + /* Don't switch if we're currently in the minibuffer. + This tries to work around problems where the + minibuffer gets unselected unexpectedly, and where + you then have to move your mouse all the way down to + the minibuffer to select it. */ + && !MINI_WINDOW_P (XWINDOW (selected_window)) + /* With `focus-follows-mouse' non-nil create an event + also when the target window is on another frame. */ + && (f == XFRAME (selected_frame) + || !NILP (focus_follows_mouse))) + { + static Lisp_Object last_mouse_window; + Lisp_Object window = window_from_coordinates (f, ev.x, ev.y, 0, false, false); + + /* A window will be autoselected only when it is not + selected now and the last mouse movement event was + not in it. The remainder of the code is a bit vague + wrt what a "window" is. For immediate autoselection, + the window is usually the entire window but for GTK + where the scroll bars don't count. For delayed + autoselection the window is usually the window's text + area including the margins. */ + if (WINDOWP (window) + && !EQ (window, last_mouse_window) + && !EQ (window, selected_window)) + { + inev.ie.kind = SELECT_WINDOW_EVENT; + inev.ie.frame_or_window = window; + } + + /* Remember the last window where we saw the mouse. */ + last_mouse_window = window; + } + + if (!x_note_mouse_movement (f, &ev)) + help_echo_string = previous_help_echo_string; + } + else + { +#ifndef USE_TOOLKIT_SCROLL_BARS + struct scroll_bar *bar + = x_window_to_scroll_bar (xi_event->display, xev->event, 2); + + if (bar) + x_scroll_bar_note_movement (bar, &ev); +#endif /* USE_TOOLKIT_SCROLL_BARS */ + + /* If we move outside the frame, then we're + certainly no longer on any text in the frame. */ + clear_mouse_face (hlinfo); + } + + /* If the contents of the global variable help_echo_string + has changed, generate a HELP_EVENT. */ + if (!NILP (help_echo_string) + || !NILP (previous_help_echo_string)) + do_help = 1; + goto XI_OTHER; + case XI_ButtonRelease: + case XI_ButtonPress: + { + /* If we decide we want to generate an event to be seen + by the rest of Emacs, we put it here. */ + Lisp_Object tab_bar_arg = Qnil; + bool tab_bar_p = false; + bool tool_bar_p = false; + + /* Ignore emulated scroll events when XI2 native + scroll events are present. */ + if (dpyinfo->xi2_version >= 1 && xev->detail >= 4 + && xev->detail <= 8) + goto XI_OTHER; + + bv.button = xev->detail; + bv.type = xev->evtype == XI_ButtonPress ? ButtonPress : ButtonRelease; + bv.x = lrint (xev->event_x); + bv.y = lrint (xev->event_y); + bv.window = xev->event; + bv.state = xev->mods.base + | xev->mods.effective + | xev->mods.latched + | xev->mods.locked; + + memset (&compose_status, 0, sizeof (compose_status)); + dpyinfo->last_mouse_glyph_frame = NULL; + x_display_set_last_user_time (dpyinfo, xev->time); + + f = mouse_or_wdesc_frame (dpyinfo, xev->event); + + if (f && xev->evtype == XI_ButtonPress + && !popup_activated () + && !x_window_to_scroll_bar (xev->display, xev->event, 2) + && !FRAME_NO_ACCEPT_FOCUS (f)) + { + /* When clicking into a child frame or when clicking + into a parent frame with the child frame selected and + `no-accept-focus' is not set, select the clicked + frame. */ + struct frame *hf = dpyinfo->highlight_frame; + + if (FRAME_PARENT_FRAME (f) || (hf && frame_ancestor_p (f, hf))) + { + block_input (); + XSetInputFocus (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), + RevertToParent, CurrentTime); + if (FRAME_PARENT_FRAME (f)) + XRaiseWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f)); + unblock_input (); + } + } + +#ifdef USE_GTK + if (f && xg_event_is_for_scrollbar (f, event)) + f = 0; +#endif + + if (f) + { + /* Is this in the tab-bar? */ + if (WINDOWP (f->tab_bar_window) + && WINDOW_TOTAL_LINES (XWINDOW (f->tab_bar_window))) + { + Lisp_Object window; + int x = bv.x; + int y = bv.y; + + window = window_from_coordinates (f, x, y, 0, true, true); + tab_bar_p = EQ (window, f->tab_bar_window); + + if (tab_bar_p) + tab_bar_arg = handle_tab_bar_click + (f, x, y, xev->evtype == XI_ButtonPress, + x_x_to_emacs_modifiers (dpyinfo, bv.state)); + } + +#if ! defined (USE_GTK) + /* Is this in the tool-bar? */ + if (WINDOWP (f->tool_bar_window) + && WINDOW_TOTAL_LINES (XWINDOW (f->tool_bar_window))) + { + Lisp_Object window; + int x = bv.x; + int y = bv.y; + + window = window_from_coordinates (f, x, y, 0, true, true); + tool_bar_p = EQ (window, f->tool_bar_window); + + if (tool_bar_p && xev->detail < 4) + handle_tool_bar_click + (f, x, y, xev->evtype == XI_ButtonPress, + x_x_to_emacs_modifiers (dpyinfo, bv.state)); + } +#endif /* !USE_GTK */ + + if (!(tab_bar_p && NILP (tab_bar_arg)) && !tool_bar_p) +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) + if (! popup_activated ()) +#endif + { + if (ignore_next_mouse_click_timeout) + { + if (xev->evtype == XI_ButtonPress + && xev->time > ignore_next_mouse_click_timeout) + { + ignore_next_mouse_click_timeout = 0; + x_construct_mouse_click (&inev.ie, &bv, f); + } + if (xev->evtype == XI_ButtonRelease) + ignore_next_mouse_click_timeout = 0; + } + else + x_construct_mouse_click (&inev.ie, &bv, f); + + if (!NILP (tab_bar_arg)) + inev.ie.arg = tab_bar_arg; + } + if (FRAME_X_EMBEDDED_P (f)) + xembed_send_message (f, xev->time, + XEMBED_REQUEST_FOCUS, 0, 0, 0); + } + + if (xev->evtype == XI_ButtonPress) + { + dpyinfo->grabbed |= (1 << xev->detail); + dpyinfo->last_mouse_frame = f; + if (f && !tab_bar_p) + f->last_tab_bar_item = -1; +#if ! defined (USE_GTK) + if (f && !tool_bar_p) + f->last_tool_bar_item = -1; +#endif /* not USE_GTK */ + + } + else + dpyinfo->grabbed &= ~(1 << xev->detail); + + if (f) + f->mouse_moved = false; + +#if defined (USE_GTK) + /* No Xt toolkit currently available has support for XI2. + So the code here assumes use of GTK. */ + f = x_menubar_window_to_frame (dpyinfo, event); + if (f /* Gtk+ menus only react to the first three buttons. */ + && xev->detail < 3) + { + /* What is done with Core Input ButtonPressed is not + possible here, because GenericEvents cannot be saved. */ + bool was_waiting_for_input = waiting_for_input; + /* This hack was adopted from the NS port. Whether + or not it is actually safe is a different story + altogether. */ + if (waiting_for_input) + waiting_for_input = 0; + set_frame_menubar (f, true); + waiting_for_input = was_waiting_for_input; + } +#endif + goto XI_OTHER; + } + case XI_KeyPress: + { + int state = xev->mods.base + | xev->mods.effective + | xev->mods.latched + | xev->mods.locked; + Lisp_Object c; +#ifdef HAVE_XKB + unsigned int mods_rtrn; +#endif + int keycode = xev->detail; + KeySym keysym; + char copy_buffer[81]; + char *copy_bufptr = copy_buffer; + unsigned char *copy_ubufptr; +#ifdef HAVE_XKB + int copy_bufsiz = sizeof (copy_buffer); +#endif + ptrdiff_t i; + int nchars, len; + +#ifdef HAVE_XKB + if (dpyinfo->xkb_desc) + { + if (!XkbTranslateKeyCode (dpyinfo->xkb_desc, keycode, + state, &mods_rtrn, &keysym)) + goto XI_OTHER; + } + else + { +#endif + int keysyms_per_keycode_return; + KeySym *ksms = XGetKeyboardMapping (dpyinfo->display, keycode, 1, + &keysyms_per_keycode_return); + if (!(keysym = ksms[0])) + { + XFree (ksms); + goto XI_OTHER; + } + XFree (ksms); +#ifdef HAVE_XKB + } +#endif + + if (keysym == NoSymbol) + goto XI_OTHER; + + x_display_set_last_user_time (dpyinfo, xev->time); + ignore_next_mouse_click_timeout = 0; + +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) + /* Dispatch XI_KeyPress events when in menu. */ + if (popup_activated ()) + goto XI_OTHER; +#endif + + f = x_any_window_to_frame (dpyinfo, xev->event); + + /* If mouse-highlight is an integer, input clears out + mouse highlighting. */ + if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight) + && (f == 0 +#if ! defined (USE_GTK) + || !EQ (f->tool_bar_window, hlinfo->mouse_face_window) +#endif + || !EQ (f->tab_bar_window, hlinfo->mouse_face_window)) + ) + { + clear_mouse_face (hlinfo); + hlinfo->mouse_face_hidden = true; + } + + if (f != 0) + { +#ifdef USE_GTK + /* Don't pass keys to GTK. A Tab will shift focus to the + tool bar in GTK 2.4. Keys will still go to menus and + dialogs because in that case popup_activated is nonzero + (see above). */ + *finish = X_EVENT_DROP; +#endif + /* If not using XIM/XIC, and a compose sequence is in progress, + we break here. Otherwise, chars_matched is always 0. */ + if (compose_status.chars_matched > 0 && nbytes == 0) + goto XI_OTHER; + + memset (&compose_status, 0, sizeof (compose_status)); + + XSETFRAME (inev.ie.frame_or_window, f); + inev.ie.modifiers + = x_x_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), state); + inev.ie.timestamp = xev->time; + + /* First deal with keysyms which have defined + translations to characters. */ + if (keysym >= 32 && keysym < 128) + /* Avoid explicitly decoding each ASCII character. */ + { + inev.ie.kind = ASCII_KEYSTROKE_EVENT; + inev.ie.code = keysym; + + goto xi_done_keysym; + } + + /* Keysyms directly mapped to Unicode characters. */ + if (keysym >= 0x01000000 && keysym <= 0x0110FFFF) + { + if (keysym < 0x01000080) + inev.ie.kind = ASCII_KEYSTROKE_EVENT; + else + inev.ie.kind = MULTIBYTE_CHAR_KEYSTROKE_EVENT; + inev.ie.code = keysym & 0xFFFFFF; + goto xi_done_keysym; + } + + /* Now non-ASCII. */ + if (HASH_TABLE_P (Vx_keysym_table) + && (c = Fgethash (make_fixnum (keysym), + Vx_keysym_table, + Qnil), + FIXNATP (c))) + { + inev.ie.kind = (SINGLE_BYTE_CHAR_P (XFIXNAT (c)) + ? ASCII_KEYSTROKE_EVENT + : MULTIBYTE_CHAR_KEYSTROKE_EVENT); + inev.ie.code = XFIXNAT (c); + goto xi_done_keysym; + } + + /* Random non-modifier sorts of keysyms. */ + if (((keysym >= XK_BackSpace && keysym <= XK_Escape) + || keysym == XK_Delete +#ifdef XK_ISO_Left_Tab + || (keysym >= XK_ISO_Left_Tab + && keysym <= XK_ISO_Enter) +#endif + || IsCursorKey (keysym) /* 0xff50 <= x < 0xff60 */ + || IsMiscFunctionKey (keysym) /* 0xff60 <= x < VARIES */ +#ifdef HPUX + /* This recognizes the "extended function + keys". It seems there's no cleaner way. + Test IsModifierKey to avoid handling + mode_switch incorrectly. */ + || (XK_Select <= keysym && keysym < XK_KP_Space) +#endif +#ifdef XK_dead_circumflex + || keysym == XK_dead_circumflex +#endif +#ifdef XK_dead_grave + || keysym == XK_dead_grave +#endif +#ifdef XK_dead_tilde + || keysym == XK_dead_tilde +#endif +#ifdef XK_dead_diaeresis + || keysym == XK_dead_diaeresis +#endif +#ifdef XK_dead_macron + || keysym == XK_dead_macron +#endif +#ifdef XK_dead_degree + || keysym == XK_dead_degree +#endif +#ifdef XK_dead_acute + || keysym == XK_dead_acute +#endif +#ifdef XK_dead_cedilla + || keysym == XK_dead_cedilla +#endif +#ifdef XK_dead_breve + || keysym == XK_dead_breve +#endif +#ifdef XK_dead_ogonek + || keysym == XK_dead_ogonek +#endif +#ifdef XK_dead_caron + || keysym == XK_dead_caron +#endif +#ifdef XK_dead_doubleacute + || keysym == XK_dead_doubleacute +#endif +#ifdef XK_dead_abovedot + || keysym == XK_dead_abovedot +#endif + || IsKeypadKey (keysym) /* 0xff80 <= x < 0xffbe */ + || IsFunctionKey (keysym) /* 0xffbe <= x < 0xffe1 */ + /* Any "vendor-specific" key is ok. */ + || (keysym & (1 << 28)) + || (keysym != NoSymbol && nbytes == 0)) + && ! (IsModifierKey (keysym) + /* The symbols from XK_ISO_Lock + to XK_ISO_Last_Group_Lock + don't have real modifiers but + should be treated similarly to + Mode_switch by Emacs. */ +#if defined XK_ISO_Lock && defined XK_ISO_Last_Group_Lock + || (XK_ISO_Lock <= keysym + && keysym <= XK_ISO_Last_Group_Lock) +#endif + )) + { + STORE_KEYSYM_FOR_DEBUG (keysym); + /* make_lispy_event will convert this to a symbolic + key. */ + inev.ie.kind = NON_ASCII_KEYSTROKE_EVENT; + inev.ie.code = keysym; + goto xi_done_keysym; + } + +#ifdef HAVE_XKB + int overflow = 0; + KeySym sym = keysym; + + if (dpyinfo->xkb_desc) + { + if (!(nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, + state & ~mods_rtrn, copy_bufptr, + copy_bufsiz, &overflow))) + goto XI_OTHER; + } + else +#else + { + block_input (); + char *str = XKeysymToString (keysym); + if (!str) + { + unblock_input (); + goto XI_OTHER; + } + nbytes = strlen (str) + 1; + copy_bufptr = alloca (nbytes); + strcpy (copy_bufptr, str); + unblock_input (); + } +#endif +#ifdef HAVE_XKB + if (overflow) + { + overflow = 0; + copy_bufptr = alloca (copy_bufsiz + overflow); + keysym = sym; + if (!(nbytes = XkbTranslateKeySym (dpyinfo->display, &sym, + state & ~mods_rtrn, copy_bufptr, + copy_bufsiz + overflow, &overflow))) + goto XI_OTHER; + + if (overflow) + goto XI_OTHER; + } +#endif + + for (i = 0, nchars = 0; i < nbytes; i++) + { + if (ASCII_CHAR_P (copy_bufptr[i])) + nchars++; + STORE_KEYSYM_FOR_DEBUG (copy_bufptr[i]); + } + + if (nchars < nbytes) + { + /* Decode the input data. */ + + setup_coding_system (Vlocale_coding_system, &coding); + coding.src_multibyte = false; + coding.dst_multibyte = true; + /* The input is converted to events, thus we can't + handle composition. Anyway, there's no XIM that + gives us composition information. */ + coding.common_flags &= ~CODING_ANNOTATION_MASK; + + SAFE_NALLOCA (coding.destination, MAX_MULTIBYTE_LENGTH, + nbytes); + coding.dst_bytes = MAX_MULTIBYTE_LENGTH * nbytes; + coding.mode |= CODING_MODE_LAST_BLOCK; + decode_coding_c_string (&coding, (unsigned char *) copy_bufptr, nbytes, Qnil); + nbytes = coding.produced; + nchars = coding.produced_char; + copy_bufptr = (char *) coding.destination; + } + + copy_ubufptr = (unsigned char *) copy_bufptr; + + /* Convert the input data to a sequence of + character events. */ + for (i = 0; i < nbytes; i += len) + { + int ch; + if (nchars == nbytes) + ch = copy_ubufptr[i], len = 1; + else + ch = string_char_and_length (copy_ubufptr + i, &len); + inev.ie.kind = (SINGLE_BYTE_CHAR_P (ch) + ? ASCII_KEYSTROKE_EVENT + : MULTIBYTE_CHAR_KEYSTROKE_EVENT); + inev.ie.code = ch; + kbd_buffer_store_buffered_event (&inev, hold_quit); + } + + inev.ie.kind = NO_EVENT; + goto xi_done_keysym; + } + goto XI_OTHER; + } + case XI_KeyRelease: + x_display_set_last_user_time (dpyinfo, xev->time); + goto XI_OTHER; + case XI_PropertyEvent: + case XI_HierarchyChanged: + case XI_DeviceChanged: + x_init_master_valuators (dpyinfo); + goto XI_OTHER; + default: + goto XI_OTHER; + } + xi_done_keysym: + if (must_free_data) + XFreeEventData (dpyinfo->display, &event->xcookie); + goto done_keysym; + XI_OTHER: + if (must_free_data) + XFreeEventData (dpyinfo->display, &event->xcookie); + goto OTHER; + } +#endif default: OTHER: @@ -13192,6 +14225,40 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) dpyinfo->supports_xdbe = true; #endif +#ifdef HAVE_XINPUT2 + dpyinfo->supports_xi2 = false; + int rc; + int major = 2; +#ifdef XI_BarrierHit /* XInput 2.3 */ + int minor = 3; +#elif defined XI_TouchBegin /* XInput 2.2 */ + int minor = 2; +#elif defined XIScrollClass /* XInput 1.1 */ + int minor = 1; +#else /* Some old version of XI2 we're not interested in. */ + int minor = 0; +#endif + int fer, fee; + + if (XQueryExtension (dpyinfo->display, "XInputExtension", + &dpyinfo->xi2_opcode, &fer, &fee)) + { + rc = XIQueryVersion (dpyinfo->display, &major, &minor); + if (rc == Success) + { + dpyinfo->supports_xi2 = true; + x_init_master_valuators (dpyinfo); + } + } + dpyinfo->xi2_version = minor; +#endif + +#ifdef HAVE_XKB + dpyinfo->xkb_desc = XkbGetMap (dpyinfo->display, + XkbAllComponentsMask, + XkbUseCoreKbd); +#endif + #if defined USE_CAIRO || defined HAVE_XFT { /* If we are using Xft, the following precautions should be made: @@ -13624,6 +14691,14 @@ x_delete_terminal (struct terminal *terminal) XrmDestroyDatabase (dpyinfo->rdb); #endif +#ifdef HAVE_XKB + 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 @@ -13783,9 +14858,12 @@ x_initialize (void) void init_xterm (void) { - /* Emacs can handle only core input events, so make sure - Gtk doesn't use Xinput or Xinput2 extensions. */ +#ifndef HAVE_XINPUT2 + /* Emacs can handle only core input events when built without XI2 + support, so make sure Gtk doesn't use Xinput or Xinput2 + extensions. */ xputenv ("GDK_CORE_DEVICE_EVENTS=1"); +#endif } #endif diff --git a/src/xterm.h b/src/xterm.h index 9d9534dd62..25eddf8bf2 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -88,6 +88,10 @@ typedef GtkWidget *xt_or_gtk_widget; #include #endif +#ifdef HAVE_XKB +#include +#endif + #include "dispextern.h" #include "termhooks.h" @@ -163,6 +167,26 @@ struct color_name_cache_entry char *name; }; +#ifdef HAVE_XINPUT2 +struct xi_scroll_valuator_t +{ + bool invalid_p; + double current_value; + double emacs_value; + double increment; + + int number; + int horizontal; +}; + +struct xi_device_t +{ + int device_id; + int scroll_valuator_count; + struct xi_scroll_valuator_t *valuators; +}; +#endif + Status x_parse_color (struct frame *f, const char *color_name, XColor *color); @@ -474,6 +498,19 @@ struct x_display_info #ifdef HAVE_XDBE bool supports_xdbe; #endif + +#ifdef HAVE_XINPUT2 + bool supports_xi2; + int xi2_version; + int xi2_opcode; + + int num_devices; + struct xi_device_t *devices; +#endif + +#ifdef HAVE_XKB + XkbDescPtr xkb_desc; +#endif }; #ifdef HAVE_X_I18N @@ -481,6 +518,11 @@ struct x_display_info extern bool use_xim; #endif +#ifdef HAVE_XINPUT2 +/* Defined in xmenu.c. */ +extern int popup_activated_flag; +#endif + /* This is a chain of structures for all the X displays currently in use. */ extern struct x_display_info *x_display_list; commit 68a2a3307d1703ac8abe4b54c8e1ef9dda677c12 Author: oldosfan Date: Fri Oct 15 18:41:50 2021 +0800 *** empty log message *** diff --git a/src/nsterm.m b/src/nsterm.m index 3727f861ac..ed0e7a2aae 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -3976,19 +3976,6 @@ Function modeled after x_draw_glyph_string_box (). NSRect r[2]; int n; char box_drawn_p = 0; - - struct face *face = s->face; - if (s->hl == DRAW_MOUSE_FACE) - { - face - = FACE_FROM_ID_OR_NULL (s->f, - MOUSE_HL_INFO (s->f)->mouse_face_face_id); - if (!face) - face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); - } - - s->face = face; - struct font *font = s->face->font; if (! font) font = FRAME_FONT (s->f); commit 278e4fc9c6353068334dd39d45334b1df82a6cee Author: oldosfan Date: Thu Oct 14 11:05:00 2021 +0800 Fix mouse face in NS port * src/nsterm.m (ns_draw_glyph_string): Set s->face to the mouse face. diff --git a/src/nsterm.m b/src/nsterm.m index ed0e7a2aae..3727f861ac 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -3976,6 +3976,19 @@ Function modeled after x_draw_glyph_string_box (). NSRect r[2]; int n; char box_drawn_p = 0; + + struct face *face = s->face; + if (s->hl == DRAW_MOUSE_FACE) + { + face + = FACE_FROM_ID_OR_NULL (s->f, + MOUSE_HL_INFO (s->f)->mouse_face_face_id); + if (!face) + face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + } + + s->face = face; + struct font *font = s->face->font; if (! font) font = FRAME_FONT (s->f); commit 057fd1ee9bf6dd135039faaed22bfc5edcd16c72 Author: Lars Ingebrigtsen Date: Wed Nov 10 05:19:48 2021 +0100 Fix package-tests failure on native-comp * test/lisp/emacs-lisp/package-tests.el (package-test-macro-compilation-gz): Fix test failure on native-comp. diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 0f0ed029c3..3b12f57e5c 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -367,7 +367,7 @@ but with a different end of line convention (bug#48137)." (let ((load-path load-path)) (add-to-list 'load-path (directory-file-name dir)) (byte-recompile-directory dir 0 t) - (mapc (lambda (f) (rename-file f (concat f ".gz"))) + (mapc (lambda (f) (call-process "gzip" nil nil nil f)) (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")) (require 'macro-builtin) (should (member (expand-file-name "macro-builtin-aux.elc" dir) @@ -382,7 +382,7 @@ but with a different end of line convention (bug#48137)." (should (equal (macro-builtin-10-and-90) '(10 90)))) (mapc #'delete-file (directory-files-recursively dir "\\`[^\\.].*\\.elc\\'")) - (mapc (lambda (f) (rename-file f (file-name-sans-extension f))) + (mapc (lambda (f) (call-process "gunzip" nil nil nil f)) (directory-files-recursively dir "\\`[^\\.].*\\.el.gz\\'")))))) (ert-deftest package-test-install-two-dependencies () commit 8d81ab374da4d159cd05cd8caaaae2390829ccee Author: Stephen Gildea Date: Tue Nov 9 20:09:22 2021 -0800 time-stamp: %F is "file name" not "pathname" + other doc * lisp/time-stamp.el (time-stamp-format): doc 'file' instead of 'path'. * test/lisp/time-stamp-tests.el (formatz, format-time-offset): Clarify the difference and similarity between these two test helpers. diff --git a/lisp/time-stamp.el b/lisp/time-stamp.el index 178e490fb7..04e736d027 100644 --- a/lisp/time-stamp.el +++ b/lisp/time-stamp.el @@ -65,7 +65,7 @@ with %, as follows. Non-date items: %% a literal percent character: `%' -%f file name without directory %F gives absolute pathname +%f file name without directory %F absolute file name %l login name %L full name of logged-in user %q unqualified host name %Q fully-qualified host name %h mail host name @@ -661,7 +661,7 @@ and all `time-stamp-format' compatibility." (if buffer-file-name (file-name-nondirectory buffer-file-name) time-stamp-no-file)) - ((eq cur-char ?F) ;buffer-file-name, full path + ((eq cur-char ?F) ;buffer-file-name, absolute name (or buffer-file-name time-stamp-no-file)) ((eq cur-char ?s) ;system name, legacy diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index fa9edcbd40..cb446eb486 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -704,9 +704,10 @@ ;;;; Setup for tests of time offset formatting with %z (defun formatz (format zone) - "Uses time FORMAT string to format the offset of ZONE, returning the result. -FORMAT is \"%z\" or a variation. -ZONE is as the ZONE argument of the `format-time-string' function." + "Uses FORMAT to format the offset of ZONE, returning the result. +FORMAT must be time format \"%z\" or some variation thereof. +ZONE is as the ZONE argument of the `format-time-string' function. +This function is called by 99% of the `time-stamp' \"%z\" unit tests." (with-time-stamp-test-env (let ((time-stamp-time-zone zone)) ;; Call your favorite time formatter here. @@ -718,9 +719,9 @@ ZONE is as the ZONE argument of the `format-time-string' function." (defun format-time-offset (format offset-secs) "Uses FORMAT to format the time zone represented by OFFSET-SECS. -FORMAT must be \"%z\", possibly with a flag and padding. +FORMAT must be time format \"%z\" or some variation thereof. This function is a wrapper around `time-stamp-formatz-from-parsed-options' -and is used for testing." +and is called by some low-level `time-stamp' \"%z\" unit tests." ;; This wrapper adds a simple regexp-based parser that handles only ;; %z and variants. In normal use, time-stamp-formatz-from-parsed-options ;; is called from a parser that handles all time string formats. commit 18ebe6c4da30857d864e54ecd1944c102593624d Author: Lars Ingebrigtsen Date: Wed Nov 10 02:31:54 2021 +0100 Fix the look of the