commit d0b2eee278929238239efcdb90760906853b86b9 (HEAD, refs/remotes/origin/master) Author: Stefan Kangas Date: Wed Sep 14 08:45:45 2022 +0200 Improve messages in image-crop.el * lisp/image/image-crop.el (image-crop) (image-crop--crop-image-1): Improve messages and include the name of the current operation. diff --git a/lisp/image/image-crop.el b/lisp/image/image-crop.el index adf2a49348..e5014c81db 100644 --- a/lisp/image/image-crop.el +++ b/lisp/image/image-crop.el @@ -138,8 +138,12 @@ After cropping an image, it can be saved by `M-x image-save' or (save-excursion (forward-line 1) (image-crop--crop-image-1 - svg square (car size) (cdr size))) - (quit nil)))) + svg square (car size) (cdr size) + (if elide "elide" "crop"))) + (quit nil)))) + (message (substitute-command-keys + "Type \\[image-save] to save %s image to file") + (if elide "elided" "cropped")) (delete-region (pos-bol) (pos-eol)) (if area (image-crop--crop-image-update area orig-data size type elide) @@ -180,10 +184,15 @@ After cropping an image, it can be saved by `M-x image-save' or (?f . ,(cadr (split-string type "/")))))) (buffer-string))))) -(defun image-crop--crop-image-1 (svg &optional square image-width image-height) +(defun image-crop--crop-image-1 (svg &optional square image-width image-height op) (track-mouse (cl-loop - with prompt = (if square "Move square" "Set start point") + with prompt = (if square + (format "Move square for %s" op) + (format + (substitute-command-keys + "Select area for %s (click \\`mouse-1' and drag)") + op)) and state = (if square 'move-unclick 'begin) and area = (if square (list :left (- (/ image-width 2) @@ -212,7 +221,7 @@ After cropping an image, it can be saved by `M-x image-save' or (cond ((eq (car event) 'down-mouse-1) (setq state 'stretch - prompt "Stretch to end point") + prompt (format "Stretch to end point for %s" op)) (setf (cl-getf area :left) (car pos) (cl-getf area :top) (cdr pos) (cl-getf area :right) (car pos) @@ -224,7 +233,12 @@ After cropping an image, it can be saved by `M-x image-save' or (cl-getf area :bottom) (cdr pos))) ((memq (car event) '(mouse-1 drag-mouse-1)) (setq state 'corner - prompt "Choose corner to adjust (RET to crop)")))) + prompt (format + (substitute-command-keys + (concat + "Type \\`RET' to %s, or click and drag " + "\\`mouse-1' to adjust corners")) + op))))) (corner (cond ((eq (car event) 'down-mouse-1) @@ -237,12 +251,15 @@ After cropping an image, it can be saved by `M-x image-save' or (:right :bottom)))) (when corner (setq state 'adjust - prompt "Adjust crop"))))) + prompt (format + (substitute-command-keys + "Adjusting %s area (release \\`mouse-1' to confirm)") + op)))))) (adjust (cond ((memq (car event) '(mouse drag-mouse-1)) (setq state 'corner - prompt "Choose corner to adjust")) + prompt (format "Choose corner to adjust area for %s" op))) ((eq (car event) 'mouse-movement) (setf (cl-getf area (car corner)) (car pos) (cl-getf area (cadr corner)) (cdr pos))))) @@ -250,7 +267,7 @@ After cropping an image, it can be saved by `M-x image-save' or (cond ((eq (car event) 'down-mouse-1) (setq state 'move-click - prompt "Move")))) + prompt (format "Move for %s" op))))) (move-click (cond ((eq (car event) 'mouse-movement) @@ -258,7 +275,7 @@ After cropping an image, it can be saved by `M-x image-save' or (cl-getf area :right) (+ (car pos) image-height))) ((memq (car event) '(mouse-1 drag-mouse-1)) (setq state 'move-unclick - prompt "Click to move"))))))) + prompt (format "Click to move for %s" op)))))))) do (svg-line svg (cl-getf area :left) (cl-getf area :top) (cl-getf area :right) (cl-getf area :top) :id "top-line" :stroke-color "white") commit b9ca1a8e4fbd3f8ef0d384d402ec5721ddcad28c Author: Po Lu Date: Wed Sep 14 06:24:49 2022 +0000 Implement wallpaper.el support for Haiku * lisp/image/wallpaper.el (haiku-set-wallpaper, wallpaper-set): Use `haiku-set-wallpaper' on Haiku. * lisp/term/haiku-win.el (haiku-write-node-attribute) (haiku-send-message, haiku-set-wallpaper): New function. * src/haiku_support.cc (be_write_node_message, be_send_message): New functions. * src/haiku_support.h: Update prototypes. * src/haikuselect.c (haiku_message_to_lisp) (haiku_lisp_to_message): Fix CSTR type handling to include NULL byte. (haiku_report_system_error, Fhaiku_write_node_attribute) (Fhaiku_send_message): New functions. (syms_of_haikuselect): Add defsubrs. diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index ca2b36db2e..19741a20f1 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -105,6 +105,8 @@ You can also use \\[report-emacs-bug]." (executable-find (car cmd))) (throw 'found cmd))))) +(declare-function haiku-set-wallpaper "term/haiku-win.el") + (defun wallpaper-set (file) "Set the desktop background to FILE in a graphical environment." (interactive (list (and @@ -121,32 +123,34 @@ You can also use \\[report-emacs-bug]." (unless (file-readable-p file) (error "File is not readable: %s" file)) (when (display-graphic-p) - (let* ((command (wallpaper--find-command)) - (fmt-spec `((?f . ,(expand-file-name file)) - (?h . ,(display-pixel-height)) - (?w . ,(display-pixel-width)))) - (bufname (format " *wallpaper-%s*" (random))) - (process - (and command - (apply #'start-process "set-wallpaper" bufname - (car command) - (mapcar (lambda (arg) (format-spec arg fmt-spec)) - (cdr command)))))) - (unless command - (error "Can't find a suitable command for setting the wallpaper")) - (wallpaper-debug "Using command %s" (car command)) - (setf (process-sentinel process) - (lambda (process status) - (unwind-protect - (unless (and (eq (process-status process) 'exit) - (zerop (process-exit-status process))) - (message "command %S %s: %S" (string-join (process-command process) " ") - (string-replace "\n" "" status) - (with-current-buffer (process-buffer process) - (string-clean-whitespace (buffer-string))))) - (ignore-errors - (kill-buffer (process-buffer process)))))) - process))) + (if (featurep 'haiku) + (haiku-set-wallpaper file) + (let* ((command (wallpaper--find-command)) + (fmt-spec `((?f . ,(expand-file-name file)) + (?h . ,(display-pixel-height)) + (?w . ,(display-pixel-width)))) + (bufname (format " *wallpaper-%s*" (random))) + (process + (and command + (apply #'start-process "set-wallpaper" bufname + (car command) + (mapcar (lambda (arg) (format-spec arg fmt-spec)) + (cdr command)))))) + (unless command + (error "Can't find a suitable command for setting the wallpaper")) + (wallpaper-debug "Using command %s" (car command)) + (setf (process-sentinel process) + (lambda (process status) + (unwind-protect + (unless (and (eq (process-status process) 'exit) + (zerop (process-exit-status process))) + (message "command %S %s: %S" (string-join (process-command process) " ") + (string-replace "\n" "" status) + (with-current-buffer (process-buffer process) + (string-clean-whitespace (buffer-string))))) + (ignore-errors + (kill-buffer (process-buffer process)))))) + process)))) (provide 'wallpaper) diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index a16169d477..24942d96c1 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -598,6 +598,45 @@ MODIFIERS is the internal modifier mask of the wheel movement." ;; the Deskbar will not, so kill ourself here. (unless cancel-shutdown (kill-emacs)))) +;;;; Wallpaper support. + + +(declare-function haiku-write-node-attribute "haikuselect.c") +(declare-function haiku-send-message "haikuselect.c") + +(defun haiku-set-wallpaper (file) + "Make FILE the wallpaper. +Set the desktop background to the image FILE, on all workspaces, +with an offset of 0, 0." + (let ((encoded-file (encode-coding-string + (expand-file-name file) + (or file-name-coding-system + default-file-name-coding-system)))) + ;; Write the necessary information to the desktop directory. + (haiku-write-node-attribute "/boot/home/Desktop" + "be:bgndimginfo" + (list '(type . 0) + '("be:bgndimginfoerasetext" bool t) + (list "be:bgndimginfopath" 'string + encoded-file) + '("be:bgndimginfoworkspaces" long + ;; This is a mask of all the + ;; workspaces the background + ;; image will be applied to. It + ;; is treated as an unsigned + ;; value by the Tracker, despite + ;; the type being signed. + -1) + ;; Don't apply an offset + '("be:bgndimginfooffset" point (0 . 0)) + ;; Don't stretch or crop or anything + '("be:bgndimginfomode" long 0) + ;; Don't apply a set + '("be:bgndimginfoset" long 0))) + ;; Tell the tracker to redisplay the wallpaper. + (haiku-send-message "application/x-vnd.Be-TRAK" + (list (cons 'type (haiku-numeric-enum Tbgr)))))) + ;;;; Cursors. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 983928442a..0f8e26d0db 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -54,12 +54,14 @@ along with GNU Emacs. If not, see . */ #include #include +#include #include #include #include #include #include #include +#include #include #include @@ -5501,3 +5503,54 @@ be_set_use_frame_synchronization (void *view, bool sync) vw = (EmacsView *) view; vw->SetFrameSynchronization (sync); } + +status_t +be_write_node_message (const char *path, const char *name, void *message) +{ + BNode node (path); + status_t rc; + ssize_t flat, result; + char *buffer; + BMessage *msg; + + rc = node.InitCheck (); + msg = (BMessage *) message; + + if (rc < B_OK) + return rc; + + flat = msg->FlattenedSize (); + if (flat < B_OK) + return flat; + + buffer = new (std::nothrow) char[flat]; + if (!buffer) + return B_NO_MEMORY; + + rc = msg->Flatten (buffer, flat); + if (rc < B_OK) + { + delete[] buffer; + return rc; + } + + result = node.WriteAttr (name, B_MIME_TYPE, 0, + buffer, flat); + delete[] buffer; + + if (result < B_OK) + return result; + + if (result != flat) + return B_ERROR; + + return B_OK; +} + +void +be_send_message (const char *app_id, void *message) +{ + BMessenger messenger (app_id); + + messenger.SendMessage ((BMessage *) message); +} diff --git a/src/haiku_support.h b/src/haiku_support.h index ca1808556a..d66dbc5fa6 100644 --- a/src/haiku_support.h +++ b/src/haiku_support.h @@ -724,6 +724,9 @@ extern void be_get_window_decorator_frame (void *, int *, int *, int *, int *); extern void be_send_move_frame_event (void *); extern void be_set_window_fullscreen_mode (void *, enum haiku_fullscreen_mode); +extern status_t be_write_node_message (const char *, const char *, void *); +extern void be_send_message (const char *, void *); + extern void be_lock_window (void *); extern void be_unlock_window (void *); extern bool be_get_explicit_workarea (int *, int *, int *, int *); diff --git a/src/haikuselect.c b/src/haikuselect.c index 7eb93a2754..bd004f4900 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -325,6 +325,15 @@ haiku_message_to_lisp (void *message) t1 = make_float (*(float *) buf); break; + case 'CSTR': + /* Is this even possible? */ + if (!buf_size) + buf_size = 1; + + t1 = make_uninit_string (buf_size - 1); + memcpy (SDATA (t1), buf, buf_size - 1); + break; + default: t1 = make_uninit_string (buf_size); memcpy (SDATA (t1), buf, buf_size); @@ -747,6 +756,21 @@ haiku_lisp_to_message (Lisp_Object obj, void *message) signal_error ("Failed to add bool", data); break; + case 'CSTR': + /* C strings must be handled specially, since they + include a trailing NULL byte. */ + CHECK_STRING (data); + + block_input (); + rc = be_add_message_data (message, SSDATA (name), + type_code, SDATA (data), + SBYTES (data) + 1); + unblock_input (); + + if (rc) + signal_error ("Failed to add", data); + break; + default: decode_normally: CHECK_STRING (data); @@ -779,6 +803,49 @@ haiku_unwind_drag_message (void *message) BMessage_delete (message); } +static void +haiku_report_system_error (status_t code, const char *format) +{ + switch (code) + { + case B_BAD_VALUE: + error (format, "Bad value"); + break; + + case B_ENTRY_NOT_FOUND: + error (format, "File not found"); + break; + + case B_PERMISSION_DENIED: + error (format, "Permission denied"); + break; + + case B_LINK_LIMIT: + error (format, "Link limit reached"); + break; + + case B_BUSY: + error (format, "Device busy"); + break; + + case B_NO_MORE_FDS: + error (format, "No more file descriptors"); + break; + + case B_FILE_ERROR: + error (format, "File error"); + break; + + case B_NO_MEMORY: + memory_full (SIZE_MAX); + break; + + default: + error (format, "Unknown error"); + break; + } +} + DEFUN ("haiku-drag-message", Fhaiku_drag_message, Shaiku_drag_message, 2, 4, 0, doc: /* Begin dragging MESSAGE from FRAME. @@ -958,6 +1025,66 @@ after it starts. */) return SAFE_FREE_UNBIND_TO (depth, Qnil); } +DEFUN ("haiku-write-node-attribute", Fhaiku_write_node_attribute, + Shaiku_write_node_attribute, 3, 3, 0, + doc: /* Write a message as a file-system attribute of NODE. +FILE should be a file name of a file on a Be File System volume, NAME +should be a string describing the name of the attribute that will be +written, and MESSAGE will be the attribute written to FILE, as a +system message in the format accepted by `haiku-drag-message', which +see. */) + (Lisp_Object file, Lisp_Object name, Lisp_Object message) +{ + void *be_message; + status_t rc; + specpdl_ref count; + + CHECK_STRING (file); + CHECK_STRING (name); + + file = ENCODE_FILE (file); + name = ENCODE_SYSTEM (name); + + be_message = be_create_simple_message (); + count = SPECPDL_INDEX (); + + record_unwind_protect_ptr (BMessage_delete, be_message); + haiku_lisp_to_message (message, be_message); + rc = be_write_node_message (SSDATA (file), SSDATA (name), + be_message); + + if (rc < B_OK) + haiku_report_system_error (rc, "Failed to set attribute: %s"); + + return unbind_to (count, Qnil); +} + +DEFUN ("haiku-send-message", Fhaiku_send_message, Shaiku_send_message, + 2, 2, 0, + doc: /* Send a system message to PROGRAM. +PROGRAM must be the name of the application to which the message will +be sent. MESSAGE is the system message, serialized in the format +accepted by `haiku-drag-message', that will be sent to the application +specified by PROGRAM. There is no guarantee that the message will +arrive after this function is called. */) + (Lisp_Object program, Lisp_Object message) +{ + specpdl_ref count; + void *be_message; + + CHECK_STRING (program); + program = ENCODE_SYSTEM (program); + + be_message = be_create_simple_message (); + count = SPECPDL_INDEX (); + + record_unwind_protect_ptr (BMessage_delete, be_message); + haiku_lisp_to_message (message, be_message); + be_send_message (SSDATA (program), be_message); + + return unbind_to (count, Qnil); +} + static void haiku_dnd_compute_tip_xy (int *root_x, int *root_y) { @@ -1191,6 +1318,8 @@ keyboard modifiers currently held down. */); defsubr (&Shaiku_selection_owner_p); defsubr (&Shaiku_drag_message); defsubr (&Shaiku_roster_launch); + defsubr (&Shaiku_write_node_attribute); + defsubr (&Shaiku_send_message); haiku_dnd_frame = NULL; } commit f0798ac13dcb4c01a883f165e03c3cd7f208667c Author: Stefan Kangas Date: Wed Sep 14 04:44:12 2022 +0200 Support wbg in wallpaper.el (Bug#57781) * lisp/image/wallpaper.el (wallpaper-commands): Add "wbg". (wallpaper--check-command): New cl-defmethod for "wbg". diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index 4c90559183..ca2b36db2e 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -38,6 +38,8 @@ '( ;; Sway (Wayland) ("swaybg" "-o" "*" "-i" "%f" "-m" "fill") + ;; Wayland General + ("wbg" %f) ;; Gnome ("gsettings" "set" "org.gnome.desktop.background" "picture-uri" "file://%f") ;; Other / General X @@ -89,6 +91,9 @@ You can also use \\[report-emacs-bug]." (and (getenv "WAYLAND_DISPLAY") (getenv "SWAYSOCK"))) +(cl-defmethod wallpaper--check-command ((_type (eql 'wbg))) + (getenv "WAYLAND_DISPLAY")) + (cl-defmethod wallpaper--check-command (_type) t) commit 439a3cd29dce275c98012972d3a1d1f4b5b50786 Author: Stefan Kangas Date: Tue Sep 13 18:54:14 2022 +0200 ; Prefer string-join in image-dired * lisp/image/image-dired-dired.el (subr-x): Require. (image-dired-dired-display-properties): Prefer string-join. * lisp/image/image-dired.el (subr-x): Require. (image-dired-update-header-line): Prefer string-join. diff --git a/lisp/image/image-dired-dired.el b/lisp/image/image-dired-dired.el index ef0323d166..ab994742ec 100644 --- a/lisp/image/image-dired-dired.el +++ b/lisp/image/image-dired-dired.el @@ -24,6 +24,8 @@ ;;; Code: +(eval-when-compile (require 'subr-x)) ; for string-join + (require 'image-dired) (defgroup image-dired-dired nil @@ -370,7 +372,7 @@ matching tag will be marked in the Dired buffer." (let* ((file (dired-get-filename)) (file-name (file-name-nondirectory file)) (dired-buf (buffer-name (current-buffer))) - (props (mapconcat #'identity (image-dired-list-tags file) ", ")) + (props (string-join (image-dired-list-tags file) ", ")) (comment (image-dired-get-comment file)) (message-log-max nil)) (if file-name diff --git a/lisp/image/image-dired.el b/lisp/image/image-dired.el index f1074247e9..ff10be2ab4 100644 --- a/lisp/image/image-dired.el +++ b/lisp/image/image-dired.el @@ -138,6 +138,7 @@ (eval-when-compile (require 'cl-lib) + (require 'subr-x) ; for string-join (require 'wid-edit)) (require 'image-dired-external) @@ -704,7 +705,7 @@ comment." image-dired-display-image-mode))) (let ((file-name (file-name-nondirectory (image-dired-original-file-name))) (dired-buf (buffer-name (image-dired-associated-dired-buffer))) - (props (mapconcat #'identity (get-text-property (point) 'tags) ", ")) + (props (string-join (get-text-property (point) 'tags) ", ")) (comment (get-text-property (point) 'comment)) (message-log-max nil)) (if file-name commit 10e9ec6da457ed32236ed9c70aa6cc3fdf9ae7ea Author: Lars Ingebrigtsen Date: Wed Sep 14 02:30:54 2022 +0200 Fix recently-added cl-macs tests * test/lisp/emacs-lisp/cl-macs-tests.el (cl-case-error) (cl-case-warning): Fix warning matches. diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 427b8f4689..83928775f1 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -752,42 +752,44 @@ collection clause." (ert-deftest cl-case-error () "Test that `cl-case' and `cl-ecase' signal an error if a t or `otherwise' key is misplaced." - (dolist (form '((cl-case val (t 1) (123 2)) - (cl-ecase val (t 1) (123 2)) - (cl-ecase val (123 2) (t 1)))) - (ert-info ((prin1-to-string form) :prefix "Form: ") - (let ((error (should-error (macroexpand form)))) - (should (equal (cdr error) - '("Misplaced t or `otherwise' clause"))))))) + (let ((text-quoting-style 'grave)) + (dolist (form '((cl-case val (t 1) (123 2)) + (cl-ecase val (t 1) (123 2)) + (cl-ecase val (123 2) (t 1)))) + (ert-info ((prin1-to-string form) :prefix "Form: ") + (let ((error (should-error (macroexpand form)))) + (should (equal (cdr error) + '("Misplaced t or `otherwise' clause")))))))) (ert-deftest cl-case-warning () "Test that `cl-case' and `cl-ecase' warn about suspicious constructs." - (pcase-dolist (`(,case . ,message) - `((nil . "Case nil will never match") - ('nil . ,(concat "Case 'nil will match `quote'. " + (let ((text-quoting-style 'grave)) + (pcase-dolist (`(,case . ,message) + `((nil . "Case nil will never match") + ('nil . ,(concat "Case 'nil will match `quote'. " + "If that's intended, write " + "(nil quote) instead. " + "Otherwise, don't quote `nil'.")) + ('t . ,(concat "Case 't will match `quote'. " "If that's intended, write " - "(nil quote) instead. " - "Otherwise, don't quote `nil'.")) - ('t . ,(concat "Case 't will match `quote'. " - "If that's intended, write " - "(t quote) instead. " - "Otherwise, don't quote `t'.")) - ('foo . ,(concat "Case 'foo will match `quote'. " - "If that's intended, write " - "(foo quote) instead. " - "Otherwise, don't quote `foo'.")) - (#'foo . ,(concat "Case #'foo will match " - "`function'. If that's " - "intended, write (foo function) " - "instead. Otherwise, don't " - "quote `foo'.")))) - (dolist (macro '(cl-case cl-ecase)) - (let ((form `(,macro val (,case 1)))) - (ert-info ((prin1-to-string form) :prefix "Form: ") - (ert-with-message-capture messages - (macroexpand form) - (should (equal messages - (concat "Warning: " message "\n"))))))))) + "(t quote) instead. " + "Otherwise, don't quote `t'.")) + ('foo . ,(concat "Case 'foo will match `quote'. " + "If that's intended, write " + "(foo quote) instead. " + "Otherwise, don't quote `foo'.")) + (#'foo . ,(concat "Case #'foo will match " + "`function'. If that's " + "intended, write (foo function) " + "instead. Otherwise, don't " + "quote `foo'.")))) + (dolist (macro '(cl-case cl-ecase)) + (let ((form `(,macro val (,case 1)))) + (ert-info ((prin1-to-string form) :prefix "Form: ") + (ert-with-message-capture messages + (macroexpand form) + (should (equal messages + (concat "Warning: " message "\n")))))))))) ;;; cl-macs-tests.el ends here commit c4235eb26db27df63982083455f355ac9b46d70f Author: Lars Ingebrigtsen Date: Tue Sep 13 18:32:30 2022 +0200 Make help-fns--generalized-variable more resilient * lisp/help-fns.el (help-fns--generalized-variable): Don't bug out when a key binding isn't a symbol. diff --git a/lisp/help-fns.el b/lisp/help-fns.el index d5b576de28..a3d4e002b6 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -1159,7 +1159,8 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (add-hook 'help-fns-describe-function-functions #'help-fns--compiler-macro 100) (defun help-fns--generalized-variable (function) - (when (and (get function 'gv-expander) + (when (and (symbolp function) + (get function 'gv-expander) ;; Don't mention obsolete generalized variables. (not (get function 'byte-obsolete-generalized-variable))) (insert (format-message " `%s' is also a " function) commit fd1ee0597708fbd6926b93e1c13830883d3c1687 Author: Juri Linkov Date: Tue Sep 13 21:17:55 2022 +0300 Prefer defvar-keymap for repeat-map in outline.el * lisp/outline.el (outline-navigation-repeat-map) (outline-editing-repeat-map): Prefer defvar-keymap. diff --git a/lisp/outline.el b/lisp/outline.el index 6579e12bfe..b19e0cf811 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -1627,19 +1627,18 @@ With a prefix argument, show headings up to that LEVEL." (message "Show all"))) (outline--fix-up-all-buttons))) -(defvar outline-navigation-repeat-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-b") #'outline-backward-same-level) - (define-key map (kbd "b") #'outline-backward-same-level) - (define-key map (kbd "C-f") #'outline-forward-same-level) - (define-key map (kbd "f") #'outline-forward-same-level) - (define-key map (kbd "C-n") #'outline-next-visible-heading) - (define-key map (kbd "n") #'outline-next-visible-heading) - (define-key map (kbd "C-p") #'outline-previous-visible-heading) - (define-key map (kbd "p") #'outline-previous-visible-heading) - (define-key map (kbd "C-u") #'outline-up-heading) - (define-key map (kbd "u") #'outline-up-heading) - map)) + +(defvar-keymap outline-navigation-repeat-map + "C-b" #'outline-backward-same-level + "b" #'outline-backward-same-level + "C-f" #'outline-forward-same-level + "f" #'outline-forward-same-level + "C-n" #'outline-next-visible-heading + "n" #'outline-next-visible-heading + "C-p" #'outline-previous-visible-heading + "p" #'outline-previous-visible-heading + "C-u" #'outline-up-heading + "u" #'outline-up-heading) (dolist (command '(outline-backward-same-level outline-forward-same-level @@ -1648,17 +1647,15 @@ With a prefix argument, show headings up to that LEVEL." outline-up-heading)) (put command 'repeat-map 'outline-navigation-repeat-map)) -(defvar outline-editing-repeat-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-v") #'outline-move-subtree-down) - (define-key map (kbd "v") #'outline-move-subtree-down) - (define-key map (kbd "C-^") #'outline-move-subtree-up) - (define-key map (kbd "^") #'outline-move-subtree-up) - (define-key map (kbd "C->") #'outline-demote) - (define-key map (kbd ">") #'outline-demote) - (define-key map (kbd "C-<") #'outline-promote) - (define-key map (kbd "<") #'outline-promote) - map)) +(defvar-keymap outline-editing-repeat-map + "C-v" #'outline-move-subtree-down + "v" #'outline-move-subtree-down + "C-^" #'outline-move-subtree-up + "^" #'outline-move-subtree-up + "C->" #'outline-demote + ">" #'outline-demote + "C-<" #'outline-promote + "<" #'outline-promote) (dolist (command '(outline-move-subtree-down outline-move-subtree-up @@ -1666,6 +1663,7 @@ With a prefix argument, show headings up to that LEVEL." outline-promote)) (put command 'repeat-map 'outline-editing-repeat-map)) + (provide 'outline) (provide 'noutline) commit 49419912f20b3cf0131a40798b162cbb596d368e Author: Paul Eggert Date: Tue Sep 13 12:41:34 2022 -0500 Port alignas definition to C23 * src/lisp.h (alignas): C23 is removing the __alignas_is_defined macro, so do not rely on it. Instead, do not define alignas if C23 or later, or if C++11 or later. diff --git a/src/lisp.h b/src/lisp.h index 2f73ba4c61..9710dbef8d 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -245,7 +245,8 @@ DEFINE_GDB_SYMBOL_BEGIN (EMACS_INT, VALMASK) DEFINE_GDB_SYMBOL_END (VALMASK) /* Ignore 'alignas' on compilers lacking it. */ -#if !defined alignas && !defined __alignas_is_defined +#if (!defined alignas && !defined __alignas_is_defined \ + && __STDC_VERSION__ < 202311 && __cplusplus < 201103) # define alignas(a) #endif commit 9d4c135046fcd33ecce9018fdbb749b33468fa06 Author: Eli Zaretskii Date: Tue Sep 13 20:00:30 2022 +0300 ; * etc/NEWS: Fix wording of 'image-crop' entry. diff --git a/etc/NEWS b/etc/NEWS index dde340627b..ae3f84c1b9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2445,8 +2445,9 @@ The old name is still available as an obsolete function alias. These commands allow interactively cropping/eliding the image at point. The commands are bound to keys 'c' and 'e' (respectively) in the local keymap over images. They rely on external programs, by -default 'convert' from ImageMagick and 'exiftool', to do the actual -cropping/eliding of the image file. +default 'convert' from ImageMagick, to do the actual cropping/eliding +of the image file. If the 'exiftool' program is available, it is used +to optionally rotate images which have the :rotation property. +++ ** New package 'oclosure'. commit 0b6793b5e3d0ca030df54aad5a3b304fb922f5aa Author: Lars Ingebrigtsen Date: Tue Sep 13 18:28:14 2022 +0200 Fix wallpaper.el build warning * lisp/image/wallpaper.el (require): Fix build warning. diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index d997cb48d7..4c90559183 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -32,6 +32,8 @@ ;;; Code: +(eval-when-compile (require 'subr-x)) + (defcustom wallpaper-commands '( ;; Sway (Wayland) commit aed39a518d5e5f5dc47ed808247bfb89cc3328c2 Author: Lars Ingebrigtsen Date: Tue Sep 13 18:25:32 2022 +0200 Revert "Fix help--analyze-key problem when not called from menu" This reverts commit 7e374b96635ce70f574fba351defc765e9a52da9. This should not be needed -- perhaps it was triggered by an ephemeral code change in my running Emacs. diff --git a/lisp/help.el b/lisp/help.el index a95bbaa4ae..92b87cf799 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -725,8 +725,7 @@ in the selected window." ;; is selected from the context menu that should describe KEY ;; at the position of mouse click that opened the context menu. ;; When no mouse was involved, don't use `posn-set-point'. - (defn (if (or buffer - (not (consp (event-end event)))) + (defn (if buffer (key-binding key t) (save-excursion (posn-set-point (event-end event)) (key-binding key t))))) commit 3713183a3db73a720dbcf20a5b6bf3bf3232a301 Author: Stefan Kangas Date: Tue Sep 13 18:02:21 2022 +0200 Use wallpaper-set in thumbs.el * lisp/thumbs.el (wallpaper): Require. (thumbs-setroot-command): Make defcustom obsolete. (thumbs-call-setroot-command): Make obsolete in favor of wallpaper-set. (thumbs-set-image-at-point-to-root-window, thumbs-set-root) (thumbs-dired-setroot): Use wallpaper-set instead of thumbs-call-setroot-command. (thumbs-before-setroot-hook, thumbs-after-setroot-hook): Make obsolete. diff --git a/lisp/thumbs.el b/lisp/thumbs.el index 0b3d36d6e3..0c5307f8de 100644 --- a/lisp/thumbs.el +++ b/lisp/thumbs.el @@ -54,6 +54,7 @@ ;;; Code: (require 'dired) +(require 'wallpaper) (require 'cl-lib) ; for cl-gensym ;; CUSTOMIZATIONS @@ -99,6 +100,8 @@ This must be the ImageMagick \"convert\" utility." :type 'string :version "28.1") +(make-obsolete-variable 'thumbs-setroot-command + 'wallpaper-commands-alist "29.1") (defcustom thumbs-setroot-command "xloadimage -onroot -fullscreen *" "Command to set the root window." @@ -425,6 +428,7 @@ Open another window." (defun thumbs-call-setroot-command (img) "Call the setroot program for IMG." + (declare (obsolete wallpaper-set "29.1")) (run-hooks 'thumbs-before-setroot-hook) (shell-command (string-replace "*" @@ -435,15 +439,13 @@ Open another window." (defun thumbs-set-image-at-point-to-root-window () "Set the image at point as the desktop wallpaper." (interactive) - (thumbs-call-setroot-command - (thumbs-current-image))) + (wallpaper-set (thumbs-current-image))) (defun thumbs-set-root () "Set the current image as root." (interactive) - (thumbs-call-setroot-command - (or thumbs-current-tmp-filename - thumbs-current-image-filename))) + (wallpaper-set (or thumbs-current-tmp-filename + thumbs-current-image-filename))) (defun thumbs-file-alist () "Make an alist of elements (POS . FILENAME) for all images in thumb buffer." @@ -756,13 +758,16 @@ ACTION and ARG should be a valid convert command." (defun thumbs-dired-setroot () "In dired, call the setroot program on the image at point." (interactive) - (thumbs-call-setroot-command (dired-get-filename))) + (wallpaper-set (dired-get-filename))) ;; Modif to dired mode map (define-key dired-mode-map "\C-ta" 'thumbs-dired-show) (define-key dired-mode-map "\C-tm" 'thumbs-dired-show-marked) (define-key dired-mode-map "\C-tw" 'thumbs-dired-setroot) +(make-obsolete-variable 'thumbs-before-setroot-hook nil "29.1") +(make-obsolete-variable 'thumbs-after-setroot-hook nil "29.1") + (define-obsolete-function-alias 'thumbs-image-type #'image-supported-file-p "29.1") commit 535adb96f6c1be7f43ba5d1b04b3d00e1c94b626 Author: Stefan Kangas Date: Tue Sep 13 17:56:22 2022 +0200 Add new command image-dired-set-wallpaper * lisp/image/image-dired.el (wallpaper): Require. (image-dired-set-wallpaper): New command. (image-dired-thumbnail-mode-map): Bind above new command to "W". diff --git a/etc/NEWS b/etc/NEWS index db3fcf19e5..dde340627b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2052,6 +2052,11 @@ If 'image-dired-thumb-mark' is non-nil (the default), this face is used for images that are flagged for deletion in the Dired buffer associated with Image-Dired. +--- +*** New command 'image-dired-wallpaper-set'. +This command sets the wallpaper to the image at point in the thumbnail +buffer. It is bound to 'W' by default. + --- *** 'image-dired-slideshow-start' is now bound to 'S'. It is bound in both the thumbnail and display buffer. diff --git a/lisp/image/image-dired.el b/lisp/image/image-dired.el index 65844863c6..f1074247e9 100644 --- a/lisp/image/image-dired.el +++ b/lisp/image/image-dired.el @@ -55,7 +55,6 @@ ;; ;; file-name-non-directory;comment:comment-text;tag1;tag2;tag3;...;tagN ;; -;; ;; PREREQUISITES ;; ============= ;; @@ -109,8 +108,6 @@ ;; * From thumbs.el: Add an option for clean-up/max-size functionality ;; for thumbnail directory. ;; -;; * From thumbs.el: Add setroot function. -;; ;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find out ;; which is best, saving old batch just before inserting new, or ;; saving the current batch in the ring when inserting it. Adding @@ -135,6 +132,7 @@ (require 'dired) (require 'image-mode) +(require 'wallpaper) (require 'widget) (require 'xdg) @@ -861,6 +859,7 @@ You probably want to use this together with "SPC" #'image-dired-display-next-thumbnail-original "DEL" #'image-dired-display-previous-thumbnail-original "c" #'image-dired-comment-thumbnail + "W" #'image-dired-wallpaper-set ;; Mouse "" #'image-dired-mouse-display-image @@ -1152,6 +1151,12 @@ With prefix ARG, move that many thumbnails." (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode) (image-dired-display-next-thumbnail-original (- arg))) +(defun image-dired-wallpaper-set (file) + "Set the wallpaper to FILE in a graphical environment." + (interactive (list (image-dired-original-file-name)) + image-dired-thumbnail-mode) + (wallpaper-set file)) + ;;; Image Comments commit 32b7aaa9f1e1fa12ea1db92594a872503f0de498 Author: Stefan Kangas Date: Tue Sep 13 16:57:01 2022 +0200 Add new library wallpaper.el * lisp/image/wallpaper.el: New file. diff --git a/etc/NEWS b/etc/NEWS index 5416aa8066..db3fcf19e5 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1989,6 +1989,12 @@ and is bound to "s p" in Image mode. *** Users can now add special image conversion functions. This is done via 'image-converter-add-handler'. +--- +*** New library wallpaper.el. +This library contains the command `wallpaper-set', which uses an +external command to set the desktop background. The new user option +`wallpaper-commands' controls which command is being used. + ** Image-Dired +++ diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el new file mode 100644 index 0000000000..d997cb48d7 --- /dev/null +++ b/lisp/image/wallpaper.el @@ -0,0 +1,146 @@ +;;; wallpaper.el --- Set wallpaper using external command -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: Stefan Kangas +;; Keywords: images + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This library provides the command `wallpaper-set', which uses an +;; external command to set the desktop background. This is obviously +;; a bit tricky to get right, as there is no lack of platforms, window +;; managers, desktop environments and tools. +;; +;; If this doesn't work in your environment, customize the user option +;; `wallpaper-commands'. + +;;; Code: + +(defcustom wallpaper-commands + '( + ;; Sway (Wayland) + ("swaybg" "-o" "*" "-i" "%f" "-m" "fill") + ;; Gnome + ("gsettings" "set" "org.gnome.desktop.background" "picture-uri" "file://%f") + ;; Other / General X + ("gm" "display" "-size" "%wx%h" "-window" "root" "%f") + ("display" "-resize" "%wx%h" "-window" "root" "%f") + ("feh" "--bg-max" "%f") + ("xloadimage" "-onroot" "-fullscreen" "%f") + ("xsetbg" " %f") + ) + "List of executables and arguments for setting the wallpaper. +This is used by `wallpaper-set', which will test the commands +in the order they appear. + +Every item in the list has the following form: + + (COMMAND ARG1 .. ARGN) + +COMMAND is the name of the executable (a string) and ARG1 .. ARGN +is its command line arguments (also strings). + +In each of the command line arguments, \"%f\" will be replaced +with the full file name, \"%h\" with the height of the selected +frame's display (as returned by `display-pixel-height'), and +\"%w\" with the width of the selected frame's display (as +returned by `display-pixel-width'). + +Note: If you find that you need to use a command that is not in +this list to set the wallpaper in your environment, we would love +to hear about it! Please send an email to bug-gnu-emacs@gnu.org +and tell us the command (and all options) that worked for you. +You can also use \\[report-emacs-bug]." + :type '(repeat (repeat string)) + :group 'image + :version "29.1") + +(defvar wallpaper-debug nil + "If non-nil, display debug messages.") + +(defun wallpaper-debug (&rest args) + (when wallpaper-debug + (apply #'message + (concat "wallpaper-debug: " (car args)) + (cdr args)))) + +(cl-defmethod wallpaper--check-command ((_type (eql 'gsettings))) + (equal (getenv "XDG_CURRENT_DESKTOP") "GNOME")) + +(cl-defmethod wallpaper--check-command ((_type (eql 'swaybg))) + (and (getenv "WAYLAND_DISPLAY") + (getenv "SWAYSOCK"))) + +(cl-defmethod wallpaper--check-command (_type) + t) + +(defun wallpaper--find-command () + "Return a valid command for this system." + (catch 'found + (dolist (cmd wallpaper-commands) + (if (and (wallpaper--check-command (intern (car cmd))) + (executable-find (car cmd))) + (throw 'found cmd))))) + +(defun wallpaper-set (file) + "Set the desktop background to FILE in a graphical environment." + (interactive (list (and + (display-graphic-p) + (read-file-name "Set desktop background to: " + default-directory nil t nil + (lambda (fn) + (or (file-directory-p fn) + (string-match (image-file-name-regexp) fn))))))) + (when (file-directory-p file) + (error "Can't set wallpaper to a directory: %s" file)) + (unless (file-exists-p file) + (error "No such file: %s" file)) + (unless (file-readable-p file) + (error "File is not readable: %s" file)) + (when (display-graphic-p) + (let* ((command (wallpaper--find-command)) + (fmt-spec `((?f . ,(expand-file-name file)) + (?h . ,(display-pixel-height)) + (?w . ,(display-pixel-width)))) + (bufname (format " *wallpaper-%s*" (random))) + (process + (and command + (apply #'start-process "set-wallpaper" bufname + (car command) + (mapcar (lambda (arg) (format-spec arg fmt-spec)) + (cdr command)))))) + (unless command + (error "Can't find a suitable command for setting the wallpaper")) + (wallpaper-debug "Using command %s" (car command)) + (setf (process-sentinel process) + (lambda (process status) + (unwind-protect + (unless (and (eq (process-status process) 'exit) + (zerop (process-exit-status process))) + (message "command %S %s: %S" (string-join (process-command process) " ") + (string-replace "\n" "" status) + (with-current-buffer (process-buffer process) + (string-clean-whitespace (buffer-string))))) + (ignore-errors + (kill-buffer (process-buffer process)))))) + process))) + +(provide 'wallpaper) + +;;; wallpaper.el ends here commit 2984b752f1e9e7148ec802e388f2b7cdef2763f7 Author: Stefan Kangas Date: Tue Sep 13 17:16:33 2022 +0200 ; image-dired: Delete unnecessary :group arg * lisp/image/image-dired.el (image-dired-db-file): Delete unnecessary :group arg. diff --git a/lisp/image/image-dired.el b/lisp/image/image-dired.el index a22edee2ec..65844863c6 100644 --- a/lisp/image/image-dired.el +++ b/lisp/image/image-dired.el @@ -206,7 +206,6 @@ https://specifications.freedesktop.org/thumbnail-spec/thumbnail-spec-latest.html (defcustom image-dired-db-file (expand-file-name ".image-dired_db" image-dired-dir) "Database file where file names and their associated tags are stored." - :group 'image-dired :type 'file) (defcustom image-dired-rotate-original-ask-before-overwrite t commit 6e6a3efa2e806738b4c88e67db1b9bc87969831d Author: Lars Ingebrigtsen Date: Tue Sep 13 18:24:14 2022 +0200 Remove a nil cl-case case * lisp/emacs-lisp/testcover.el (testcover-coverage-combine): Remove the nil case, which will never match (bug#51368). diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index cd2e388ce4..760063d1f9 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -637,8 +637,7 @@ argument is maybe, return maybe. Return 1value only if both arguments are 1value." (cl-case val (testcover-1value result) - (maybe (and result 'maybe)) - (nil nil))) + (maybe (and result 'maybe)))) (defun testcover-analyze-coverage-compose (forms func) "Analyze a list of FORMS for code coverage using FUNC. commit ef0c2e9940552e9b8612e8ae8c908466b2c99f0a Author: Lars Ingebrigtsen Date: Tue Sep 13 18:19:26 2022 +0200 Fix some misleading quoting in cl-case * lisp/progmodes/compile.el (compilation-auto-jump): * lisp/image/image-crop.el (image-crop--crop-image-1): (image-crop--crop-image-1): * lisp/image/exif.el (exif--process-value): * lisp/image-mode.el (image-mode--next-file): * lisp/dnd.el (dnd-begin-text-drag): (dnd-begin-file-drag): (dnd-begin-drag-files): Fix misleading quoting in cl-case (bug#51368). diff --git a/lisp/dnd.el b/lisp/dnd.el index 70852885a8..b2e93a63de 100644 --- a/lisp/dnd.el +++ b/lisp/dnd.el @@ -370,8 +370,8 @@ currently being held down. It should only be called upon a ;; the standard (i.e. Qt programs). "text/plain" "text/plain;charset=utf-8") (cl-ecase action - ('copy 'XdndActionCopy) - ('move 'XdndActionMove)) + (copy 'XdndActionCopy) + (move 'XdndActionMove)) frame nil allow-same-frame))) (cond ((eq return-value 'XdndActionCopy) 'copy) @@ -457,9 +457,9 @@ currently being held down. It should only be called upon a ;; programs. "_DT_NETFILE") (cl-ecase action - ('copy 'XdndActionCopy) - ('move 'XdndActionMove) - ('link 'XdndActionLink)) + (copy 'XdndActionCopy) + (move 'XdndActionMove) + (link 'XdndActionLink)) frame nil allow-same-frame))) (cond ((eq return-value 'XdndActionCopy) 'copy) @@ -527,9 +527,9 @@ FILES will be dragged." ;; and Haiku. "FILE_NAME" "HOST_NAME") (cl-ecase action - ('copy 'XdndActionCopy) - ('move 'XdndActionMove) - ('link 'XdndActionLink)) + (copy 'XdndActionCopy) + (move 'XdndActionMove) + (link 'XdndActionLink)) frame nil allow-same-frame))) (cond ((eq return-value 'XdndActionCopy) 'copy) diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 9485f1e006..d27462ff0a 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -1262,7 +1262,7 @@ If N is negative, go to the previous file." (save-window-excursion (switch-to-buffer (cdr buffer) t t) (cl-case (car buffer) - ('dired + (dired (dired-goto-file file) (let (found) (while (and (not found) @@ -1280,9 +1280,9 @@ If N is negative, go to the previous file." ;; If we didn't find a next/prev file, then restore ;; point. (dired-goto-file file)))) - ('archive + (archive (setq next (archive-next-file-displayer file regexp n))) - ('tar + (tar (setq next (tar-next-file-displayer file regexp n)))))) next)) diff --git a/lisp/image/exif.el b/lisp/image/exif.el index b25968af53..53d2074ed7 100644 --- a/lisp/image/exif.el +++ b/lisp/image/exif.el @@ -271,13 +271,13 @@ VALUE is an integer representing BYTES characters." "Do type-based post-processing of the value." (cl-case type ;; Chop off trailing zero byte. - ('ascii (substring value 0 (1- (length value)))) - ('rational (with-temp-buffer - (set-buffer-multibyte nil) - (insert value) - (goto-char (point-min)) - (cons (exif--read-number 4 le) - (exif--read-number 4 le)))) + (ascii (substring value 0 (1- (length value)))) + (rational (with-temp-buffer + (set-buffer-multibyte nil) + (insert value) + (goto-char (point-min)) + (cons (exif--read-number 4 le) + (exif--read-number 4 le)))) (otherwise value))) (defun exif--read-chunk (bytes) diff --git a/lisp/image/image-crop.el b/lisp/image/image-crop.el index 1a533aaf42..adf2a49348 100644 --- a/lisp/image/image-crop.el +++ b/lisp/image/image-crop.el @@ -208,7 +208,7 @@ After cropping an image, it can be saved by `M-x image-save' or () (let ((pos (nth 8 (cadr event)))) (cl-case state - ('begin + (begin (cond ((eq (car event) 'down-mouse-1) (setq state 'stretch @@ -217,7 +217,7 @@ After cropping an image, it can be saved by `M-x image-save' or (cl-getf area :top) (cdr pos) (cl-getf area :right) (car pos) (cl-getf area :bottom) (cdr pos))))) - ('stretch + (stretch (cond ((eq (car event) 'mouse-movement) (setf (cl-getf area :right) (car pos) @@ -225,7 +225,7 @@ After cropping an image, it can be saved by `M-x image-save' or ((memq (car event) '(mouse-1 drag-mouse-1)) (setq state 'corner prompt "Choose corner to adjust (RET to crop)")))) - ('corner + (corner (cond ((eq (car event) 'down-mouse-1) ;; Find out what corner we're close to. @@ -238,7 +238,7 @@ After cropping an image, it can be saved by `M-x image-save' or (when corner (setq state 'adjust prompt "Adjust crop"))))) - ('adjust + (adjust (cond ((memq (car event) '(mouse drag-mouse-1)) (setq state 'corner @@ -246,12 +246,12 @@ After cropping an image, it can be saved by `M-x image-save' or ((eq (car event) 'mouse-movement) (setf (cl-getf area (car corner)) (car pos) (cl-getf area (cadr corner)) (cdr pos))))) - ('move-unclick + (move-unclick (cond ((eq (car event) 'down-mouse-1) (setq state 'move-click prompt "Move")))) - ('move-click + (move-click (cond ((eq (car event) 'mouse-movement) (setf (cl-getf area :left) (car pos) diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 5ce80e0657..ded5d2130e 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -1235,10 +1235,10 @@ POS and RES.") (if win (set-window-point win pos))) (when compilation-auto-jump-to-first-error (cl-case compilation-auto-jump-to-first-error - ('if-location-known + (if-location-known (when (compilation--file-known-p) (compile-goto-error))) - ('first-known + (first-known (let (match) (while (and (not (compilation--file-known-p)) (setq match (text-property-search-forward commit 35d597348cca9159fefeb1adddebf7d1a146f47b Author: Eli Zaretskii Date: Tue Sep 13 18:58:21 2022 +0300 ; * etc/NEWS: More detail about 'image-crop' and 'image-elide'. diff --git a/etc/NEWS b/etc/NEWS index 726c78afbf..5416aa8066 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2431,10 +2431,11 @@ The old name is still available as an obsolete function alias. +++ ** New commands 'image-crop' and 'image-elide'. -These commands allow interactively cropping/eliding the image under -point. These commands are bound to 'c' and 'e' (respectively) in the -local keymap over images. They rely on external programs to do the -actual cropping/eliding of the image file. +These commands allow interactively cropping/eliding the image at +point. The commands are bound to keys 'c' and 'e' (respectively) in +the local keymap over images. They rely on external programs, by +default 'convert' from ImageMagick and 'exiftool', to do the actual +cropping/eliding of the image file. +++ ** New package 'oclosure'. commit 857d7f3881c4ce0a2f9201467b316b090f48a370 Author: Lars Ingebrigtsen Date: Tue Sep 13 17:27:20 2022 +0200 Regenerated ldefs-boot.el diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index b870494477..909ecf773c 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -4006,8 +4006,8 @@ from which to start. (fn STRING &optional LAX FROM)") (autoload 'describe-char-fold-equivalences "char-fold" "\ Display characters equivalent to CHAR under character-folding. -Prompt for CHAR (using `read-char-by-name', which see for how can -you specify the character). With no input, i.e. when CHAR is nil, +Prompt for CHAR (using `read-char-by-name', which see for how to +specify the character). With no input, i.e. when CHAR is nil, describe all available character equivalences of `char-fold-to-regexp'. Optional argument LAX (interactively, the prefix argument), if non-nil, means also include partially matching ligatures and @@ -4476,8 +4476,6 @@ instead. ;;; Generated autoloads from emacs-lisp/cl-lib.el (push (purecopy '(cl-lib 1 0)) package--builtin-versions) -(define-obsolete-variable-alias 'custom-print-functions 'cl-custom-print-functions "\ -24.3") (defvar cl-custom-print-functions nil "\ This is a list of functions that format user objects for printing. Each function is called in turn with three arguments: the object, the @@ -5030,8 +5028,6 @@ evaluate `compilation-shell-minor-mode'. The mode's hook is called both when the mode is enabled and when it is disabled. -\\{compilation-shell-minor-mode-map} - (fn &optional ARG)" t) (autoload 'compilation-minor-mode "compile" "\ Toggle Compilation minor mode. @@ -5055,8 +5051,6 @@ evaluate `compilation-minor-mode'. The mode's hook is called both when the mode is enabled and when it is disabled. -\\{compilation-minor-mode-map} - (fn &optional ARG)" t) (autoload 'compilation-next-error-function "compile" "\ Advance to the next error message and visit the file where the error was. @@ -7256,6 +7250,13 @@ The mode's hook is called both when the mode is enabled and when it is disabled. (fn &optional ARG)" t) +(defvar diff-add-log-use-relative-names nil "\ +Use relative file names when generating ChangeLog skeletons. +The files will be relative to the root directory of the VC +repository. This option affects the behavior of +`diff-add-log-current-defuns'.") +(custom-autoload 'diff-add-log-use-relative-names "diff-mode" t) +(put 'diff-add-log-use-relative-names 'safe-local-variable #'booleanp) (autoload 'diff-vc-deduce-fileset "diff-mode") (register-definition-prefixes "diff-mode" '("diff-")) @@ -7585,6 +7586,34 @@ This provides increased compatibility for users who call this function in `.emacs'. (fn ARG)") +(autoload 'standard-display-by-replacement-char "disp-table" "\ +Produce code to display characters between FROM and TO using REPL. +This function produces a buffer with code to set up `standard-display-table' +such that characters that cannot be displayed by the terminal, and +don't already have their display set up in `standard-display-table', will +be represented by a replacement character. You can evaluate the produced +code to use the setup for the current Emacs session, or copy the code +into your init file, to make Emacs use it for subsequent sessions. + +Interactively, the produced code arranges for any character in +the range [#x100..#x10FFFF] that the terminal cannot display to +be represented by the #xFFFD Unicode replacement character. + +When called from Lisp, FROM and TO define the range of characters for +which to produce the setup code for `standard-display-table'. If they +are omitted, they default to #x100 and #x10FFFF respectively, covering +the entire non-ASCII range of Unicode characters. +REPL is the replacement character to use. If it's omitted, it defaults +to #xFFFD, the Unicode replacement character, usually displayed as a +black diamond with a question mark inside. +The produced code sets up `standard-display-table' to show REPL with +the `homoglyph' face, making the replacements stand out on display. + +This command is most useful with text-mode terminals, such as the +Linux console, for which Emacs has a reliable way of determining +which characters can be displayed and which cannot. + +(fn &optional REPL FROM TO)" t) (register-definition-prefixes "disp-table" '("display-table-print-array")) @@ -8079,6 +8108,7 @@ Valid keywords and arguments are: `nodigits' to suppress digits as prefix arguments. (fn BS &optional NAME M ARGS)") +(make-obsolete 'easy-mmode-define-keymap 'define-keymap "29.1") (autoload 'easy-mmode-defmap "easy-mmode" "\ Define a constant M whose value is the result of `easy-mmode-define-keymap'. The M, BS, and ARGS arguments are as per that function. DOC is @@ -8089,6 +8119,7 @@ This macro is deprecated; use `defvar-keymap' instead. (fn M BS DOC &rest ARGS)" nil t) (function-put 'easy-mmode-defmap 'doc-string-elt 3) (function-put 'easy-mmode-defmap 'lisp-indent-function 1) +(make-obsolete 'easy-mmode-defmap 'defvar-keymap "29.1") (autoload 'easy-mmode-defsyntax "easy-mmode" "\ Define variable ST as a syntax-table. CSS contains a list of syntax specifications of the form (CHAR . SYNTAX). @@ -8404,7 +8435,7 @@ A second call of this function without changing point inserts the next match. A call with prefix PREFIX reads the symbol to insert from the minibuffer with completion. -(fn PREFIX)" t) +(fn PREFIX)" '("P")) (autoload 'ebrowse-tags-loop-continue "ebrowse" "\ Repeat last operation on files in tree. FIRST-TIME non-nil means this is not a repetition, but the first time. @@ -9951,7 +9982,7 @@ When present, ID should be an opaque object used to identify the connection unequivocally. This is rarely needed and not available interactively. -(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) (USER (erc-compute-user)) PASSWORD (FULL-NAME (erc-compute-full-name)) ID)" t) +(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) (USER (erc-compute-user)) PASSWORD (FULL-NAME (erc-compute-full-name)) ID)" '((erc-select-read-args))) (defalias 'erc-select #'erc) (autoload 'erc-tls "erc" "\ ERC is a powerful, modular, and extensible IRC client. @@ -9998,7 +10029,7 @@ symbol composed of letters from the Latin alphabet.) This option is generally unneeded, however. See info node `(erc) Connecting' for use cases. Not available interactively. -(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) (USER (erc-compute-user)) PASSWORD (FULL-NAME (erc-compute-full-name)) CLIENT-CERTIFICATE ID)" t) +(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) (USER (erc-compute-user)) PASSWORD (FULL-NAME (erc-compute-full-name)) CLIENT-CERTIFICATE ID)" '((let ((erc-default-port erc-default-port-tls)) (erc-select-read-args)))) (autoload 'erc-handle-irc-url "erc" "\ Use ERC to IRC on HOST:PORT in CHANNEL as USER with PASSWORD. If ERC is already connected to HOST:PORT, simply /join CHANNEL. @@ -10214,9 +10245,7 @@ it has to be wrapped in `(eval (quote ...))'. If NAME is already defined as a test and Emacs is running in batch mode, an error is signalled. -(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] BODY...)" nil t) -(function-put 'ert-deftest 'doc-string-elt 3) -(function-put 'ert-deftest 'lisp-indent-function 2) +(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] BODY...)" nil 'macro) (autoload 'ert-run-tests-batch "ert" "\ Run the tests specified by SELECTOR, printing results to the terminal. @@ -12122,12 +12151,17 @@ Define some key bindings for the `find-function' family of functions.") ;;; Generated autoloads from find-lisp.el (autoload 'find-lisp-find-dired "find-lisp" "\ -Find files in DIR, matching REGEXP. +Find the files within DIR whose names match REGEXP. +A Dired buffer with the results will be opened. (fn DIR REGEXP)" t) (autoload 'find-lisp-find-dired-subdirectories "find-lisp" "\ Find all subdirectories of DIR. +(fn DIR)" t) +(autoload 'find-lisp-find-dired-subdirs-other-window "find-lisp" "\ +Same as `find-lisp-find-dired-subdirectories', but use another window. + (fn DIR)" t) (autoload 'find-lisp-find-dired-filter "find-lisp" "\ Change the filter on a `find-lisp-find-dired' buffer to REGEXP. @@ -12287,8 +12321,6 @@ evaluate `flymake-mode'. The mode's hook is called both when the mode is enabled and when it is disabled. -\\{flymake-mode-map} - (fn &optional ARG)" t) (autoload 'flymake-mode-on "flymake" "\ Turn Flymake mode on.") @@ -15902,8 +15934,7 @@ inlined into the compiled format versions. This means that if you change its definition, you should explicitly call `ibuffer-recompile-formats'. -(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)" nil t) -(function-put 'define-ibuffer-column 'lisp-indent-function 'defun) +(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)" nil 'macro) (autoload 'define-ibuffer-sorter "ibuf-macs" "\ Define a method of sorting named NAME. DOCUMENTATION is the documentation of the function, which will be called @@ -15914,9 +15945,7 @@ For sorting, the forms in BODY will be evaluated with `a' bound to one buffer object, and `b' bound to another. BODY should return a non-nil value if and only if `a' is \"less than\" `b'. -(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)" nil t) -(function-put 'define-ibuffer-sorter 'lisp-indent-function 1) -(function-put 'define-ibuffer-sorter 'doc-string-elt 2) +(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)" nil 'macro) (autoload 'define-ibuffer-op "ibuf-macs" "\ Generate a function which operates on a buffer. OP becomes the name of the function; if it doesn't begin with @@ -15955,9 +15984,7 @@ BODY define the operation; they are forms to evaluate per each marked buffer. BODY is evaluated with `buf' bound to the buffer object. -(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING BEFORE AFTER COMPLEX) &rest BODY)" nil t) -(function-put 'define-ibuffer-op 'lisp-indent-function 2) -(function-put 'define-ibuffer-op 'doc-string-elt 3) +(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING BEFORE AFTER COMPLEX) &rest BODY)" nil 'macro) (autoload 'define-ibuffer-filter "ibuf-macs" "\ Define a filter named NAME. DOCUMENTATION is the documentation of the function. @@ -15972,9 +15999,7 @@ not a particular buffer should be displayed or not. The forms in BODY will be evaluated with BUF bound to the buffer object, and QUALIFIER bound to the current value of the filter. -(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)" nil t) -(function-put 'define-ibuffer-filter 'lisp-indent-function 2) -(function-put 'define-ibuffer-filter 'doc-string-elt 2) +(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)" nil 'macro) (register-definition-prefixes "ibuf-macs" '("ibuffer-")) @@ -16916,17 +16941,32 @@ should output the image in the current buffer, converted to (register-definition-prefixes "image-converter" '("image-convert")) -;;; Generated autoloads from image-dired.el +;;; Generated autoloads from image/image-crop.el -(push (purecopy '(image-dired 0 4 11)) package--builtin-versions) -(autoload 'image-dired-dired-toggle-marked-thumbs "image-dired" "\ -Toggle thumbnails in front of file names in the Dired buffer. -If no marked file could be found, insert or hide thumbnails on the -current line. ARG, if non-nil, specifies the files to use instead -of the marked files. If ARG is an integer, use the next ARG (or -previous -ARG, if ARG<0) files. +(autoload 'image-elide "image-crop" "\ +Elide a square from the image under point. +If SQUARE (interactively, the prefix), elide a square instead of a +rectangle from the image. -(fn &optional ARG)" t) +(fn &optional SQUARE)" t) +(autoload 'image-crop "image-crop" "\ +Crop the image under point. +If SQUARE (interactively, the prefix), crop a square instead of a +rectangle from the image. + +If ELIDE, remove a rectangle from the image instead of cropping +the image. + +After cropping an image, it can be saved by `M-x image-save' or +\\\\[image-save] when point is over the image. + +(fn &optional SQUARE ELIDE)" t) +(register-definition-prefixes "image-crop" '("image-crop-")) + + +;;; Generated autoloads from image/image-dired.el + +(push (purecopy '(image-dired 0 4 11)) package--builtin-versions) (autoload 'image-dired-dired-with-window-configuration "image-dired" "\ Open directory DIR and create a default window configuration. @@ -16967,7 +17007,7 @@ used or not. If non-nil, use `display-buffer' instead of `image-dired-previous-line-and-display' where we do not want the thumbnail buffer to be selected. -(fn &optional ARG APPEND DO-NOT-POP)" t) +(fn &optional ARG APPEND DO-NOT-POP)" '(nil dired-mode)) (autoload 'image-dired-show-all-from-dir "image-dired" "\ Make a thumbnail buffer for all images in DIR and display it. Any file matching `image-file-name-regexp' is considered an image @@ -16980,18 +17020,28 @@ never ask for confirmation. (fn DIR)" t) (defalias 'image-dired 'image-dired-show-all-from-dir) -(autoload 'image-dired-tag-files "image-dired" "\ -Tag marked file(s) in Dired. With prefix ARG, tag file at point. +(autoload 'image-dired-bookmark-jump "image-dired" "\ +Default bookmark handler for Image-Dired buffers. -(fn ARG)" t) -(autoload 'image-dired-delete-tag "image-dired" "\ -Remove tag for selected file(s). -With prefix argument ARG, remove tag from file at point. +(fn BOOKMARK)") +(define-obsolete-function-alias 'tumme #'image-dired "24.4") +(define-obsolete-function-alias 'image-dired-setup-dired-keybindings #'image-dired-minor-mode "26.1") +(register-definition-prefixes "image-dired" '("image-dired-")) -(fn ARG)" t) -(autoload 'image-dired-jump-thumbnail-buffer "image-dired" "\ -Jump to thumbnail buffer." t) -(autoload 'image-dired-minor-mode "image-dired" "\ + +;;; Generated autoloads from image/image-dired-dired.el + +(autoload 'image-dired-dired-toggle-marked-thumbs "image-dired-dired" "\ +Toggle thumbnails in front of file names in the Dired buffer. +If no marked file could be found, insert or hide thumbnails on the +current line. ARG, if non-nil, specifies the files to use instead +of the marked files. If ARG is an integer, use the next ARG (or +previous -ARG, if ARG<0) files. + +(fn &optional ARG)" '(dired-mode)) +(autoload 'image-dired-jump-thumbnail-buffer "image-dired-dired" "\ +Jump to thumbnail buffer." '(dired-mode)) +(autoload 'image-dired-minor-mode "image-dired-dired" "\ Setup easy-to-use keybindings for the commands to be used in Dired mode. Note that n, p and and will be hijacked and bound to @@ -17013,21 +17063,19 @@ The mode's hook is called both when the mode is enabled and when it is disabled. (fn &optional ARG)" t) -(autoload 'image-dired-display-thumbs-append "image-dired" "\ -Append thumbnails to `image-dired-thumbnail-buffer'." t) -(autoload 'image-dired-display-thumb "image-dired" "\ -Shorthand for `image-dired-display-thumbs' with prefix argument." t) -(autoload 'image-dired-dired-display-external "image-dired" "\ -Display file at point using an external viewer." t) -(autoload 'image-dired-dired-display-image "image-dired" "\ +(autoload 'image-dired-display-thumbs-append "image-dired-dired" "\ +Append thumbnails to `image-dired-thumbnail-buffer'." '(dired-mode)) +(autoload 'image-dired-display-thumb "image-dired-dired" "\ +Shorthand for `image-dired-display-thumbs' with prefix argument." '(dired-mode)) +(autoload 'image-dired-dired-display-external "image-dired-dired" "\ +Display file at point using an external viewer." '(dired-mode)) +(autoload 'image-dired-dired-display-image "image-dired-dired" "\ Display current image file. See documentation for `image-dired-display-image' for more information. -With prefix argument ARG, display image in its original size. -(fn &optional ARG)" t) -(autoload 'image-dired-dired-comment-files "image-dired" "\ -Add comment to current or marked files in Dired." t) -(autoload 'image-dired-mark-tagged-files "image-dired" "\ +(fn &optional _)" '(dired-mode)) +(set-advertised-calling-convention 'image-dired-dired-display-image 'nil '"29.1") +(autoload 'image-dired-mark-tagged-files "image-dired-dired" "\ Use REGEXP to mark files with matching tag. A `tag' is a keyword, a piece of meta data, associated with an image file and stored in image-dired's database file. This command @@ -17035,18 +17083,38 @@ lets you input a regexp and this will be matched against all tags on all image files in the database file. The files that have a matching tag will be marked in the Dired buffer. -(fn REGEXP)" t) -(autoload 'image-dired-dired-edit-comment-and-tags "image-dired" "\ +(fn REGEXP)" '(dired-mode)) +(register-definition-prefixes "image-dired-dired" '("image-dired-")) + + +;;; Generated autoloads from image/image-dired-external.el + +(register-definition-prefixes "image-dired-external" '("image-dired-")) + + +;;; Generated autoloads from image/image-dired-tags.el + +(autoload 'image-dired-tag-files "image-dired-tags" "\ +Tag marked file(s) in Dired. With prefix ARG, tag file at point. + +(fn ARG)" '(dired-mode)) +(autoload 'image-dired-delete-tag "image-dired-tags" "\ +Remove tag for selected file(s). +With prefix argument ARG, remove tag from file at point. + +(fn ARG)" '(dired-mode)) +(autoload 'image-dired-dired-comment-files "image-dired-tags" "\ +Add comment to current or marked files in Dired." '(dired-mode)) +(autoload 'image-dired-dired-edit-comment-and-tags "image-dired-tags" "\ Edit comment and tags of current or marked image files. Edit comment and tags for all marked image files in an -easy-to-use form." t) -(autoload 'image-dired-bookmark-jump "image-dired" "\ -Default bookmark handler for Image-Dired buffers. +easy-to-use form." '(dired-mode)) +(register-definition-prefixes "image-dired-tags" '("image-dired-")) -(fn BOOKMARK)") -(define-obsolete-function-alias 'tumme #'image-dired "24.4") -(define-obsolete-function-alias 'image-dired-setup-dired-keybindings #'image-dired-minor-mode "26.1") -(register-definition-prefixes "image-dired" '("image-dired-")) + +;;; Generated autoloads from image/image-dired-util.el + +(register-definition-prefixes "image-dired-util" '("image-dired-")) ;;; Generated autoloads from image-file.el @@ -18488,7 +18556,7 @@ This option also treats some characters in the `mule-unicode-...' charsets if you don't have a Unicode font with which to display them. Setting this variable directly does not take effect; -use either \\[customize] or the function `latin1-display'.") +use either \\[customize] or the command `latin1-display'.") (custom-autoload 'latin1-display "latin1-disp" nil) (autoload 'latin1-display "latin1-disp" "\ Set up Latin-1/ASCII display for the arguments character SETS. @@ -18504,7 +18572,7 @@ This uses the transliterations of the Lynx browser. The display isn't changed if the display can render Unicode characters. Setting this variable directly does not take effect; -use either \\[customize] or the function `latin1-display'.") +use either \\[customize] or the command `latin1-display-ucs-per-lynx'.") (custom-autoload 'latin1-display-ucs-per-lynx "latin1-disp" nil) (autoload 'latin1-display-ucs-per-lynx "latin1-disp" "\ Set up Latin-1/ASCII display for Unicode characters. @@ -21908,7 +21976,7 @@ Coloring: ;;; Generated autoloads from org/org.el -(push (purecopy '(org 9 5 4)) package--builtin-versions) +(push (purecopy '(org 9 5 5)) package--builtin-versions) (autoload 'org-babel-do-load-languages "org" "\ Load the languages defined in `org-babel-load-languages'. @@ -24827,8 +24895,8 @@ Run an inferior Python process. Argument CMD defaults to `python-shell-calculate-command' return value. When called interactively with `prefix-arg', it allows the user to edit such value and choose whether the interpreter -should be DEDICATED for the current buffer. When numeric prefix -arg is other than 0 or 4 do not SHOW. +should be DEDICATED to the current buffer or project. When +numeric prefix arg is other than 0 or 4 do not SHOW. For a given buffer and same values of DEDICATED, if a process is already running for it, it will do nothing. This means that if @@ -24840,6 +24908,37 @@ Runs the hook `inferior-python-mode-hook' after process buffer for a list of commands.) (fn &optional CMD DEDICATED SHOW)" t) +(autoload 'python-add-import "python" "\ +Add an import statement to the current buffer. + +Interactively, ask for an import statement using all imports +found in the current project as suggestions. With a prefix +argument, restrict the suggestions to imports defining the symbol +at point. If there is only one such suggestion, act without +asking. + +When calling from Lisp, use a non-nil NAME to restrict the +suggestions to imports defining NAME. + +(fn NAME)" t) +(autoload 'python-import-symbol-at-point "python" "\ +Add an import statement for the symbol at point to the current buffer. +This works like `python-add-import', but with the opposite +behavior regarding the prefix argument." t) +(autoload 'python-remove-import "python" "\ +Remove an import statement from the current buffer. + +Interactively, ask for an import statement to remove, displaying +the imports of the current buffer as suggestions. With a prefix +argument, restrict the suggestions to imports defining the symbol +at point. If there is only one such suggestion, act without +asking. + +(fn NAME)" t) +(autoload 'python-sort-imports "python" "\ +Sort Python imports in the current buffer." t) +(autoload 'python-fix-imports "python" "\ +Add missing imports and remove unused ones from the current buffer." t) (autoload 'python-mode "python" "\ Major mode for editing Python files. @@ -25360,8 +25459,6 @@ evaluate `rectangle-mark-mode'. The mode's hook is called both when the mode is enabled and when it is disabled. -\\{rectangle-mark-mode-map} - (fn &optional ARG)" t) (register-definition-prefixes "rect" '("apply-on-rectangle" "clear-rectangle-line" "delete-" "extract-rectangle-" "killed-rectangle" "ope" "rectangle-" "spaces-string" "string-rectangle-")) @@ -31755,7 +31852,7 @@ It must be supported by libarchive(3).") List of suffixes which indicate a compressed file. It must be supported by libarchive(3).") (defmacro tramp-archive-autoload-file-name-regexp nil "\ -Regular expression matching archive file names." '(rx bos (group (+ nonl) "." (regexp (regexp-opt tramp-archive-suffixes)) (32 "." (regexp (regexp-opt tramp-archive-compression-suffixes)))) (group "/" (* nonl)) eos)) +Regular expression matching archive file names." `(rx bos (group (+ nonl) "." ,(cons '| tramp-archive-suffixes) (32 "." ,(cons '| tramp-archive-compression-suffixes))) (group "/" (* nonl)) eos)) (autoload 'tramp-archive-file-name-handler "tramp-archive") (defun tramp-archive-autoload-file-name-handler (operation &rest args) "\ Load Tramp archive file name handler, and perform OPERATION." (defvar tramp-archive-autoload) (let ((default-directory temporary-file-directory) (tramp-archive-autoload tramp-archive-enabled)) (apply #'tramp-autoload-file-name-handler operation args))) @@ -31778,6 +31875,7 @@ Add archive file name handler to `file-name-handler-alist'." (when (and tramp-ar ;;; Generated autoloads from net/tramp-compat.el + (defalias 'tramp-compat-rx #'rx) (register-definition-prefixes "tramp-compat" '("tramp-")) @@ -32593,14 +32691,14 @@ Fetch a GNU Info URL. (fn URL)") -(defalias 'url-rlogin 'url-generic-emulator-loader) +(define-obsolete-function-alias 'url-rlogin #'url-generic-emulator-loader "29.1") (defalias 'url-telnet 'url-generic-emulator-loader) (defalias 'url-tn3270 'url-generic-emulator-loader) (autoload 'url-data "url-misc" "\ Fetch a data URL (RFC 2397). (fn URL)") -(register-definition-prefixes "url-misc" '("url-do-terminal-emulator")) +(register-definition-prefixes "url-misc" '("url-")) ;;; Generated autoloads from url/url-news.el @@ -33161,6 +33259,12 @@ given, the tag is made as a new branch and the files are checked out in that new branch. (fn DIR NAME BRANCHP)" t) +(autoload 'vc-create-branch "vc" "\ +Descending recursively from DIR, make a branch called NAME. +After a new branch is made, the files are checked out in that new branch. +Uses `vc-create-tag' with the non-nil arg `branchp'. + +(fn DIR NAME)" t) (autoload 'vc-retrieve-tag "vc" "\ For each file in or below DIR, retrieve their tagged version NAME. NAME can name a branch, in which case this command will switch to the @@ -33171,8 +33275,16 @@ If NAME is empty, it refers to the latest revisions of the current branch. If locking is used for the files in DIR, then there must not be any locked files at or below DIR (but if NAME is empty, locked files are allowed and simply skipped). +If the prefix argument BRANCHP is given, switch the branch +and check out the files in that branch. This function runs the hook `vc-retrieve-tag-hook' when finished. +(fn DIR NAME &optional BRANCHP)" t) +(autoload 'vc-switch-branch "vc" "\ +Switch to the branch NAME in the directory DIR. +If NAME is empty, it refers to the latest revisions of the current branch. +Uses `vc-retrieve-tag' with the non-nil arg `branchp'. + (fn DIR NAME)" t) (autoload 'vc-print-log "vc" "\ List the change log of the current fileset in a window. @@ -33446,6 +33558,13 @@ case, and the process object in the asynchronous case. ;;; Generated autoloads from vc/vc-git.el +(autoload 'vc-git-annotate-switches-safe-p "vc-git" "\ +Check if local value of `vc-git-annotate-switches' is safe. +Currently only \"-w\" (ignore whitespace) is considered safe, but +this list might be extended in the future. + +(fn SWITCHES)") +(put 'vc-git-annotate-switches 'safe-local-variable #'vc-git-annotate-switches-safe-p) (defun vc-git-registered (file) "Return non-nil if FILE is registered with git." (if (vc-find-root file ".git") ; Short cut. @@ -35636,7 +35755,7 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT. ;;; Generated autoloads from progmodes/xref.el -(push (purecopy '(xref 1 5 0)) package--builtin-versions) +(push (purecopy '(xref 1 5 1)) package--builtin-versions) (autoload 'xref-find-backend "xref") (define-obsolete-function-alias 'xref-pop-marker-stack #'xref-go-back "29.1") (autoload 'xref-go-back "xref" "\ @@ -35855,6 +35974,7 @@ Zone out, completely." t) ;; no-byte-compile: t ;; version-control: never ;; no-update-autoloads: t +;; no-native-compile: t ;; coding: utf-8-emacs-unix ;; End: commit fffa53ff1afe097fe38f7664df5debe9811201d1 Author: Philipp Stephani Date: Tue Sep 13 17:12:57 2022 +0200 Have 'cl-case' warn about suspicious cases * lisp/emacs-lisp/cl-macs.el (cl-case): Warn if the user passes a nil key list (which would never match). Warn about quoted symbols that should probably be unquoted. * test/lisp/emacs-lisp/cl-macs-tests.el (cl-case-warning): New unit test (bug#51368). diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 946d2c09a9..5d330f32d6 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -788,6 +788,21 @@ compared by `eql'. ((eq (car c) 'cl--ecase-error-flag) `(error "cl-ecase failed: %s, %s" ,temp ',(reverse head-list))) + ((null (car c)) + (macroexp-warn-and-return + "Case nil will never match" + nil 'suspicious)) + ((and (consp (car c)) (not (cddar c)) + (memq (caar c) '(quote function))) + (macroexp-warn-and-return + (format-message + (concat "Case %s will match `%s'. If " + "that's intended, write %s " + "instead. Otherwise, don't " + "quote `%s'.") + (car c) (caar c) (list (cadar c) (caar c)) + (cadar c)) + `(cl-member ,temp ',(car c)) 'suspicious)) ((listp (car c)) (setq head-list (append (car c) head-list)) `(cl-member ,temp ',(car c))) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 77817abd85..427b8f4689 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -25,6 +25,8 @@ (require 'cl-macs) (require 'edebug) (require 'ert) +(require 'ert-x) +(require 'pcase) ;;;; cl-loop tests -- many adapted from Steele's CLtL2 @@ -758,4 +760,34 @@ collection clause." (should (equal (cdr error) '("Misplaced t or `otherwise' clause"))))))) +(ert-deftest cl-case-warning () + "Test that `cl-case' and `cl-ecase' warn about suspicious +constructs." + (pcase-dolist (`(,case . ,message) + `((nil . "Case nil will never match") + ('nil . ,(concat "Case 'nil will match `quote'. " + "If that's intended, write " + "(nil quote) instead. " + "Otherwise, don't quote `nil'.")) + ('t . ,(concat "Case 't will match `quote'. " + "If that's intended, write " + "(t quote) instead. " + "Otherwise, don't quote `t'.")) + ('foo . ,(concat "Case 'foo will match `quote'. " + "If that's intended, write " + "(foo quote) instead. " + "Otherwise, don't quote `foo'.")) + (#'foo . ,(concat "Case #'foo will match " + "`function'. If that's " + "intended, write (foo function) " + "instead. Otherwise, don't " + "quote `foo'.")))) + (dolist (macro '(cl-case cl-ecase)) + (let ((form `(,macro val (,case 1)))) + (ert-info ((prin1-to-string form) :prefix "Form: ") + (ert-with-message-capture messages + (macroexpand form) + (should (equal messages + (concat "Warning: " message "\n"))))))))) + ;;; cl-macs-tests.el ends here commit 6d8f5161ead689b7a2e44a7de0a695f0ab4c833b Author: Philipp Stephani Date: Tue Sep 13 17:11:53 2022 +0200 Signal an error if a fallback cl-case is misplaced * lisp/emacs-lisp/cl-macs.el (cl-case): Warn if the user passes a nil key list (which would never match). Warn about quoted symbols that should probably be unquoted. * test/lisp/emacs-lisp/cl-macs-tests.el (cl-case-warning): New unit test (bug#51368). diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index f8fdc50251..946d2c09a9 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -775,11 +775,16 @@ compared by `eql'. \(fn EXPR (KEYLIST BODY...)...)" (declare (indent 1) (debug (form &rest (sexp body)))) (macroexp-let2 macroexp-copyable-p temp expr - (let* ((head-list nil)) + (let* ((head-list nil) + (has-otherwise nil)) `(cond ,@(mapcar (lambda (c) - (cons (cond ((memq (car c) '(t otherwise)) t) + (cons (cond (has-otherwise + (error "Misplaced t or `otherwise' clause")) + ((memq (car c) '(t otherwise)) + (setq has-otherwise t) + t) ((eq (car c) 'cl--ecase-error-flag) `(error "cl-ecase failed: %s, %s" ,temp ',(reverse head-list))) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 68898720d9..77817abd85 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -747,4 +747,15 @@ collection clause." ;; Just make sure the forms can be instrumented. (eval-buffer)))) +(ert-deftest cl-case-error () + "Test that `cl-case' and `cl-ecase' signal an error if a t or +`otherwise' key is misplaced." + (dolist (form '((cl-case val (t 1) (123 2)) + (cl-ecase val (t 1) (123 2)) + (cl-ecase val (123 2) (t 1)))) + (ert-info ((prin1-to-string form) :prefix "Form: ") + (let ((error (should-error (macroexpand form)))) + (should (equal (cdr error) + '("Misplaced t or `otherwise' clause"))))))) + ;;; cl-macs-tests.el ends here commit 07ee1be052a45d8e6f671d0851f11c545dd9511a Author: Lars Ingebrigtsen Date: Tue Sep 13 16:37:31 2022 +0200 Move imagep in image.c from the debugging section * lisp/simple.el (imagep): Remove. * src/image.c (Fimagep): Always define. diff --git a/lisp/simple.el b/lisp/simple.el index 85c43df2f5..60f2ad3452 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -10717,10 +10717,6 @@ If the buffer doesn't exist, create it first." (plist-put plist prop val #'equal)) -(defun imagep (object) - "Return non-nil if OBJECT is an image." - (and (consp object) (eq (car object) 'image))) - (provide 'simple) ;;; simple.el ends here diff --git a/src/image.c b/src/image.c index 551da71643..1e323ba66a 100644 --- a/src/image.c +++ b/src/image.c @@ -11838,9 +11838,6 @@ x_kill_gs_process (Pixmap pixmap, struct frame *f) /*********************************************************************** Tests ***********************************************************************/ - -#ifdef GLYPH_DEBUG - DEFUN ("imagep", Fimagep, Simagep, 1, 1, 0, doc: /* Value is non-nil if SPEC is a valid image specification. */) (Lisp_Object spec) @@ -11848,6 +11845,7 @@ DEFUN ("imagep", Fimagep, Simagep, 1, 1, 0, return valid_image_p (spec) ? Qt : Qnil; } +#ifdef GLYPH_DEBUG DEFUN ("lookup-image", Flookup_image, Slookup_image, 1, 1, 0, doc: /* */) @@ -12240,9 +12238,9 @@ non-numeric, there is no explicit limit on the size of images. */); defsubr (&Simage_mask_p); defsubr (&Simage_metadata); defsubr (&Simage_cache_size); + defsubr (&Simagep); #ifdef GLYPH_DEBUG - defsubr (&Simagep); defsubr (&Slookup_image); #endif commit 7e374b96635ce70f574fba351defc765e9a52da9 Author: Lars Ingebrigtsen Date: Tue Sep 13 16:14:37 2022 +0200 Fix help--analyze-key problem when not called from menu * lisp/help.el (help--analyze-key): Don't bug out when not called from the menu. diff --git a/lisp/help.el b/lisp/help.el index 92b87cf799..a95bbaa4ae 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -725,7 +725,8 @@ in the selected window." ;; is selected from the context menu that should describe KEY ;; at the position of mouse click that opened the context menu. ;; When no mouse was involved, don't use `posn-set-point'. - (defn (if buffer + (defn (if (or buffer + (not (consp (event-end event)))) (key-binding key t) (save-excursion (posn-set-point (event-end event)) (key-binding key t))))) commit 48c562fb748623ed01385eaf215333a6c2edac80 Author: Eli Zaretskii Date: Tue Sep 13 17:12:40 2022 +0300 ; * src/image.c (svg_load_image): Another minor cleanup. (Bug#51104) diff --git a/src/image.c b/src/image.c index 52fdf86138..551da71643 100644 --- a/src/image.c +++ b/src/image.c @@ -11183,6 +11183,10 @@ svg_load_image (struct frame *f, struct image *img, char *contents, char *wrapped_contents = NULL; ptrdiff_t wrapped_size; + bool empty_errmsg = true; + const char *errmsg = ""; + ptrdiff_t errlen = 0; + #if LIBRSVG_CHECK_VERSION (2, 48, 0) char *css = NULL; #endif @@ -11540,20 +11544,22 @@ svg_load_image (struct frame *f, struct image *img, char *contents, return true; rsvg_error: - if (!err || !err->message[0]) - image_error ("Error parsing SVG image"); - else + if (err && err->message[0]) { - char *errmsg = err->message; - ptrdiff_t errlen = strlen (errmsg); - + errmsg = err->message; + errlen = strlen (errmsg); /* Remove trailing whitespace from the error message text. It has a newline at the end, and perhaps more whitespace. */ - while (c_isspace (errmsg[errlen - 1])) + while (errlen && c_isspace (errmsg[errlen - 1])) errlen--; - image_error ("Error parsing SVG image: %s", make_string (errmsg, errlen)); + empty_errmsg = errlen == 0; } + if (empty_errmsg) + image_error ("Error parsing SVG image"); + else + image_error ("Error parsing SVG image: %s", make_string (errmsg, errlen)); + if (err) g_error_free (err); commit 07c0e090bd17204bb1a7670716974c566a8ff6ae Author: Lars Ingebrigtsen Date: Tue Sep 13 15:52:56 2022 +0200 Add new commands 'image-crop' and 'image-elide' * doc/lispref/display.texi (Showing Images): Document it. * lisp/image.el (image-map): Bind commands. * lisp/image/image-crop.el: New file (bug#51331). diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 69b752688e..32cf01b237 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -6863,6 +6863,12 @@ A prefix means to rotate by 90 degrees counter-clockwise instead. @item o Save the image to a file (@code{image-save}). + +@item c +Crop the image interactively (@code{image-crop}). + +@item e +Elide a rectangle from the image interactively (@code{image-elide}). @end table @node Multi-Frame Images diff --git a/etc/NEWS b/etc/NEWS index 35d3db5ceb..726c78afbf 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2429,6 +2429,13 @@ The old name is still available as an obsolete function alias. * New Modes and Packages in Emacs 29.1 ++++ +** New commands 'image-crop' and 'image-elide'. +These commands allow interactively cropping/eliding the image under +point. These commands are bound to 'c' and 'e' (respectively) in the +local keymap over images. They rely on external programs to do the +actual cropping/eliding of the image file. + +++ ** New package 'oclosure'. Allows the creation of "functions with slots" or "function objects" diff --git a/lisp/image.el b/lisp/image.el index 9311125450..bbc3b996b1 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -178,6 +178,8 @@ or \"ffmpeg\") is installed." "+" #'image-increase-size "r" #'image-rotate "o" #'image-save + "c" #'image-crop + "e" #'image-elide "h" #'image-flip-horizontally "v" #'image-flip-vertically "C-" #'image-mouse-decrease-size diff --git a/lisp/image/image-crop.el b/lisp/image/image-crop.el new file mode 100644 index 0000000000..1a533aaf42 --- /dev/null +++ b/lisp/image/image-crop.el @@ -0,0 +1,366 @@ +;;; image-crop.el --- Image Cropping -*- lexical-binding: t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Keywords: multimedia + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This package provides an interface for cropping images +;; interactively, but relies on external programs to do the actual +;; modifications to files. + +;;; Code: + +(require 'svg) + +(defvar image-crop-exif-rotate nil + "If non-nil, rotate images by updating exif data. +If nil, rotate the images \"physically\".") + +(defvar image-crop-resize-command '("convert" "-resize" "%wx" "-" "%f:-") + "Command to resize an image. +The following `format-spec' elements are allowed: + +%w: Width. +%f: Result file type.") + +(defvar image-crop-elide-command '("convert" "-draw" "rectangle %l,%t %r,%b" + "-" "%f:-") + "Command to make a rectangle inside an image. + +The following `format-spec' elements are allowed: +%l: Left. +%t: Top. +%r: Right. +%b: Bottom. +%f: Result file type.") + +(defvar image-crop-crop-command '("convert" "+repage" "-crop" "%wx%h+%l+%t" + "-" "%f:-") + "Command to crop an image. + +The following `format-spec' elements are allowed: +%l: Left. +%t: Top. +%w: Width. +%h: Height. +%f: Result file type.") + +(defvar image-crop-rotate-command '("convert" "-rotate" "%r" "-" "%f:-") + "Command to rotate an image. + +The following `format-spec' elements are allowed: +%r: Rotation (in degrees). +%f: Result file type.") + +;;;###autoload +(defun image-elide (&optional square) + "Elide a square from the image under point. +If SQUARE (interactively, the prefix), elide a square instead of a +rectangle from the image." + (interactive "P") + (image-crop square t)) + +;;;###autoload +(defun image-crop (&optional square elide) + "Crop the image under point. +If SQUARE (interactively, the prefix), crop a square instead of a +rectangle from the image. + +If ELIDE, remove a rectangle from the image instead of cropping +the image. + +After cropping an image, it can be saved by `M-x image-save' or +\\\\[image-save] when point is over the image." + (interactive "P") + (unless (image-type-available-p 'svg) + (error "SVG support is needed to crop images")) + (unless (executable-find (car image-crop-crop-command)) + (error "Couldn't find %s command to crop the image" + (car image-crop-crop-command))) + (let ((image (get-text-property (point) 'display))) + (unless (imagep image) + (user-error "No image under point")) + ;; We replace the image under point with an SVG image that looks + ;; just like that image. That allows us to draw lines over it. + ;; At the end, we replace that SVG with a cropped version of the + ;; original image. + (let* ((data (cl-getf (cdr image) :data)) + (undo-handle (prepare-change-group)) + (type (cond + ((cl-getf (cdr image) :format) + (format "%s" (cl-getf (cdr image) :format))) + (data + (image-crop--content-type data)))) + (image-scaling-factor 1) + (size (image-size image t)) + (svg (svg-create (car size) (cdr size) + :xmlns:xlink "http://www.w3.org/1999/xlink" + :stroke-width 5)) + (text (buffer-substring (pos-bol) (pos-eol))) + (inhibit-read-only t) + orig-data) + (with-temp-buffer + (set-buffer-multibyte nil) + (if (null data) + (insert-file-contents-literally (cl-getf (cdr image) :file)) + (insert data)) + (let ((image-crop-exif-rotate nil)) + (image-crop--possibly-rotate-buffer image)) + (setq orig-data (buffer-string)) + (setq type (image-crop--content-type orig-data)) + (image-crop--process image-crop-resize-command + `((?w . 600) + (?f . ,(cadr (split-string type "/"))))) + (setq data (buffer-string))) + (svg-embed svg data type t + :width (car size) + :height (cdr size)) + (delete-region (pos-bol) (pos-eol)) + (svg-insert-image svg) + (let ((area (condition-case _ + (save-excursion + (forward-line 1) + (image-crop--crop-image-1 + svg square (car size) (cdr size))) + (quit nil)))) + (delete-region (pos-bol) (pos-eol)) + (if area + (image-crop--crop-image-update area orig-data size type elide) + ;; If the user didn't complete the crop, re-insert the + ;; original image (and text). + (insert text)) + (undo-amalgamate-change-group undo-handle))))) + +(defun image-crop--crop-image-update (area data size type elide) + (let* ((image-scaling-factor 1) + (osize (image-size (create-image data nil t) t)) + (factor (/ (float (car osize)) (car size))) + ;; width x height + left + top + (width (abs (truncate (* factor (- (cl-getf area :right) + (cl-getf area :left)))))) + (height (abs (truncate (* factor (- (cl-getf area :bottom) + (cl-getf area :top)))))) + (left (truncate (* factor (min (cl-getf area :left) + (cl-getf area :right))))) + (top (truncate (* factor (min (cl-getf area :top) + (cl-getf area :bottom)))))) + (image-crop--insert-image-data + (with-temp-buffer + (set-buffer-multibyte nil) + (insert data) + (if elide + (image-crop--process image-crop-elide-command + `((?l . ,left) + (?t . ,top) + (?r . ,(+ left width)) + (?b . ,(+ top height)) + (?f . ,(cadr (split-string type "/"))))) + (image-crop--process image-crop-crop-command + `((?l . ,left) + (?t . ,top) + (?w . ,width) + (?h . ,height) + (?f . ,(cadr (split-string type "/")))))) + (buffer-string))))) + +(defun image-crop--crop-image-1 (svg &optional square image-width image-height) + (track-mouse + (cl-loop + with prompt = (if square "Move square" "Set start point") + and state = (if square 'move-unclick 'begin) + and area = (if square + (list :left (- (/ image-width 2) + (/ image-height 2)) + :top 0 + :right (+ (/ image-width 2) + (/ image-height 2)) + :bottom image-height) + (list :left 0 + :top 0 + :right 0 + :bottom 0)) + and corner = nil + for event = (read-event prompt) + do (if (or (not (consp event)) + (not (consp (cadr event))) + (not (nth 7 (cadr event))) + ;; Only do things if point is over the SVG being + ;; tracked. + (not (eq (cl-getf (cdr (nth 7 (cadr event))) :type) + 'svg))) + () + (let ((pos (nth 8 (cadr event)))) + (cl-case state + ('begin + (cond + ((eq (car event) 'down-mouse-1) + (setq state 'stretch + prompt "Stretch to end point") + (setf (cl-getf area :left) (car pos) + (cl-getf area :top) (cdr pos) + (cl-getf area :right) (car pos) + (cl-getf area :bottom) (cdr pos))))) + ('stretch + (cond + ((eq (car event) 'mouse-movement) + (setf (cl-getf area :right) (car pos) + (cl-getf area :bottom) (cdr pos))) + ((memq (car event) '(mouse-1 drag-mouse-1)) + (setq state 'corner + prompt "Choose corner to adjust (RET to crop)")))) + ('corner + (cond + ((eq (car event) 'down-mouse-1) + ;; Find out what corner we're close to. + (setq corner (image-crop--find-corner + area pos + '((:left :top) + (:left :bottom) + (:right :top) + (:right :bottom)))) + (when corner + (setq state 'adjust + prompt "Adjust crop"))))) + ('adjust + (cond + ((memq (car event) '(mouse drag-mouse-1)) + (setq state 'corner + prompt "Choose corner to adjust")) + ((eq (car event) 'mouse-movement) + (setf (cl-getf area (car corner)) (car pos) + (cl-getf area (cadr corner)) (cdr pos))))) + ('move-unclick + (cond + ((eq (car event) 'down-mouse-1) + (setq state 'move-click + prompt "Move")))) + ('move-click + (cond + ((eq (car event) 'mouse-movement) + (setf (cl-getf area :left) (car pos) + (cl-getf area :right) (+ (car pos) image-height))) + ((memq (car event) '(mouse-1 drag-mouse-1)) + (setq state 'move-unclick + prompt "Click to move"))))))) + do (svg-line svg (cl-getf area :left) (cl-getf area :top) + (cl-getf area :right) (cl-getf area :top) + :id "top-line" :stroke-color "white") + (svg-line svg (cl-getf area :left) (cl-getf area :bottom) + (cl-getf area :right) (cl-getf area :bottom) + :id "bottom-line" :stroke-color "white") + (svg-line svg (cl-getf area :left) (cl-getf area :top) + (cl-getf area :left) (cl-getf area :bottom) + :id "left-line" :stroke-color "white") + (svg-line svg (cl-getf area :right) (cl-getf area :top) + (cl-getf area :right) (cl-getf area :bottom) + :id "right-line" :stroke-color "white") + while (not (member event '(return ?q))) + finally (return (and (eq event 'return) + area))))) + +(defun image-crop--find-corner (area pos corners) + (cl-loop for corner in corners + ;; We accept 10 pixels off. + when (and (< (- (car pos) 10) + (cl-getf area (car corner)) + (+ (car pos) 10)) + (< (- (cdr pos) 10) + (cl-getf area (cadr corner)) + (+ (cdr pos) 10))) + return corner)) + +(defun image-crop--content-type (image) + ;; Get the MIME type by running "file" over it. + (with-temp-buffer + (set-buffer-multibyte nil) + (insert image) + (call-process-region (point-min) (point-max) + "file" t (current-buffer) nil + "--mime-type" "-") + (cadr (split-string (buffer-string))))) + +(defun image-crop--possibly-rotate-buffer (image) + (when (imagep image) + (let ((content-type (image-crop--content-type (buffer-string)))) + (when (image-property image :rotation) + (cond + ;; We can rotate jpegs losslessly by setting the correct + ;; orientation. + ((and image-crop-exif-rotate + (equal content-type "image/jpeg") + (executable-find "exiftool")) + (call-process-region + (point-min) (point-max) "exiftool" t (list (current-buffer) nil) nil + (format "-Orientation#=%d" + (cl-case (truncate (image-property image :rotation)) + (0 0) + (90 6) + (180 3) + (270 8) + (otherwise 0))) + "-o" "-" "-")) + ;; Most other image formats have to be reencoded to do + ;; rotation. + (t + (image-crop--process + image-crop-rotate-command + `((?r . ,(image-property image :rotation)) + (?f . ,(cadr (split-string content-type "/"))))) + (when (and (equal content-type "image/jpeg") + (executable-find "exiftool")) + (call-process-region + (point-min) (point-max) "exiftool" + t (list (current-buffer) nil) nil + "-Orientation#=0" + "-o" "-" "-"))))) + (when (image-property image :width) + (image-crop--process + image-crop-resize-command + `((?w . ,(image-property image :width)) + (?f . ,(cadr (split-string content-type "/"))))))))) + +(defun image-crop--insert-image-data (image) + (insert-image + (create-image image nil t + :max-width (- (frame-pixel-width) 50) + :max-height (- (frame-pixel-height) 150)) + (format "" + (image-crop--content-type image) + ;; Get a base64 version of the image. + (with-temp-buffer + (set-buffer-multibyte nil) + (insert image) + (base64-encode-region (point-min) (point-max) t) + (buffer-string))) + nil nil t)) + +(defun image-crop--process (command expansions) + "Use `call-process-region' with COMMAND expanded with EXPANSIONS." + (apply + #'call-process-region (point-min) (point-max) + (format-spec (car command) expansions) + t (list (current-buffer) nil) nil + (mapcar (lambda (elem) + (format-spec elem expansions)) + (cdr command)))) + +(provide 'image-crop) + +;;; image-crop.el ends here commit 36993bb9c2e96df80d37775ba658201ae7353395 Author: Lars Ingebrigtsen Date: Tue Sep 13 15:49:18 2022 +0200 Add new function imagep * lisp/simple.el (imagep): New function. diff --git a/lisp/simple.el b/lisp/simple.el index 60f2ad3452..85c43df2f5 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -10717,6 +10717,10 @@ If the buffer doesn't exist, create it first." (plist-put plist prop val #'equal)) +(defun imagep (object) + "Return non-nil if OBJECT is an image." + (and (consp object) (eq (car object) 'image))) + (provide 'simple) ;;; simple.el ends here commit 543b8717c7b4d82e2e0afdfe339be1d6bfdf5c97 Author: Eli Zaretskii Date: Tue Sep 13 16:49:02 2022 +0300 ; Add commentary to comp-tests.el Sigh... why do people insist on removing useful comments and leave their tricky code more obfuscated than it must be?? * test/src/comp-tests.el (comp-tests-type-spec-tests): Add a comment explaining why the expressions are quoted. (Bug#51104) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a400a1a50a..1edbd1777c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -860,6 +860,11 @@ Return a list of results." (cl-eval-when (compile eval load) (defconst comp-tests-type-spec-tests + ;; Why we quote everything here, you ask? So that values of + ;; `most-positive-fixnum' and `most-negative-fixnum', which can be + ;; architecture-dependent, do not end up hardcoded in the + ;; resulting byte-compiled file, and thus we could run the same + ;; .elc file on several architectures without fear. '( ;; 1 ((defun comp-tests-ret-type-spec-f (x) commit 7df898d532f922ea2a7acce4446bc35eec1da38e Author: Gerd Möllmann Date: Tue Sep 13 15:37:56 2022 +0200 Fix whitespace-tests on macOS * test/lisp/whitespace-tests.el (whitespace-tests--empty-bob): (whitespace-tests--empty-eob): Use C-a/C-e instead of / (bug#57763). diff --git a/test/lisp/whitespace-tests.el b/test/lisp/whitespace-tests.el index 792e157ec0..97c30c4d62 100644 --- a/test/lisp/whitespace-tests.el +++ b/test/lisp/whitespace-tests.el @@ -149,7 +149,7 @@ buffer's content." "»\t\n" "\n" " x")) - (execute-kbd-macro (kbd " ")) + (execute-kbd-macro (kbd " C-a")) (should (equal (point) 1)) (should (whitespace-tests--faceup " \n" "\t\n" @@ -187,7 +187,7 @@ buffer's content." "» x")) ;; Inserting content on line 2 should un-highlight lines 2 and 3. - (execute-kbd-macro (kbd " ")) + (execute-kbd-macro (kbd " C-e")) (should (equal (line-number-at-pos) 2)) (should (equal (- (point) (line-beginning-position)) 1)) (execute-kbd-macro (kbd "y ")) @@ -199,7 +199,7 @@ buffer's content." ;; Removing the content on line 2 should re-highlight lines 2 and ;; 3. - (execute-kbd-macro (kbd " ")) + (execute-kbd-macro (kbd " C-e")) (should (equal (line-number-at-pos) 2)) (should (equal (- (point) (line-beginning-position)) 2)) (execute-kbd-macro (kbd "DEL ")) @@ -288,7 +288,7 @@ buffer's content." " »")) ;; Inserting content on line 3 should un-highlight lines 2 and 3. - (execute-kbd-macro (kbd " ")) + (execute-kbd-macro (kbd " C-a")) (should (equal (line-number-at-pos) 3)) (should (equal (- (point) (line-beginning-position)) 0)) (execute-kbd-macro (kbd "y ")) @@ -300,7 +300,7 @@ buffer's content." ;; Removing the content on line 3 should re-highlight lines 2 and ;; 3. - (execute-kbd-macro (kbd " ")) + (execute-kbd-macro (kbd " C-a")) (should (equal (line-number-at-pos) 3)) (should (equal (- (point) (line-beginning-position)) 0)) (execute-kbd-macro (kbd " ")) commit b0b687150b059337e60a14bf062bff509fa83283 Merge: 96b221dd2a 93466e85d1 Author: Eli Zaretskii Date: Tue Sep 13 16:39:26 2022 +0300 Merge branch 'master' of git.savannah.gnu.org:/srv/git/emacs commit 96b221dd2a6f36143e2e132c5ee9d13d5f39d4b3 Author: Eli Zaretskii Date: Tue Sep 13 16:38:50 2022 +0300 ; * src/image.c (svg_load_image): Always free 'err' if non-NULL. diff --git a/src/image.c b/src/image.c index b1d597d721..52fdf86138 100644 --- a/src/image.c +++ b/src/image.c @@ -11552,9 +11552,11 @@ svg_load_image (struct frame *f, struct image *img, char *contents, while (c_isspace (errmsg[errlen - 1])) errlen--; image_error ("Error parsing SVG image: %s", make_string (errmsg, errlen)); - g_error_free (err); } + if (err) + g_error_free (err); + done_error: if (rsvg_handle) g_object_unref (rsvg_handle); commit 93466e85d138b7e0765b97f83d442202121b4298 Author: Stefan Monnier Date: Tue Sep 13 09:36:21 2022 -0400 comp-tests.el: Enable compilation again Rather than disable byte-compilation to circumvent bug#51104, change the ELisp code so that `most-positive/negative-fixnum` does not end up hardcoded in the `.elc` file. * test/src/comp-tests.el (comp-tests-define-type-spec-test): Don't quote the type expressions. (comp-tests-type-spec-tests): Quote them here instead. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index b85d365b0b..a400a1a50a 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -860,21 +860,21 @@ Return a list of results." (cl-eval-when (compile eval load) (defconst comp-tests-type-spec-tests - `( + '( ;; 1 ((defun comp-tests-ret-type-spec-f (x) x) - t) + 't) ;; 2 ((defun comp-tests-ret-type-spec-f () 1) - (integer 1 1)) + '(integer 1 1)) ;; 3 ((defun comp-tests-ret-type-spec-f (x) (if x 1 3)) - (or (integer 1 1) (integer 3 3))) + '(or (integer 1 1) (integer 3 3))) ;; 4 ((defun comp-tests-ret-type-spec-f (x) @@ -883,7 +883,7 @@ Return a list of results." (setf y 1) (setf y 2)) y)) - (integer 1 2)) + '(integer 1 2)) ;; 5 ((defun comp-tests-ret-type-spec-f (x) @@ -892,73 +892,73 @@ Return a list of results." (setf y 1) (setf y 3)) y)) - (or (integer 1 1) (integer 3 3))) + '(or (integer 1 1) (integer 3 3))) ;; 6 ((defun comp-tests-ret-type-spec-f (x) (if x (list x) 3)) - (or cons (integer 3 3))) + '(or cons (integer 3 3))) ;; 7 ((defun comp-tests-ret-type-spec-f (x) (if x 'foo 3)) - (or (member foo) (integer 3 3))) + '(or (member foo) (integer 3 3))) ;; 8 ((defun comp-tests-ret-type-spec-f (x) (if (eq x 3) x 'foo)) - (or (member foo) (integer 3 3))) + '(or (member foo) (integer 3 3))) ;; 9 ((defun comp-tests-ret-type-spec-f (x) (if (eq 3 x) x 'foo)) - (or (member foo) (integer 3 3))) + '(or (member foo) (integer 3 3))) ;; 10 ((defun comp-tests-ret-type-spec-f (x) (if (eql x 3) x 'foo)) - (or (member foo) (integer 3 3))) + '(or (member foo) (integer 3 3))) ;; 11 ((defun comp-tests-ret-type-spec-f (x) (if (eql 3 x) x 'foo)) - (or (member foo) (integer 3 3))) + '(or (member foo) (integer 3 3))) ;; 12 ((defun comp-tests-ret-type-spec-f (x) (if (eql x 3) 'foo x)) - (not (integer 3 3))) + '(not (integer 3 3))) ;; 13 ((defun comp-tests-ret-type-spec-f (x y) (if (= x y) x 'foo)) - (or (member foo) marker number)) + '(or (member foo) marker number)) ;; 14 ((defun comp-tests-ret-type-spec-f (x) (comp-hint-fixnum x)) - (integer ,most-negative-fixnum ,most-positive-fixnum)) + `(integer ,most-negative-fixnum ,most-positive-fixnum)) ;; 15 ((defun comp-tests-ret-type-spec-f (x) (comp-hint-cons x)) - cons) + 'cons) ;; 16 ((defun comp-tests-ret-type-spec-f (x) @@ -966,7 +966,7 @@ Return a list of results." (when x (setf y 4)) y)) - (or null (integer 4 4))) + '(or null (integer 4 4))) ;; 17 ((defun comp-tests-ret-type-spec-f () @@ -974,7 +974,7 @@ Return a list of results." (y 3)) (setf x y) y)) - (integer 3 3)) + '(integer 3 3)) ;; 18 ((defun comp-tests-ret-type-spec-f (x) @@ -982,120 +982,120 @@ Return a list of results." (when x (setf y x)) y)) - t) + 't) ;; 19 ((defun comp-tests-ret-type-spec-f (x y) (eq x y)) - boolean) + 'boolean) ;; 20 ((defun comp-tests-ret-type-spec-f (x) (when x 'foo)) - (or (member foo) null)) + '(or (member foo) null)) ;; 21 ((defun comp-tests-ret-type-spec-f (x) (unless x 'foo)) - (or (member foo) null)) + '(or (member foo) null)) ;; 22 ((defun comp-tests-ret-type-spec-f (x) (when (> x 3) x)) - (or null float (integer 4 *))) + '(or null float (integer 4 *))) ;; 23 ((defun comp-tests-ret-type-spec-f (x) (when (>= x 3) x)) - (or null float (integer 3 *))) + '(or null float (integer 3 *))) ;; 24 ((defun comp-tests-ret-type-spec-f (x) (when (< x 3) x)) - (or null float (integer * 2))) + '(or null float (integer * 2))) ;; 25 ((defun comp-tests-ret-type-spec-f (x) (when (<= x 3) x)) - (or null float (integer * 3))) + '(or null float (integer * 3))) ;; 26 ((defun comp-tests-ret-type-spec-f (x) (when (> 3 x) x)) - (or null float (integer * 2))) + '(or null float (integer * 2))) ;; 27 ((defun comp-tests-ret-type-spec-f (x) (when (>= 3 x) x)) - (or null float (integer * 3))) + '(or null float (integer * 3))) ;; 28 ((defun comp-tests-ret-type-spec-f (x) (when (< 3 x) x)) - (or null float (integer 4 *))) + '(or null float (integer 4 *))) ;; 29 ((defun comp-tests-ret-type-spec-f (x) (when (<= 3 x) x)) - (or null float (integer 3 *))) + '(or null float (integer 3 *))) ;; 30 ((defun comp-tests-ret-type-spec-f (x) (let ((y 3)) (when (> x y) x))) - (or null float (integer 4 *))) + '(or null float (integer 4 *))) ;; 31 ((defun comp-tests-ret-type-spec-f (x) (let ((y 3)) (when (> y x) x))) - (or null float (integer * 2))) + '(or null float (integer * 2))) ;; 32 ((defun comp-tests-ret-type-spec-f (x) (when (and (> x 3) (< x 10)) x)) - (or null float (integer 4 9))) + '(or null float (integer 4 9))) ;; 33 ((defun comp-tests-ret-type-spec-f (x) (when (or (> x 3) (< x 10)) x)) - (or null float integer)) + '(or null float integer)) ;; 34 ((defun comp-tests-ret-type-spec-f (x) (when (or (< x 3) (> x 10)) x)) - (or null float (integer * 2) (integer 11 *))) + '(or null float (integer * 2) (integer 11 *))) ;; 35 No float range support. ((defun comp-tests-ret-type-spec-f (x) (when (> x 1.0) x)) - (or null marker number)) + '(or null marker number)) ;; 36 ((defun comp-tests-ret-type-spec-f (x y) (when (and (> x 3) (> y 2)) (+ x y))) - (or null float (integer 7 *))) + '(or null float (integer 7 *))) ;; 37 ;; SBCL: (OR REAL NULL) @@ -1103,14 +1103,14 @@ Return a list of results." (when (and (<= x 3) (<= y 2)) (+ x y))) - (or null float (integer * 5))) + '(or null float (integer * 5))) ;; 38 ((defun comp-tests-ret-type-spec-f (x y) (when (and (< 1 x 5) (< 1 y 5)) (+ x y))) - (or null float (integer 4 8))) + '(or null float (integer 4 8))) ;; 39 ;; SBCL gives: (OR REAL NULL) @@ -1118,7 +1118,7 @@ Return a list of results." (when (and (<= 1 x 10) (<= 2 y 3)) (+ x y))) - (or null float (integer 3 13))) + '(or null float (integer 3 13))) ;; 40 ;; SBCL: (OR REAL NULL) @@ -1126,42 +1126,42 @@ Return a list of results." (when (and (<= 1 x 10) (<= 2 y 3)) (- x y))) - (or null float (integer -2 8))) + '(or null float (integer -2 8))) ;; 41 ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= 1 x) (<= 2 y 3)) (- x y))) - (or null float (integer -2 *))) + '(or null float (integer -2 *))) ;; 42 ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= 1 x 10) (<= 2 y)) (- x y))) - (or null float (integer * 8))) + '(or null float (integer * 8))) ;; 43 ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= x 10) (<= 2 y)) (- x y))) - (or null float (integer * 8))) + '(or null float (integer * 8))) ;; 44 ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= x 10) (<= y 3)) (- x y))) - (or null float integer)) + '(or null float integer)) ;; 45 ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= 2 x) (<= 3 y)) (- x y))) - (or null float integer)) + '(or null float integer)) ;; 46 ;; SBCL: (OR (RATIONAL (6) (30)) (SINGLE-FLOAT 6.0 30.0) @@ -1174,63 +1174,63 @@ Return a list of results." (< 1 j 5) (< 1 k 5)) (+ x y z i j k))) - (or null float (integer 12 24))) + '(or null float (integer 12 24))) ;; 47 ((defun comp-tests-ret-type-spec-f (x) (when (<= 1 x 5) (1+ x))) - (or null float (integer 2 6))) + '(or null float (integer 2 6))) ;;48 ((defun comp-tests-ret-type-spec-f (x) (when (<= 1 x 5) (1- x))) - (or null float (integer 0 4))) + '(or null float (integer 0 4))) ;; 49 ((defun comp-tests-ret-type-spec-f () (error "Foo")) - nil) + 'nil) ;; 50 ((defun comp-tests-ret-type-spec-f (x) (if (stringp x) x 'bar)) - (or (member bar) string)) + '(or (member bar) string)) ;; 51 ((defun comp-tests-ret-type-spec-f (x) (if (stringp x) 'bar x)) - (not string)) + '(not string)) ;; 52 ((defun comp-tests-ret-type-spec-f (x) (if (integerp x) x 'bar)) - (or (member bar) integer)) + '(or (member bar) integer)) ;; 53 ((defun comp-tests-ret-type-spec-f (x) (when (integerp x) x)) - (or null integer)) + '(or null integer)) ;; 54 ((defun comp-tests-ret-type-spec-f (x) (unless (symbolp x) x)) - t) + 't) ;; 55 ((defun comp-tests-ret-type-spec-f (x) (unless (integerp x) x)) - (not integer)) + '(not integer)) ;; 56 ((defun comp-tests-ret-type-spec-f (x) @@ -1238,7 +1238,7 @@ Return a list of results." (1 (message "one")) (5 (message "five"))) x) - t + 't ;; FIXME improve `comp-cond-cstrs-target-mvar' to cross block ;; boundary if necessary as this should return: ;; (or (integer 1 1) (integer 5 5)) @@ -1250,7 +1250,7 @@ Return a list of results." (eql x 3)) (error "Not foo or 3")) x) - (or (member foo) (integer 3 3))) + '(or (member foo) (integer 3 3))) ;;58 ((defun comp-tests-ret-type-spec-f (x y) @@ -1259,7 +1259,7 @@ Return a list of results." (<= x y)) x (error ""))) - (integer 0 *)) + '(integer 0 *)) ;; 59 ((defun comp-tests-ret-type-spec-f (x y) @@ -1268,7 +1268,7 @@ Return a list of results." (<= x y)) x (error ""))) - (or float (integer 3 10))) + '(or float (integer 3 10))) ;; 60 ((defun comp-tests-ret-type-spec-f (x y) @@ -1277,56 +1277,56 @@ Return a list of results." (>= x y)) x (error ""))) - (or float (integer 3 10))) + '(or float (integer 3 10))) ;; 61 ((defun comp-tests-ret-type-spec-f (x) (if (= x 1.0) x (error ""))) - (or (member 1.0) (integer 1 1))) + '(or (member 1.0) (integer 1 1))) ;; 62 ((defun comp-tests-ret-type-spec-f (x) (if (= x 1.0) x (error ""))) - (or (member 1.0) (integer 1 1))) + '(or (member 1.0) (integer 1 1))) ;; 63 ((defun comp-tests-ret-type-spec-f (x) (if (= x 1.1) x (error ""))) - (member 1.1)) + '(member 1.1)) ;; 64 ((defun comp-tests-ret-type-spec-f (x) (if (= x 1) x (error ""))) - (or (member 1.0) (integer 1 1))) + '(or (member 1.0) (integer 1 1))) ;; 65 ((defun comp-tests-ret-type-spec-f (x) (if (= x 1) x (error ""))) - (or (member 1.0) (integer 1 1))) + '(or (member 1.0) (integer 1 1))) ;; 66 ((defun comp-tests-ret-type-spec-f (x) (if (eql x 0.0) x (error ""))) - float) + 'float) ;; 67 ((defun comp-tests-ret-type-spec-f (x) (if (equal x '(1 2 3)) x (error ""))) - cons) + 'cons) ;; 68 ((defun comp-tests-ret-type-spec-f (x) @@ -1335,7 +1335,7 @@ Return a list of results." x (error ""))) ;; Conservative (see cstr relax in `comp-cstr-='). - (or (member 1.0) (integer 1 1))) + '(or (member 1.0) (integer 1 1))) ;; 69 ((defun comp-tests-ret-type-spec-f (x) @@ -1344,7 +1344,7 @@ Return a list of results." x (error ""))) ;; Conservative (see cstr relax in `comp-cstr-='). - (or (member 1.0) (integer 1 1))) + '(or (member 1.0) (integer 1 1))) ;; 70 ((defun comp-tests-ret-type-spec-f (x y) @@ -1353,14 +1353,14 @@ Return a list of results." (= x y)) x (error ""))) - (or float integer)) + '(or float integer)) ;; 71 ((defun comp-tests-ret-type-spec-f (x) (if (= x 0.0) x (error ""))) - (or (member -0.0 0.0) (integer 0 0))) + '(or (member -0.0 0.0) (integer 0 0))) ;; 72 ((defun comp-tests-ret-type-spec-f (x) @@ -1369,27 +1369,27 @@ Return a list of results." (unless (eql x -0.0) (error "")) x) - float) + 'float) ;; 73 ((defun comp-tests-ret-type-spec-f (x) (when (eql x 1.0) (error "")) x) - t) + 't) ;; 74 ((defun comp-tests-ret-type-spec-f (x) (if (eq x 0) (error "") (1+ x))) - number))) + 'number))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () ,(format "Type specifier test number %d." number) (let ((comp-ctxt (make-comp-cstr-ctxt))) - (comp-tests-check-ret-type-spec ',(car x) ',(cadr x)))))) + (comp-tests-check-ret-type-spec ',(car x) ,(cadr x)))))) (defmacro comp-tests-define-type-spec-tests () "Define all type specifier tests." @@ -1472,13 +1472,4 @@ folded." (equal (comp-mvar-typeset mvar) comp-tests-cond-rw-expected-type)))))))) -;; We don't want to byte compile this to avoid recording in the -;; bytecode the architecture-dependent values of most-positive-fixnum -;; and most-negative-fixnum, thus making the byte-compiled file -;; non-portable. - -;; Local Variables: -;; no-byte-compile: t -;; End: - ;;; comp-tests.el ends here commit dfbe745ed9ba89e516ef89955f2ca88be04d1d72 Author: Eli Zaretskii Date: Tue Sep 13 16:26:50 2022 +0300 Fix last change in image.c * src/image.c (svg_load_image): Don't call Lisp to remove trailing whitespace from librsvg error messages, do it in C instead; this reduces consing and is much cleaner. Don't display empty error reason if librsvg happens to return an empty message text. (syms_of_image): Don't DEFSYM string-trim-right. (Bug#57755) diff --git a/src/image.c b/src/image.c index 2e04685e7f..b1d597d721 100644 --- a/src/image.c +++ b/src/image.c @@ -11540,13 +11540,18 @@ svg_load_image (struct frame *f, struct image *img, char *contents, return true; rsvg_error: - if (err == NULL) + if (!err || !err->message[0]) image_error ("Error parsing SVG image"); else { - image_error ("Error parsing SVG image: %s", - call2 (Qstring_trim_right, build_string (err->message), - Qnil)); + char *errmsg = err->message; + ptrdiff_t errlen = strlen (errmsg); + + /* Remove trailing whitespace from the error message text. It + has a newline at the end, and perhaps more whitespace. */ + while (c_isspace (errmsg[errlen - 1])) + errlen--; + image_error ("Error parsing SVG image: %s", make_string (errmsg, errlen)); g_error_free (err); } @@ -12272,6 +12277,4 @@ The options are: /* MagickExportImagePixels is in 6.4.6-9, but not 6.4.4-10. */ imagemagick_render_type = 0; #endif - - DEFSYM (Qstring_trim_right, "string-trim-right"); } commit aac4965702d3d8c665e13e8c8c7f6fb229b05097 Author: Stefan Kangas Date: Tue Sep 13 15:05:28 2022 +0200 Prefer defvar-keymap in several cases * lisp/calc/calc-embed.el (calc-override-minor-modes-map): * lisp/calc/calc-yank.el (calc-edit-mode-map): * lisp/calc/calc.el (calc-trail-mode-map): * lisp/cedet/semantic/mru-bookmark.el (semantic-mru-bookmark-mode-map): * lisp/cedet/semantic/util-modes.el (semantic-highlight-edits-mode-map) (semantic-show-unmatched-syntax-mode-map) (semantic-show-parser-state-mode-map) (semantic-stickyfunc-mode-map, semantic-highlight-func-mode-map): * lisp/cedet/srecode/srt-mode.el (srecode-template-mode-map): * lisp/gnus/gnus-art.el (gnus-prev-page-map, gnus-next-page-map): * lisp/gnus/gnus-search.el (gnus-search-minibuffer-map): * lisp/gnus/score-mode.el (gnus-score-mode-map): * lisp/gnus/smime.el (smime-mode-map): * lisp/indent.el (edit-tab-stops-map): * lisp/isearch.el (minibuffer-local-isearch-map): * lisp/printing.el (pr-interface-map): * lisp/progmodes/prog-mode.el (prog-mode-map): * lisp/progmodes/subword.el (subword-mode-map): * lisp/reveal.el (reveal-mode-map): * lisp/strokes.el (strokes-mode-map): * lisp/textmodes/flyspell.el (flyspell-mouse-map): * lisp/textmodes/less-css-mode.el (less-css-mode-map): * lisp/textmodes/remember.el (remember-mode-map) (remember-notes-mode-map): * lisp/wid-browse.el (widget-browse-mode-map): * lisp/wid-edit.el (widget-key-sequence-map): Prefer defvar-keymap in some easy-to-convert cases. diff --git a/lisp/calc/calc-embed.el b/lisp/calc/calc-embed.el index bb427ef86e..4a9ff256f9 100644 --- a/lisp/calc/calc-embed.el +++ b/lisp/calc/calc-embed.el @@ -207,9 +207,8 @@ ;; The following is to take care of any minor modes which override ;; a Calc command. -(defvar calc-override-minor-modes-map - (make-sparse-keymap) - "A list of keybindings that might be overwritten by minor modes.") +(defvar-keymap calc-override-minor-modes-map + :doc "A list of keybindings that might be overwritten by minor modes.") ;; Add any keys that might be overwritten here. (define-key calc-override-minor-modes-map "`" 'calc-edit) diff --git a/lisp/calc/calc-yank.el b/lisp/calc/calc-yank.el index 504ba5b40d..35014e022b 100644 --- a/lisp/calc/calc-yank.el +++ b/lisp/calc/calc-yank.el @@ -668,13 +668,11 @@ Interactively, reads the register using `register-read-with-preview'." (backward-char 1) (calc-set-command-flag 'do-edit)) -(defvar calc-edit-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\n" #'calc-edit-finish) - (define-key map "\r" #'calc-edit-return) - (define-key map "\C-c\C-c" #'calc-edit-finish) - map) - "Keymap for use by the `calc-edit' command.") +(defvar-keymap calc-edit-mode-map + :doc "Keymap for use by the `calc-edit' command." + "C-j" #'calc-edit-finish + "RET" #'calc-edit-return + "C-c C-c" #'calc-edit-finish) (defvar calc-original-buffer nil) (defvar calc-return-buffer nil) diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 6c21430b1b..5077c8c852 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -1373,10 +1373,8 @@ Notations: 3.14e6 3.14 * 10^6 (calc-check-defines)) (setplist 'calc-define nil))))) -(defvar calc-trail-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map calc-mode-map) - map)) +(defvar-keymap calc-trail-mode-map + :parent calc-mode-map) (defun calc--header-line (long short width &optional fudge) "Return a Calc header line appropriate for the buffer WIDTH. diff --git a/lisp/cedet/semantic/mru-bookmark.el b/lisp/cedet/semantic/mru-bookmark.el index 9dee0415a3..c3f59a3358 100644 --- a/lisp/cedet/semantic/mru-bookmark.el +++ b/lisp/cedet/semantic/mru-bookmark.el @@ -264,11 +264,9 @@ been edited, and you can re-visit them with \\[semantic-mrub-switch-tags]." :group 'semantic :type 'hook) -(defvar semantic-mru-bookmark-mode-map - (let ((km (make-sparse-keymap))) - (define-key km "\C-xB" #'semantic-mrub-switch-tags) - km) - "Keymap for mru-bookmark minor mode.") +(defvar-keymap semantic-mru-bookmark-mode-map + :doc "Keymap for mru-bookmark minor mode." + "C-x B" #'semantic-mrub-switch-tags) (define-minor-mode semantic-mru-bookmark-mode "Minor mode for tracking tag-based bookmarks automatically. diff --git a/lisp/cedet/semantic/util-modes.el b/lisp/cedet/semantic/util-modes.el index 33fed9191e..96d1de5a26 100644 --- a/lisp/cedet/semantic/util-modes.el +++ b/lisp/cedet/semantic/util-modes.el @@ -196,10 +196,8 @@ Argument OVERLAY is the overlay created to mark the change. This function will set the face property on this overlay." (overlay-put overlay 'face 'semantic-highlight-edits-face)) -(defvar semantic-highlight-edits-mode-map - (let ((km (make-sparse-keymap))) - km) - "Keymap for highlight-edits minor mode.") +(defvar-keymap semantic-highlight-edits-mode-map + :doc "Keymap for highlight-edits minor mode.") ;;;###autoload (define-minor-mode semantic-highlight-edits-mode @@ -343,11 +341,9 @@ Do not search past BOUND if non-nil." (setq ol (cdr ol)))))) ol))) -(defvar semantic-show-unmatched-syntax-mode-map - (let ((km (make-sparse-keymap))) - (define-key km "\C-c,`" #'semantic-show-unmatched-syntax-next) - km) - "Keymap for command `semantic-show-unmatched-syntax-mode'.") +(defvar-keymap semantic-show-unmatched-syntax-mode-map + :doc "Keymap for command `semantic-show-unmatched-syntax-mode'." + "C-c , `" #'semantic-show-unmatched-syntax-next) ;;;###autoload (define-minor-mode semantic-show-unmatched-syntax-mode @@ -417,10 +413,8 @@ non-nil if the minor mode is enabled. :group 'semantic :type 'hook) -(defvar semantic-show-parser-state-mode-map - (let ((km (make-sparse-keymap))) - km) - "Keymap for show-parser-state minor mode.") +(defvar-keymap semantic-show-parser-state-mode-map + :doc "Keymap for show-parser-state minor mode.") ;;;###autoload (define-minor-mode semantic-show-parser-state-mode @@ -553,11 +547,9 @@ to indicate a parse in progress." :group 'semantic :type 'hook) -(defvar semantic-stickyfunc-mode-map - (let ((km (make-sparse-keymap))) - (define-key km [ header-line down-mouse-1 ] #'semantic-stickyfunc-menu) - km) - "Keymap for stickyfunc minor mode.") +(defvar-keymap semantic-stickyfunc-mode-map + :doc "Keymap for stickyfunc minor mode." + " " #'semantic-stickyfunc-menu) (defvar semantic-stickyfunc-popup-menu nil "Menu used if the user clicks on the header line used by stickyfunc mode.") @@ -824,11 +816,9 @@ Argument EVENT describes the event that caused this function to be called." :group 'semantic :type 'hook) -(defvar semantic-highlight-func-mode-map - (let ((km (make-sparse-keymap))) - (define-key km [mouse-3] #'semantic-highlight-func-menu) - km) - "Keymap for highlight-func minor mode.") +(defvar-keymap semantic-highlight-func-mode-map + :doc "Keymap for highlight-func minor mode." + "" #'semantic-highlight-func-menu) (defvar semantic-highlight-func-popup-menu nil "Menu used if the user clicks on the header line. diff --git a/lisp/cedet/srecode/srt-mode.el b/lisp/cedet/srecode/srt-mode.el index 56b482e100..cc0983f9f9 100644 --- a/lisp/cedet/srecode/srt-mode.el +++ b/lisp/cedet/srecode/srt-mode.el @@ -179,13 +179,11 @@ Don't scan past LIMIT." Once the escape_start, and escape_end sequences are known, then we can tell font lock about them.") -(defvar srecode-template-mode-map - (let ((km (make-sparse-keymap))) - (define-key km "\C-c\C-c" #'srecode-compile-templates) - (define-key km "\C-c\C-m" #'srecode-macro-help) - (define-key km "/" #'srecode-self-insert-complete-end-macro) - km) - "Keymap used in srecode mode.") +(defvar-keymap srecode-template-mode-map + :doc "Keymap used in srecode mode." + "C-c C-c" #'srecode-compile-templates + "C-c C-m" #'srecode-macro-help + "/" #'srecode-self-insert-complete-end-macro) ;;;###autoload (define-derived-mode srecode-template-mode fundamental-mode "SRecode" diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 83ba72c091..fbcf801313 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -8550,17 +8550,13 @@ url is put as the `gnus-button-url' overlay property on the button." (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n") (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n") -(defvar gnus-prev-page-map - (let ((map (make-sparse-keymap))) - (define-key map [mouse-2] #'gnus-button-prev-page) - (define-key map "\r" #'gnus-button-prev-page) - map)) +(defvar-keymap gnus-prev-page-map + "" #'gnus-button-prev-page + "RET" #'gnus-button-prev-page) -(defvar gnus-next-page-map - (let ((map (make-sparse-keymap))) - (define-key map [mouse-2] #'gnus-button-next-page) - (define-key map "\r" #'gnus-button-next-page) - map)) +(defvar-keymap gnus-next-page-map + "" #'gnus-button-next-page + "RET" #'gnus-button-next-page) (defun gnus-insert-prev-page-button () (let ((b (point)) e diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index 327dba95c0..b8f7e7a08f 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -2247,11 +2247,9 @@ article came from is also searched." (forward-line))))) groups)) -(defvar gnus-search-minibuffer-map - (let ((km (make-sparse-keymap))) - (set-keymap-parent km minibuffer-local-map) - (define-key km (kbd "TAB") #'completion-at-point) - km)) +(defvar-keymap gnus-search-minibuffer-map + :parent minibuffer-local-map + "TAB" #'completion-at-point) (defun gnus-search--complete-key-data () "Potentially return completion data for a search key or value." diff --git a/lisp/gnus/score-mode.el b/lisp/gnus/score-mode.el index 8e27e87939..4c9d73a6e5 100644 --- a/lisp/gnus/score-mode.el +++ b/lisp/gnus/score-mode.el @@ -45,13 +45,11 @@ (defvar gnus-score-edit-exit-function nil "Function run on exit from the score buffer.") -(defvar gnus-score-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map emacs-lisp-mode-map) - (define-key map "\C-c\C-c" 'gnus-score-edit-exit) - (define-key map "\C-c\C-d" 'gnus-score-edit-insert-date) - (define-key map "\C-c\C-p" 'gnus-score-pretty-print) - map)) +(defvar-keymap gnus-score-mode-map + :parent emacs-lisp-mode-map + "C-c C-c" #'gnus-score-edit-exit + "C-c C-d" #'gnus-score-edit-insert-date + "C-c C-p" #'gnus-score-pretty-print) (defvar score-mode-syntax-table (let ((table (copy-syntax-table lisp-mode-syntax-table))) diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el index fd2791f5c5..7bb116d0c5 100644 --- a/lisp/gnus/smime.el +++ b/lisp/gnus/smime.el @@ -614,12 +614,10 @@ A string or a list of strings is returned." (defvar smime-buffer "*SMIME*") -(defvar smime-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "q" 'smime-exit) - (define-key map "f" 'smime-certificate-info) - map)) +(defvar-keymap smime-mode-map + :suppress t + "q" #'smime-exit + "f" #'smime-certificate-info) (autoload 'gnus-completing-read "gnus-util") diff --git a/lisp/indent.el b/lisp/indent.el index b0c1a021da..c7ec5c9a3e 100644 --- a/lisp/indent.el +++ b/lisp/indent.el @@ -695,12 +695,10 @@ A value of nil means a tab stop every `tab-width' columns." :safe 'listp :type '(repeat integer)) -(defvar edit-tab-stops-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-x\C-s" 'edit-tab-stops-note-changes) - (define-key map "\C-c\C-c" 'edit-tab-stops-note-changes) - map) - "Keymap used in `edit-tab-stops'.") +(defvar-keymap edit-tab-stops-map + :doc "Keymap used in `edit-tab-stops'." + "C-x C-s" #'edit-tab-stops-note-changes + "C-c C-c" #'edit-tab-stops-note-changes) (defvar edit-tab-stops-buffer nil "Buffer whose tab stops are being edited. diff --git a/lisp/isearch.el b/lisp/isearch.el index 2ef35438e9..3e840b014f 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -832,17 +832,15 @@ This is like `describe-bindings', but displays only Isearch keys." :image '(isearch-tool-bar-image "left-arrow"))) map)) -(defvar minibuffer-local-isearch-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-map) - (define-key map "\r" 'exit-minibuffer) - (define-key map "\M-\t" 'isearch-complete-edit) - (define-key map "\C-s" 'isearch-forward-exit-minibuffer) - (define-key map "\C-r" 'isearch-reverse-exit-minibuffer) - (define-key map "\C-f" 'isearch-yank-char-in-minibuffer) - (define-key map [right] 'isearch-yank-char-in-minibuffer) - map) - "Keymap for editing Isearch strings in the minibuffer.") +(defvar-keymap minibuffer-local-isearch-map + :doc "Keymap for editing Isearch strings in the minibuffer." + :parent minibuffer-local-map + "RET" #'exit-minibuffer + "M-TAB" #'isearch-complete-edit + "C-s" #'isearch-forward-exit-minibuffer + "C-r" #'isearch-reverse-exit-minibuffer + "C-f" #'isearch-yank-char-in-minibuffer + "" #'isearch-yank-char-in-minibuffer) ;; Internal variables declared globally for byte-compiler. ;; These are all set with setq while isearching diff --git a/lisp/printing.el b/lisp/printing.el index d10de24e03..0654dcda3d 100644 --- a/lisp/printing.el +++ b/lisp/printing.el @@ -5546,13 +5546,11 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." (defvar pr-i-ps-send 'printer) -(defvar pr-interface-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map widget-keymap) - (define-key map "q" 'pr-interface-quit) - (define-key map "?" 'pr-interface-help) - map) - "Keymap for `pr-interface'.") +(defvar-keymap pr-interface-map + :doc "Keymap for `pr-interface'." + :parent widget-keymap + "q" #'pr-interface-quit + "?" #'pr-interface-help) (defmacro pr-interface-save (&rest body) `(with-current-buffer pr-i-buffer diff --git a/lisp/progmodes/prog-mode.el b/lisp/progmodes/prog-mode.el index 7738de6a74..f87230bd2f 100644 --- a/lisp/progmodes/prog-mode.el +++ b/lisp/progmodes/prog-mode.el @@ -100,11 +100,9 @@ menu) -(defvar prog-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [?\C-\M-q] 'prog-indent-sexp) - map) - "Keymap used for programming modes.") +(defvar-keymap prog-mode-map + :doc "Keymap used for programming modes." + "C-M-q" #'prog-indent-sexp) (defvar prog-indentation-context nil "When non-nil, provides context for indenting embedded code chunks. diff --git a/lisp/progmodes/subword.el b/lisp/progmodes/subword.el index e06eb9a6f7..34327f756e 100644 --- a/lisp/progmodes/subword.el +++ b/lisp/progmodes/subword.el @@ -79,12 +79,11 @@ "\\(\\(\\W\\|[[:lower:][:digit:]]\\)\\([[:upper:]]+\\W*\\)\\|\\W\\w+\\)" "Regexp used by `subword-backward-internal'.") -(defvar subword-mode-map +(defvar-keymap subword-mode-map ;; We originally remapped motion keys here, but now use Emacs core ;; hooks. Leave this keymap around so that user additions to it ;; keep working. - (make-sparse-keymap) - "Keymap used in `subword-mode' minor mode.") + :doc "Keymap used in `subword-mode' minor mode.") ;;;###autoload (define-obsolete-function-alias diff --git a/lisp/reveal.el b/lisp/reveal.el index 64e9ceef64..b3b42177f9 100644 --- a/lisp/reveal.el +++ b/lisp/reveal.el @@ -210,13 +210,11 @@ that text." (let ((reveal-auto-hide t)) (reveal-post-command))) -(defvar reveal-mode-map - (let ((map (make-sparse-keymap))) - ;; Override the default move-beginning-of-line and move-end-of-line - ;; which skips valuable invisible text. - (define-key map [remap move-beginning-of-line] 'beginning-of-line) - (define-key map [remap move-end-of-line] 'end-of-line) - map)) +(defvar-keymap reveal-mode-map + ;; Override the default move-beginning-of-line and move-end-of-line + ;; which skips valuable invisible text. + " " #'beginning-of-line + " " #'end-of-line) ;;;###autoload (define-minor-mode reveal-mode diff --git a/lisp/strokes.el b/lisp/strokes.el index 0edb20c2eb..0f84588a41 100644 --- a/lisp/strokes.el +++ b/lisp/strokes.el @@ -1359,11 +1359,9 @@ If STROKES-MAP is not given, `strokes-global-map' will be used instead." "Return t if STROKE1's command name precedes STROKE2's in lexicographic order." (string-lessp (cdr stroke1) (cdr stroke2))) -(defvar strokes-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(shift down-mouse-2)] #'strokes-do-stroke) - (define-key map [(meta down-mouse-2)] #'strokes-do-complex-stroke) - map)) +(defvar-keymap strokes-mode-map + "S-" #'strokes-do-stroke + "M-" #'strokes-do-complex-stroke) ;;;###autoload (define-minor-mode strokes-mode diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index a893bc7b9c..774e7ac737 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -425,11 +425,9 @@ like \"Some." ;;*---------------------------------------------------------------------*/ ;;* The minor mode declaration. */ ;;*---------------------------------------------------------------------*/ -(defvar flyspell-mouse-map - (let ((map (make-sparse-keymap))) - (define-key map [mouse-2] 'flyspell-correct-word) - map) - "Keymap for Flyspell to put on erroneous words.") +(defvar-keymap flyspell-mouse-map + :doc "Keymap for Flyspell to put on erroneous words." + "" #'flyspell-correct-word) (defvar flyspell-mode-map (let ((map (make-sparse-keymap))) diff --git a/lisp/textmodes/less-css-mode.el b/lisp/textmodes/less-css-mode.el index a0462756b0..5d17b390f4 100644 --- a/lisp/textmodes/less-css-mode.el +++ b/lisp/textmodes/less-css-mode.el @@ -209,10 +209,8 @@ directory by default." (modify-syntax-entry ?. "'" st) st)) -(defvar less-css-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-c" #'less-css-compile) - map)) +(defvar-keymap less-css-mode-map + "C-c C-c" #'less-css-compile) ;;;###autoload (add-to-list 'auto-mode-alist '("\\.less\\'" . less-css-mode)) ;;;###autoload diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index c7a9f20ea2..f8c7af2500 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -548,13 +548,11 @@ If this is nil, then `diary-file' will be used instead." ;;; Internal Functions: -(defvar remember-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-x\C-s" #'remember-finalize) - (define-key map "\C-c\C-c" #'remember-finalize) - (define-key map "\C-c\C-k" #'remember-destroy) - map) - "Keymap used in `remember-mode'.") +(defvar-keymap remember-mode-map + :doc "Keymap used in `remember-mode'." + "C-x C-s" #'remember-finalize + "C-c C-c" #'remember-finalize + "C-c C-k" #'remember-destroy) (define-derived-mode remember-mode text-mode "Remember" "Major mode for output from \\[remember]. @@ -596,11 +594,9 @@ If this is nil, use `initial-major-mode'." -(defvar remember-notes-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-c" #'remember-notes-save-and-bury-buffer) - map) - "Keymap used in `remember-notes-mode'.") +(defvar-keymap remember-notes-mode-map + :doc "Keymap used in `remember-notes-mode'." + "C-c C-c" #'remember-notes-save-and-bury-buffer) (define-minor-mode remember-notes-mode "Minor mode for the `remember-notes' buffer. diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el index 7fc476e5df..a90f7bc160 100644 --- a/lisp/wid-browse.el +++ b/lisp/wid-browse.el @@ -35,12 +35,10 @@ ;;; The Mode. -(defvar widget-browse-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map widget-keymap) - (define-key map "q" #'bury-buffer) - map) - "Keymap for `widget-browse-mode'.") +(defvar-keymap widget-browse-mode-map + :doc "Keymap for `widget-browse-mode'." + :parent widget-keymap + "q" #'bury-buffer) (easy-menu-define widget-browse-mode-customize-menu widget-browse-mode-map @@ -245,11 +243,9 @@ VALUE is assumed to be a list of widgets." ;;; Widget Minor Mode. -(defvar widget-minor-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map widget-keymap) - map) - "Keymap used in Widget Minor Mode.") +(defvar-keymap widget-minor-mode-map + :doc "Keymap used in Widget Minor Mode." + :parent widget-keymap) ;;;###autoload (define-minor-mode widget-minor-mode diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 9aec6b0244..4d9663cea9 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -3452,11 +3452,9 @@ It reads a directory name from an editable text field." (defvar widget-key-sequence-default-value [ignore] "Default value for an empty key sequence.") -(defvar widget-key-sequence-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map widget-field-keymap) - (define-key map [(control ?q)] 'widget-key-sequence-read-event) - map)) +(defvar-keymap widget-key-sequence-map + :parent widget-field-keymap + "C-q" #'widget-key-sequence-read-event) (define-widget 'key-sequence 'restricted-sexp "A key sequence. This is obsolete; use the `key' type instead." commit 280b40cd8a46b325768f757ae9b50064524a46e1 Author: Lars Ingebrigtsen Date: Tue Sep 13 14:31:59 2022 +0200 Enable undo in eww buffers * lisp/net/eww.el (eww-render): Enable undo after rendering. This allows using `undo' in text input boxes. (eww-setup-buffer): Disable undo before rendering (bug#57750). * lisp/net/shr.el (shr-image-fetched): Inhibit undo tracking. diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 6ed0719eca..35e5bdd734 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -626,7 +626,10 @@ The renaming scheme is performed in accordance with (setq eww-history-position 0) (and last-coding-system-used (set-buffer-file-coding-system last-coding-system-used)) - (run-hooks 'eww-after-render-hook))) + (run-hooks 'eww-after-render-hook) + ;; Enable undo again so that undo works in text input + ;; boxes. + (setq buffer-undo-list nil))) (kill-buffer data-buffer)))) (defun eww-parse-headers () @@ -928,7 +931,8 @@ The renaming scheme is performed in accordance with ;; May be set later if there's a next/prev link. (setq-local multi-isearch-next-buffer-function nil) (unless (eq major-mode 'eww-mode) - (eww-mode))) + (eww-mode)) + (buffer-disable-undo)) (defun eww-current-url nil "Return URI of the Web page the current EWW buffer is visiting." diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 248faeb223..a06978d9ce 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1019,6 +1019,8 @@ the mouse click event." (widen) (let ((alt (buffer-substring start end)) (properties (text-properties-at start)) + ;; We don't want to record these changes. + (buffer-undo-list t) (inhibit-read-only t)) (delete-region start end) (goto-char start) commit b2329fbbe4e694e32c391dd5009f17f72b45e0f2 Author: Lars Ingebrigtsen Date: Tue Sep 13 14:07:40 2022 +0200 Indirect Buffers manual improvement * doc/emacs/buffers.texi (Indirect Buffers): There's no point in mentioning both clone-indirect-buffer and clone-indirect-buffer-other-window here since they do the pretty much the same (bug#57753). diff --git a/doc/emacs/buffers.texi b/doc/emacs/buffers.texi index 120c957ff8..8b21b6457c 100644 --- a/doc/emacs/buffers.texi +++ b/doc/emacs/buffers.texi @@ -631,13 +631,11 @@ buffer, but killing an indirect buffer has no effect on its base buffer. outline. @xref{Outline Views}. A quick and handy way to make an indirect buffer is with the command -@kbd{M-x clone-indirect-buffer}. It creates and selects an indirect -buffer whose base buffer is the current buffer. With a numeric -argument, it prompts for the name of the indirect buffer; otherwise it -uses the name of the current buffer, with a @samp{<@var{n}>} suffix -added. @kbd{C-x 4 c} (@code{clone-indirect-buffer-other-window}) -works like @kbd{M-x clone-indirect-buffer}, but it selects the new -buffer in another window. +@kbd{C-x 4 c} (@code{clone-indirect-buffer-other-window}). It creates +and selects an indirect buffer whose base buffer is the current +buffer. With a numeric argument, it prompts for the name of the +indirect buffer; otherwise it uses the name of the current buffer, +with a @samp{<@var{n}>} suffix added. The more general way to make an indirect buffer is with the command @kbd{M-x make-indirect-buffer}. It creates an indirect buffer commit 83531a336db21364c53439ba1e9d6ee76db73efe Author: Eli Zaretskii Date: Tue Sep 13 15:21:54 2022 +0300 ; * test/src/comp-tests.el: Explain the last change. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a5f33069e0..b85d365b0b 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1472,6 +1472,11 @@ folded." (equal (comp-mvar-typeset mvar) comp-tests-cond-rw-expected-type)))))))) +;; We don't want to byte compile this to avoid recording in the +;; bytecode the architecture-dependent values of most-positive-fixnum +;; and most-negative-fixnum, thus making the byte-compiled file +;; non-portable. + ;; Local Variables: ;; no-byte-compile: t ;; End: commit dd22694421249ef071488c02192b724da1aa03cb Author: dickmao Date: Tue Sep 13 13:57:44 2022 +0200 Avoid double svg error reporting and segfaults * src/image.c (svg_load_image): Use g_error_free directly instead of the helder g_clear_error (since we're only calling it with non-nil values). (svg_load_image): Avoid segfault and double reporting errors. * test/manual/image-tests.el (image-tests-load-image/svg-too-big) (image-tests-load-image/svg-invalid): Test it (bug#57755). diff --git a/src/image.c b/src/image.c index 549fe30ef7..2e04685e7f 100644 --- a/src/image.c +++ b/src/image.c @@ -10907,7 +10907,7 @@ DEF_DLL_FN (int, gdk_pixbuf_get_bits_per_sample, (const GdkPixbuf *)); DEF_DLL_FN (void, g_type_init, (void)); # endif DEF_DLL_FN (void, g_object_unref, (gpointer)); -DEF_DLL_FN (void, g_clear_error, (GError **)); +DEF_DLL_FN (void, g_error_free, (GError *)); static bool init_svg_functions (void) @@ -10967,7 +10967,7 @@ init_svg_functions (void) LOAD_DLL_FN (gobject, g_type_init); # endif LOAD_DLL_FN (gobject, g_object_unref); - LOAD_DLL_FN (glib, g_clear_error); + LOAD_DLL_FN (glib, g_error_free); return 1; } @@ -10983,7 +10983,7 @@ init_svg_functions (void) # undef gdk_pixbuf_get_pixels # undef gdk_pixbuf_get_rowstride # undef gdk_pixbuf_get_width -# undef g_clear_error +# undef g_error_free # undef g_object_unref # undef g_type_init # if LIBRSVG_CHECK_VERSION (2, 52, 1) @@ -11019,7 +11019,7 @@ init_svg_functions (void) # define gdk_pixbuf_get_pixels fn_gdk_pixbuf_get_pixels # define gdk_pixbuf_get_rowstride fn_gdk_pixbuf_get_rowstride # define gdk_pixbuf_get_width fn_gdk_pixbuf_get_width -# define g_clear_error fn_g_clear_error +# define g_error_free fn_g_error_free # define g_object_unref fn_g_object_unref # if ! GLIB_CHECK_VERSION (2, 36, 0) # define g_type_init fn_g_type_init @@ -11353,7 +11353,7 @@ svg_load_image (struct frame *f, struct image *img, char *contents, if (! check_image_size (f, width, height)) { image_size_error (); - goto rsvg_error; + goto done_error; } /* We are now done with the unmodified data. */ @@ -11536,9 +11536,21 @@ svg_load_image (struct frame *f, struct image *img, char *contents, image_put_x_image (f, img, ximg, 0); } + eassume (err == NULL); return true; rsvg_error: + if (err == NULL) + image_error ("Error parsing SVG image"); + else + { + image_error ("Error parsing SVG image: %s", + call2 (Qstring_trim_right, build_string (err->message), + Qnil)); + g_error_free (err); + } + + done_error: if (rsvg_handle) g_object_unref (rsvg_handle); if (wrapped_contents) @@ -11547,10 +11559,6 @@ svg_load_image (struct frame *f, struct image *img, char *contents, if (css && !STRINGP (lcss)) xfree (css); #endif - image_error ("Error parsing SVG image: %s", - /* The -1 removes an extra newline. */ - make_string (err->message, strlen (err->message) - 1)); - g_clear_error (&err); return false; } @@ -12265,4 +12273,5 @@ The options are: imagemagick_render_type = 0; #endif + DEFSYM (Qstring_trim_right, "string-trim-right"); } diff --git a/test/manual/image-tests.el b/test/manual/image-tests.el index 7f1eab9512..400657132c 100644 --- a/test/manual/image-tests.el +++ b/test/manual/image-tests.el @@ -79,6 +79,21 @@ (image-tests-make-load-image-test 'xbm) (image-tests-make-load-image-test 'xpm) +(ert-deftest image-tests-load-image/svg-too-big () + (with-temp-buffer + (let* ((max-image-size 0) + (messages-buffer-name (buffer-name (current-buffer))) + (img (cdr (assq 'svg image-tests--images))) + (file (if (listp img) + (plist-get (cdr img) :file) + img))) + (save-excursion (find-file file)) + (should (string-match-p "invalid image size" (buffer-string))) + ;; no annoying newlines + (should-not (string-match-p "^[ \t\n\r]+$" (buffer-string))) + ;; no annoying double error reporting + (should-not (string-match-p "error parsing" (buffer-string)))))) + (ert-deftest image-tests-load-image/svg-invalid () (with-temp-buffer (let ((messages-buffer-name (buffer-name (current-buffer)))) @@ -90,7 +105,9 @@ :type svg))) (redisplay)) ;; librsvg error: "... Start tag expected, '<' not found [3 times]" - (should (string-match "[Ee]rror.+Start tag expected" (buffer-string)))))) + (should (string-match-p "[Ee]rror.+Start tag expected" (buffer-string))) + ;; no annoying newlines + (should-not (string-match-p "^[ \t\n\r]+$" (buffer-string)))))) ;;;; image-test-size commit 89199f16aef2b1a2e79f22dddd7322f9f4fdd1fc Author: Stefan Kangas Date: Tue Sep 13 11:06:11 2022 +0200 ; Fix last change in test/manual/image-tests.el * test/manual/image-tests.el (image-skip-unless): (image-tests-image-metadata/gif): Fix last change. diff --git a/test/manual/image-tests.el b/test/manual/image-tests.el index f867047d08..7f1eab9512 100644 --- a/test/manual/image-tests.el +++ b/test/manual/image-tests.el @@ -32,9 +32,9 @@ ;;; Code: (defmacro image-skip-unless (format &rest condition) - `(skip-unless (or (and (display-images-p) - (image-type-available-p ,format)) - ,@condition))) + `(skip-unless (and (and (display-images-p) + (image-type-available-p ,format)) + ,@condition))) (defconst image-tests--images `((gif . ,(expand-file-name "test/data/image/black.gif" @@ -222,7 +222,8 @@ ;; contain metadata. (ert-deftest image-tests-image-metadata/gif () - (image-skip-unless 'gif (not w32-use-native-image-API)) + (image-skip-unless 'gif + (not (bound-and-true-p w32-use-native-image-API))) (should (memq 'delay (image-metadata (create-image (cdr (assq 'gif image-tests--images))))))) commit 16d6ef13c27805781e6c2b43672d911ed9dfdc66 Author: Stefan Kangas Date: Mon Sep 12 17:03:26 2022 +0200 Prefer defvar-keymap in pixel-scroll-precision-mode-map * lisp/pixel-scroll.el (pixel-scroll-precision-mode-map): Prefer defvar-keymap. diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 167cb4fabe..c4d59728ae 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -116,39 +116,37 @@ is always with pixel resolution.") (defvar mwheel-coalesce-scroll-events) -(defvar pixel-scroll-precision-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [wheel-down] 'pixel-scroll-precision) - (define-key map [wheel-up] 'pixel-scroll-precision) - (define-key map [touch-end] 'pixel-scroll-start-momentum) - (define-key map [mode-line wheel-down] 'pixel-scroll-precision) - (define-key map [mode-line wheel-up] 'pixel-scroll-precision) - (define-key map [mode-line touch-end] 'pixel-scroll-start-momentum) - (define-key map [header-line wheel-down] 'pixel-scroll-precision) - (define-key map [header-line wheel-up] 'pixel-scroll-precision) - (define-key map [header-line touch-end] 'pixel-scroll-start-momentum) - (define-key map [vertical-scroll-bar wheel-down] 'pixel-scroll-precision) - (define-key map [vertical-scroll-bar wheel-up] 'pixel-scroll-precision) - (define-key map [vertical-scroll-bar touch-end] 'pixel-scroll-start-momentum) - (define-key map [tool-bar wheel-down] 'pixel-scroll-precision) - (define-key map [tool-bar wheel-up] 'pixel-scroll-precision) - (define-key map [tool-bar touch-end] 'pixel-scroll-start-momentum) - (define-key map [left-margin wheel-down] 'pixel-scroll-precision) - (define-key map [left-margin wheel-up] 'pixel-scroll-precision) - (define-key map [left-margin touch-end] 'pixel-scroll-start-momentum) - (define-key map [right-margin wheel-down] 'pixel-scroll-precision) - (define-key map [right-margin wheel-up] 'pixel-scroll-precision) - (define-key map [right-margin touch-end] 'pixel-scroll-start-momentum) - (define-key map [left-fringe wheel-down] 'pixel-scroll-precision) - (define-key map [left-fringe wheel-up] 'pixel-scroll-precision) - (define-key map [left-fringe touch-end] 'pixel-scroll-start-momentum) - (define-key map [right-fringe wheel-down] 'pixel-scroll-precision) - (define-key map [right-fringe wheel-up] 'pixel-scroll-precision) - (define-key map [right-fringe touch-end] 'pixel-scroll-start-momentum) - (define-key map [next] 'pixel-scroll-interpolate-down) - (define-key map [prior] 'pixel-scroll-interpolate-up) - map) - "The key map used by `pixel-scroll-precision-mode'.") +(defvar-keymap pixel-scroll-precision-mode-map + :doc "The key map used by `pixel-scroll-precision-mode'." + "" #'pixel-scroll-precision + "" #'pixel-scroll-precision + "" #'pixel-scroll-start-momentum + " " #'pixel-scroll-precision + " " #'pixel-scroll-precision + " " #'pixel-scroll-start-momentum + " " #'pixel-scroll-precision + " " #'pixel-scroll-precision + " " #'pixel-scroll-start-momentum + " " #'pixel-scroll-precision + " " #'pixel-scroll-precision + " " #'pixel-scroll-start-momentum + " " #'pixel-scroll-precision + " " #'pixel-scroll-precision + " " #'pixel-scroll-start-momentum + " " #'pixel-scroll-precision + " " #'pixel-scroll-precision + " " #'pixel-scroll-start-momentum + " " #'pixel-scroll-precision + " " #'pixel-scroll-precision + " " #'pixel-scroll-start-momentum + " " #'pixel-scroll-precision + " " #'pixel-scroll-precision + " " #'pixel-scroll-start-momentum + " " #'pixel-scroll-precision + " " #'pixel-scroll-precision + " " #'pixel-scroll-start-momentum + "" #'pixel-scroll-interpolate-down + "" #'pixel-scroll-interpolate-up) (defcustom pixel-scroll-precision-use-momentum nil "If non-nil, continue to scroll the display after wheel movement stops. commit 4f9902eb0c1105406353c8639c6a2f728bcd68b8 Author: Stefan Kangas Date: Mon Sep 12 16:53:26 2022 +0200 Prefer defvar-keymap in tab-line.el * lisp/tab-line.el (tab-line-tab-map, tab-line-add-map) (tab-line-tab-close-map, tab-line-left-map, tab-line-right-map): Prefer defvar-keymap. diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 3e3b4c9559..94e8f29a95 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -135,45 +135,35 @@ function `tab-line-tab-face-group'." :group 'tab-line-faces) -(defvar tab-line-tab-map - (let ((map (make-sparse-keymap))) - (define-key map [tab-line down-mouse-1] 'tab-line-select-tab) - (define-key map [tab-line mouse-2] 'tab-line-close-tab) - (define-key map [tab-line down-mouse-3] 'tab-line-tab-context-menu) - (define-key map "\C-m" 'tab-line-select-tab) - map) - "Local keymap for `tab-line-mode' window tabs.") - -(defvar tab-line-add-map - (let ((map (make-sparse-keymap))) - (define-key map [tab-line down-mouse-1] 'tab-line-new-tab) - (define-key map [tab-line down-mouse-2] 'tab-line-new-tab) - (define-key map "\C-m" 'tab-line-new-tab) - map) - "Local keymap to add `tab-line-mode' window tabs.") - -(defvar tab-line-tab-close-map - (let ((map (make-sparse-keymap))) - (define-key map [tab-line mouse-1] 'tab-line-close-tab) - (define-key map [tab-line mouse-2] 'tab-line-close-tab) - map) - "Local keymap to close `tab-line-mode' window tabs.") - -(defvar tab-line-left-map - (let ((map (make-sparse-keymap))) - (define-key map [tab-line down-mouse-1] 'tab-line-hscroll-left) - (define-key map [tab-line down-mouse-2] 'tab-line-hscroll-left) - (define-key map "\C-m" 'tab-line-new-tab) - map) - "Local keymap to scroll `tab-line-mode' window tabs to the left.") - -(defvar tab-line-right-map - (let ((map (make-sparse-keymap))) - (define-key map [tab-line down-mouse-1] 'tab-line-hscroll-right) - (define-key map [tab-line down-mouse-2] 'tab-line-hscroll-right) - (define-key map "\C-m" 'tab-line-new-tab) - map) - "Local keymap to scroll `tab-line-mode' window tabs to the right.") +(defvar-keymap tab-line-tab-map + :doc "Local keymap for `tab-line-mode' window tabs." + " " #'tab-line-select-tab + " " #'tab-line-close-tab + " " #'tab-line-tab-context-menu + "RET" #'tab-line-select-tab) + +(defvar-keymap tab-line-add-map + :doc "Local keymap to add `tab-line-mode' window tabs." + " " #'tab-line-new-tab + " " #'tab-line-new-tab + "RET" #'tab-line-new-tab) + +(defvar-keymap tab-line-tab-close-map + :doc "Local keymap to close `tab-line-mode' window tabs." + " " #'tab-line-close-tab + " " #'tab-line-close-tab) + +(defvar-keymap tab-line-left-map + :doc "Local keymap to scroll `tab-line-mode' window tabs to the left." + " " #'tab-line-hscroll-left + " " #'tab-line-hscroll-left + "RET" #'tab-line-new-tab) + +(defvar-keymap tab-line-right-map + :doc "Local keymap to scroll `tab-line-mode' window tabs to the right." + " " #'tab-line-hscroll-right + " " #'tab-line-hscroll-right + "RET" #'tab-line-new-tab) (defcustom tab-line-new-tab-choice t commit cbbecd46fda2c07b5e00d5ad63e7487680cd5b36 Author: Stefan Kangas Date: Mon Sep 12 16:47:53 2022 +0200 Prefer defvar-keymap in lisp/epa*.el * lisp/epa-ks.el (epa-ks-search-mode-map): * lisp/epa.el (epa-key-list-mode-map, epa-key-mode-map): Prefer defvar-keymap. diff --git a/lisp/epa-ks.el b/lisp/epa-ks.el index 7c60b659f0..df8a72af70 100644 --- a/lisp/epa-ks.el +++ b/lisp/epa-ks.el @@ -66,14 +66,12 @@ This is used by `epa-ks-lookup-key', for looking up public keys." "List of arguments to pass to `epa-search-keys'. This is used when reverting a buffer to restart search.") -(defvar epa-ks-search-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map (kbd "f") #'epa-ks-mark-key-to-fetch) - (define-key map (kbd "i") #'epa-ks-inspect-key-to-fetch) - (define-key map (kbd "u") #'epa-ks-unmark-key-to-fetch) - (define-key map (kbd "x") #'epa-ks-do-key-to-fetch) - map)) +(defvar-keymap epa-ks-search-mode-map + :suppress t + "f" #'epa-ks-mark-key-to-fetch + "i" #'epa-ks-inspect-key-to-fetch + "u" #'epa-ks-unmark-key-to-fetch + "x" #'epa-ks-do-key-to-fetch) (define-derived-mode epa-ks-search-mode tabulated-list-mode "Keyserver" "Major mode for listing public key search results." diff --git a/lisp/epa.el b/lisp/epa.el index 63bc0941d6..cb87d80885 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -183,28 +183,26 @@ You should bind this variable with `let', but do not set it globally.") (defvar epa-suppress-error-buffer nil) (defvar epa-last-coding-system-specified nil) -(defvar epa-key-list-mode-map - (let ((keymap (make-sparse-keymap))) - (define-key keymap "\C-m" 'epa-show-key) - (define-key keymap [?\t] 'forward-button) - (define-key keymap [backtab] 'backward-button) - (define-key keymap "m" 'epa-mark-key) - (define-key keymap "u" 'epa-unmark-key) - (define-key keymap "d" 'epa-decrypt-file) - (define-key keymap "v" 'epa-verify-file) - (define-key keymap "s" 'epa-sign-file) - (define-key keymap "e" 'epa-encrypt-file) - (define-key keymap "r" 'epa-delete-keys) - (define-key keymap "i" 'epa-import-keys) - (define-key keymap "o" 'epa-export-keys) - (define-key keymap "g" 'revert-buffer) - (define-key keymap "n" 'next-line) - (define-key keymap "p" 'previous-line) - (define-key keymap " " 'scroll-up-command) - (define-key keymap [?\S-\ ] 'scroll-down-command) - (define-key keymap [delete] 'scroll-down-command) - (define-key keymap "q" 'epa-exit-buffer) - keymap)) +(defvar-keymap epa-key-list-mode-map + "RET" #'epa-show-key + "TAB" #'forward-button + "" #'backward-button + "m" #'epa-mark-key + "u" #'epa-unmark-key + "d" #'epa-decrypt-file + "v" #'epa-verify-file + "s" #'epa-sign-file + "e" #'epa-encrypt-file + "r" #'epa-delete-keys + "i" #'epa-import-keys + "o" #'epa-export-keys + "g" #'revert-buffer + "n" #'next-line + "p" #'previous-line + "SPC" #'scroll-up-command + "S-SPC" #'scroll-down-command + "" #'scroll-down-command + "q" #'epa-exit-buffer) (easy-menu-define epa-key-list-mode-menu epa-key-list-mode-map "Menu for `epa-key-list-mode'." @@ -230,10 +228,8 @@ You should bind this variable with `let', but do not set it globally.") ["Unmark Key" epa-unmark-key :help "Unmark a key"])) -(defvar epa-key-mode-map - (let ((keymap (make-sparse-keymap))) - (define-key keymap "q" 'epa-exit-buffer) - keymap)) +(defvar-keymap epa-key-mode-map + "q" #'epa-exit-buffer) (defvar epa-exit-buffer-function #'quit-window)