commit 523d246d6635bc682448cb24ba79847f7f628d6b (HEAD, refs/remotes/origin/master) Merge: f3891da4972 87e4e1beab0 Author: Eli Zaretskii Date: Fri May 31 09:36:42 2024 +0300 Merge branch 'master' of git.savannah.gnu.org:/srv/git/emacs commit f3891da49722a5e8a9f68435c8af13d24e03a6be Author: Eli Zaretskii Date: Fri May 31 09:36:03 2024 +0300 ; * src/w32image.c (thumb_type_data): Revert parts of recent change. diff --git a/src/w32image.c b/src/w32image.c index de95af7b370..6daf42c1916 100644 --- a/src/w32image.c +++ b/src/w32image.c @@ -522,8 +522,7 @@ w32_load_image (struct frame *f, struct image *img, return 1; } -struct cached_encoder -{ +struct cached_encoder { int num; char *type; CLSID clsid; @@ -531,8 +530,7 @@ struct cached_encoder static struct cached_encoder last_encoder; -struct thumb_type_data -{ +struct thumb_type_data { const char *ext; const wchar_t *mime; }; commit 87e4e1beab05c297c6a4b2b159dd07246381884f Author: Juri Linkov Date: Fri May 31 09:34:28 2024 +0300 Limit matches of treesit-thing-settings in js-ts-mode (bug#71244) * lisp/progmodes/js.el (js-ts-mode): Use 'js--regexp-opt-symbol' for 'js--treesit-sexp-nodes', 'js--treesit-sentence-nodes' and 'text' that wraps the regexp in \_< and \_> delimiters to avoid false positives such as "expression" used for "expression_statement". (js--treesit-sexp-nodes): Add more useful nodes "parenthesized_expression", "formal_parameters", "statement_block", "object", "object_pattern", "named_imports", "class_body". diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index 6cb84592896..f5629ff8fbe 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -3829,6 +3829,8 @@ See `treesit-thing-settings' for more information.") (defvar js--treesit-sexp-nodes '("expression" + "parenthesized_expression" + "formal_parameters" "pattern" "array" "function" @@ -3846,7 +3848,12 @@ See `treesit-thing-settings' for more information.") "undefined" "arguments" "pair" - "jsx") + "jsx" + "statement_block" + "object" + "object_pattern" + "named_imports" + "class_body") "Nodes that designate sexps in JavaScript. See `treesit-thing-settings' for more information.") @@ -3889,10 +3896,10 @@ See `treesit-thing-settings' for more information.") (setq-local treesit-thing-settings `((javascript - (sexp ,(regexp-opt js--treesit-sexp-nodes)) - (sentence ,(regexp-opt js--treesit-sentence-nodes)) - (text ,(regexp-opt '("comment" - "template_string")))))) + (sexp ,(js--regexp-opt-symbol js--treesit-sexp-nodes)) + (sentence ,(js--regexp-opt-symbol js--treesit-sentence-nodes)) + (text ,(js--regexp-opt-symbol '("comment" + "template_string")))))) ;; Fontification. (setq-local treesit-font-lock-settings js--treesit-font-lock-settings) commit b7824916300e63e7352d2e268c72894b68937553 Author: Juri Linkov Date: Fri May 31 09:25:52 2024 +0300 * lisp/man.el (Man-getpage-in-background): Don't set buffer before display. Call 'Man-notify-when-ready' before switching the current buffer. This will avoid possible messing with the current buffer by 'Man-notify-when-ready' where display-buffer functions might change the current buffer, thus breaking the subsequent setting of buffer-local variables like Man-arguments in the wrong buffer (bug#71271). diff --git a/lisp/man.el b/lisp/man.el index d96396483d3..816c75d749c 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -1202,8 +1202,8 @@ Return the buffer in which the manpage will appear." (Man-notify-when-ready buffer) (message "Invoking %s %s in the background" manual-program man-args) (setq buffer (generate-new-buffer bufname)) + (Man-notify-when-ready buffer) (with-current-buffer buffer - (Man-notify-when-ready buffer) (setq buffer-undo-list t) (setq Man-original-frame (selected-frame)) (setq Man-arguments man-args) commit 4077bb9867c4396769fa5837b40c0461de6b92d6 Author: Po Lu Date: Fri May 31 09:54:49 2024 +0800 ; Fix coding style in w32image.c * src/w32image.c (get_encoder_clsid): Insert space between identifier and param type list. (struct thumb_data_type, struct cached_encoder): Break before opening bracket at top-level. diff --git a/src/w32image.c b/src/w32image.c index c81c3f0d3d1..de95af7b370 100644 --- a/src/w32image.c +++ b/src/w32image.c @@ -522,7 +522,8 @@ w32_load_image (struct frame *f, struct image *img, return 1; } -struct cached_encoder { +struct cached_encoder +{ int num; char *type; CLSID clsid; @@ -530,7 +531,8 @@ struct cached_encoder { static struct cached_encoder last_encoder; -struct thumb_type_data { +struct thumb_type_data +{ const char *ext; const wchar_t *mime; }; @@ -550,7 +552,7 @@ static struct thumb_type_data thumb_types [] = static int -get_encoder_clsid(const char *type, CLSID *clsid) +get_encoder_clsid (const char *type, CLSID *clsid) { /* A simple cache based on the assumptions that many thumbnails will be generated using the same TYPE. */ commit 436b344be36152acbac693009c560b6bfb9697a2 Author: Stefan Monnier Date: Thu May 30 19:00:23 2024 -0400 track-changes.el: Keep a bit more info when logging an error * lisp/emacs-lisp/track-changes.el (track-changes--recover-from-error): Add arg `info`. (track-changes-fetch, track-changes--after): Use it to preserve a bit more information about errors. diff --git a/lisp/emacs-lisp/track-changes.el b/lisp/emacs-lisp/track-changes.el index 2824a70586d..958def17a2f 100644 --- a/lisp/emacs-lisp/track-changes.el +++ b/lisp/emacs-lisp/track-changes.el @@ -272,7 +272,8 @@ returns nil, otherwise it returns the value returned by FUNC and re-enable the TRACKER corresponding to ID." (cl-assert (memq id track-changes--trackers)) (unless (equal track-changes--buffer-size (buffer-size)) - (track-changes--recover-from-error)) + (track-changes--recover-from-error + `(buffer-size ,track-changes--buffer-size ,(buffer-size)))) (let ((beg nil) (end nil) (before t) @@ -443,7 +444,7 @@ returned to a consistent state." "List of errors encountered. Each element is a triplet (BUFFER-NAME BACKTRACE RECENT-KEYS).") -(defun track-changes--recover-from-error () +(defun track-changes--recover-from-error (&optional info) ;; We somehow got out of sync. This is usually the result of a bug ;; elsewhere that causes the before-c-f and after-c-f to be improperly ;; paired, or to be skipped altogether. @@ -452,7 +453,7 @@ Each element is a triplet (BUFFER-NAME BACKTRACE RECENT-KEYS).") (message "Recovering from confusing calls to `before/after-change-functions'!") (warn "Missing/incorrect calls to `before/after-change-functions'!! Details logged to `track-changes--error-log'") - (push (list (buffer-name) + (push (list (buffer-name) info (let* ((bf (backtrace-frames #'track-changes--recover-from-error)) (tail (nthcdr 50 bf))) @@ -573,7 +574,7 @@ Details logged to `track-changes--error-log'") track-changes--before-end (point-max))))) ;; BEG..END is not covered by previous `before-change-functions'!! - (track-changes--recover-from-error) + (track-changes--recover-from-error `(unexpected-after ,beg ,end ,len)) ;; Note the new changes. (when (< beg (track-changes--state-beg track-changes--state)) (setf (track-changes--state-beg track-changes--state) beg)) commit 2e16bcd8ede77e41e0caaf71e1d22edadadc79dd Author: Stefan Monnier Date: Thu May 30 18:57:56 2024 -0400 ad-activate-advised-definition: Use proper function objects * lisp/emacs-lisp/advice.el (ad-activate-advised-definition): Use interpreted functions rather than lambda lists. diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 752660156b9..73d11fc8aa8 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2845,7 +2845,11 @@ The current definition and its cache-id will be put into the cache." (old-ispec (interactive-form advicefunname))) (fset advicefunname (or verified-cached-definition - (ad-make-advised-definition function))) + (eval + (ad-make-advised-definition function) + ;; We don't keep track of the `lexical-binding' of the + ;; various chunks: assume it's the old dynbound dialect. + nil))) (put advicefunname 'function-documentation `(ad--make-advised-docstring ',advicefunname)) (unless (equal (interactive-form advicefunname) old-ispec) commit 0d7d835902dfaeaae03850fb37e369833bb5664d Author: Stefan Monnier Date: Thu May 30 18:28:02 2024 -0400 server.el: Avoid nested runs of process filters (bug#71223) In case we have a "storm" of emacsclient requests coming at the same time, our process filters ended up running nested within each other, eating up the stack and causing errors. Try and be more careful with our use of `sit-for` in the process filter, and make sure our process filters are run one at a time. * lisp/server.el (server--message-sit-for): New function. (server--process-filter-1): New function, extracted from `server-process-filter`. Use `server--message-sit-for` to display the messages and use `run-with-timer` to delay the `delete-process`. (server--process-filter-pending, server--process-filter-active): New vars. (server--process-filter-all-pending): New function. (server-process-filter): Use them. diff --git a/lisp/server.el b/lisp/server.el index b65053267a6..27fbe95b64b 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -438,7 +438,8 @@ If CLIENT is non-nil, add a description of it to the logged message." (ignore-errors (delete-file (process-get proc :server-file)))) (server-log (format "Status changed to %s: %s" - (process-status proc) msg) proc) + (process-status proc) msg) + proc) (server-delete-client proc)) (defun server--on-display-p (frame display) @@ -1046,7 +1047,13 @@ This handles splitting the command if it would be bigger than (process-put proc 'continuation nil) (if continuation (ignore-errors (funcall continuation))))) -(cl-defun server-process-filter (proc string) +(defvar server--process-filter-pending nil + "List of process filter calls still to be processed. +Kept in the order in which the calls occurred (and hence need to be processed).") +(defvar server--process-filter-active nil + "Non-nil if we're currently running our process filter.") + +(defun server-process-filter (proc string) "Process a request from the server to edit some files. PROC is the server process. STRING consists of a sequence of commands prefixed by a dash. Some commands have arguments; @@ -1145,6 +1152,44 @@ The following commands are accepted by the client: `-suspend' Suspend this terminal, i.e., stop the client process. Sent when the user presses \\[suspend-frame]." + ;; Push this to the end of the list, so the list is in the order in which + ;; we need to process it. + ;; This implies an O(N²) worst-case, which is not good: + ;; we should arguably use a "true" O(N) queue, but N is bounded by + ;; the number of concurrent emacsclient requests, so we should hopefully + ;; never see really large values of N. + (setq server--process-filter-pending + (nconc server--process-filter-pending (list (cons proc string)))) + ;; Since our process filter sometimes needs to wait with `sit-for', + ;; we need to be careful to try and avoid nested process filters + ;; eating up the stack, so we use `server--process-filter-active&pending' + ;; to make sure our process filters are run in sequence rather than in + ;; a nested way. (bug#71223) + (unless server--process-filter-active + (server--process-filter-all-pending))) + +(defun server--process-filter-all-pending () + (let ((server--process-filter-active t)) + (unwind-protect + (while server--process-filter-pending + (let* ((oldest (pop server--process-filter-pending))) + (server--process-filter-1 (car oldest) (cdr oldest)))) + ;; In case we're exiting early (e.g. for `server-goto-toplevel'), + ;; make sure we continue running the other pending filters. + (when server--process-filter-pending + (run-with-timer 0 nil #'server--process-filter-all-pending))))) + +(defun server--message-sit-for (time &rest args) + ;; FIXME: Ideally we should not need `sit-for' here and instead use + ;; some `message-sit-for' call which returns immediately while making sure + ;; the message is visible for TIME seconds. + (apply #'message args) + ;; If there's already another process-filter pending, skip `sit-for', + ;; just as it does when there's pending user input. + (unless (consp server--process-filter-pending) + (sit-for time))) + +(cl-defun server--process-filter-1 (proc string) (server-log (concat "Received " string) proc) ;; First things first: let's check the authentication (unless (process-get proc :authenticated) @@ -1158,8 +1203,7 @@ The following commands are accepted by the client: ;; Display the error as a message and give the user time to see ;; it, in case the error written by emacsclient to stderr is not ;; visible for some reason. - (message "Authentication failed") - (sit-for 2) + (server--message-sit-for 2 "Authentication failed") (server-send-string proc (concat "-error " (server-quote-arg "Authentication failed"))) (unless (eq system-type 'windows-nt) @@ -1169,10 +1213,10 @@ The following commands are accepted by the client: (delete-terminal terminal)))) ;; Before calling `delete-process', give emacsclient time to ;; receive the error string and shut down on its own. - (sit-for 1) - (delete-process proc) + ;; FIXME: Why do we wait 1s here but 5s in the other one? + (run-with-timer 1 nil #'delete-process proc) ;; We return immediately. - (cl-return-from server-process-filter))) + (cl-return-from server--process-filter))) (let ((prev (process-get proc 'previous-string))) (when prev (setq string (concat prev string)) @@ -1507,8 +1551,7 @@ invocations of \"emacs\".") ;; Display the error as a message and give the user time to see ;; it, in case the error written by emacsclient to stderr is not ;; visible for some reason. - (message (error-message-string err)) - (sit-for 2) + (server--message-sit-for 2 (error-message-string err)) (server-send-string proc (concat "-error " (server-quote-arg (error-message-string err)))) @@ -1520,8 +1563,8 @@ invocations of \"emacs\".") (delete-terminal terminal)))) ;; Before calling `delete-process', give emacsclient time to ;; receive the error string and shut down on its own. - (sit-for 5) - (delete-process proc))) + ;; FIXME: Why do we wait 5s here but 1s in the other one? + (run-with-timer 5 nil #'delete-process proc))) (defun server-goto-line-column (line-col) "Move point to the position indicated in LINE-COL. commit baecf9bb283e52a829e31ae6f36c4687171a51c5 Author: Michael Albinus Date: Thu May 30 18:55:21 2024 +0200 Fix job control in remote shell * lisp/net/tramp-sh.el (tramp-methos) : Adapt `tramp-direct-async' argument. (Bug#71259) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 615f9219448..87c1bc0b460 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -189,7 +189,7 @@ The string is used in `tramp-methods'.") (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") ("-e" "none") ("%h"))) (tramp-async-args (("-q"))) - (tramp-direct-async t) + (tramp-direct-async ("-t" "-t")) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) @@ -253,7 +253,7 @@ The string is used in `tramp-methods'.") (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") ("-e" "none") ("%h"))) (tramp-async-args (("-q"))) - (tramp-direct-async t) + (tramp-direct-async ("-t" "-t")) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")))) commit 0b4d2bb9b366ea78e8bc6bf1915d91d4131e98f7 Author: Sean Whitton Date: Thu May 30 12:45:57 2024 +0100 universal-argument--preserve: Preserve last-prefix-arg * lisp/simple.el (universal-argument--preserve): Set current-prefix-arg to last-prefix-arg in order to preserve last-prefix-arg, too (bug#71277). diff --git a/lisp/simple.el b/lisp/simple.el index 44197c3189a..76fb81c9df5 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -5414,7 +5414,8 @@ Runs `prefix-command-preserve-state-hook'." (add-hook 'prefix-command-preserve-state-hook #'universal-argument--preserve) (defun universal-argument--preserve () - (setq prefix-arg current-prefix-arg)) + (setq prefix-arg current-prefix-arg) + (setq current-prefix-arg last-prefix-arg)) (defvar universal-argument-map (let ((map (make-sparse-keymap)) commit ae7d0e86b37eabc434c48f85f56df0a221e0e7c7 Author: Eli Zaretskii Date: Thu May 30 17:45:33 2024 +0300 Support built-in thumbnail creation on MS-Windows * src/w32image.c (get_encoder_clsid, Fw32image_create_thumbnail) (globals_of_w32image, syms_of_w32image): New functions. * src/emacs.c (main): Call 'syms_of_w32image' and 'globals_of_w32image'. * src/w32term.h (syms_of_w32image, globals_of_w32image): Add prototypes. * lisp/image/image-dired.el (image-dired-thumbnail-display-external): Add a fallback for MS-Windows. * lisp/image/image-dired-external.el (image-dired--probe-thumbnail-cmd): New function. (image-dired--check-executable-exists): Call it to verify that "convert" is indeed an Imagemagick program. New argument FUNC specifies a function that can be used as an alternative to running EXECUTABLE. (image-dired-create-thumb-1): Don't call 'image-dired--check-executable-exists' here, ... (image-dired-thumb-queue-run): ...call it here, with 'w32image-create-thumbnail' as the alternative function. If on MS-Windows and no "convert" command, call 'image-dired-create-thumb-2' instead. (image-dired-create-thumb-2): New function. * etc/NEWS: Announce the thumbnail support. diff --git a/etc/NEWS b/etc/NEWS index c9334e18e2d..3c672ffed8f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2818,6 +2818,15 @@ title bars' and scroll bars' appearance. If the new user option will disregard the system's Dark mode and will always use the default Light mode. +--- +*** You can now use Image-Dired even if 'convert' command is not installed. +If you don't have GraphicsMagick or ImageMagick installed, and thus the +'gm convert'/'convert' command is not available, Emacs on MS-Windows +will now use its own function 'w32image-create-thumbnail' to create +thumbnail images and show them in the thumbnail buffer. Unlike with +using 'convert', this fallback method is synchronous, so Emacs will wait +until all the thumbnails are created and displayed, before showing them. + ---------------------------------------------------------------------- This file is part of GNU Emacs. diff --git a/lisp/image/image-dired-external.el b/lisp/image/image-dired-external.el index 8a73f518e6b..cdeeba4c367 100644 --- a/lisp/image/image-dired-external.el +++ b/lisp/image/image-dired-external.el @@ -187,9 +187,40 @@ and %v which is replaced by the tag value." ;;; Util functions -(defun image-dired--check-executable-exists (executable) - (unless (executable-find (symbol-value executable)) - (error "Executable %S not found" executable))) +(defun image-dired--probe-thumbnail-cmd (cmd) + "Check whether CMD is usable for thumbnail creation." + (cond + ;; MS-Windows has an incompatible 'convert' command. Make sure this + ;; is the one we expect, from ImageMagick. FIXME: Should we do this + ;; also on systems other than MS-Windows? + ((and (memq system-type '(windows-nt cygwin ms-dos)) + (member (downcase (file-name-nondirectory cmd)) + '("convert" "convert.exe"))) + (with-temp-buffer + (let (process-file-side-effects) + (and (equal (condition-case nil + ;; Implementation note: 'process-file' below + ;; returns non-zero status when convert.exe is + ;; the Windows command, because we quote the + ;; "/?" argument, and Windows is not smart + ;; enough to process quoted options correctly. + (apply #'process-file cmd nil t nil '("/?")) + (error nil)) + 0) + (progn + (goto-char (point-min)) + (looking-at-p "Version: ImageMagick")))))) + (t t))) + +(defun image-dired--check-executable-exists (executable &optional func) + "If program EXECUTABLE does not exist or cannot be used, signal an error. +But if optional argument FUNC (which must be a symbol) names a known +function, consider that function to be an alternative to running EXECUTABLE." + (let ((cmd (symbol-value executable))) + (or (and (executable-find cmd) + (image-dired--probe-thumbnail-cmd cmd)) + (and func (fboundp func) 'function) + (error "Executable %S not found or not pertinent" executable)))) ;;; Creating thumbnails @@ -286,8 +317,6 @@ and remove the cached thumbnail files between each trial run.") (defun image-dired-create-thumb-1 (original-file thumbnail-file) "For ORIGINAL-FILE, create thumbnail image named THUMBNAIL-FILE." - (image-dired--check-executable-exists - 'image-dired-cmd-create-thumbnail-program) (let* ((size (number-to-string (image-dired--thumb-size))) (modif-time (format-time-string "%s" (file-attribute-modification-time @@ -354,15 +383,51 @@ and remove the cached thumbnail files between each trial run.") (image-dired-optipng-thumb spec))))))) process)) +(defun image-dired-create-thumb-2 (original-file thumbnail-file) + "For ORIGINAL-FILE, create thumbnail image named THUMBNAIL-FILE. +This is like `image-dired-create-thumb-1', but used when the thumbnail +file is created by Emacs itself." + (let ((size (image-dired--thumb-size)) + (thumbnail-dir (file-name-directory thumbnail-file))) + (when (not (file-exists-p thumbnail-dir)) + (with-file-modes #o700 + (make-directory thumbnail-dir t)) + (message "Thumbnail directory created: %s" thumbnail-dir)) + (image-dired-debug "Creating thumbnail for %s" original-file) + (if (null (w32image-create-thumbnail original-file thumbnail-file + (file-name-extension thumbnail-file) + size size)) + (message "Failed to create a thumbnail for %s" + (abbreviate-file-name original-file)) + (clear-image-cache thumbnail-file) + ;; FIXME: Add PNG optimization like image-dired-create-thumb-1 does. + ) + ;; Trigger next in queue once a thumbnail has been created. + (image-dired-thumb-queue-run))) + (defun image-dired-thumb-queue-run () "Run a queued job if one exists and not too many jobs are running. Queued items live in `image-dired-queue'. Number of simultaneous jobs is limited by `image-dired-queue-active-limit'." - (while (and image-dired-queue - (< image-dired-queue-active-jobs - image-dired-queue-active-limit)) - (cl-incf image-dired-queue-active-jobs) - (apply #'image-dired-create-thumb-1 (pop image-dired-queue)))) + (if (not (eq (image-dired--check-executable-exists + 'image-dired-cmd-create-thumbnail-program + 'w32image-create-thumbnail) + 'function)) + ;; We have a usable gm/convert command; queue thethumbnail jobs. + (while (and image-dired-queue + (< image-dired-queue-active-jobs + image-dired-queue-active-limit)) + (cl-incf image-dired-queue-active-jobs) + (apply #'image-dired-create-thumb-1 (pop image-dired-queue))) + ;; We are on MS-Windows and need to generate thumbnails by our + ;; lonesome selves. + (if image-dired-queue + (let* ((job (pop image-dired-queue)) + (orig-file (car job)) + (thumb-file (cadr job))) + (run-with-timer 0.05 nil + #'image-dired-create-thumb-2 + orig-file thumb-file))))) (defun image-dired-create-thumb (original-file thumbnail-file) "Add a job for generating ORIGINAL-FILE thumbnail to `image-dired-queue'. diff --git a/lisp/image/image-dired.el b/lisp/image/image-dired.el index ca808bcb5ab..1e970d60a96 100644 --- a/lisp/image/image-dired.el +++ b/lisp/image/image-dired.el @@ -1248,9 +1248,15 @@ The viewer command is specified by `image-dired-external-viewer'." (message "No thumbnail at point") (if (not file) (message "No original file name found") - (apply #'start-process "image-dired-thumb-external" nil - (append (string-split image-dired-external-viewer " ") - (list file))))))) + (cond + ((stringp image-dired-external-viewer) + (apply #'start-process "image-dired-thumb-external" nil + (append (string-split image-dired-external-viewer " ") + (list file)))) + ((eq system-type 'windows-nt) + (w32-shell-execute "open" file)) + (t + (error "`image-dired-external-viewer' does not name an image viewer program"))))))) (defun image-dired-display-image (file &optional _ignored) "Display image FILE in the image buffer window. diff --git a/src/emacs.c b/src/emacs.c index f122955884e..036bc1864e6 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2358,6 +2358,9 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #ifdef HAVE_WINDOW_SYSTEM syms_of_fringe (); syms_of_image (); +#ifdef HAVE_NTGUI + syms_of_w32image (); +#endif /* HAVE_NTGUI */ #endif /* HAVE_WINDOW_SYSTEM */ #ifdef HAVE_X_WINDOWS syms_of_xterm (); @@ -2495,6 +2498,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem globals_of_w32font (); globals_of_w32fns (); globals_of_w32menu (); + globals_of_w32image (); #endif /* HAVE_NTGUI */ #if defined WINDOWSNT || defined HAVE_NTGUI diff --git a/src/w32image.c b/src/w32image.c index 9010338a267..c81c3f0d3d1 100644 --- a/src/w32image.c +++ b/src/w32image.c @@ -65,6 +65,16 @@ typedef GpStatus (WINGDIPAPI *GdipCreateHBITMAPFromBitmap_Proc) typedef GpStatus (WINGDIPAPI *GdipDisposeImage_Proc) (GpImage *); typedef GpStatus (WINGDIPAPI *GdipGetImageHeight_Proc) (GpImage *, UINT *); typedef GpStatus (WINGDIPAPI *GdipGetImageWidth_Proc) (GpImage *, UINT *); +typedef GpStatus (WINGDIPAPI *GdipGetImageEncodersSize_Proc) (UINT *, UINT *); +typedef GpStatus (WINGDIPAPI *GdipGetImageEncoders_Proc) + (UINT, UINT, ImageCodecInfo *); +typedef GpStatus (WINGDIPAPI *GdipLoadImageFromFile_Proc) + (GDIPCONST WCHAR *,GpImage **); +typedef GpStatus (WINGDIPAPI *GdipGetImageThumbnail_Proc) + (GpImage *, UINT, UINT, GpImage**, GetThumbnailImageAbort, VOID *); +typedef GpStatus (WINGDIPAPI *GdipSaveImageToFile_Proc) + (GpImage *, GDIPCONST WCHAR *, GDIPCONST CLSID *, + GDIPCONST EncoderParameters *); GdiplusStartup_Proc fn_GdiplusStartup; GdiplusShutdown_Proc fn_GdiplusShutdown; @@ -81,6 +91,11 @@ GdipCreateHBITMAPFromBitmap_Proc fn_GdipCreateHBITMAPFromBitmap; GdipDisposeImage_Proc fn_GdipDisposeImage; GdipGetImageHeight_Proc fn_GdipGetImageHeight; GdipGetImageWidth_Proc fn_GdipGetImageWidth; +GdipGetImageEncodersSize_Proc fn_GdipGetImageEncodersSize; +GdipGetImageEncoders_Proc fn_GdipGetImageEncoders; +GdipLoadImageFromFile_Proc fn_GdipLoadImageFromFile; +GdipGetImageThumbnail_Proc fn_GdipGetImageThumbnail; +GdipSaveImageToFile_Proc fn_GdipSaveImageToFile; static bool gdiplus_init (void) @@ -161,6 +176,26 @@ gdiplus_init (void) if (!fn_SHCreateMemStream) return false; } + fn_GdipGetImageEncodersSize = (GdipGetImageEncodersSize_Proc) + get_proc_addr (gdiplus_lib, "GdipGetImageEncodersSize"); + if (!fn_GdipGetImageEncodersSize) + return false; + fn_GdipGetImageEncoders = (GdipGetImageEncoders_Proc) + get_proc_addr (gdiplus_lib, "GdipGetImageEncoders"); + if (!fn_GdipGetImageEncoders) + return false; + fn_GdipLoadImageFromFile = (GdipLoadImageFromFile_Proc) + get_proc_addr (gdiplus_lib, "GdipLoadImageFromFile"); + if (!fn_GdipLoadImageFromFile) + return false; + fn_GdipGetImageThumbnail = (GdipGetImageThumbnail_Proc) + get_proc_addr (gdiplus_lib, "GdipGetImageThumbnail"); + if (!fn_GdipGetImageThumbnail) + return false; + fn_GdipSaveImageToFile = (GdipSaveImageToFile_Proc) + get_proc_addr (gdiplus_lib, "GdipSaveImageToFile"); + if (!fn_GdipSaveImageToFile) + return false; return true; } @@ -180,6 +215,11 @@ gdiplus_init (void) # undef GdipDisposeImage # undef GdipGetImageHeight # undef GdipGetImageWidth +# undef GdipGetImageEncodersSize +# undef GdipGetImageEncoders +# undef GdipLoadImageFromFile +# undef GdipGetImageThumbnail +# undef GdipSaveImageToFile # define GdiplusStartup fn_GdiplusStartup # define GdiplusShutdown fn_GdiplusShutdown @@ -196,6 +236,11 @@ gdiplus_init (void) # define GdipDisposeImage fn_GdipDisposeImage # define GdipGetImageHeight fn_GdipGetImageHeight # define GdipGetImageWidth fn_GdipGetImageWidth +# define GdipGetImageEncodersSize fn_GdipGetImageEncodersSize +# define GdipGetImageEncoders fn_GdipGetImageEncoders +# define GdipLoadImageFromFile fn_GdipLoadImageFromFile +# define GdipGetImageThumbnail fn_GdipGetImageThumbnail +# define GdipSaveImageToFile fn_GdipSaveImageToFile #endif /* WINDOWSNT */ @@ -476,3 +521,159 @@ w32_load_image (struct frame *f, struct image *img, } return 1; } + +struct cached_encoder { + int num; + char *type; + CLSID clsid; +}; + +static struct cached_encoder last_encoder; + +struct thumb_type_data { + const char *ext; + const wchar_t *mime; +}; + +static struct thumb_type_data thumb_types [] = + { + /* jpg and png are at the front because 'image-dired-thumb-name' + uses them in most cases. */ + {"jpg", L"image/jpeg"}, + {"png", L"image/png"}, + {"bmp", L"image/bmp"}, + {"jpeg", L"image/jpeg"}, + {"gif", L"image/gif"}, + {"tiff", L"image/tiff"}, + {NULL, NULL} + }; + + +static int +get_encoder_clsid(const char *type, CLSID *clsid) +{ + /* A simple cache based on the assumptions that many thumbnails will + be generated using the same TYPE. */ + if (last_encoder.type && stricmp (type, last_encoder.type) == 0) + { + *clsid = last_encoder.clsid; + return last_encoder.num; + } + + const wchar_t *format = NULL; + struct thumb_type_data *tp = thumb_types; + for ( ; tp->ext; tp++) + { + if (stricmp (type, tp->ext) == 0) + { + format = tp->mime; + break; + } + } + if (!format) + return -1; + + unsigned num = 0; + unsigned size = 0; + ImageCodecInfo *image_codec_info = NULL; + + GdipGetImageEncodersSize (&num, &size); + if(size == 0) + return -1; + + image_codec_info = xmalloc (size); + GdipGetImageEncoders (num, size, image_codec_info); + + for (int j = 0; j < num; ++j) + { + if (wcscmp (image_codec_info[j].MimeType, format) == 0 ) + { + if (last_encoder.type) + xfree (last_encoder.type); + last_encoder.type = xstrdup (tp->ext); + last_encoder.clsid = image_codec_info[j].Clsid; + last_encoder.num = j; + *clsid = image_codec_info[j].Clsid; + xfree (image_codec_info); + return j; + } + } + + xfree (image_codec_info); + return -1; +} + +DEFUN ("w32image-create-thumbnail", Fw32image_create_thumbnail, + Sw32image_create_thumbnail, 5, 5, 0, + doc: /* Create a HEIGHT by WIDTH thumnail file THUMB-FILE for image INPUT-FILE. +TYPE is the image type to use for the thumbnail file, a string. It is +usually identical to the file-name extension of THUMB-FILE, but without +the leading period, and both "jpeg" and "jpg" can be used for JPEG. +TYPE is matched case-insensitively against supported types. Currently, +the supported TYPEs are BMP, JPEG, GIF, TIFF, and PNG; any other type +will cause the function to fail. +Return non-nil if thumbnail creation succeeds, nil otherwise. */) + (Lisp_Object input_file, Lisp_Object thumb_file, Lisp_Object type, + Lisp_Object height, Lisp_Object width) +{ + /* Sanity checks. */ + CHECK_STRING (input_file); + CHECK_STRING (thumb_file); + CHECK_STRING (type); + CHECK_FIXNAT (height); + CHECK_FIXNAT (width); + + if (!gdiplus_started) + { + if (!gdiplus_startup ()) + return Qnil; + } + + /* Create an image by reading from INPUT_FILE. */ + wchar_t input_file_w[MAX_PATH]; + input_file = ENCODE_FILE (Fexpand_file_name (input_file, Qnil)); + unixtodos_filename (SSDATA (input_file)); + filename_to_utf16 (SSDATA (input_file), input_file_w); + GpImage *file_image; + GpStatus status = GdipLoadImageFromFile (input_file_w, &file_image); + + if (status == Ok) + { + /* Create a thumbnail for the image. */ + GpImage *thumb_image; + status = GdipGetImageThumbnail (file_image, + XFIXNAT (width), XFIXNAT (height), + &thumb_image, NULL, NULL); + GdipDisposeImage (file_image); + CLSID thumb_clsid; + if (status == Ok + /* Get the GUID of the TYPE's encoder. */ + && get_encoder_clsid (SSDATA (type), &thumb_clsid) >= 0) + { + /* Save the thumbnail image to a file of specified TYPE. */ + wchar_t thumb_file_w[MAX_PATH]; + thumb_file = ENCODE_FILE (Fexpand_file_name (thumb_file, Qnil)); + unixtodos_filename (SSDATA (thumb_file)); + filename_to_utf16 (SSDATA (thumb_file), thumb_file_w); + status = GdipSaveImageToFile (thumb_image, thumb_file_w, + &thumb_clsid, NULL); + GdipDisposeImage (thumb_image); + } + else if (status == Ok) /* no valid encoder */ + status = InvalidParameter; + } + return (status == Ok) ? Qt : Qnil; +} + +void +syms_of_w32image (void) +{ + defsubr (&Sw32image_create_thumbnail); +} + +void +globals_of_w32image (void) +{ + /* This is only needed in an unexec build. */ + memset (&last_encoder, 0, sizeof last_encoder); +} diff --git a/src/w32term.h b/src/w32term.h index 3120c8bd71f..a19be1a9e6a 100644 --- a/src/w32term.h +++ b/src/w32term.h @@ -909,6 +909,9 @@ extern void globals_of_w32menu (void); extern void globals_of_w32fns (void); extern void globals_of_w32notify (void); +extern void syms_of_w32image (void); +extern void globals_of_w32image (void); + extern void w32_init_main_thread (void); #ifdef CYGWIN commit 1ebb9cb93b2fefa84f18a63fb24c1ed4fcf095a7 Author: Po Lu Date: Thu May 30 21:31:18 2024 +0800 Don't set text scale to fractional values in touch-screen-pinch * lisp/touch-screen.el (touch-screen-pinch): Take floor of computed scale. diff --git a/lisp/touch-screen.el b/lisp/touch-screen.el index ca02ca3caf6..436b8d0954c 100644 --- a/lisp/touch-screen.el +++ b/lisp/touch-screen.el @@ -937,8 +937,8 @@ text scale by the ratio therein." (aset touch-screen-aux-tool 7 current-scale))) ;; Set the text scale. - (text-scale-set (+ start-scale - (round (log scale text-scale-mode-step)))) + (text-scale-set (floor (+ (round (log scale text-scale-mode-step)) + start-scale))) ;; Subsequently move the row which was at the centrum to its Y ;; position. (if (and (not (eq current-scale commit 1fdf0f68ccf02cc92e4fb995f82f01a6148b62e7 Author: Alan Mackenzie Date: Thu May 30 12:40:07 2024 +0000 In normal-mode, make c-mode call c-mode when CC Mode is loaded As regards which mode normal-mode calls for the symbols c-mode, etc., the first of the following which applies holds: (i) If the user has made a pertinent entry in major-mode-remap-alist, this is used. (ii) If CC Mode has been loaded, c-mode is called. (iii) If library c-ts-mode has been loaded, c-ts-mode is called. (iv) Otherwise c-mode is called. * lisp/progmodes/cc-mode.el (top level): Add entries to major-mode-remap-defaults to implement the above. diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 5f11622733f..8ce4da56ef7 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -3326,6 +3326,22 @@ Key bindings: (insert (format "Buffer Style: %s\nc-emacs-features: %s\n" style c-features))))))) + +;; Make entries in `major-mode-remap-defaults' to ensure that when CC +;; Mode has been loaded, the symbols `c-mode' etc., will call CC Mode's +;; modes rather than c-ts-mode etc.. +(when (boundp 'major-mode-remap-defaults) + (add-to-list 'major-mode-remap-defaults '(c++-mode . c++-ts-mode)) + (add-to-list 'major-mode-remap-defaults '(c-mode . c-ts-mode)) + (add-to-list 'major-mode-remap-defaults '(c-or-c++-mode . c-or-c++-ts-mode)) + (let (entry) + (dolist (mode '(c-mode c++-mode c-or-c++-mode)) + (if (and (setq entry (assq mode major-mode-remap-defaults)) + (null (cdr entry))) + (setq major-mode-remap-defaults + (delq entry major-mode-remap-defaults))) + (push (cons mode nil) major-mode-remap-defaults)))) + (cc-provide 'cc-mode) commit 39b704e36e308783dcec791d333fca317c6a5202 Author: Jakub Ječmínek Date: Thu May 30 10:54:57 2024 +0200 Show all date options when adding Gnus scores interactively * lisp/gnus/gnus-score.el (gnus-summary-increase-score): Rename 'char-to-type' variable to 'char-to-types' and bind all legal types for date header. * lisp/gnus/gnus-score.el (gnus-summary-score-entry): Provide better default values for each scoring type and cast 'match' to number only if necessary. Co-authored-by: Alex Bochannek diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index c5e4c885ccf..56f259db9a1 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -20093,6 +20093,9 @@ Regexp matching. @item date @table @kbd +@item r +Regexp matching. + @item b Before date. @@ -20101,6 +20104,12 @@ After date. @item n This date. + +@item < +Less than days. + +@item > +Greater than days. @end table @item number diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index 479b7496cf1..31ce1328e37 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -593,18 +593,18 @@ current score file." (?d "date" nil nil date) (?f "followup" nil nil string) (?t "thread" "message-id" nil string))) - (char-to-type + (char-to-types '((?s s "substring" string) (?e e "exact string" string) (?f f "fuzzy string" string) - (?r r "regexp string" string) + (?r r "regexp string" string date) (?z s "substring" body-string) (?p r "regexp string" body-string) (?b before "before date" date) (?a after "after date" date) (?n at "this date" date) - (?< < "less than number" number) - (?> > "greater than number" number) + (?< < "less than number" number date) + (?> > "greater than number" number date) (?= = "equal to number" number))) (current-score-file gnus-current-score-file) (char-to-perm @@ -652,10 +652,9 @@ current score file." (let ((legal-types (delq nil (mapcar (lambda (s) - (if (eq (nth 4 entry) - (nth 3 s)) + (if (member (nth 4 entry) (nthcdr 3 s)) s nil)) - char-to-type)))) + char-to-types)))) (setq header-string (format "%s header `%s' with match type (%s?): " (if increase "Increase" "Lower") @@ -894,12 +893,16 @@ If optional argument `EXTRA' is non-nil, it's a non-standard overview header." header (if (< score 0) "lower" "raise")) (cond ((numberp match) (int-to-string match)) + ;; Provide better defaults if we're scoring on date header ((string= header "date") - (int-to-string - (- - (/ (car (time-convert (current-time) 1)) 86400) - (/ (car (time-convert (gnus-date-get-time match) 1)) - 86400)))) + (if (or (eq type '<) (eq type '>)) + ;; Determine the time difference in days between today + ;; and the article's date + (format-seconds "%d" + (time-subtract + (current-time) + (gnus-date-get-time match))) + (gnus-date-iso8601 match))) (t match))))) ;; If this is an integer comparison, we transform from string to int. @@ -909,16 +912,13 @@ If optional argument `EXTRA' is non-nil, it's a non-standard overview header." (set-text-properties 0 (length match) nil match)) ;; Modify match and type for article age scoring. - (if (string= "date" (nth 0 (assoc header gnus-header-index))) - (let ((age (string-to-number match))) - (if (or (< age 0) - (string= "0" match)) - (user-error "Article age must be a positive number")) - (setq match age - type (cond ((eq type 'after) - '<) - ((eq type 'before) - '>))))) + (when (and (string= header "date") + (or (eq type '<) (eq type '>))) + (let ((age (string-to-number match))) + (if (or (< age 0) + (string= "0" match)) + (user-error "Article age must be a positive number")) + (setq match age))) (unless (eq date 'now) ;; Add the score entry to the score file. @@ -1806,7 +1806,7 @@ score in `gnus-newsgroup-scored' by SCORE." ((eq type 'at) (setq match-func 'string= match (gnus-date-iso8601 (nth 0 kill)))) - ((eq type 'regexp) + ((or (eq type 'regexp) (eq type 'r)) (setq match-func 'string-match match (nth 0 kill))) (t (error "Invalid match type: %s" type))) @@ -1833,6 +1833,8 @@ score in `gnus-newsgroup-scored' by SCORE." (gnus-score-set 'touched '(t) alist) (setcdr entries (cdr rest)) (setq rest entries))) + (when (stringp (nth 0 kill)) + (set-text-properties 0 1 nil (nth 0 kill))) (setq entries rest))))) nil) commit c166abe897bcc2d6e1f59283cf25aef9d47e0c9f Author: Michael Albinus Date: Thu May 30 10:44:30 2024 +0200 Improve Tramp error handling * lisp/net/tramp-container.el (tramp-container-no-container-regexp): New defcustom. (tramp-actions-before-shell, tramp-actions-copy-out-of-band): Declare. Add `tramp-container-no-container-regexp'. (Bug#71200) diff --git a/lisp/net/tramp-container.el b/lisp/net/tramp-container.el index cc1d9f457cc..e456c51045f 100644 --- a/lisp/net/tramp-container.el +++ b/lisp/net/tramp-container.el @@ -117,6 +117,21 @@ ;;; Code: (require 'tramp) +(defvar tramp-actions-before-shell) +(defvar tramp-actions-copy-out-of-band) + +;; This does not match all container-based methods. Both in general, +;; the command returns with an error; `tramp-process-alive-regexp' +;; does the check then. +(defcustom tramp-container-no-container-regexp + (rx bol "Error:" (1+ nonl) "no such container" (0+ nonl) + ;; Distrobox adds an interactive prompt. + (* "\n" (1+ nonl))) + "Regexp matching missing container message. +The regexp should match at end of buffer." + :group 'tramp + :version "30.1" + :type 'regexp) ;;;###tramp-autoload (defcustom tramp-docker-program "docker" @@ -620,6 +635,14 @@ see its function help for a description of the format." `(:application tramp :protocol ,tramp-kubernetes-method) 'tramp-kubernetes-connection-local-default-profile)) +(add-to-list + 'tramp-actions-before-shell + '(tramp-container-no-container-regexp tramp-action-permission-denied)) + +(add-to-list + 'tramp-actions-copy-out-of-band + '(tramp-container-no-container-regexp tramp-action-permission-denied)) + ;;;###tramp-autoload (defun tramp-enable-toolbox-method () "Enable connection to Toolbox containers."