commit 9445d7bf8c3f73a400e9eb6bb3617788d9421b62 (HEAD, refs/remotes/origin/master) Author: Stefan Monnier Date: Wed Aug 11 22:42:06 2021 -0400 * lisp/emacs-lisp/cl-macs.el (fixnum, bignum): Fix type definitions diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index caf8bba2f8..4ef1948b0f 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3332,14 +3332,16 @@ Of course, we really can't know that for sure, so it's just a heuristic." '((array . arrayp) (atom . atom) (base-char . characterp) + (bignum . bignump) (boolean . booleanp) (bool-vector . bool-vector-p) (buffer . bufferp) (character . natnump) (char-table . char-table-p) + (command . commandp) (hash-table . hash-table-p) (cons . consp) - (fixnum . integerp) + (fixnum . fixnump) (float . floatp) (function . functionp) (integer . integerp) @@ -3597,8 +3599,6 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (cl-deftype extended-char () '(and character (not base-char))) ;; Define fixnum so `cl-typep' recognize it and the type check emitted ;; by `cl-the' is effective. -(cl-deftype fixnum () 'fixnump) -(cl-deftype bignum () 'bignump) ;;; Additional functions that we can now define because we've defined ;;; `cl-defsubst' and `cl-typep'. commit 8dd6120594569a1d8186211963094f53caa7a6ed Author: Lars Ingebrigtsen Date: Thu Aug 12 01:19:26 2021 +0200 Fix bytecomp container test case * lisp/startup.el (normal-top-level): Make startup more robust -- we may not be allowed to create any directories when running under test mode (bug#48350). diff --git a/lisp/startup.el b/lisp/startup.el index f337f7c6bc..58030ca06a 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -549,7 +549,11 @@ It is the default value of the variable `top-level'." ;; When $HOME is set to '/nonexistent' means we are running the ;; testsuite, add a temporary folder in front to produce there ;; new compilations. - (when (equal (getenv "HOME") "/nonexistent") + (when (and (equal (getenv "HOME") "/nonexistent") + ;; We may be running in a chroot environment where we + ;; can't write anything. + (file-writable-p (expand-file-name + (or temporary-file-directory "")))) (let ((tmp-dir (make-temp-file "emacs-testsuite-" t))) (add-hook 'kill-emacs-hook (lambda () (delete-directory tmp-dir t))) (push tmp-dir native-comp-eln-load-path)))) commit bd6c3a014a55176c56ca38c89c6ecab69a384ab7 Author: Stefan Monnier Date: Wed Aug 11 18:20:35 2021 -0400 * lisp/obsolete/cl.el (labels): Don't quote lambda (flet): Don't need `fboundp` any more before calling `symbol-function`. diff --git a/lisp/obsolete/cl.el b/lisp/obsolete/cl.el index 09f9ab7b7f..9df6231857 100644 --- a/lisp/obsolete/cl.el +++ b/lisp/obsolete/cl.el @@ -431,8 +431,7 @@ definitions, or lack thereof). (obsolete "use either `cl-flet' or `cl-letf'." "24.3")) `(letf ,(mapcar (lambda (x) - (if (or (and (fboundp (car x)) - (eq (car-safe (symbol-function (car x))) 'macro)) + (if (or (eq (car-safe (symbol-function (car x))) 'macro) (cdr (assq (car x) macroexpand-all-environment))) (error "Use `labels', not `flet', to rebind macro names")) (let ((func `(cl-function @@ -466,10 +465,10 @@ rather than relying on `lexical-binding'." (push `(cl-function (lambda . ,(cdr binding))) sets) (push var sets) (push (cons (car binding) - `(lambda (&rest cl-labels-args) - (if (eq (car cl-labels-args) cl--labels-magic) - (list cl--labels-magic ',var) - (cl-list* 'funcall ',var cl-labels-args)))) + (lambda (&rest cl-labels-args) + (if (eq (car cl-labels-args) cl--labels-magic) + (list cl--labels-magic var) + (cl-list* 'funcall var cl-labels-args)))) newenv))) ;; `lexical-let' adds `cl--function-convert' (which calls ;; `cl--labels-convert') as a macroexpander for `function'. commit 2f90fa19b8fdc70303232d389553afa524c72509 Author: Earl Hyatt Date: Wed Aug 11 23:54:31 2021 +0200 Add a `pcase-setq' macro * doc/lispref/control.texi (Destructuring with pcase Patterns): Document this macro. * lisp/emacs-lisp/pcase.el (pcase-setq): New macro. This macro is the 'setq' equivalent of 'pcase-let'. * test/lisp/emacs-lisp/pcase-tests.el (pcase-setq): Test this new macro. (bug#49809). diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 5026d0a4d7..aacf66c5cf 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -1312,6 +1312,10 @@ element of @var{list}. The bindings are performed as if by up being equivalent to @code{dolist} (@pxref{Iteration}). @end defmac +@defmac pcase-setq pattern value@dots{} +Assign values to variables in a @code{setq} form, destructuring each +@var{value} according to its respective @var{pattern}. +@end defmac @node Iteration @section Iteration diff --git a/etc/NEWS b/etc/NEWS index 18fa54b97e..ffe8f5b32c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -559,6 +559,10 @@ The new 'cl-type' pattern compares types using 'cl-typep', which allows comparing simple types like '(cl-type integer)', as well as forms like '(cl-type (integer 0 10))'. +*** New macro 'pcase-setq' +This macro is the 'setq' equivalent of 'pcase-let', which allows for +destructuring patterns in a 'setq' form. + +++ ** profiler.el The results displayed by 'profiler-report' now have the usage figures diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 006517db75..d111d9e41f 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -317,6 +317,44 @@ of the elements of LIST is performed as if by `pcase-let'. (pcase-let* ((,(car spec) ,tmpvar)) ,@body))))) +;;;###autoload +(defmacro pcase-setq (pat val &rest args) + "Assign values to variables by destructuring with `pcase'. +PATTERNS are normal `pcase' patterns, and VALUES are expression. + +Evaluation happens sequentially as in `setq' (not in parallel). + +An example: (pcase-setq `((,a) [(,b)]) '((1) [(2)])) + +When a PATTERN doesn't match it's VALUE, the pair is silently skipped. + +\(fn PATTERNS VALUE PATTERN VALUES ...)" + (declare (debug (&rest [pcase-PAT form]))) + (cond + (args + (let ((arg-length (length args))) + (unless (= 0 (mod arg-length 2)) + (signal 'wrong-number-of-arguments + (list 'pcase-setq (+ 2 arg-length))))) + (let ((result)) + (while args + (push `(pcase-setq ,(pop args) ,(pop args)) + result)) + `(progn + (pcase-setq ,pat ,val) + ,@(nreverse result)))) + ((pcase--trivial-upat-p pat) + `(setq ,pat ,val)) + (t + (pcase-compile-patterns + val + (list (cons pat + (lambda (varvals &rest _) + `(setq ,@(mapcan (lambda (varval) + (let ((var (car varval)) + (val (cadr varval))) + (list var val))) + varvals))))))))) (defun pcase--trivial-upat-p (upat) (and (symbolp upat) (not (memq upat pcase--dontcare-upats)))) diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 02d3878ad0..67882d00d8 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -110,4 +110,52 @@ (should-error (pcase 1 ((cl-type notatype) 'integer)))) +(ert-deftest pcase-setq () + (should (equal (let (a b) + (pcase-setq `(,a ,b) nil) + (list a b)) + (list nil nil))) + + (should (equal (let (a b) + (pcase-setq `((,a) (,b)) '((1) (2))) + (list a b)) + (list 1 2))) + + (should (equal (list 'unset 'unset) + (let ((a 'unset) + (b 'unset)) + (pcase-setq `(,a ,b) nil) + (list a b)))) + + (should (equal (let (a b) + (pcase-setq `[,a ,b] [1 2]) + (list a b)) + '(1 2))) + + (should (equal (let (a b) + (pcase-setq a 1 b 2) + (list a b)) + '(1 2))) + + (should (= (let (a) + (pcase-setq a 1 `(,a) '(2)) + a) + 2)) + + (should (equal (let (array list-item array-copy) + (pcase-setq (or `(,list-item) array) [1 2 3] + array-copy array + ;; This re-sets `array' to nil. + (or `(,list-item) array) '(4)) + (list array array-copy list-item)) + '(nil [1 2 3] 4))) + + (let ((a nil)) + (should-error (pcase-setq a 1 b) + :type '(wrong-number-of-arguments)) + (should (eq a nil))) + + (should-error (pcase-setq a) + :type '(wrong-number-of-arguments))) + ;;; pcase-tests.el ends here. commit 3b5f8ab0d06f6c39aaa716b6279c2ceb4bfc5b14 Author: Lars Ingebrigtsen Date: Wed Aug 11 22:29:38 2021 +0200 Allow using a single anonymous face in enriced-mode * lisp/format.el (format-annotate-single-property-change): Allow using a single anonymous face (bug#33682). diff --git a/lisp/format.el b/lisp/format.el index 1e87d25284..71cf885d41 100644 --- a/lisp/format.el +++ b/lisp/format.el @@ -1013,6 +1013,12 @@ either strings, or lists of the form (PARAMETER VALUE)." prop-alist (car old) nil)) close) old (cdr old))) + ;; If the font is on the format (:background "red"), + ;; then we have a single face. We're assuming a list of + ;; faces, so transform. + (when (and (listp new) + (keywordp (car new))) + (setq new (list new))) (while new (setq open (append (cdr (format-annotate-atomic-property-change commit 81fd380dea4d4e66d2a93b708caa0e2a9c79de4a Author: Lars Ingebrigtsen Date: Wed Aug 11 22:07:13 2021 +0200 Allow using XLFD font names with dashes in the family name * src/font.c (font_parse_xlfd_1): Rename from font_parse_xlfd to allow calling twice from a wrapper (bug#35816). (font_parse_xlfd): Wrapper function -- first try to parse in the normal way, and then try to guess that the hyphenated bits are in the family name. diff --git a/src/font.c b/src/font.c index 7c1d1ff89b..e043ef8d01 100644 --- a/src/font.c +++ b/src/font.c @@ -1029,8 +1029,8 @@ font_expand_wildcards (Lisp_Object *field, int n) X font backend driver, it is a font-entity. In that case, NAME is a fully specified XLFD. */ -int -font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font) +static int +font_parse_xlfd_1 (char *name, ptrdiff_t len, Lisp_Object font, int segments) { int i, j, n; char *f[XLFD_LAST_INDEX + 1]; @@ -1040,17 +1040,27 @@ font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font) if (len > 255 || !len) /* Maximum XLFD name length is 255. */ return -1; + /* Accept "*-.." as a fully specified XLFD. */ if (name[0] == '*' && (len == 1 || name[1] == '-')) i = 1, f[XLFD_FOUNDRY_INDEX] = name; else i = 0; + + /* Split into segments. */ for (p = name + i; *p; p++) if (*p == '-') { - f[i++] = p + 1; - if (i == XLFD_LAST_INDEX) - break; + /* If we have too many segments, then gather them up into the + FAMILY part of the name. This allows using fonts with + dashes in the FAMILY bit. */ + if (segments > XLFD_LAST_INDEX && i == XLFD_WEIGHT_INDEX) + segments--; + else { + f[i++] = p + 1; + if (i == XLFD_LAST_INDEX) + break; + } } f[i] = name + len; @@ -1215,6 +1225,28 @@ font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font) return 0; } +int +font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font) +{ + int found = font_parse_xlfd_1 (name, len, font, -1); + if (found > -1) + return found; + + int segments = 0; + /* Count how many segments we have. */ + for (char *p = name; *p; p++) + if (*p == '-') + segments++; + + /* If we have a surplus of segments, then we try to parse again, in + case there's a font with dashes in the family name. */ + if (segments > XLFD_LAST_INDEX) + return font_parse_xlfd_1 (name, len, font, segments); + else + return -1; +} + + /* Store XLFD name of FONT (font-spec or font-entity) in NAME (NBYTES length), and return the name length. If FONT_SIZE_INDEX of FONT is 0, use PIXEL_SIZE instead. */ commit bdec9daf57a72dc48a70ae1600b3f331531c229b Author: Lars Ingebrigtsen Date: Wed Aug 11 21:26:29 2021 +0200 Allow `tex-buffer' to work on buffers not visiting files * lisp/textmodes/tex-mode.el (tex-region): Make `tex-buffer' work again on unsaved files (bug#34082). diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 5169377c13..51216bdbe7 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -2533,7 +2533,10 @@ The value of `tex-command' specifies the command to use to run TeX." (file-name-as-directory (expand-file-name tex-directory))) (tex-out-file (expand-file-name (concat tex-zap-file ".tex") zap-directory)) - (main-file (expand-file-name (tex-main-file))) + ;; We may be running from an unsaved buffer, in which case + ;; there's no point in guessing for a main file name. + (main-file (and buffer-file-name + (expand-file-name (tex-main-file)))) (ismain (string-equal main-file (buffer-file-name))) already-output) ;; Don't delete temp files if we do the same buffer twice in a row. @@ -2542,9 +2545,11 @@ The value of `tex-command' specifies the command to use to run TeX." (let ((default-directory zap-directory)) ; why? ;; We assume the header is fully contained in tex-main-file. ;; We use f-f-ns so we get prompted about any changes on disk. - (with-current-buffer (find-file-noselect main-file) - (setq already-output (tex-region-header tex-out-file - (and ismain beg)))) + (if (not main-file) + (setq already-output 0) + (with-current-buffer (find-file-noselect main-file) + (setq already-output (tex-region-header tex-out-file + (and ismain beg))))) ;; Write out the specified region (but don't repeat anything ;; already written in the header). (write-region (if ismain commit b81de1be90ce287b5aa6d859317c157d988e8cb0 Author: Stephen Berman Date: Wed Aug 11 18:06:13 2021 +0200 Fix URL entry in ffap after previous change * lisp/ffap.el (ffap-read-file-or-url): Make URL entry actually work again (bug#50011). diff --git a/lisp/ffap.el b/lisp/ffap.el index 635e9814f1..84dcc04a71 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -1543,7 +1543,7 @@ which may actually result in an URL rather than a filename." (progn (push elem file-name-handler-alist) (if (ffap-url-p guess) - (read-file-name prompt guess) + (read-file-name prompt guess guess) (unless guess (setq guess default-directory)) (unless (ffap-file-remote-p guess) commit 7dbbe6cbc54b9331f7b32aa8ce96f6eeadfb0dcd Author: Peter Münster Date: Wed Aug 11 18:02:25 2021 +0200 Add new image-dired commands * lisp/image-dired.el (image-dired-delete-marked): Factored out (bug#50000). (image-dired-display-thumbs): From here. (image-dired-tag-marked-thumbnails): New command. (image-dired-delete-marked): Ditto. diff --git a/etc/NEWS b/etc/NEWS index 523af6b97d..18fa54b97e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2406,6 +2406,10 @@ This command, called interactively, toggles the local value of If non-nil (the default), use 'image-dired-thumb-mark' to say what images are marked. +*** New command 'image-dired-tag-marked-thumbnails'. + +*** New command 'image-dired-delete-marked'. + ** Miscellaneous --- diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 2916323937..76c7ae91f0 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -1005,6 +1005,19 @@ Restore any changes to the window configuration made by calling (set-window-configuration image-dired-saved-window-configuration) (message "No saved window configuration"))) +(defun image-dired--line-up-with-method () + "Line up thumbnails according to `image-dired-line-up-method'." + (cond ((eq 'dynamic image-dired-line-up-method) + (image-dired-line-up-dynamic)) + ((eq 'fixed image-dired-line-up-method) + (image-dired-line-up)) + ((eq 'interactive image-dired-line-up-method) + (image-dired-line-up-interactive)) + ((eq 'none image-dired-line-up-method) + nil) + (t + (image-dired-line-up-dynamic)))) + ;;;###autoload (defun image-dired-display-thumbs (&optional arg append do-not-pop) "Display thumbnails of all marked files, in `image-dired-thumbnail-buffer'. @@ -1046,16 +1059,7 @@ thumbnail buffer to be selected." (if do-not-pop (display-buffer buf) (pop-to-buffer buf)) - (cond ((eq 'dynamic image-dired-line-up-method) - (image-dired-line-up-dynamic)) - ((eq 'fixed image-dired-line-up-method) - (image-dired-line-up)) - ((eq 'interactive image-dired-line-up-method) - (image-dired-line-up-interactive)) - ((eq 'none image-dired-line-up-method) - nil) - (t - (image-dired-line-up-dynamic)))))) + (image-dired--line-up-with-method)))) ;;;###autoload (defun image-dired-show-all-from-dir (dir) @@ -1186,6 +1190,13 @@ FILE-TAGS is an alist in the following form: (cons x tag)) files)))) +(defun image-dired-tag-marked-thumbnails () + "Tag marked thumbnails." + (interactive) + (when-let ((dired-buf (image-dired-associated-dired-buffer))) + (with-current-buffer dired-buf + (image-dired-tag-files nil)))) + (defun image-dired-tag-thumbnail () "Tag current thumbnail." (interactive) @@ -1417,27 +1428,26 @@ dired." (message "No image, or image with correct properties, at point.") (with-current-buffer dired-buf (message "%s" file-name) - (if (dired-goto-file file-name) - (cond ((eq command 'mark) (dired-mark 1)) - ((eq command 'unmark) (dired-unmark 1)) - ((eq command 'toggle) - (if (image-dired-dired-file-marked-p) - (dired-unmark 1) - (dired-mark 1))) - ((eq command 'flag) (dired-flag-file-deletion 1)))))))) + (when (dired-goto-file file-name) + (cond ((eq command 'mark) (dired-mark 1)) + ((eq command 'unmark) (dired-unmark 1)) + ((eq command 'toggle) + (if (image-dired-dired-file-marked-p) + (dired-unmark 1) + (dired-mark 1))) + ((eq command 'flag) (dired-flag-file-deletion 1))) + (image-dired-thumb-update-marks)))))) (defun image-dired-mark-thumb-original-file () "Mark original image file in associated dired buffer." (interactive) (image-dired-modify-mark-on-thumb-original-file 'mark) - (image-dired-thumb-update-marks) (image-dired-forward-image)) (defun image-dired-unmark-thumb-original-file () "Unmark original image file in associated dired buffer." (interactive) (image-dired-modify-mark-on-thumb-original-file 'unmark) - (image-dired-thumb-update-marks) (image-dired-forward-image)) (defun image-dired-flag-thumb-original-file () @@ -1449,8 +1459,7 @@ dired." (defun image-dired-toggle-mark-thumb-original-file () "Toggle mark on original image file in associated dired buffer." (interactive) - (image-dired-modify-mark-on-thumb-original-file 'toggle) - (image-dired-thumb-update-marks)) + (image-dired-modify-mark-on-thumb-original-file 'toggle)) (defun image-dired-jump-original-dired-buffer () "Jump to the dired buffer associated with the current image file. @@ -2336,6 +2345,19 @@ non-nil." (when (dired-goto-file file-name) (image-dired-dired-file-marked-p)))))) +(defun image-dired-delete-marked () + "Delete marked thumbnails and associated images." + (interactive) + (goto-char (point-min)) + (let ((dired-buf (image-dired-associated-dired-buffer))) + (while (not (eobp)) + (if (image-dired-thumb-file-marked-p) + (image-dired-delete-char) + (forward-char))) + (image-dired--line-up-with-method) + (with-current-buffer dired-buf + (dired-do-delete)))) + (defun image-dired-thumb-update-marks () "Update the marks in the thumbnail buffer." ;; TODO: only called by image-dired-mouse-toggle-mark but there are commit 244acc5a057b0d6ff03754af14d71808b6f20233 Author: Michael Albinus Date: Wed Aug 11 15:34:43 2021 +0200 Replace some `string-match-p' calls in Tramp * lisp/net/tramp.el (tramp-debug-message, tramp-set-completion-function) (tramp-get-completion-methods, tramp-get-completion-user-host): * lisp/net/tramp-adb.el (tramp-adb-handle-make-process): * lisp/net/tramp-sh.el (tramp-sh-handle-make-process) (tramp-open-connection-setup-interactive-shell) (tramp-convert-file-attributes): Use `string-prefix-p'. * lisp/net/tramp.el (tramp-dissect-file-name) (tramp-progress-reporter-update, tramp-handle-insert-directory): * lisp/net/tramp-cache.el (tramp-get-hash-table) (tramp-flush-directory-properties): * lisp/net/tramp-cmds.el (tramp-append-tramp-buffers): * lisp/net/tramp-sh.el (tramp-sh-handle-insert-directory) (tramp-call-local-coding-command, tramp-get-inline-coding): * lisp/net/tramp-smb.el (tramp-smb-handle-file-attributes) (tramp-smb-handle-file-name-all-completions) (tramp-smb-handle-file-writable-p) (tramp-smb-handle-insert-directory) (tramp-smb-handle-start-file-process, ) (tramp-smb-read-file-entry): Use `tramp-compat-string-search'. diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 5e0accc142..2f84312f07 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -1065,7 +1065,7 @@ implementation will be used." p)))) ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) (ignore-errors (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index fcfad012ec..5a00915f4f 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -125,7 +125,7 @@ If KEY is `tramp-cache-undefined', don't create anything, and return nil." (puthash key (make-hash-table :test #'equal) tramp-cache-data))) (when (tramp-file-name-p key) (dolist (elt tramp-connection-properties) - (when (string-match-p + (when (tramp-compat-string-search (or (nth 0 elt) "") (tramp-make-tramp-file-name key 'noloc 'nohop)) (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) @@ -268,8 +268,8 @@ Remove also properties of all files in subdirectories." (dolist (key (hash-table-keys tramp-cache-data)) (when (and (tramp-file-name-p key) (stringp (tramp-file-name-localname key)) - (string-match-p (regexp-quote directory) - (tramp-file-name-localname key))) + (tramp-compat-string-search + directory (tramp-file-name-localname key))) (remhash key tramp-cache-data))) ;; Remove file properties of symlinks. (when (and (stringp truename) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index d30d22021a..6278fd302a 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -672,7 +672,7 @@ buffer in your bug report. (insert "\nload-path shadows:\n==================\n") (ignore-errors (mapc - (lambda (x) (when (string-match-p "tramp" x) (insert x "\n"))) + (lambda (x) (when (tramp-compat-string-search "tramp" x) (insert x "\n"))) (split-string (list-load-path-shadows t) "\n"))) ;; Append buffers only when we are in message mode. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index c3b8df9e57..fad07d87c5 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2603,8 +2603,8 @@ The method used must be an out-of-band method." (save-restriction (narrow-to-region beg-marker end-marker) ;; Some busyboxes are reluctant to discard colors. - (unless - (string-match-p "color" (tramp-get-connection-property v "ls" "")) + (unless (tramp-compat-string-search + "color" (tramp-get-connection-property v "ls" "")) (goto-char (point-min)) (while (re-search-forward tramp-display-escape-sequence-regexp nil t) (replace-match ""))) @@ -2958,7 +2958,7 @@ implementation will be used." p))) ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) (ignore-errors (set-process-buffer p nil) (kill-buffer (current-buffer))) @@ -4309,7 +4309,7 @@ process to set up. VEC specifies the connection." ;; Use MULE to select the right EOL convention for communicating ;; with the process. (let ((cs (or (and (memq 'utf-8-hfs (coding-system-list)) - (string-match-p "^Darwin" uname) + (string-prefix-p "Darwin" uname) (cons 'utf-8-hfs 'utf-8-hfs)) (and (memq 'utf-8 (coding-system-list)) (string-match-p "utf-?8" (tramp-get-remote-locale vec)) @@ -4322,7 +4322,7 @@ process to set up. VEC specifies the connection." cs-encode (or (cdr cs) 'undecided) cs-encode (coding-system-change-eol-conversion - cs-encode (if (string-match-p "^Darwin" uname) 'mac 'unix))) + cs-encode (if (string-prefix-p "Darwin" uname) 'mac 'unix))) (tramp-send-command vec "(echo foo ; echo bar)" t) (goto-char (point-min)) (when (search-forward "\r" nil t) @@ -4372,7 +4372,7 @@ process to set up. VEC specifies the connection." ;; IRIX64 bash expands "!" even when in single quotes. This ;; destroys our shell functions, we must disable it. See ;; . - (when (string-match-p "^IRIX64" uname) + (when (string-prefix-p "IRIX64" uname) (tramp-send-command vec "set +H" t)) ;; Disable tab expansion. @@ -4628,12 +4628,12 @@ means standard output and thus the current buffer), or nil (which means discard it)." (tramp-call-process nil tramp-encoding-shell - (when (and input (not (string-match-p "%s" cmd))) input) + (when (and input (not (tramp-compat-string-search "%s" cmd))) input) (if (eq output t) t nil) nil tramp-encoding-command-switch (concat - (if (string-match-p "%s" cmd) (format cmd input) cmd) + (if (tramp-compat-string-search "%s" cmd) (format cmd input) cmd) (if (stringp output) (concat " >" output) "")))) (defconst tramp-inline-compress-commands @@ -5223,7 +5223,7 @@ Return ATTR." (when (stringp (car attr)) (aset (nth 8 attr) 0 ?l))) ;; Convert directory indication bit. - (when (string-match-p "^d" (nth 8 attr)) + (when (string-prefix-p "d" (nth 8 attr)) (setcar attr t)) ;; Convert symlink from `tramp-do-file-attributes-with-stat'. ;; Decode also multibyte string. @@ -5803,12 +5803,13 @@ function cell is returned to be applied on a buffer." (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-encoding vec) (tramp-get-connection-property (tramp-get-process vec) prop nil))) - (prop1 (if (string-match-p "encoding" prop) + (prop1 (if (tramp-compat-string-search "encoding" prop) "inline-compress" "inline-decompress")) compress) ;; The connection property might have been cached. So we must ;; send the script to the remote side - maybe. - (when (and coding (symbolp coding) (string-match-p "remote" prop)) + (when (and coding (symbolp coding) + (tramp-compat-string-search "remote" prop)) (let ((name (symbol-name coding))) (while (string-match "-" name) (setq name (replace-match "_" nil t name))) @@ -5820,7 +5821,7 @@ function cell is returned to be applied on a buffer." ;; Return the value. (cond ((and compress (symbolp coding)) - (if (string-match-p "decompress" prop1) + (if (tramp-compat-string-search "decompress" prop1) `(lambda (beg end) (,coding beg end) (let ((coding-system-for-write 'binary) @@ -5839,16 +5840,16 @@ function cell is returned to be applied on a buffer." (,coding (point-min) (point-max))))) ((symbolp coding) coding) - ((and compress (string-match-p "decoding" prop)) + ((and compress (tramp-compat-string-search "decoding" prop)) (format ;; Windows shells need the program file name after ;; the pipe symbol be quoted if they use forward ;; slashes as directory separators. (cond - ((and (string-match-p "local" prop) + ((and (tramp-compat-string-search "local" prop) (eq system-type 'windows-nt)) "(%s | \"%s\")") - ((string-match-p "local" prop) "(%s | %s)") + ((tramp-compat-string-search "local" prop) "(%s | %s)") (t "(%s | %s >%%s)")) coding compress)) (compress @@ -5856,14 +5857,14 @@ function cell is returned to be applied on a buffer." ;; Windows shells need the program file name after ;; the pipe symbol be quoted if they use forward ;; slashes as directory separators. - (if (and (string-match-p "local" prop) + (if (and (tramp-compat-string-search "local" prop) (eq system-type 'windows-nt)) "(%s <%%s | \"%s\")" "(%s <%%s | %s)") compress coding)) - ((string-match-p "decoding" prop) + ((tramp-compat-string-search "decoding" prop) (cond - ((string-match-p "local" prop) (format "%s" coding)) + ((tramp-compat-string-search "local" prop) (format "%s" coding)) (t (format "%s >%%s" coding)))) (t (format "%s <%%s" coding))))))) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 3d5be61d3f..6937244917 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -849,7 +849,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check result. (when entry - (list (and (string-match-p "d" (nth 1 entry)) + (list (and (tramp-compat-string-search "d" (nth 1 entry)) t) ;0 file type -1 ;1 link count uid ;2 uid @@ -982,7 +982,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (mapcar (lambda (x) (list - (if (string-match-p "d" (nth 1 x)) + (if (tramp-compat-string-search "d" (nth 1 x)) (file-name-as-directory (nth 0 x)) (nth 0 x)))) (tramp-smb-get-file-entries directory))))))) @@ -1021,7 +1021,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-smb-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." (if (file-exists-p filename) - (string-match-p + (tramp-compat-string-search "w" (or (tramp-compat-file-attribute-modes (file-attributes filename)) "")) (let ((dir (file-name-directory filename))) @@ -1076,9 +1076,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check for matching entries. (mapcar (lambda (x) - (when (string-match-p - (format "^%s" base) (nth 0 x)) - x)) + (when (string-match-p (format "^%s" base) (nth 0 x)) x)) entries) ;; We just need the only and only entry FILENAME. (list (assoc base entries))))) @@ -1088,14 +1086,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (sort entries (lambda (x y) - (if (string-match-p "t" switches) + (if (tramp-compat-string-search "t" switches) ;; Sort by date. (time-less-p (nth 3 y) (nth 3 x)) ;; Sort by name. (string-lessp (nth 0 x) (nth 0 y)))))) ;; Handle "-F" switch. - (when (string-match-p "F" switches) + (when (tramp-compat-string-search "F" switches) (mapc (lambda (x) (unless (zerop (length (car x))) @@ -1124,7 +1122,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (expand-file-name (nth 0 x) (file-name-directory filename)) 'string))))) - (when (string-match-p "l" switches) + (when (tramp-compat-string-search "l" switches) (insert (format "%10s %3d %-8s %-8s %8s %s " @@ -1153,7 +1151,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (put-text-property start (point) 'dired-filename t)) ;; Insert symlink. - (when (and (string-match-p "l" switches) + (when (and (tramp-compat-string-search "l" switches) (stringp (tramp-compat-file-attribute-type attr))) (insert " -> " (tramp-compat-file-attribute-type attr)))) @@ -1551,7 +1549,7 @@ component is used as the target of the symlink." ;; Save exit. (with-current-buffer (tramp-get-connection-buffer v) - (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (if (tramp-compat-string-search tramp-temp-buffer-name (buffer-name)) (progn (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) @@ -1857,10 +1855,12 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." mode (or (match-string 1 line) "") mode (format "%s%s" - (if (string-match-p "D" mode) "d" "-") + (if (tramp-compat-string-search "D" mode) "d" "-") (mapconcat (lambda (_x) "") " " - (concat "r" (if (string-match-p "R" mode) "-" "w") "x"))) + (format + "r%sx" + (if (tramp-compat-string-search "R" mode) "-" "w")))) line (substring line 0 -6)) (cl-return)) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index fd426960fd..6fc0ac8e1e 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1625,7 +1625,8 @@ default values are used." (setq v (tramp-dissect-hop-name hop) hop (and hop (tramp-make-tramp-hop-name v)))) (let ((tramp-default-host - (or (and v (not (string-match-p "%h" (tramp-file-name-host v))) + (or (and v (not (tramp-compat-string-search + "%h" (tramp-file-name-host v))) (tramp-file-name-host v)) tramp-default-host))) (setq method (tramp-find-method method user host) @@ -1973,7 +1974,7 @@ ARGUMENTS to actually emit the message (if applicable)." (if (not btf) (setq fn "") (and (symbolp btf) (setq fn (symbol-name btf)) - (or (not (string-match-p "^tramp" fn)) + (or (not (string-prefix-p "tramp" fn)) (get btf 'tramp-suppress-trace)) (setq fn nil)) (setq btn (1+ btn)))) @@ -2225,7 +2226,7 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', "Report progress of an operation for Tramp." (let* ((parameters (cdr reporter)) (message (aref parameters 3))) - (when (string-match-p message (or (current-message) "")) + (when (tramp-compat-string-search message (or (current-message) "")) (tramp-compat-progress-reporter-update reporter value suffix)))) (defmacro with-tramp-progress-reporter (vec level message &rest body) @@ -2339,7 +2340,7 @@ Example: (unless (and (functionp (nth 0 (car v))) (cond ;; Windows registry. - ((string-match-p "^HKEY_CURRENT_USER" (nth 1 (car v))) + ((string-prefix-p "HKEY_CURRENT_USER" (nth 1 (car v))) (and (memq system-type '(cygwin windows-nt)) (zerop (tramp-call-process @@ -2998,8 +2999,7 @@ remote host and localname (filename on remote host)." "Return all method completions for PARTIAL-METHOD." (mapcar (lambda (method) - (and method - (string-match-p (concat "^" (regexp-quote partial-method)) method) + (and method (string-prefix-p partial-method method) (tramp-completion-make-tramp-file-name method nil nil nil))) (mapcar #'car tramp-methods))) @@ -3011,8 +3011,7 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." (cond ((and partial-user partial-host) - (if (and host - (string-match-p (concat "^" (regexp-quote partial-host)) host) + (if (and host (string-prefix-p partial-host host) (string-equal partial-user (or user partial-user))) (setq user partial-user) (setq user nil @@ -3020,16 +3019,12 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." (partial-user (setq host nil) - (unless - (and user - (string-match-p (concat "^" (regexp-quote partial-user)) user)) + (unless (and user (string-prefix-p partial-user user)) (setq user nil))) (partial-host (setq user nil) - (unless - (and host - (string-match-p (concat "^" (regexp-quote partial-host)) host)) + (unless (and host (string-prefix-p partial-host host)) (setq host nil))) (t (setq user nil @@ -3707,7 +3702,7 @@ User is always nil." (list filename switches wildcard full-directory-p)) ;; `ls-lisp' always returns full listings. We must remove ;; superfluous parts. - (unless (string-match-p "l" switches) + (unless (tramp-compat-string-search "l" switches) (save-excursion (goto-char (point-min)) (while (setq start commit 1ab9fa60e75a15e09ca28966dd1e4cb364ca3809 Author: Rajeev Narang Date: Wed Aug 11 14:57:43 2021 +0200 Make icalendar parse multi-line items correctly * lisp/calendar/icalendar.el (icalendar--parse-summary-and-rest): Parse multi-line items correctly (bug#37887). diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index 3c1bac28f6..eaee2e9d95 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -1273,7 +1273,7 @@ Returns an alist." (concat "\\(" icalendar-import-format-uid "\\)??")))) ;; Need the \' regexp in order to detect multi-line items (setq s (concat "\\`" - (replace-regexp-in-string "%s" "\\(.*?\\)" s nil t) + (replace-regexp-in-string "%s" "\\([^z-a]*?\\)" s nil t) "\\'")) (if (string-match s summary-and-rest) (let (cla des loc org sta url uid) ;; sum commit 0af1142de17056d0feafdcd9257d5fc429a2f306 Author: Lars Ingebrigtsen Date: Wed Aug 11 14:54:20 2021 +0200 Fix icalendar-import-file prompt * lisp/calendar/icalendar.el (icalendar-import-file): Fix prompt. diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index cf37331394..3c1bac28f6 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -1985,9 +1985,7 @@ Argument ICAL-FILENAME output iCalendar file. Argument DIARY-FILENAME input `diary-file'. Optional argument NON-MARKING determines whether events are created as non-marking or not." - (interactive "fImport iCalendar data from file: \n\ -Finto diary file: -P") + (interactive "fImport iCalendar data from file: \nFInto diary file: \nP") ;; clean up the diary file (save-current-buffer ;; now load and convert from the ical file commit 8b15ce8daa1c8ad4fa948b7b58057441819e58c1 Author: Lars Ingebrigtsen Date: Wed Aug 11 14:52:32 2021 +0200 Make gnus-icalendar-event-from-ical more robust * lisp/gnus/gnus-icalendar.el (gnus-icalendar-event-from-ical): Don't bug out on nil UIDs. diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index 56f4fdf6d3..5294b83d9e 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -222,28 +222,32 @@ (uid . UID))) (method (caddr (assoc 'METHOD (caddr (car (nreverse ical)))))) (attendee (when attendee-name-or-email - (gnus-icalendar-event--find-attendee ical attendee-name-or-email))) + (gnus-icalendar-event--find-attendee + ical attendee-name-or-email))) (attendee-names (gnus-icalendar-event--get-attendee-names ical)) (role (plist-get (cadr attendee) 'ROLE)) (participation-type (pcase role - ("REQ-PARTICIPANT" 'required) - ("OPT-PARTICIPANT" 'optional) - (_ 'non-participant))) + ("REQ-PARTICIPANT" 'required) + ("OPT-PARTICIPANT" 'optional) + (_ 'non-participant))) (zone-map (icalendar--convert-all-timezones ical)) - (args (list :method method - :organizer organizer - :start-time (gnus-icalendar-event--decode-datefield event 'DTSTART zone-map) - :end-time (gnus-icalendar-event--decode-datefield event 'DTEND zone-map) - :rsvp (string= (plist-get (cadr attendee) 'RSVP) "TRUE") - :participation-type participation-type - :req-participants (car attendee-names) - :opt-participants (cadr attendee-names))) - (event-class (cond - ((string= method "REQUEST") 'gnus-icalendar-event-request) - ((string= method "CANCEL") 'gnus-icalendar-event-cancel) - ((string= method "REPLY") 'gnus-icalendar-event-reply) - (t 'gnus-icalendar-event)))) - + (args + (list :method method + :organizer organizer + :start-time (gnus-icalendar-event--decode-datefield + event 'DTSTART zone-map) + :end-time (gnus-icalendar-event--decode-datefield + event 'DTEND zone-map) + :rsvp (string= (plist-get (cadr attendee) 'RSVP) "TRUE") + :participation-type participation-type + :req-participants (car attendee-names) + :opt-participants (cadr attendee-names))) + (event-class + (cond + ((string= method "REQUEST") 'gnus-icalendar-event-request) + ((string= method "CANCEL") 'gnus-icalendar-event-cancel) + ((string= method "REPLY") 'gnus-icalendar-event-reply) + (t 'gnus-icalendar-event)))) (cl-labels ((map-property (prop) @@ -271,7 +275,11 @@ for keyword = (intern (format ":%s" (eieio-slot-descriptor-name slot))) when (plist-member args keyword) - append (list keyword (plist-get args keyword))))))) + append (list keyword + (if (eq keyword :uid) + ;; The UID has to be a string. + (or (plist-get args keyword) "") + (plist-get args keyword)))))))) (defun gnus-icalendar-event-from-buffer (buf &optional attendee-name-or-email) "Parse RFC5545 iCalendar in buffer BUF and return an event object. commit 024e6d213cfd6a0f273d485003e1c37e061ef227 Author: Peter Oliver Date: Sat Jul 10 12:01:57 2021 +0100 Drop redundant keywords in .desktop files. The Freedesktop.org Desktop Entry spec says, “The values [of Keywords]… should not be redundant with the values of Name or GenericName”. * etc/emacs.desktop, etc/emacsclient.desktop (Keywords): Remove keywords that are duplicated from the GenericName field. diff --git a/etc/emacs.desktop b/etc/emacs.desktop index 81c53c6121..0d7cac14da 100644 --- a/etc/emacs.desktop +++ b/etc/emacs.desktop @@ -10,4 +10,3 @@ Terminal=false Categories=Development;TextEditor; StartupNotify=true StartupWMClass=Emacs -Keywords=Text;Editor; diff --git a/etc/emacsclient.desktop b/etc/emacsclient.desktop index 4e4870730e..1ecdecffaf 100644 --- a/etc/emacsclient.desktop +++ b/etc/emacsclient.desktop @@ -10,7 +10,7 @@ Terminal=false Categories=Development;TextEditor; StartupNotify=true StartupWMClass=Emacs -Keywords=Text;Editor;emacsclient; +Keywords=emacsclient; Actions=new-window;new-instance; [Desktop Action new-window] commit aea7823a7e4a2cd3a1904b3bc2ed4f5fc5c26a69 Author: Peter Oliver Date: Sat Jul 10 12:01:09 2021 +0100 Hint that emacsclient.desktop should match a search for “emacsclient” This is necessary to get the Gnome desktop to show “Emacs (Client)” when the user searches for “emacsclient”. * etc/emacsclient.desktop, emacsclient-mail.desktop (Keywords): Add “emacsclient”. diff --git a/etc/emacsclient-mail.desktop b/etc/emacsclient-mail.desktop index f96e8a3c97..b575a41758 100644 --- a/etc/emacsclient-mail.desktop +++ b/etc/emacsclient-mail.desktop @@ -8,6 +8,7 @@ MimeType=x-scheme-handler/mailto; NoDisplay=true Terminal=false Type=Application +Keywords=emacsclient; Actions=new-window;new-instance; [Desktop Action new-window] diff --git a/etc/emacsclient.desktop b/etc/emacsclient.desktop index 0feec67da5..4e4870730e 100644 --- a/etc/emacsclient.desktop +++ b/etc/emacsclient.desktop @@ -10,7 +10,7 @@ Terminal=false Categories=Development;TextEditor; StartupNotify=true StartupWMClass=Emacs -Keywords=Text;Editor; +Keywords=Text;Editor;emacsclient; Actions=new-window;new-instance; [Desktop Action new-window] commit 0a4b66f82752adeb808851a36eabd0554779b33c Author: Peter Oliver Date: Wed Jul 7 22:04:01 2021 +0100 Valid quoting in .desktop files * etc/emacsclient.desktop, emacsclient-mail.desktop (Exec): Quote according to the rules in the Freedesktop.org Desktop Entry Specification. diff --git a/etc/emacsclient-mail.desktop b/etc/emacsclient-mail.desktop index 8d51dcdd2f..f96e8a3c97 100644 --- a/etc/emacsclient-mail.desktop +++ b/etc/emacsclient-mail.desktop @@ -1,7 +1,7 @@ [Desktop Entry] Categories=Network;Email; Comment=GNU Emacs is an extensible, customizable text editor - and more -Exec=sh -c 'exec emacsclient --alternate-editor= --display="$DISPLAY" --eval "(message-mailto \"%u\")"' +Exec=sh -c "exec emacsclient --alternate-editor= --display=\\"\\$DISPLAY\\" --eval \\\\(message-mailto\\\\ \\\\\\"%u\\\\\\"\\\\)" Icon=emacs Name=Emacs (Mail, Client) MimeType=x-scheme-handler/mailto; @@ -12,7 +12,7 @@ Actions=new-window;new-instance; [Desktop Action new-window] Name=New Window -Exec=emacsclient --alternate-editor= --create-frame --eval '(message-mailto "%u")' +Exec=emacsclient --alternate-editor= --create-frame --eval "(message-mailto \\"%u\\")" [Desktop Action new-instance] Name=New Instance diff --git a/etc/emacsclient.desktop b/etc/emacsclient.desktop index cd45463093..0feec67da5 100644 --- a/etc/emacsclient.desktop +++ b/etc/emacsclient.desktop @@ -3,7 +3,7 @@ Name=Emacs (Client) GenericName=Text Editor Comment=Edit text MimeType=text/english;text/plain;text/x-makefile;text/x-c++hdr;text/x-c++src;text/x-chdr;text/x-csrc;text/x-java;text/x-moc;text/x-pascal;text/x-tcl;text/x-tex;application/x-shellscript;text/x-c;text/x-c++; -Exec=sh -c 'if [ -n "$*" ]; then exec emacsclient --alternate-editor= --display="$DISPLAY" "$@"; else exec emacsclient --alternate-editor= --create-frame; fi' placeholder %F +Exec=sh -c "if [ -n \\"\\$*\\" ]; then exec emacsclient --alternate-editor= --display=\\"\\$DISPLAY\\" \\"\\$@\\"; else exec emacsclient --alternate-editor= --create-frame; fi" placeholder %F Icon=emacs Type=Application Terminal=false commit 8b645837d228102a04005b98d75a56f9b78cabae Author: Peter Münster Date: Wed Aug 11 14:03:23 2021 +0200 Mark marked images in Image-Dired mode * lisp/image-dired.el (image-dired-thumb-update-marks): New function that makes the marks visible in the thumbnail buffer (bug#49988). (image-dired-thumb-margin, image-dired-thumb-mark-color): New user options. diff --git a/doc/emacs/dired.texi b/doc/emacs/dired.texi index 3fbaf8bab7..680b20c593 100644 --- a/doc/emacs/dired.texi +++ b/doc/emacs/dired.texi @@ -1553,6 +1553,11 @@ image. You comment a file from the thumbnail buffer by typing @kbd{c}. You will be prompted for a comment. Type @kbd{C-t c} to add a comment from Dired (@code{image-dired-dired-comment-files}). +@vindex image-dired-thumb-visible-marks + Files that are marked in Dired will also be marked in Image-Dired if +@code{image-dired-thumb-visible-marks} is non-@code{nil} (which is the +default). + Image-Dired also provides simple image manipulation. In the thumbnail buffer, type @kbd{L} to rotate the original image 90 degrees anti clockwise, and @kbd{R} to rotate it 90 degrees clockwise. This diff --git a/etc/NEWS b/etc/NEWS index ac1fd3421f..523af6b97d 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2396,11 +2396,18 @@ When non-nil, this option suppresses lock files for remote files. This command, called interactively, toggles the local value of 'create-lockfiles' in the current buffer. -** Miscellaneous +** image-dired --- *** 'image-dired-mouse-toggle-mark' now toggles files in the active region. ++++ +*** New user option 'image-dired-thumb-visible-marks'. +If non-nil (the default), use 'image-dired-thumb-mark' to say what +images are marked. + +** Miscellaneous + --- *** 'shell-script-mode' now supports 'outline-minor-mode'. The outline headings have lines that start with "###". diff --git a/lisp/image-dired.el b/lisp/image-dired.el index cef145e9c8..2916323937 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -460,6 +460,19 @@ This is where you see the cursor." :type 'integer :group 'image-dired) +(defcustom image-dired-thumb-visible-marks t + "Make marks visible in thumbnail buffer. +If non-nil, apply the `image-dired-thumb-mark' face to marked +images." + :type 'boolean + :version "28.1") + +(defface image-dired-thumb-mark + '((t (:background "orange"))) + "Background-color for marked images in thumbnail buffer." + :group 'image-dired + :version "28.1") + (defcustom image-dired-line-up-method 'dynamic "Default method for line-up of thumbnails in thumbnail buffer. Used by `image-dired-display-thumbs' and other functions that needs @@ -1417,12 +1430,14 @@ dired." "Mark original image file in associated dired buffer." (interactive) (image-dired-modify-mark-on-thumb-original-file 'mark) + (image-dired-thumb-update-marks) (image-dired-forward-image)) (defun image-dired-unmark-thumb-original-file () "Unmark original image file in associated dired buffer." (interactive) (image-dired-modify-mark-on-thumb-original-file 'unmark) + (image-dired-thumb-update-marks) (image-dired-forward-image)) (defun image-dired-flag-thumb-original-file () @@ -1434,7 +1449,8 @@ dired." (defun image-dired-toggle-mark-thumb-original-file () "Toggle mark on original image file in associated dired buffer." (interactive) - (image-dired-modify-mark-on-thumb-original-file 'toggle)) + (image-dired-modify-mark-on-thumb-original-file 'toggle) + (image-dired-thumb-update-marks)) (defun image-dired-jump-original-dired-buffer () "Jump to the dired buffer associated with the current image file. @@ -2311,6 +2327,33 @@ non-nil." (image-dired-track-original-file)) (image-dired-display-thumb-properties)) +(defun image-dired-thumb-file-marked-p () + "Check if file is marked in associated dired buffer." + (let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (when (and dired-buf file-name) + (with-current-buffer dired-buf + (when (dired-goto-file file-name) + (image-dired-dired-file-marked-p)))))) + +(defun image-dired-thumb-update-marks () + "Update the marks in the thumbnail buffer." + ;; TODO: only called by image-dired-mouse-toggle-mark but there are + ;; certainly other places, where it should be called too. + (when image-dired-thumb-visible-marks + (with-current-buffer image-dired-thumbnail-buffer + (save-excursion + (goto-char (point-min)) + (let ((inhibit-read-only t)) + (while (not (eobp)) + (if (image-dired-thumb-file-marked-p) + (add-face-text-property + (point) (1+ (point)) + 'image-dired-thumb-mark) + (remove-text-properties (point) (1+ (point)) + '(face image-dired-thumb-mark))) + (forward-char))))))) + (defun image-dired-mouse-toggle-mark-1 () "Toggle dired mark for current thumbnail. Track this in associated dired buffer if `image-dired-track-movement' is @@ -2335,7 +2378,8 @@ non-nil." (forward-char)))) (mouse-set-point event) (goto-char (posn-point (event-end event))) - (image-dired-mouse-toggle-mark-1))) + (image-dired-mouse-toggle-mark-1)) + (image-dired-thumb-update-marks)) (defun image-dired-dired-display-properties () "Display properties for dired file in the echo area." commit c56e395edf5babdbcc65fa7bdb9fb462c674f156 Author: Peter Münster Date: Wed Aug 11 13:39:53 2021 +0200 Let image-dired-mouse-toggle-mark act on active region * lisp/image-dired.el (image-dired-mouse-toggle-mark): When region is active, then toggle marks of all images within (bug#49987). (image-dired-mouse-toggle-mark-1): Separated out into function. diff --git a/etc/NEWS b/etc/NEWS index 3560c9d34e..ac1fd3421f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2398,6 +2398,9 @@ This command, called interactively, toggles the local value of ** Miscellaneous +--- +*** 'image-dired-mouse-toggle-mark' now toggles files in the active region. + --- *** 'shell-script-mode' now supports 'outline-minor-mode'. The outline headings have lines that start with "###". diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 74985b9e56..cef145e9c8 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -2311,16 +2311,31 @@ non-nil." (image-dired-track-original-file)) (image-dired-display-thumb-properties)) +(defun image-dired-mouse-toggle-mark-1 () + "Toggle dired mark for current thumbnail. +Track this in associated dired buffer if `image-dired-track-movement' is +non-nil." + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-toggle-mark-thumb-original-file)) + (defun image-dired-mouse-toggle-mark (event) "Use mouse EVENT to toggle dired mark for thumbnail. +Toggle marks of all thumbnails in region, if it's active. Track this in associated dired buffer if `image-dired-track-movement' is non-nil." (interactive "e") - (mouse-set-point event) - (goto-char (posn-point (event-end event))) - (if image-dired-track-movement - (image-dired-track-original-file)) - (image-dired-toggle-mark-thumb-original-file)) + (if (use-region-p) + (let ((end (region-end))) + (save-excursion + (goto-char (region-beginning)) + (while (<= (point) end) + (when (image-dired-image-at-point-p) + (image-dired-mouse-toggle-mark-1)) + (forward-char)))) + (mouse-set-point event) + (goto-char (posn-point (event-end event))) + (image-dired-mouse-toggle-mark-1))) (defun image-dired-dired-display-properties () "Display properties for dired file in the echo area."