commit de863f70aa905d3a7feaedb58b65bd7f9776853b (HEAD, refs/remotes/origin/master) Author: Po Lu Date: Wed Jul 27 13:01:41 2022 +0800 Remove workaround for some input method problems * src/xterm.c (handle_one_xevent): Remove modifier key workaround for some input method problems, since they cause more problems than they fix. (bug#56782) diff --git a/src/xterm.c b/src/xterm.c index 6f8291b494..48e9a174fa 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -17756,7 +17756,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, /* `xkey' will be modified, but it's not important to modify `event' itself. */ XKeyEvent xkey = event->xkey; - int i; + #ifdef HAVE_XINPUT2 Time pending_keystroke_time; struct xi_device_t *source; @@ -17806,27 +17806,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (modifiers & dpyinfo->meta_mod_mask) memset (&compose_status, 0, sizeof (compose_status)); -#ifdef HAVE_XKB - if (dpyinfo->xkb_desc) - { - XkbDescRec *rec = dpyinfo->xkb_desc; - - if (rec->map->modmap && rec->map->modmap[xkey.keycode]) - goto done_keysym; - } - else -#endif - { - if (dpyinfo->modmap) - { - for (i = 0; i < 8 * dpyinfo->modmap->max_keypermod; i++) - { - if (xkey.keycode == dpyinfo->modmap->modifiermap[i]) - goto done_keysym; - } - } - } - #ifdef HAVE_X_I18N if (FRAME_XIC (f)) { @@ -21160,27 +21139,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, state |= x_emacs_to_x_modifiers (dpyinfo, extra_keyboard_modifiers); -#ifdef HAVE_XKB - if (dpyinfo->xkb_desc) - { - XkbDescRec *rec = dpyinfo->xkb_desc; - - if (rec->map->modmap && rec->map->modmap[xev->detail]) - goto xi_done_keysym; - } - else -#endif - { - if (dpyinfo->modmap) - { - for (i = 0; i < 8 * dpyinfo->modmap->max_keypermod; i++) - { - if (xev->detail == dpyinfo->modmap->modifiermap[i]) - goto xi_done_keysym; - } - } - } - #ifdef HAVE_XKB if (dpyinfo->xkb_desc) { commit 86f60ec54a8033dc783646655ffd31447c8bf8c3 Author: Po Lu Date: Wed Jul 27 11:21:34 2022 +0800 Fix NS stretch glyph display * src/nsterm.m (ns_draw_window_cursor): Just draw hollow cursor. There is no need to draw the phys cursor glyph. (ns_dumpglyphs_stretch): Delete function. (ns_draw_glyph_string): New function. Port code from X and use it instead. (bug#56787) diff --git a/src/nsterm.m b/src/nsterm.m index 57f1f44de2..e3f47eb905 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -3108,14 +3108,9 @@ Note that CURSOR_WIDTH is meaningful only for (h)bar cursors. ns_focus (f, &r, 1); break; case HOLLOW_BOX_CURSOR: - [ctx restoreGraphicsState]; - ns_unfocus (f); - draw_phys_cursor_glyph (w, glyph_row, DRAW_NORMAL_TEXT); - ns_focus (f, &r, 1); - [FRAME_CURSOR_COLOR (f) set]; - /* This works like it does in PostScript, not X Windows. */ [NSBezierPath strokeRect: NSInsetRect (r, 0.5, 0.5)]; + [ctx restoreGraphicsState]; break; case HBAR_CURSOR: NSRectFill (r); @@ -3998,42 +3993,104 @@ Function modeled after x_draw_glyph_string_box (). static void -ns_dumpglyphs_stretch (struct glyph_string *s) +ns_draw_stretch_glyph_string (struct glyph_string *s) { - NSRect glyphRect; - struct face *face = s->face; - NSColor *fgCol, *bgCol; + struct face *face; - if (!s->background_filled_p) + if (s->hl == DRAW_CURSOR + && !x_stretch_cursor_p) { + /* If `x-stretch-cursor' is nil, don't draw a block cursor as + wide as the stretch glyph. */ + int width, background_width = s->background_width; + int x = s->x; - face = s->face; + if (!s->row->reversed_p) + { + int left_x = window_box_left_offset (s->w, TEXT_AREA); - bgCol = [NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND (face)]; - fgCol = [NSColor colorWithUnsignedLong:NS_FACE_FOREGROUND (face)]; + 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; if (s->hl == DRAW_CURSOR) + [FRAME_CURSOR_COLOR (s->f) set]; + else + [[NSColor colorWithUnsignedLong: s->face->foreground] set]; + + NSRectFill (NSMakeRect (x, s->y, width, s->height)); + + /* Clear rest using the GC of the original non-cursor face. */ + if (width < background_width) { - fgCol = bgCol; - bgCol = FRAME_CURSOR_COLOR (s->f); - } + int y = s->y; + int w = background_width - width, h = s->height; - glyphRect = NSMakeRect (s->x, s->y, s->background_width, s->height); + if (!s->row->reversed_p) + x += width; + else + x = s->x; - [bgCol set]; + if (s->row->mouse_face_p + && cursor_in_mouse_face_p (s->w)) + { + face = FACE_FROM_ID_OR_NULL (s->f, + MOUSE_HL_INFO (s->f)->mouse_face_face_id); + + if (!s->face) + face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + prepare_face_for_display (s->f, face); - NSRectFill (glyphRect); + [[NSColor colorWithUnsignedLong: face->background] set]; + } + else + [[NSColor colorWithUnsignedLong: s->face->background] set]; + NSRectFill (NSMakeRect (x, y, w, h)); + } + } + 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); - /* Draw overlining, etc. on the stretch glyph (or the part of - the stretch glyph after the cursor). If the glyph has a box, - then decorations will be drawn after drawing the box in - ns_draw_glyph_string, in order to prevent them from being - overwritten by the box. */ - if (s->face->box == FACE_NO_BOX) - ns_draw_text_decoration (s, face, fgCol, NSWidth (glyphRect), - NSMinX (glyphRect)); + /* 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; + } - s->background_filled_p = 1; + if (!s->row->stipple_p) + s->row->stipple_p = s->stippled_p; + + if (background_width > 0) + { + if (s->hl == DRAW_CURSOR) + [FRAME_CURSOR_COLOR (s->f) set]; + else + [[NSColor colorWithUnsignedLong: s->face->background] set]; + + NSRectFill (NSMakeRect (x, s->y, background_width, s->height)); + } } } @@ -4255,13 +4312,9 @@ Function modeled after x_draw_glyph_string_box (). n = ns_get_glyph_string_clip_rect (s->next, r); ns_focus (s->f, r, n); if (next->first_glyph->type != STRETCH_GLYPH) - { - ns_maybe_dumpglyphs_background (s->next, 1); - } - else - { - ns_dumpglyphs_stretch (s->next); - } + ns_maybe_dumpglyphs_background (s->next, 1); + else + ns_draw_stretch_glyph_string (s->next); ns_unfocus (s->f); next->num_clips = 0; } @@ -4301,7 +4354,7 @@ Function modeled after x_draw_glyph_string_box (). break; case STRETCH_GLYPH: - ns_dumpglyphs_stretch (s); + ns_draw_stretch_glyph_string (s); break; case CHAR_GLYPH: commit 004ee6b0460c450308c83dffc567fb1b8672777c Author: Alan Mackenzie Date: Tue Jul 26 19:43:13 2022 +0000 CC Mode: correct the calculation and handling of c-use-category. This fixes bug #56629. The use of c-use-category was inconsistent, with the result that it would be nil at compilation time, but t at run time. This resulted in wrongly writing syntax-table text properties to s, yet testing for category properties on them. * lisp/progmodes/cc-defs.el (c-use-category): Move to after the definition of c-<-as-paren-syntax and c->-as-paren-syntax so as correctly to be able to use their values. Put an eval-when-compile around the calculation of its value, to reduce the chances of future failure. (c-mark-<-as-paren, c-mark->-as-paren, c-unmark-<->-as-paren, c-sc-scan-lists) (c-sc-parse-partial-sexp): Wrap c-use-category in (eval-when-compile ...) as an optimization, preventing the XEmacs code also being generated. diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el index 9edaf46534..04f519dd0a 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -425,23 +425,6 @@ to it is returned. This function does not modify the point or the mark." (defvar lookup-syntax-properties) ;XEmacs. -(eval-and-compile - ;; Constant to decide at compilation time whether to use category - ;; properties. Currently (2010-03) they're available only on GNU Emacs. - (defconst c-use-category - (with-temp-buffer - (let ((parse-sexp-lookup-properties t) - (lookup-syntax-properties t)) - (set-syntax-table (make-syntax-table)) - (insert "<()>") - (put-text-property (point-min) (1+ (point-min)) - 'category 'c-<-as-paren-syntax) - (put-text-property (+ 3 (point-min)) (+ 4 (point-min)) - 'category 'c->-as-paren-syntax) - (goto-char (point-min)) - (forward-sexp) - (= (point) (+ 4 (point-min))))))) - (defmacro c-is-escaped (pos) ;; Are there an odd number of backslashes before POS? (declare (debug t)) @@ -1147,11 +1130,13 @@ MODE is either a mode symbol or a list of mode symbols." (cc-bytecomp-fboundp 'delete-extent) (cc-bytecomp-fboundp 'map-extents)))) -(defconst c-<-as-paren-syntax '(4 . ?>)) -(put 'c-<-as-paren-syntax 'syntax-table c-<-as-paren-syntax) +(eval-and-compile + (defconst c-<-as-paren-syntax '(4 . ?>)) + (put 'c-<-as-paren-syntax 'syntax-table c-<-as-paren-syntax)) -(defconst c->-as-paren-syntax '(5 . ?<)) -(put 'c->-as-paren-syntax 'syntax-table c->-as-paren-syntax) +(eval-and-compile + (defconst c->-as-paren-syntax '(5 . ?<)) + (put 'c->-as-paren-syntax 'syntax-table c->-as-paren-syntax)) ;; `c-put-char-property' is complex enough in XEmacs and Emacs < 21 to ;; make it a function. @@ -1210,6 +1195,26 @@ MODE is either a mode symbol or a list of mode symbols." `((setq c-syntax-table-hwm (min c-syntax-table-hwm -pos-)))) (put-text-property -pos- (1+ -pos-) ',property ,value)))) +(eval-and-compile + ;; Constant to decide at compilation time whether to use category + ;; properties. Currently (2010-03) they're available only on GNU + ;; Emacs. This defconst must follow the declarations of + ;; `c-<-as-paren-syntax' and `c->-as-paren-syntax'. + (defconst c-use-category + (eval-when-compile + (with-temp-buffer + (let ((parse-sexp-lookup-properties t) + (lookup-syntax-properties t)) + (set-syntax-table (make-syntax-table)) + (insert "<()>") + (put-text-property (point-min) (1+ (point-min)) + 'category 'c-<-as-paren-syntax) + (put-text-property (+ 3 (point-min)) (+ 4 (point-min)) + 'category 'c->-as-paren-syntax) + (goto-char (point-min)) + (forward-sexp) + (= (point) (+ 4 (point-min)))))))) + (defmacro c-get-char-property (pos property) ;; Get the value of the given property on the character at POS if ;; it's been put there by `c-put-char-property'. PROPERTY is @@ -1646,7 +1651,7 @@ with value CHAR in the region [FROM to)." ;; toggle the property in all template brackets simultaneously and ;; cheaply. We use this, for instance, in `c-parse-state'. (declare (debug t)) - (if c-use-category + (if (eval-when-compile c-use-category) `(c-put-char-property ,pos 'category 'c-<-as-paren-syntax) `(c-put-char-property ,pos 'syntax-table c-<-as-paren-syntax))) @@ -1661,7 +1666,7 @@ with value CHAR in the region [FROM to)." ;; toggle the property in all template brackets simultaneously and ;; cheaply. We use this, for instance, in `c-parse-state'. (declare (debug t)) - (if c-use-category + (if (eval-when-compile c-use-category) `(c-put-char-property ,pos 'category 'c->-as-paren-syntax) `(c-put-char-property ,pos 'syntax-table c->-as-paren-syntax))) @@ -1675,7 +1680,9 @@ with value CHAR in the region [FROM to)." ;; toggle the property in all template brackets simultaneously and ;; cheaply. We use this, for instance, in `c-parse-state'. (declare (debug t)) - `(c-clear-char-property ,pos ,(if c-use-category ''category ''syntax-table))) + `(c-clear-char-property ,pos ,(if (eval-when-compile c-use-category) + ''category + ''syntax-table))) (defsubst c-suppress-<->-as-parens () ;; Suppress the syntactic effect of all marked < and > as parens. Note @@ -1755,7 +1762,7 @@ with value CHAR in the region [FROM to)." (defmacro c-sc-scan-lists (from count depth) (declare (debug t)) - (if c-use-category + (if (eval-when-compile c-use-category) `(scan-lists ,from ,count ,depth) (cond ((and (eq count 1) (eq depth 1)) @@ -1803,7 +1810,7 @@ with value CHAR in the region [FROM to)." (defmacro c-sc-parse-partial-sexp (from to &optional targetdepth stopbefore oldstate) (declare (debug t)) - (if c-use-category + (if (eval-when-compile c-use-category) `(parse-partial-sexp ,from ,to ,targetdepth ,stopbefore ,oldstate) `(c-sc-parse-partial-sexp-no-category ,from ,to ,targetdepth ,stopbefore ,oldstate))) commit 058d3c0d163edd8074252a3062e9f28f75af316a Author: Lars Ingebrigtsen Date: Tue Jul 26 20:54:23 2022 +0200 Add missing @end defun to strings.texi * doc/lispref/strings.texi (Text Comparison): Add missing @end defun. diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi index bf61bb7c47..374381e595 100644 --- a/doc/lispref/strings.texi +++ b/doc/lispref/strings.texi @@ -564,6 +564,7 @@ Representations}. @code{string-equal-ignore-case} compares strings ignoring case differences, like @code{char-equal} when @code{case-fold-search} is @code{t}. +@end defun @cindex locale-dependent string equivalence @defun string-collate-equalp string1 string2 &optional locale ignore-case commit d809207f532579a699a6bd4d05151ebca9dcf872 Author: Eli Zaretskii Date: Tue Jul 26 21:34:38 2022 +0300 ; Fix documentation of 'network-lookup-address-info' * doc/lispref/processes.texi (Misc Network): Fix punctuation and markup. diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index a7dccd774b..1ef8fc3d03 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -3205,25 +3205,26 @@ If the vector does not include the port number, @var{p}, or if @end defun @defun network-lookup-address-info name &optional family hints -Perform hostname lookups on @var{name}, which is expected to be an -ASCII-only string, otherwise signal an error. Call +This function perform hostname lookups on @var{name}, which is +expected to be an ASCII-only string, otherwise it signals an error. Call @code{puny-encode-domain} on @var{name} first if you wish to lookup internationalized hostnames. -If successful, return a list of Lisp representations of network -addresses (@pxref{Network Processes} for a description of the -format.), otherwise return @code{nil}. In the latter case, also log +If successful, this function returns a list of Lisp representations of network +addresses (@pxref{Network Processes}, for a description of the +format), otherwise return @code{nil}. In the latter case, it also logs an error message hopefully explaining what went wrong. -By default, attempt both IPv4 and IPv6 lookups. The optional argument -@var{family} controls this behavior, specifying the symbol @code{ipv4} -or @code{ipv6} restricts lookups to IPv4 and IPv6 respectively. +By default, this function attempts both IPv4 and IPv6 lookups. The +optional argument @var{family} controls this behavior, specifying the +symbol @code{ipv4} or @code{ipv6} restricts lookups to IPv4 and IPv6 +respectively. -If optional argument @var{hints} is @code{numeric}, treat the hostname -as a numerical IP address (and do not perform DNS lookups). This can -be used to check whether a string is a valid numerical representation -of an IP address, or to convert a numerical string to its canonical -representation. e.g. +If optional argument @var{hints} is @code{numeric}, the function +treats the @var{name} as a numerical IP address (and does not perform DNS +lookups). This can be used to check whether a string is a valid +numerical representation of an IP address, or to convert a numerical +string to its canonical representation. e.g.@: @example (network-lookup-address-info "127.1" 'ipv4 'numeric) @@ -3234,8 +3235,8 @@ representation. e.g. @end example Be warned that there are some surprising valid forms, -especially for IPv4, e.g ``0xe3010203'' and ``0343.1.2.3'' are both -valid, as are ``0'' and ``1'' (but they are invalid for IPv6). +especially for IPv4, e.g @samp{0xe3010203} and @samp{0343.1.2.3} are both +valid, as are @samp{0} and @samp{1} (but they are invalid for IPv6). @end defun @node Serial Ports commit 7b447956d870d6fbe27cb7c2432c8154ab786c99 Author: Eli Zaretskii Date: Tue Jul 26 21:27:39 2022 +0300 ; Improve doc string of 'read-extended-command' * lisp/simple.el (read-extended-command-mode) (read-extended-command): Doc fixes. diff --git a/lisp/simple.el b/lisp/simple.el index e4fdb61076..2ef8a3cf00 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2234,15 +2234,15 @@ This is used by the \\\\[execute-extended-comma "M-X" #'execute-extended-command-cycle) (define-minor-mode read-extended-command-mode - "Minor mode when doing completion in `read-extended-command'.") + "Minor mode used for completion in `read-extended-command'.") (defun read-extended-command (&optional prompt) - "Read command name to invoke in `execute-extended-command'. -This function uses the `read-extended-command-predicate' user -option. + "Read command name to invoke via `execute-extended-command'. +Use `read-extended-command-predicate' to determine which commands +to include among completion candidates. -When reading the command name, the `read-extended-command-mode' -minor mode is activated." +This function activates the `read-extended-command-mode' minor +mode when reading the command name." (let ((default-predicate read-extended-command-predicate) (read-extended-command-predicate read-extended-command-predicate) already-typed ret) commit 90ec9bb83e213712e2170e7f2ed69f11d925919b Author: Sam Steingold Date: Tue Jul 26 14:08:38 2022 -0400 restore and obsolete `gnus-string-equal' and `bibtex-string=' * lisp/gnus/gnus-util.el (gnus-string-equal): Restore and declare obsolete. * lisp/textmodes/bibtex.el (bibtex-string=): Likewise. diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 31a275c7d0..dda2b4ff5f 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1073,6 +1073,16 @@ ARG is passed to the first function." s) (error string))) +;; This might use `compare-strings' to reduce consing in the +;; case-insensitive case, but it has to cope with null args. +;; (`string-equal' uses symbol print names.) +(defun gnus-string-equal (x y) + "Like `string-equal', except it compares case-insensitively." + (declare (obsolete string-equal-ignore-case "29.1")) + (and (= (length x) (length y)) + (or (string-equal x y) + (string-equal (downcase x) (downcase y))))) + (defcustom gnus-use-byte-compile t "If non-nil, byte-compile crucial run-time code." :type 'boolean diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index 64cb0dc0fe..8135d40d26 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -2213,6 +2213,11 @@ Point must be at beginning of preamble. Do not move point." ;; Helper Functions +(defsubst bibtex-string= (str1 str2) + "Return t if STR1 and STR2 are equal, ignoring case." + (declare (obsolete string-equal-ignore-case "29.1")) + (eq t (compare-strings str1 0 nil str2 0 nil t))) + (defun bibtex-delete-whitespace () "Delete all whitespace starting at point." (if (looking-at "[ \t\n]+") commit 1e3a7bf69d05dbbe5c853780f18caf81f1e22d32 Author: Sam Steingold Date: Tue Jul 26 14:02:49 2022 -0400 avoid error when message-fetch-field returns nil * gnus-art.el (article-hide-boring-headers): Use "" when `message-fetch-field' returns `nil' diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index e28d84e06f..18baf982b2 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -1987,8 +1987,8 @@ always hide." (gnus-article-hide-header "cc")))) ((eq elem 'followup-to) (when (string-equal-ignore-case - (message-fetch-field "followup-to") - (message-fetch-field "newsgroups")) + (or (message-fetch-field "followup-to") "") + (or (message-fetch-field "newsgroups") "")) (gnus-article-hide-header "followup-to"))) ((eq elem 'reply-to) (if (gnus-group-find-parameter commit 70341cab3eb26e2f49bbc13d6bca247ab9403abc Author: Sam Steingold Date: Tue Jul 26 13:47:03 2022 -0400 string-equal-ignore-case: new function * lisp/cedet/semantic/complete.el (semantic-collector-calculate-completions): Use `string-prefix-p' instead of explicit `compare-strings'. * lisp/emacs-lisp/byte-opt.el (side-effect-free-fns): Add `string-equal-ignore-case'. * lisp/emacs-lisp/cl-extra.el (cl-equalp): Use `string-equal-ignore-case'. * lisp/emacs-lisp/shadow.el (load-path-shadows-find): Likewise. * lisp/emacs-lisp/shortdoc.el (string): Add `string-equal-ignore-case'. * lisp/files.el (file-truename): Use `string-equal-ignore-case'. (file-relative-name): Likewise. * lisp/gnus/gnus-art.el (article-hide-boring-headers): Use `string-equal-ignore-case' instead of `gnus-string-equal'. * lisp/gnus/gnus-util.el (gnus-string-equal): Remove, use `string-equal-ignore-case' instead. * lisp/international/mule-cmds.el (describe-language-environment): Use `string-equal-ignore-case'. (locale-charset-match-p): Likewise. * lisp/man.el (Man-softhyphen-to-minus): Use `string-prefix-p'. * lisp/minibuffer.el (completion--string-equal-p): Remove, use `string-equal-ignore-case' instead. (completion--twq-all): Use `string-equal-ignore-case'. (completion--do-completion): Likewise. * lisp/net/browse-url.el (browse-url-default-windows-browser): Use `string-prefix-p' instead of explicit `compare-strings'. * lisp/org/ob-core.el (org-babel-results-keyword): Use `string-equal-ignore-case' instead of explicit `compare-strings'. (org-babel-insert-result): Likewise. * lisp/org/org-compat.el (string-equal-ignore-case): Define unless defined already. (org-mode-flyspell-verify): Use `string-equal-ignore-case'. * lisp/org/org-lint.el (org-lint-duplicate-custom-id): Likewise. * lisp/org/ox.el (org-export-resolve-radio-link): Use `string-equal-ignore-case' and `string-clean-whitespace'. * lisp/progmodes/flymake-proc.el (flymake-proc--check-patch-master-file-buffer): Use `string-prefix-p' instead of explicit `compare-strings'. * lisp/progmodes/idlwave.el (idlwave-class-or-superclass-with-tag): Use `string-equal-ignore-case' instead of explicit `compare-strings'. * lisp/subr.el (member-ignore-case): Use `string-equal-ignore-case'. (string-equal-ignore-case): Compare strings ignoring case. * lisp/textmodes/bibtex.el (bibtex-string=): Remove. (bibtex-format-entry, bibtex-font-lock-url, bibtex-autofill-entry) (bibtex-print-help-message, bibtex-validate, bibtex-validate-globally) (bibtex-clean-entry, bibtex-completion-at-point-function, (bibtex-url): Use `string-equal-ignore-case' instead of `bibtex-string='. * lisp/textmodes/sgml-mode.el (sgml-get-context): Use `string-equal-ignore-case' instead of explicit `compare-strings'. (sgml-calculate-indent): Likewise * test/lisp/subr-tests.el (string-comparison-test): Add tests for `string-equal-ignore-case'. diff --git a/doc/lispref/hash.texi b/doc/lispref/hash.texi index d3ae673d44..25a56bd715 100644 --- a/doc/lispref/hash.texi +++ b/doc/lispref/hash.texi @@ -324,15 +324,13 @@ the same integer. compared case-insensitively. @example -(defun case-fold-string= (a b) - (eq t (compare-strings a nil nil b nil nil t))) -(defun case-fold-string-hash (a) +(defun string-hash-ignore-case (a) (sxhash-equal (upcase a))) -(define-hash-table-test 'case-fold - 'case-fold-string= 'case-fold-string-hash) +(define-hash-table-test 'ignore-case + 'string-equal-ignore-case 'string-hash-ignore-case) -(make-hash-table :test 'case-fold) +(make-hash-table :test 'ignore-case) @end example Here is how you could define a hash table test equivalent to the diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi index cb9019daa9..bf61bb7c47 100644 --- a/doc/lispref/strings.texi +++ b/doc/lispref/strings.texi @@ -560,6 +560,11 @@ Representations}. @code{string-equal} is another name for @code{string=}. @end defun +@defun string-equal-ignore-case string1 string2 +@code{string-equal-ignore-case} compares strings ignoring case +differences, like @code{char-equal} when @code{case-fold-search} is +@code{t}. + @cindex locale-dependent string equivalence @defun string-collate-equalp string1 string2 &optional locale ignore-case This function returns @code{t} if @var{string1} and @var{string2} are diff --git a/etc/NEWS b/etc/NEWS index a31c50a850..7c1462ee57 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2502,6 +2502,9 @@ abbrevs. This has been generalized via the 'save-some-buffers-functions' variable, and packages can now register things to be saved. +** New function 'string-equal-ignore-case'. +This compares strings ignoring case differences. + ** Themes --- diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el index cd04cf8643..436ad08c5f 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@ -1011,20 +1011,14 @@ Output must be in semanticdb Find result format." (oref obj last-prefix))) (completionlist (cond ((or same-prefix-p - (and last-prefix (eq (compare-strings - last-prefix 0 nil - prefix 0 (length last-prefix)) - t))) + (and last-prefix (string-prefix-p last-prefix prefix t))) ;; We have the same prefix, or last-prefix is a ;; substring of the of new prefix, in which case we are ;; refining our symbol so just re-use cache. (oref obj last-all-completions)) ((and last-prefix (> (length prefix) 1) - (eq (compare-strings - prefix 0 nil - last-prefix 0 (length prefix)) - t)) + (string-prefix-p prefix last-prefix t)) ;; The new prefix is a substring of the old ;; prefix, and it's longer than one character. ;; Perform a full search to pull in additional diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 5705b2a8fd..3f4af44051 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1451,7 +1451,7 @@ See Info node `(elisp) Integer Basics'." radians-to-degrees rassq rassoc read-from-string regexp-opt regexp-quote region-beginning region-end reverse round sin sqrt string string< string= string-equal string-lessp - string> string-greaterp string-empty-p + string> string-greaterp string-empty-p string-equal-ignore-case string-prefix-p string-suffix-p string-blank-p string-search string-to-char string-to-number string-to-syntax substring diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 8e38df43c8..607810ee14 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -71,8 +71,7 @@ numbers of different types (float vs. integer), and also compares strings case-insensitively." (cond ((eq x y) t) ((stringp x) - (and (stringp y) (= (length x) (length y)) - (eq (compare-strings x nil nil y nil nil t) t))) + (and (stringp y) (string-equal-ignore-case x y))) ((numberp x) (and (numberp y) (= x y))) ((consp x) diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 2343a9b589..da32e4564f 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -128,11 +128,8 @@ See the documentation for `list-load-path-shadows' for further information." (if (setq orig-dir (assoc file files - (when dir-case-insensitive - (lambda (f1 f2) - (eq (compare-strings f1 nil nil - f2 nil nil t) - t))))) + (and dir-case-insensitive + #'string-equal-ignore-case))) ;; This file was seen before, we have a shadowing. ;; Report it unless the files are identical. (let ((base1 (concat (cdr orig-dir) "/" (car orig-dir))) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 05b3361cb3..315afd4312 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -243,6 +243,8 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), "Predicates for Strings" (string-equal :eval (string-equal "foo" "foo")) + (string-equal-ignore-case + :eval (string-equal-ignore-case "foo" "FOO")) (eq :eval (eq "foo" "foo")) (eql diff --git a/lisp/files.el b/lisp/files.el index bc74dfa738..37ed796a68 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -1428,7 +1428,7 @@ containing it, until no links are left at any level. ;; If these are equal, we have the (or a) root directory. (or (string= dir dirfile) (and (file-name-case-insensitive-p dir) - (eq (compare-strings dir 0 nil dirfile 0 nil t) t)) + (string-equal-ignore-case dir dirfile)) ;; If this is the same dir we last got the truename for, ;; save time--don't recalculate. (if (assoc dir (car prev-dirs)) @@ -5459,21 +5459,17 @@ on a DOS/Windows machine, it returns FILENAME in expanded form." ;; Test for different drive letters (not (eq t (compare-strings filename 0 2 directory 0 2 fold-case))) ;; Test for UNCs on different servers - (not (eq t (compare-strings - (progn - (if (string-match "\\`//\\([^:/]+\\)/" filename) - (match-string 1 filename) - ;; Windows file names cannot have ? in - ;; them, so use that to detect when - ;; neither FILENAME nor DIRECTORY is a - ;; UNC. - "?")) - 0 nil - (progn - (if (string-match "\\`//\\([^:/]+\\)/" directory) - (match-string 1 directory) - "?")) - 0 nil t))))) + (not (string-equal-ignore-case + (if (string-match "\\`//\\([^:/]+\\)/" filename) + (match-string 1 filename) + ;; Windows file names cannot have ? in + ;; them, so use that to detect when + ;; neither FILENAME nor DIRECTORY is a + ;; UNC. + "?") + (if (string-match "\\`//\\([^:/]+\\)/" directory) + (match-string 1 directory) + "?"))))) ;; Test for different remote file system identification (not (equal fremote dremote))) filename diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 4b68a54ce8..e28d84e06f 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -1939,8 +1939,8 @@ always hide." 'boring-headers))) ;; Hide boring Newsgroups header. ((eq elem 'newsgroups) - (when (gnus-string-equal - (gnus-fetch-field "newsgroups") + (when (string-equal-ignore-case + (or (gnus-fetch-field "newsgroups") "") (gnus-group-real-name (if (boundp 'gnus-newsgroup-name) gnus-newsgroup-name @@ -1954,7 +1954,7 @@ always hide." gnus-newsgroup-name "")))) (when (and to to-address (ignore-errors - (gnus-string-equal + (string-equal-ignore-case ;; only one address in To (nth 1 (mail-extract-address-components to)) to-address))) @@ -1967,7 +1967,7 @@ always hide." gnus-newsgroup-name "")))) (when (and to to-list (ignore-errors - (gnus-string-equal + (string-equal-ignore-case ;; only one address in To (nth 1 (mail-extract-address-components to)) to-list))) @@ -1980,13 +1980,13 @@ always hide." gnus-newsgroup-name "")))) (when (and cc to-list (ignore-errors - (gnus-string-equal + (string-equal-ignore-case ;; only one address in Cc (nth 1 (mail-extract-address-components cc)) to-list))) (gnus-article-hide-header "cc")))) ((eq elem 'followup-to) - (when (gnus-string-equal + (when (string-equal-ignore-case (message-fetch-field "followup-to") (message-fetch-field "newsgroups")) (gnus-article-hide-header "followup-to"))) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 218a4d242b..31a275c7d0 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1073,15 +1073,6 @@ ARG is passed to the first function." s) (error string))) -;; This might use `compare-strings' to reduce consing in the -;; case-insensitive case, but it has to cope with null args. -;; (`string-equal' uses symbol print names.) -(defun gnus-string-equal (x y) - "Like `string-equal', except it compares case-insensitively." - (and (= (length x) (length y)) - (or (string-equal x y) - (string-equal (downcase x) (downcase y))))) - (defcustom gnus-use-byte-compile t "If non-nil, byte-compile crucial run-time code." :type 'boolean diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index df1c06ec27..12896cc4b0 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -2199,8 +2199,7 @@ See `set-language-info-alist' for use in programs." 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))) + (string-equal-ignore-case language-name (nth 1 elt))) (when first (insert "Input methods:\n") (setq first nil)) @@ -2599,7 +2598,7 @@ Matching is done ignoring case and any hyphens and underscores in the names. E.g. `ISO_8859-1' and `iso88591' both match `iso-8859-1'." (setq charset1 (replace-regexp-in-string "[-_]" "" charset1)) (setq charset2 (replace-regexp-in-string "[-_]" "" charset2)) - (eq t (compare-strings charset1 nil nil charset2 nil nil t))) + (string-equal-ignore-case charset1 charset2)) (defvar locale-charset-alist nil "Coding system alist keyed on locale-style charset name. diff --git a/lisp/man.el b/lisp/man.el index 951e0ef9ad..d66f63972a 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -1241,8 +1241,7 @@ See the variable `Man-notify-method' for the different notification behaviors." (defun Man-softhyphen-to-minus () ;; \255 is SOFT HYPHEN in Latin-N. Versions of Debian man, at ;; least, emit it even when not in a Latin-N locale. - (unless (eq t (compare-strings "latin-" 0 nil - current-language-environment 0 6 t)) + (unless (string-prefix-p "latin-" current-language-environment t) (goto-char (point-min)) (while (search-forward "­" nil t) (replace-match "-")))) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index bdf6d852a9..3daab8a1e8 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -634,9 +634,6 @@ for use at QPOS." (let ((qstr (funcall qfun completion))) (cons qstr (length qstr)))))) -(defun completion--string-equal-p (s1 s2) - (eq t (compare-strings s1 nil nil s2 nil nil 'ignore-case))) - (defun completion--twq-all (string ustring completions boundary _unquote requote) (when completions @@ -650,7 +647,7 @@ for use at QPOS." (qfullprefix (substring string 0 qfullpos)) ;; FIXME: This assertion can be wrong, e.g. in Cygwin, where ;; (unquote "c:\bin") => "/usr/bin" but (unquote "c:\") => "/". - ;;(cl-assert (completion--string-equal-p + ;;(cl-assert (string-equal-ignore-case ;; (funcall unquote qfullprefix) ;; (concat (substring ustring 0 boundary) prefix)) ;; t)) @@ -688,7 +685,7 @@ for use at QPOS." (let* ((rest (substring completion 0 (length prefix))) (qrest (funcall qfun rest))) - (if (completion--string-equal-p qprefix qrest) + (if (string-equal-ignore-case qprefix qrest) (propertize qrest 'face 'completions-common-part) qprefix)))) @@ -696,7 +693,7 @@ for use at QPOS." ;; FIXME: Similarly here, Cygwin's mapping trips this ;; assertion. ;;(cl-assert - ;; (completion--string-equal-p + ;; (string-equal-ignore-case ;; (funcall unquote ;; (concat (substring string 0 qboundary) ;; qcompletion)) @@ -1309,10 +1306,8 @@ when the buffer's text is already an exact match." ;; for appearance, the string is rewritten if the case changes. (let* ((comp-pos (cdr comp)) (completion (car comp)) - (completed (not (eq t (compare-strings completion nil nil - string nil nil t)))) - (unchanged (eq t (compare-strings completion nil nil - string nil nil nil)))) + (completed (not (string-equal-ignore-case completion string))) + (unchanged (string-equal completion string))) (if unchanged (goto-char end) ;; Insert in minibuffer the chars we got. diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index a55aec76bf..6713208d26 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -981,8 +981,7 @@ The optional NEW-WINDOW argument is not used." ;; quotes in the MAILTO URLs, so we prefer ;; to leave the URL with its embedded %nn ;; encoding intact. - (if (eq t (compare-strings url nil 7 - "file://" nil nil)) + (if (string-prefix-p "file://" url) (url-unhex-string url) url))))) diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index 04af84d2e4..3d159ed38a 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -136,8 +136,7 @@ used." :type 'string :safe (lambda (v) (and (stringp v) - (eq (compare-strings "RESULTS" nil nil v nil nil t) - t)))) + (string-equal-ignore-case "RESULTS" v)))) (defcustom org-babel-noweb-wrap-start "<<" "String used to begin a noweb reference in a code block. @@ -2435,7 +2434,7 @@ INFO may provide the values of these header arguments (in the ;; Escape contents from "export" wrap. Wrap ;; inline results within an export snippet with ;; appropriate value. - ((eq t (compare-strings type nil nil "export" nil nil t)) + ((string-equal-ignore-case type "export") (let ((backend (pcase split (`(,_) "none") (`(,_ ,b . ,_) b)))) @@ -2446,14 +2445,14 @@ INFO may provide the values of these header arguments (in the backend) "@@)}}}"))) ;; Escape contents from "example" wrap. Mark ;; inline results as verbatim. - ((eq t (compare-strings type nil nil "example" nil nil t)) + ((string-equal-ignore-case type "example") (funcall wrap opening-line closing-line nil nil "{{{results(=" "=)}}}")) ;; Escape contents from "src" wrap. Mark ;; inline results as inline source code. - ((eq t (compare-strings type nil nil "src" nil nil t)) + ((string-equal-ignore-case type "src") (let ((inline-open (pcase split (`(,_) diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el index a65bf6f677..085e32d677 100644 --- a/lisp/org/org-compat.el +++ b/lisp/org/org-compat.el @@ -934,6 +934,14 @@ Implements `define-error' for older emacsen." (put name 'error-conditions (copy-sequence (cons name (get 'error 'error-conditions)))))) +(unless (fboundp 'string-equal-ignore-case) + ;; From Emacs subr.el. + (defun string-equal-ignore-case (string1 string2) + "Like `string-equal', but case-insensitive. +Upper-case and lower-case letters are treated as equal. +Unibyte strings are converted to multibyte for comparison." + (eq t (compare-strings string1 0 nil string2 0 nil t)))) + (unless (fboundp 'string-suffix-p) ;; From Emacs subr.el. (defun string-suffix-p (suffix string &optional ignore-case) @@ -1125,10 +1133,8 @@ ELEMENT is the element at point." (and log (let ((drawer (org-element-lineage element '(drawer)))) (and drawer - (eq (compare-strings - log nil nil - (org-element-property :drawer-name drawer) nil nil t) - t))))) + (string-equal-ignore-case + log (org-element-property :drawer-name drawer)))))) nil) (t (cl-case (org-element-type element) diff --git a/lisp/org/org-lint.el b/lisp/org/org-lint.el index 83c2d08a90..6d8cf3f237 100644 --- a/lisp/org/org-lint.el +++ b/lisp/org/org-lint.el @@ -334,10 +334,8 @@ called with one argument, the key used for comparison." ast 'node-property (lambda (property) - (and (eq (compare-strings "CUSTOM_ID" nil nil - (org-element-property :key property) nil nil - t) - t) + (and (string-equal-ignore-case + "CUSTOM_ID" (org-element-property :key property)) (org-element-property :value property))) (lambda (property _) (org-element-property :begin property)) (lambda (key) (format "Duplicate CUSTOM_ID property \"%s\"" key)))) diff --git a/lisp/org/ox.el b/lisp/org/ox.el index 55258bc79d..1bdf4dead8 100644 --- a/lisp/org/ox.el +++ b/lisp/org/ox.el @@ -80,6 +80,7 @@ (require 'org-element) (require 'org-macro) (require 'tabulated-list) +(require 'subr-x) (declare-function org-src-coderef-format "org-src" (&optional element)) (declare-function org-src-coderef-regexp "org-src" (fmt &optional label)) @@ -4436,15 +4437,12 @@ INFO is a plist used as a communication channel. Return value can be a radio-target object or nil. Assume LINK has type \"radio\"." - (let ((path (replace-regexp-in-string - "[ \r\t\n]+" " " (org-element-property :path link)))) + (let ((path (string-clean-whitespace (org-element-property :path link)))) (org-element-map (plist-get info :parse-tree) 'radio-target (lambda (radio) - (and (eq (compare-strings - (replace-regexp-in-string - "[ \r\t\n]+" " " (org-element-property :value radio)) - nil nil path nil nil t) - t) + (and (string-equal-ignore-case + (string-clean-whitespace (org-element-property :value radio)) + path) radio)) info 'first-match))) diff --git a/lisp/progmodes/flymake-proc.el b/lisp/progmodes/flymake-proc.el index 4ab16831bc..249ae9dff2 100644 --- a/lisp/progmodes/flymake-proc.el +++ b/lisp/progmodes/flymake-proc.el @@ -399,10 +399,7 @@ instead of reading master file from disk." (not (string-match (format "\\.%s\\'" source-file-extension) inc-name)) (setq inc-name (concat inc-name "." source-file-extension))) - (when (eq t (compare-strings - source-file-nondir nil nil - inc-name (- (length inc-name) - (length source-file-nondir)) nil)) + (when (string-suffix-p source-file-nondir inc-name) (flymake-log 3 "inc-name=%s" inc-name) (when (flymake-proc--check-include source-file-name inc-name include-dirs) diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index a2061fde76..b3dc3cac76 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -7528,7 +7528,7 @@ associated TAG, if any." (setq cl (pop sclasses)) (let ((tags (idlwave-class-tags cl))) (while tags - (if (eq t (compare-strings tag 0 nil (car tags) 0 nil t)) + (if (string-equal-ignore-case tag (car tags)) (throw 'exit cl)) (setq tags (cdr tags)))))))) diff --git a/lisp/subr.el b/lisp/subr.el index a0ad967533..c82b33bba5 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -868,7 +868,7 @@ Non-strings in LIST are ignored." (declare (side-effect-free t)) (while (and list (not (and (stringp (car list)) - (eq t (compare-strings elt 0 nil (car list) 0 nil t))))) + (string-equal-ignore-case elt (car list))))) (setq list (cdr list))) list) @@ -5302,6 +5302,12 @@ and replace a sub-expression, e.g. (setq matches (cons (substring string start l) matches)) ; leftover (apply #'concat (nreverse matches))))) +(defun string-equal-ignore-case (string1 string2) + "Like `string-equal', but case-insensitive. +Upper-case and lower-case letters are treated as equal. +Unibyte strings are converted to multibyte for comparison." + (eq t (compare-strings string1 0 nil string2 0 nil t))) + (defun string-prefix-p (prefix string &optional ignore-case) "Return non-nil if PREFIX is a prefix of STRING. If IGNORE-CASE is non-nil, the comparison is done without paying attention diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index 333cfa5169..64cb0dc0fe 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -2213,10 +2213,6 @@ Point must be at beginning of preamble. Do not move point." ;; Helper Functions -(defsubst bibtex-string= (str1 str2) - "Return t if STR1 and STR2 are equal, ignoring case." - (eq t (compare-strings str1 0 nil str2 0 nil t))) - (defun bibtex-delete-whitespace () "Delete all whitespace starting at point." (if (looking-at "[ \t\n]+") @@ -2657,7 +2653,7 @@ Formats current entry according to variable `bibtex-entry-format'." ;; update page dashes (if (and (memq 'page-dashes format) - (bibtex-string= field-name "pages") + (string-equal-ignore-case field-name "pages") (progn (goto-char beg-text) (looking-at "\\([\"{][0-9]+\\)[ \t\n]*--?[ \t\n]*\\([0-9]+[\"}]\\)"))) @@ -2710,7 +2706,7 @@ Formats current entry according to variable `bibtex-entry-format'." ;; use book title of crossref'd entry (if (and (memq 'inherit-booktitle format) empty-field - (bibtex-string= field-name "booktitle") + (string-equal-ignore-case field-name "booktitle") crossref-key) (let ((title (save-excursion (save-restriction @@ -3503,7 +3499,7 @@ If NO-BUTTON is non-nil do not generate buttons." (let ((lst bibtex-generate-url-list) url) (while (and (not found) (setq url (car (pop lst)))) (goto-char start) - (setq found (and (bibtex-string= name (car url)) + (setq found (and (string-equal-ignore-case name (car url)) (re-search-forward (cdr url) end t)))))) (unless found (goto-char end))) (if (and found (not no-button)) @@ -3954,7 +3950,7 @@ entry (for example, the year parts of the keys)." (goto-char (1- (match-beginning 0))) (bibtex-beginning-of-entry) (if (and (looking-at bibtex-entry-head) - (bibtex-string= type (bibtex-type-in-head)) + (string-equal-ignore-case type (bibtex-type-in-head)) ;; In case we found ourselves :-( (not (equal key (setq tmp (bibtex-key-in-head))))) (setq other-key tmp @@ -3963,7 +3959,7 @@ entry (for example, the year parts of the keys)." (bibtex-end-of-entry) (bibtex-skip-to-valid-entry) (if (and (looking-at bibtex-entry-head) - (bibtex-string= type (bibtex-type-in-head)) + (string-equal-ignore-case type (bibtex-type-in-head)) ;; In case we found ourselves :-( (not (equal key (setq tmp (bibtex-key-in-head)))) (or (not other-key) @@ -4004,9 +4000,9 @@ interactive calls." (interactive (list nil t)) (unless field (setq field (car (bibtex-find-text-internal nil nil comma)))) (if (string-search "@" field) - (cond ((bibtex-string= field "@string") + (cond ((string-equal-ignore-case field "@string") (message "String definition")) - ((bibtex-string= field "@preamble") + ((string-equal-ignore-case field "@preamble") (message "Preamble definition")) (t (message "Entry key"))) (let* ((case-fold-search t) @@ -4588,7 +4584,7 @@ Return t if test was successful, nil otherwise." bounds field idx) (while (setq bounds (bibtex-parse-field)) (let ((field-name (bibtex-name-in-field bounds))) - (if (and (bibtex-string= field-name "month") + (if (and (string-equal-ignore-case field-name "month") ;; Check only abbreviated month fields. (let ((month (bibtex-text-in-field-bounds bounds))) (not (or (string-match "\\`[\"{].+[\"}]\\'" month) @@ -4669,7 +4665,7 @@ Return t if test was successful, nil otherwise." (while (re-search-forward bibtex-entry-head nil t) (setq entry-type (bibtex-type-in-head) key (bibtex-key-in-head)) - (if (or (and strings (bibtex-string= entry-type "string")) + (if (or (and strings (string-equal-ignore-case entry-type "string")) (assoc-string entry-type bibtex-entry-alist t)) (if (member key key-list) (push (format-message @@ -5046,10 +5042,10 @@ At end of the cleaning process, the functions in (user-error "Not inside a BibTeX entry"))) (entry-type (bibtex-type-in-head)) (key (bibtex-key-in-head))) - (cond ((bibtex-string= entry-type "preamble") + (cond ((string-equal-ignore-case entry-type "preamble") ;; (bibtex-format-preamble) (user-error "No clean up of @Preamble entries")) - ((bibtex-string= entry-type "string") + ((string-equal-ignore-case entry-type "string") (setq entry-type 'string)) ;; (bibtex-format-string) (t (bibtex-format-entry))) @@ -5326,10 +5322,10 @@ entries from minibuffer." (>= pnt (bibtex-start-of-text-in-field bounds)) (<= pnt (bibtex-end-of-text-in-field bounds))) (setq name (bibtex-name-in-field bounds t) - compl (cond ((bibtex-string= name "crossref") + compl (cond ((string-equal-ignore-case name "crossref") ;; point is in crossref field 'crossref-key) - ((bibtex-string= name "month") + ((string-equal-ignore-case name "month") ;; point is in month field bibtex-predefined-month-strings) ;; point is in other field @@ -5488,7 +5484,7 @@ Return the URL or nil if none can be generated." (while (and (not url) (setq scheme (pop lst))) ;; Verify the match of `bibtex-font-lock-url' by ;; comparing with TEXT. - (when (and (bibtex-string= (caar scheme) name) + (when (and (string-equal-ignore-case (caar scheme) name) (string-match (cdar scheme) text)) (setq url t scheme (cdr scheme))))))) diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index 8f9b603ef5..ba0a94b4a1 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -1536,8 +1536,7 @@ not the case, the first tag returned is the one inside which we are." ;; [ Well, actually it depends, but we don't have the info about ;; when it doesn't and when it does. --Stef ] (setq ignore nil))) - ((eq t (compare-strings (sgml-tag-name tag-info) nil nil - (car stack) nil nil t)) + ((string-equal-ignore-case (sgml-tag-name tag-info) (car stack)) (setq stack (cdr stack))) (t ;; The open and close tags don't match. @@ -1549,9 +1548,8 @@ not the case, the first tag returned is the one inside which we are." ;; but it's a bad assumption when tags *are* closed but ;; not properly nested. (while (and (cdr tmp) - (not (eq t (compare-strings - (sgml-tag-name tag-info) nil nil - (cadr tmp) nil nil t)))) + (not (string-equal-ignore-case + (sgml-tag-name tag-info) (cadr tmp)))) (setq tmp (cdr tmp))) (if (cdr tmp) (setcdr tmp (cddr tmp))))) (message "Unmatched tags <%s> and " @@ -1701,9 +1699,8 @@ LCON is the lexical context, if any." (there (point))) ;; Ignore previous unclosed start-tag in context. (while (and context unclosed - (eq t (compare-strings - (sgml-tag-name (car context)) nil nil - unclosed nil nil t))) + (string-equal-ignore-case + (sgml-tag-name (car context)) unclosed)) (setq context (cdr context))) ;; Indent to reflect nesting. (cond diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index f50d45217c..e2a490092b 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -761,8 +761,7 @@ the buffer contents as a comment." ;; (while (and (not member) fileset) ;; (let ((elem (pop fileset))) ;; (if (if (file-directory-p elem) -;; (eq t (compare-strings buffer-file-name nil (length elem) -;; elem nil nil)) +;; (string-prefix-p elem buffer-file-name) ;; (eq (current-buffer) (get-file-buffer elem))) ;; (setq member t)))) ;; member)) diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 84f3e41148..d45f409e85 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -368,6 +368,13 @@ 2))) (ert-deftest string-comparison-test () + (should (string-equal-ignore-case "abc" "abc")) + (should (string-equal-ignore-case "abc" "ABC")) + (should (string-equal-ignore-case "abc" "abC")) + (should-not (string-equal-ignore-case "abc" "abCD")) + (should (string-equal-ignore-case "S" "s")) + ;; not yet: (should (string-equal-ignore-case "SS" "ß")) + (should (string-lessp "abc" "acb")) (should (string-lessp "aBc" "abc")) (should (string-lessp "abc" "abcd")) commit 015cf7824ea511180329dabcb67c533661da3fff Author: Lars Ingebrigtsen Date: Tue Jul 26 15:21:28 2022 +0200 Don't bind `M-X' when doing general completion * lisp/minibuffer.el (minibuffer-local-must-match-map): Remove the M-X binding here, because it's nonsensical outside read-extended-command (bug#56741). * lisp/simple.el (read-extended-command-mode-map) (read-extended-command-mode): New minor mode to bind `M-X' in read-extended-command. (read-extended-command-1): Use it. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index d139e094eb..bdf6d852a9 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2760,7 +2760,6 @@ The completion method is determined by `completion-at-point-functions'." (defvar-keymap minibuffer-local-must-match-map :doc "Local keymap for minibuffer input with completion, for exact match." :parent minibuffer-local-completion-map - "M-X" #'execute-extended-command-cycle "RET" #'minibuffer-complete-and-exit "C-j" #'minibuffer-complete-and-exit) diff --git a/lisp/simple.el b/lisp/simple.el index 5443d961e1..e4fdb61076 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2229,9 +2229,20 @@ See `extended-command-versions'." "Alist of prompts and what the extended command predicate should be. This is used by the \\\\[execute-extended-command-cycle] command when reading an extended command.") +(defvar-keymap read-extended-command-mode-map + :doc "Local keymap added to the current map when reading an extended command." + "M-X" #'execute-extended-command-cycle) + +(define-minor-mode read-extended-command-mode + "Minor mode when doing completion in `read-extended-command'.") + (defun read-extended-command (&optional prompt) "Read command name to invoke in `execute-extended-command'. -This function uses the `read-extended-command-predicate' user option." +This function uses the `read-extended-command-predicate' user +option. + +When reading the command name, the `read-extended-command-mode' +minor mode is activated." (let ((default-predicate read-extended-command-predicate) (read-extended-command-predicate read-extended-command-predicate) already-typed ret) @@ -2270,6 +2281,8 @@ This function uses the `read-extended-command-predicate' user option." (setq execute-extended-command--last-typed (minibuffer-contents))) nil 'local) + ;; This is so that we define the `M-X' toggling command. + (read-extended-command-mode) (setq-local minibuffer-default-add-function (lambda () ;; Get a command name at point in the original buffer commit a1384cd65d2f9dbb702b31fdfe06d7b8643ef978 Author: Lars Ingebrigtsen Date: Tue Jul 26 14:31:04 2022 +0200 Add a test for print-unreadable-function * test/lisp/subr-tests.el (test-print-unreadable-function): Add failing test (bug#56773). diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index f5c1c40263..84f3e41148 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -1026,7 +1026,16 @@ final or penultimate step during initialization.")) (ert-deftest test-readablep () (should (readablep "foo")) - (should-not (readablep (list (make-marker))))) + (should-not (readablep (list (make-marker)))) + (should-not (readablep (make-marker)))) + +(ert-deftest test-print-unreadable-function () + :expected-result :failed + ;; Check that problem with unwinding properly is fixed (bug#56773). + (with-temp-buffer + (let ((buf (current-buffer))) + (readablep (make-marker)) + (should (eq buf (current-buffer)))))) (ert-deftest test-string-lines () (should (equal (string-lines "") '(""))) commit 592ae7ffe20aa9b5508fa0ac51dcf0ba33881b3c Author: Mattias Engdegård Date: Mon Jun 20 11:16:26 2022 +0200 Add duplicate-dwim (bug#56418) Like duplicate-line but duplicates the region instead if active. Rectangular regions are duplicated on the right-hand side. The region remains active afterwards, to facilitate further duplication or other operations on the same text. * lisp/rect.el (rectangle--duplicate-right): * lisp/misc.el (duplicate-dwim): New. * test/lisp/misc-tests.el (misc--duplicate-dwim): New test. * etc/NEWS: Announce. diff --git a/etc/NEWS b/etc/NEWS index c8e4a065fe..a31c50a850 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -401,8 +401,11 @@ between these modes while the user is inputting a command by hitting ** Interactively, 'kill-buffer' will now offer to save the buffer if unsaved. --- -** New command 'duplicate-line'. -This command duplicates the current line the specified number of times. +** New commands 'duplicate-line' and 'duplicate-dwim'. +'duplicate-line' duplicates the current line the specified number of times. +'duplicate-dwim' duplicates the region if it is active. If not, it +works like 'duplicate-line'. An active rectangular region is +duplicated on its right-hand side. --- ** Files with the ".eld" extension are now visited in 'lisp-data-mode'. diff --git a/lisp/misc.el b/lisp/misc.el index 28c5d6e07f..a53571f463 100644 --- a/lisp/misc.el +++ b/lisp/misc.el @@ -79,6 +79,43 @@ Also see the `copy-from-above-command' command." (dotimes (_ n) (insert line "\n"))))) +(declare-function rectangle--duplicate-right "rect" (n)) + +;; `duplicate-dwim' preserves an active region and changes the buffer +;; outside of it: disregard the region when immediately undoing the +;; actions of this command. +(put 'duplicate-dwim 'undo-inhibit-region t) + +;;;###autoload +(defun duplicate-dwim (&optional n) + "Duplicate the current line or region N times. +If the region is inactive, duplicate the current line (like `duplicate-line'). +Otherwise, duplicate the region, which remains active afterwards. +If the region is rectangular, duplicate on its right-hand side. +Interactively, N is the prefix numeric argument, and defaults to 1." + (interactive "p") + (unless n + (setq n 1)) + (cond + ;; Duplicate rectangle. + ((bound-and-true-p rectangle-mark-mode) + (rectangle--duplicate-right n) + (setq deactivate-mark nil)) + + ;; Duplicate (contiguous) region. + ((use-region-p) + (let* ((beg (region-beginning)) + (end (region-end)) + (text (buffer-substring beg end))) + (save-excursion + (goto-char end) + (dotimes (_ n) + (insert text)))) + (setq deactivate-mark nil)) + + ;; Duplicate line. + (t (duplicate-line n)))) + ;; Variation of `zap-to-char'. ;;;###autoload diff --git a/lisp/rect.el b/lisp/rect.el index 47df95b04e..eebbf999d4 100644 --- a/lisp/rect.el +++ b/lisp/rect.el @@ -930,6 +930,27 @@ Ignores `line-move-visual'." (mapc #'delete-overlay (nthcdr 5 rol)) (setcar (cdr rol) nil))) +(defun rectangle--duplicate-right (n) + "Duplicate the rectangular region N times on the right-hand side." + (let ((cols (rectangle--pos-cols (point) (mark)))) + (apply-on-rectangle + (lambda (startcol endcol) + (let ((lines (list nil))) + (extract-rectangle-line startcol endcol lines) + (move-to-column endcol t) + (dotimes (_ n) + (insert (cadr lines))))) + (region-beginning) (region-end)) + ;; Recompute the rectangle state; no crutches should be needed now. + (let ((p (point)) + (m (mark))) + (rectangle--reset-crutches) + (goto-char m) + (move-to-column (cdr cols) t) + (set-mark (point)) + (goto-char p) + (move-to-column (car cols) t)))) + (provide 'rect) ;;; rect.el ends here diff --git a/test/lisp/misc-tests.el b/test/lisp/misc-tests.el index a56feaa049..f84827ab02 100644 --- a/test/lisp/misc-tests.el +++ b/test/lisp/misc-tests.el @@ -96,5 +96,43 @@ (should (equal (buffer-string) "abc\nabc\n")) (should (equal (point) 2)))) +(require 'rect) + +(ert-deftest misc--duplicate-dwim () + ;; Duplicate a line. + (with-temp-buffer + (insert "abc\ndefg\nh\n") + (goto-char 7) + (duplicate-dwim 2) + (should (equal (buffer-string) "abc\ndefg\ndefg\ndefg\nh\n")) + (should (equal (point) 7))) + + ;; Duplicate a region. + (with-temp-buffer + (insert "abc\ndef\n") + (set-mark 2) + (goto-char 7) + (transient-mark-mode) + (should (use-region-p)) + (duplicate-dwim) + (should (equal (buffer-string) "abc\ndebc\ndef\n")) + (should (equal (point) 7)) + (should (region-active-p)) + (should (equal (mark) 2))) + + ;; Duplicate a rectangular region. + (with-temp-buffer + (insert "x\n>a\n>bcde\n>fg\nyz\n") + (goto-char 4) + (rectangle-mark-mode) + (goto-char 15) + (rectangle-forward-char 1) + (duplicate-dwim) + (should (equal (buffer-string) "x\n>a a \n>bcdbcde\n>fg fg \nyz\n")) + (should (equal (point) 24)) + (should (region-active-p)) + (should rectangle-mark-mode) + (should (equal (mark) 4)))) + (provide 'misc-tests) ;;; misc-tests.el ends here commit fc1b7b720b5771a330f36e9a52688d73b790e478 Author: Robert Pluim Date: Mon Jul 25 12:17:07 2022 +0200 Teach 'network-lookup-address-info' to validate numeric addresses * src/process.c (Fnetwork_lookup_address_info): Add optional 'hints' argument, pass AI_NUMERICHOST to 'getaddrinfo' if it's 'numeric'. (syms_of_process): Add 'numeric' symbol. * doc/lispref/processes.texi (Misc Network): Expunge passive voice. Update 'network-lookup-address-info' description. * test/src/process-tests.el (lookup-hints-specification): (lookup-hints-values): Test new functionality. * etc/NEWS: Announce change. diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index 80c371e1c6..a7dccd774b 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -3204,20 +3204,38 @@ If the vector does not include the port number, @var{p}, or if @code{:@var{p}} suffix. @end defun -@defun network-lookup-address-info name &optional family -This function is used to perform hostname lookups on @var{name}, which -is expected to be an ASCII-only string, otherwise an error is -signaled. Call @code{puny-encode-domain} on @var{name} -first if you wish to lookup internationalized hostnames. - -If successful it returns a list of Lisp representations of network -addresses, otherwise it returns @code{nil}. In the latter case, it -also displays the error message hopefully explaining what went wrong. - -By default both IPv4 and IPv6 lookups are attempted. The optional -argument @var{family} controls this behavior, specifying the symbol -@code{ipv4} or @code{ipv6} restricts lookups to IPv4 and IPv6 -respectively. +@defun network-lookup-address-info name &optional family hints +Perform hostname lookups on @var{name}, which is expected to be an +ASCII-only string, otherwise signal an error. Call +@code{puny-encode-domain} on @var{name} first if you wish to lookup +internationalized hostnames. + +If successful, return a list of Lisp representations of network +addresses (@pxref{Network Processes} for a description of the +format.), otherwise return @code{nil}. In the latter case, also log +an error message hopefully explaining what went wrong. + +By default, attempt both IPv4 and IPv6 lookups. The optional argument +@var{family} controls this behavior, specifying the symbol @code{ipv4} +or @code{ipv6} restricts lookups to IPv4 and IPv6 respectively. + +If optional argument @var{hints} is @code{numeric}, treat the hostname +as a numerical IP address (and do not perform DNS lookups). This can +be used to check whether a string is a valid numerical representation +of an IP address, or to convert a numerical string to its canonical +representation. e.g. + +@example +(network-lookup-address-info "127.1" 'ipv4 'numeric) + @result{} ([127 0 0 1 0]) + +(network-lookup-address-info "::1" nil 'numeric) + @result{} ([0 0 0 0 0 0 0 1 0]) +@end example + +Be warned that there are some surprising valid forms, +especially for IPv4, e.g ``0xe3010203'' and ``0343.1.2.3'' are both +valid, as are ``0'' and ``1'' (but they are invalid for IPv6). @end defun @node Serial Ports diff --git a/etc/NEWS b/etc/NEWS index 1d0e45fdcc..c8e4a065fe 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -407,6 +407,15 @@ This command duplicates the current line the specified number of times. --- ** Files with the ".eld" extension are now visited in 'lisp-data-mode'. ++++ +** 'network-lookup-address-info' can now check numeric IP address validity. +Specifying 'numeric as the new optional 'hints' argument makes it +check if the passed address is a valid IPv4/IPv6 address (without DNS +traffic). + + (network-lookup-address-info "127.1" 'ipv4 'numeric) + => ([127 0 0 1 0]) + +++ ** New command 'find-sibling-file'. This command jumps to a file considered a "sibling file", which is diff --git a/src/process.c b/src/process.c index d6d51b26e1..1ac5a509e5 100644 --- a/src/process.c +++ b/src/process.c @@ -4641,15 +4641,20 @@ network_lookup_address_info_1 (Lisp_Object host, const char *service, } DEFUN ("network-lookup-address-info", Fnetwork_lookup_address_info, - Snetwork_lookup_address_info, 1, 2, 0, + Snetwork_lookup_address_info, 1, 3, 0, doc: /* Look up Internet Protocol (IP) address info of NAME. -Optional parameter FAMILY controls whether to look up IPv4 or IPv6 +Optional argument FAMILY controls whether to look up IPv4 or IPv6 addresses. The default of nil means both, symbol `ipv4' means IPv4 -only, symbol `ipv6' means IPv6 only. Returns a list of addresses, or -nil if none were found. Each address is a vector of integers, as per -the description of ADDRESS in `make-network-process'. In case of -error displays the error message. */) - (Lisp_Object name, Lisp_Object family) +only, symbol `ipv6' means IPv6 only. +Optional argument HINTS allows specifying the hints passed to the +underlying library call. The only supported value is `numeric', which +means treat NAME as a numeric IP address. This also suppresses DNS +traffic. +Return a list of addresses, or nil if none were found. Each address +is a vector of integers, as per the description of ADDRESS in +`make-network-process'. In case of error log the error message +returned from the lookup. */) + (Lisp_Object name, Lisp_Object family, Lisp_Object hint) { Lisp_Object addresses = Qnil; Lisp_Object msg = Qnil; @@ -4667,9 +4672,14 @@ error displays the error message. */) hints.ai_family = AF_INET6; #endif else - error ("Unsupported lookup type"); + error ("Unsupported family"); hints.ai_socktype = SOCK_DGRAM; + if (EQ (hint, Qnumeric)) + hints.ai_flags = AI_NUMERICHOST; + else if (!NILP (hint)) + error ("Unsupported hints value"); + msg = network_lookup_address_info_1 (name, NULL, &hints, &res); if (!EQ (msg, Qt)) message ("%s", SSDATA(msg)); @@ -8515,6 +8525,7 @@ syms_of_process (void) #ifdef AF_INET6 DEFSYM (Qipv6, "ipv6"); #endif + DEFSYM (Qnumeric, "numeric"); DEFSYM (Qdatagram, "datagram"); DEFSYM (Qseqpacket, "seqpacket"); diff --git a/test/src/process-tests.el b/test/src/process-tests.el index f1ed7e18d5..aab95b2d73 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -378,6 +378,58 @@ See Bug#30460." (when (ipv6-is-available) (should (network-lookup-address-info "localhost" 'ipv6))))) +(ert-deftest lookup-hints-specification () + "`network-lookup-address-info' should only accept valid hints arg." + (should-error (network-lookup-address-info "1.1.1.1" nil t)) + (should-error (network-lookup-address-info "1.1.1.1" 'ipv4 t)) + (should (network-lookup-address-info "1.1.1.1" nil 'numeric)) + (should (network-lookup-address-info "1.1.1.1" 'ipv4 'numeric)) + (when (ipv6-is-available) + (should-error (network-lookup-address-info "::1" nil t)) + (should-error (network-lookup-address-info "::1" 'ipv6 't)) + (should (network-lookup-address-info "::1" nil 'numeric)) + (should (network-lookup-address-info "::1" 'ipv6 'numeric)))) + +(ert-deftest lookup-hints-values () + "`network-lookup-address-info' should succeed/fail in looking up various numeric IP addresses." + (let ((ipv4-invalid-addrs + '("localhost" "343.1.2.3" "1.2.3.4.5")) + ;; These are valid for IPv4 but invalid for IPv6 + (ipv4-addrs + '("127.0.0.1" "127.0.1" "127.1" "127" "1" "0" + "0xe3010203" "0xe3.1.2.3" "227.0x1.2.3" + "034300201003" "0343.1.2.3" "227.001.2.3")) + (ipv6-only-invalid-addrs + '("fe80:1" "e301:203:1" "e301::203::1" + "1:2:3:4:5:6:7:8:9" "0xe301:203::1" + "343:10001:2::3" + ;; "00343:1:2::3" is invalid on GNU/Linux and FreeBSD, but + ;; valid on macOS. macOS is wrong here, but such is life. + )) + ;; These are valid for IPv6 but invalid for IPv4 + (ipv6-addrs + '("fe80::1" "e301::203:1" "e301:203::1" + "e301:0203::1" "::1" "::0" + "0343:1:2::3" "343:001:2::3"))) + (dolist (a ipv4-invalid-addrs) + (should-not (network-lookup-address-info a nil 'numeric)) + (should-not (network-lookup-address-info a 'ipv4 'numeric))) + (dolist (a ipv6-addrs) + (should-not (network-lookup-address-info a 'ipv4 'numeric))) + (dolist (a ipv4-addrs) + (should (network-lookup-address-info a nil 'numeric)) + (should (network-lookup-address-info a 'ipv4 'numeric))) + (when (ipv6-is-available) + (dolist (a ipv4-addrs) + (should-not (network-lookup-address-info a 'ipv6 'numeric))) + (dolist (a ipv6-only-invalid-addrs) + (should-not (network-lookup-address-info a 'ipv6 'numeric))) + (dolist (a ipv6-addrs) + (should (network-lookup-address-info a nil 'numeric)) + (should (network-lookup-address-info a 'ipv6 'numeric)) + (should (network-lookup-address-info (upcase a) nil 'numeric)) + (should (network-lookup-address-info (upcase a) 'ipv6 'numeric)))))) + (ert-deftest lookup-unicode-domains () "Unicode domains should fail." (skip-unless internet-is-working) commit dfa16cadc18930fad76fa6113750eaa27d367e72 Author: Michael Albinus Date: Tue Jul 26 14:10:50 2022 +0200 Fix regression in last Tramp change * lisp/net/tramp-sh.el (tramp-readlink-file-truename): Remove. (tramp-sh-handle-file-truename): Revert implementation. (Bug#56774) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 6d32622742..b991de954c 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -620,21 +620,6 @@ on the remote file system. Format specifiers are replaced by `tramp-expand-script', percent characters need to be doubled.") -(defconst tramp-readlink-file-truename - (format - (concat - "(echo -n %s &&" - " %%r --no-newline --canonicalize-missing \"$1\" &&" - " echo %s) |" - " sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'") - tramp-stat-marker - tramp-stat-marker - tramp-stat-quoted-marker) - "Shell function to produce output suitable for use with `file-truename' -on the remote file system. -Format specifiers are replaced by `tramp-expand-script', percent -characters need to be doubled.") - (defconst tramp-perl-file-name-all-completions "%p -e ' opendir(d, $ARGV[0]) || die(\"$ARGV[0]: $!\\nfail\\n\"); @@ -1193,14 +1178,15 @@ component is used as the target of the symlink." (tramp-message v 4 "Finding true name for `%s'" filename) (let ((result (cond - ;; Use GNU readlink --canonicalize-missing where - ;; available. + ;; Use GNU readlink --canonicalize-missing where available. ((tramp-get-remote-readlink v) - (tramp-maybe-send-script - v tramp-readlink-file-truename "tramp_readlink_file_truename") - (tramp-send-command-and-read - v (format "tramp_readlink_file_truename %s" - (tramp-shell-quote-argument localname)))) + (tramp-send-command-and-check + v (format "%s --canonicalize-missing %s" + (tramp-get-remote-readlink v) + (tramp-shell-quote-argument localname))) + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (buffer-substring (point-min) (point-at-eol)))) ;; Use Perl implementation. ((and (tramp-get-remote-perl v) commit a03d7630f133d08b457a6d08b9ce2050566800ff Author: Po Lu Date: Tue Jul 26 16:12:06 2022 +0800 Fix flicker when moving tooltips between frames during mouse drag-and-drop * src/haikufns.c (Fx_show_tip): * src/nsfns.m (Fx_show_tip): Allow sharing existing tooltip frames between any two frames. * src/xfns.c (Fx_show_tip): Allow that but only between frames on the same X display. diff --git a/src/haikufns.c b/src/haikufns.c index 67f79a3166..f3667ac2f9 100644 --- a/src/haikufns.c +++ b/src/haikufns.c @@ -2405,7 +2405,6 @@ DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, 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 (tip_last_string, string)) && !NILP (Fequal (tip_last_parms, parms))) { diff --git a/src/nsfns.m b/src/nsfns.m index b0b779bd41..433df05961 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -3292,7 +3292,6 @@ internalBorderWidth or internalBorder (which is what xterm calls 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 (tip_last_string, string)) && !NILP (Fequal (tip_last_parms, parms))) { diff --git a/src/xfns.c b/src/xfns.c index ce867c1619..076cd97875 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -8681,7 +8681,8 @@ Text larger than the specified size is clipped. */) if (!NILP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame))) { if (FRAME_VISIBLE_P (XFRAME (tip_frame)) - && BASE_EQ (frame, tip_last_frame) + && (FRAME_X_DISPLAY (XFRAME (frame)) + == FRAME_X_DISPLAY (XFRAME (tip_last_frame))) && !NILP (Fequal_including_properties (tip_last_string, string)) && !NILP (Fequal (tip_last_parms, parms))) {