commit 48d8543ff134e08332bf35d96409cb8e3c2cbfb9 (HEAD, refs/remotes/origin/master) Author: Eli Zaretskii Date: Thu Sep 15 09:16:41 2022 +0300 ; Fix doc string of 'loaddefs-generate' * lisp/emacs-lisp/loaddefs-gen.el (loaddefs-generate): Doc fix. (Bug#57815) diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 005a46c2d7..5819a26eb5 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -512,7 +512,7 @@ If COMPILE, don't include a \"don't compile\" cookie." (defun loaddefs-generate (dir output-file &optional excluded-files extra-data include-package-version generate-full) - "Generate loaddefs files for Lisp files in the directories DIRS. + "Generate loaddefs files for Lisp files in one or more directories given by DIR. DIR can be either a single directory or a list of directories. The autoloads will be written to OUTPUT-FILE. If any Lisp file @@ -520,7 +520,7 @@ binds `generated-autoload-file' as a file-local variable, write its autoloads into the specified file instead. The function does NOT recursively descend into subdirectories of the -directory or directories specified by DIRS. +directories specified by DIR. Optional argument EXCLUDED-FILES, if non-nil, should be a list of files, such as preloaded files, whose autoloads should not be written commit 52a3ba102c0bcfda1b69e33be2a93a245a4c3a84 Author: Eli Zaretskii Date: Thu Sep 15 09:14:59 2022 +0300 Revert "; Fix doc string of 'loaddefs-generate'" This reverts commit 5fe9a1a85ae6d54196031157a735352f6ab655ff. It included unrelated changes. diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 5819a26eb5..005a46c2d7 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -512,7 +512,7 @@ If COMPILE, don't include a \"don't compile\" cookie." (defun loaddefs-generate (dir output-file &optional excluded-files extra-data include-package-version generate-full) - "Generate loaddefs files for Lisp files in one or more directories given by DIR. + "Generate loaddefs files for Lisp files in the directories DIRS. DIR can be either a single directory or a list of directories. The autoloads will be written to OUTPUT-FILE. If any Lisp file @@ -520,7 +520,7 @@ binds `generated-autoload-file' as a file-local variable, write its autoloads into the specified file instead. The function does NOT recursively descend into subdirectories of the -directories specified by DIR. +directory or directories specified by DIRS. Optional argument EXCLUDED-FILES, if non-nil, should be a list of files, such as preloaded files, whose autoloads should not be written diff --git a/src/w32fns.c b/src/w32fns.c index 57296bd4e0..745458d0a0 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -10447,51 +10447,6 @@ w32_get_resource (const char *key, const char *name, LPDWORD lpdwtype) return (NULL); } -#ifdef WINDOWSNT - -/*********************************************************************** - Wallpaper - ***********************************************************************/ - -#if 0 - -typedef BOOL (WINAPI * SystemParametersInfoW_Proc) (UINT,UINT,PVOID,UINT); -static SystemParametersInfoW_Proc system_parameters_info_w_fn; - -DEFUN ("w32-set-wallpaper", Fw32_set_wallpaper, Sw32_set_wallpaper, 1, 1, 0, - doc: /* Set the desktop wallpaper image to IMAGE-FILE. */) - (Lisp_Object image_file) -{ - Lisp_Object encoded = ENCODE_FILE (Fexpand_file_name (image_file, Qnil)); - char *fname = SSDATA (encoded); - - if (w32_unicode_filenames) - { - } - else - { - char fname_a[MAX_PATH]; - - if (filename_to_ansi (fname, fname_a) != 0) - error ("Wallpaper file %s does not exist or cannot be accessed", fname); - - BOOL result = SystemParametersInfoA (SPI_SETDESKWALLPAPER, 0, fname_a, - SPIF_SENDCHANGE); - if (!result) - { - DWORD err = GetLastError (); - if (err) - error ("Could not set wallpaper: %s", w32_strerror (err)); - else - error ("Could not set wallpaper"); - } - } - return Qnil; -} -#endif - -#endif - /*********************************************************************** Initialization ***********************************************************************/ commit 5fe9a1a85ae6d54196031157a735352f6ab655ff Author: Eli Zaretskii Date: Thu Sep 15 09:12:13 2022 +0300 ; Fix doc string of 'loaddefs-generate' * lisp/emacs-lisp/loaddefs-gen.el (loaddefs-generate): Doc fix. (Bug#57815) diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 005a46c2d7..5819a26eb5 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -512,7 +512,7 @@ If COMPILE, don't include a \"don't compile\" cookie." (defun loaddefs-generate (dir output-file &optional excluded-files extra-data include-package-version generate-full) - "Generate loaddefs files for Lisp files in the directories DIRS. + "Generate loaddefs files for Lisp files in one or more directories given by DIR. DIR can be either a single directory or a list of directories. The autoloads will be written to OUTPUT-FILE. If any Lisp file @@ -520,7 +520,7 @@ binds `generated-autoload-file' as a file-local variable, write its autoloads into the specified file instead. The function does NOT recursively descend into subdirectories of the -directory or directories specified by DIRS. +directories specified by DIR. Optional argument EXCLUDED-FILES, if non-nil, should be a list of files, such as preloaded files, whose autoloads should not be written diff --git a/src/w32fns.c b/src/w32fns.c index 745458d0a0..57296bd4e0 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -10447,6 +10447,51 @@ w32_get_resource (const char *key, const char *name, LPDWORD lpdwtype) return (NULL); } +#ifdef WINDOWSNT + +/*********************************************************************** + Wallpaper + ***********************************************************************/ + +#if 0 + +typedef BOOL (WINAPI * SystemParametersInfoW_Proc) (UINT,UINT,PVOID,UINT); +static SystemParametersInfoW_Proc system_parameters_info_w_fn; + +DEFUN ("w32-set-wallpaper", Fw32_set_wallpaper, Sw32_set_wallpaper, 1, 1, 0, + doc: /* Set the desktop wallpaper image to IMAGE-FILE. */) + (Lisp_Object image_file) +{ + Lisp_Object encoded = ENCODE_FILE (Fexpand_file_name (image_file, Qnil)); + char *fname = SSDATA (encoded); + + if (w32_unicode_filenames) + { + } + else + { + char fname_a[MAX_PATH]; + + if (filename_to_ansi (fname, fname_a) != 0) + error ("Wallpaper file %s does not exist or cannot be accessed", fname); + + BOOL result = SystemParametersInfoA (SPI_SETDESKWALLPAPER, 0, fname_a, + SPIF_SENDCHANGE); + if (!result) + { + DWORD err = GetLastError (); + if (err) + error ("Could not set wallpaper: %s", w32_strerror (err)); + else + error ("Could not set wallpaper"); + } + } + return Qnil; +} +#endif + +#endif + /*********************************************************************** Initialization ***********************************************************************/ commit 41551ccbf63df589ed50129e92fa8dfe457617d0 Merge: b8e9239b47 5543aea1b2 Author: Stefan Kangas Date: Thu Sep 15 06:30:40 2022 +0200 Merge from origin/emacs-28 5543aea1b2 Automate exporting etc/NEWS to HTML 23a91163ed * Makefile.in (uninstall): Remove the *.eln files. (Bug#5... commit b8e9239b47391c6628d94a4e2e91320c5366d27b Author: Jim Porter Date: Tue Sep 13 16:14:00 2022 -0700 Allow using a symbol as an index into an alist in Eshell * lisp/eshell/esh-var.el (eshell-index-value): If INDEX is a symbol, use 'assoc' for indexing. * test/lisp/eshell/esh-var-tests.el (esh-var-test/interp-var-assoc) (esh-var-test/quoted-interp-var-assoc): Add checks for indexing via symbol (bug#57787). diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index a9df172e88..36e59cd5a4 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -646,23 +646,24 @@ For example, to retrieve the second element of a user's record in "Reference VALUE using the given INDEX." (when (and (stringp index) (get-text-property 0 'number index)) (setq index (string-to-number index))) - (if (stringp index) - (cdr (assoc index value)) - (cond - ((ring-p value) - (if (> index (ring-length value)) - (error "Index exceeds length of ring") - (ring-ref value index))) - ((listp value) - (if (> index (length value)) - (error "Index exceeds length of list") - (nth index value))) - ((vectorp value) - (if (> index (length value)) - (error "Index exceeds length of vector") - (aref value index))) - (t - (error "Invalid data type for indexing"))))) + (if (integerp index) + (cond + ((ring-p value) + (if (> index (ring-length value)) + (error "Index exceeds length of ring") + (ring-ref value index))) + ((listp value) + (if (> index (length value)) + (error "Index exceeds length of list") + (nth index value))) + ((vectorp value) + (if (> index (length value)) + (error "Index exceeds length of vector") + (aref value index))) + (t + (error "Invalid data type for indexing"))) + ;; INDEX is some non-integer value, so treat VALUE as an alist. + (cdr (assoc index value)))) ;;;_* Variable name completion diff --git a/test/lisp/eshell/esh-var-tests.el b/test/lisp/eshell/esh-var-tests.el index bebc57d359..cb5b1766bb 100644 --- a/test/lisp/eshell/esh-var-tests.el +++ b/test/lisp/eshell/esh-var-tests.el @@ -105,9 +105,11 @@ (ert-deftest esh-var-test/interp-var-assoc () "Interpolate alist variable with index" - (let ((eshell-test-value '(("foo" . 1)))) + (let ((eshell-test-value '(("foo" . 1) (bar . 2)))) (eshell-command-result-equal "echo $eshell-test-value[foo]" - 1))) + 1) + (eshell-command-result-equal "echo $eshell-test-value[#'bar]" + 2))) (ert-deftest esh-var-test/interp-var-length-list () "Interpolate length of list variable" @@ -257,9 +259,11 @@ inside double-quotes" (ert-deftest esh-var-test/quoted-interp-var-assoc () "Interpolate alist variable with index inside double-quotes" - (let ((eshell-test-value '(("foo" . 1)))) + (let ((eshell-test-value '(("foo" . 1) (bar . 2)))) (eshell-command-result-equal "echo \"$eshell-test-value[foo]\"" - "1"))) + "1") + (eshell-command-result-equal "echo \"$eshell-test-value[#'bar]\"" + "2"))) (ert-deftest esh-var-test/quoted-interp-var-length-list () "Interpolate length of list variable inside double-quotes" commit 30ca49c8f64b73f991d94b10afcfc0e2d592fe6a Author: Sean Whitton Date: Wed Sep 14 09:49:27 2022 -0700 Use '^' key for detach command bindings * lisp/tab-bar.el (tab-prefix-map): Move tear-off-window to C-x w ^ f. Bind tab-window-detach to C-x w ^ t. * lisp/window.el (window-prefix-map): Bind tab-detach to C-x t ^ f. diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index cf5ae09a24..abefd996a8 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -2411,6 +2411,7 @@ When `switch-to-buffer-obey-display-actions' is non-nil, (keymap-set tab-prefix-map "M" #'tab-move-to) (keymap-set tab-prefix-map "G" #'tab-group) (keymap-set tab-prefix-map "r" #'tab-rename) +(keymap-set tab-prefix-map "^ f" #'tab-detach) (keymap-set tab-prefix-map "RET" #'tab-switch) (keymap-set tab-prefix-map "b" #'switch-to-buffer-other-tab) (keymap-set tab-prefix-map "f" #'find-file-other-tab) diff --git a/lisp/window.el b/lisp/window.el index d5f42dd10b..905803b19e 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -10593,7 +10593,8 @@ displaying that processes's buffer." "2" #'split-root-window-below "3" #'split-root-window-right "s" #'window-toggle-side-windows - "f" #'tear-off-window + "^ f" #'tear-off-window + "^ t" #'tab-window-detach "-" #'fit-window-to-buffer "0" #'delete-windows-on) (define-key ctl-x-map "w" window-prefix-map) commit 8c73ed0ec3328d4108e3084fc0dabdae8bb782a7 Author: Stefan Kangas Date: Thu Sep 15 00:53:12 2022 +0200 Add image-transform-reset-to-original to manual * doc/emacs/files.texi (Image Mode): Add 'image-transform-reset-to-original'. Suggested by Juri Linkov . diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi index 744b848335..1717c5c25b 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -2273,6 +2273,7 @@ behavior by using the options @code{image-auto-resize} and @findex image-transform-set-percent @findex image-transform-set-scale @findex image-transform-reset-to-initial +@findex image-transform-reset-to-original To resize the image manually you can use the command @code{image-transform-fit-to-window} bound to @kbd{s w} that fits the image to both the window height and width. To scale the image to a @@ -2281,7 +2282,8 @@ percentage of its original size, use the command image specifying a scale factor, use the command @code{image-transform-set-scale} bound to @kbd{s s}. To reset all transformations to the initial state, use -@code{image-transform-reset-to-initial} bound to @kbd{s 0}. +@code{image-transform-reset-to-initial} bound to @kbd{s 0}, or +@code{image-transform-reset-to-original} bound to @kbd{s o}. @findex image-next-file @findex image-previous-file commit 5798c4aa2a7b3e7337234e8122d8243ecf54b402 Author: Stefan Kangas Date: Thu Sep 15 00:53:00 2022 +0200 Support fbsetbg in wallpaper.el * lisp/image/wallpaper.el (wallpaper--default-commands) (wallpaper-command): Add "fbsetbg". diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index 6d57691ff0..2ebe5be033 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -61,6 +61,7 @@ ("gm" "display" "-size" "%wx%h" "-window" "root" "%f") ("display" "-resize" "%wx%h" "-window" "root" "%f") ("feh" "--bg-max" "%f") + ("fbsetbg" "-a" "%f") ("xwallpaper" "--zoom" "%f") ("hsetroot" "-full" "%f") ("xloadimage" "-onroot" "-fullscreen" "%f") @@ -152,6 +153,7 @@ native API will be used instead (see `haiku-set-wallpaper')." (const :tag "gm (X Window System)" "gm") (const :tag "display (X Window System)" "display") (const :tag "feh (X Window System)" "feh") + (const :tag "fbsetbg (X Window System)" "fbsetbg") (const :tag "xwallpaper (X Window System)" "xwallpaper") (const :tag "hsetroot (X Window System)" "hsetroot") (const :tag "xloadimage (X Window System)" "xloadimage") commit a9941269683fe50673d0aa81feefb7a9d3d8a6b9 Author: Augusto Stoffel Date: Thu Sep 8 11:09:42 2022 +0200 pcomplete: Generate completions from --help messages * lisp/pcomplete.el (pcomplete-from-help): New function (and hash table) to get pcomplete candidates from help messages. (pcomplete-here-using-help): Helper function to define pcomplete for simple commands (pcomplete-completions-at-point): Provide annotation-function and company-docsig properties. * lisp/pcmpl-git.el: New file, provides pcomplete for Git. * lisp/pcmpl-gnu.el: Add pcomplete for awk, gpg and gdb, emacs and emacsclient. * lisp/pcmpl-linux.el: Add pcomplete for systemctl and journalctl. * lisp/pcmpl-rpm.el: Add pcomplete for dnf. * lisp/pcmpl-unix.el: Add pcomplete for sudo and most commands found in GNU Coreutils. * lisp/pcmpl-x.el: Add pcomplete for tex, pdftex, latex, pdflatex, rigrep and rclone. * test/lisp/pcomplete-tests.el (pcomplete-test-parse-gpg-help, pcomplete-test-parse-git-help): Tests for the new functions. diff --git a/lisp/pcmpl-git.el b/lisp/pcmpl-git.el new file mode 100644 index 0000000000..3584fa0673 --- /dev/null +++ b/lisp/pcmpl-git.el @@ -0,0 +1,110 @@ +;;; pcmpl-git.el --- Completions for Git -*- lexical-binding: t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Package: pcomplete + +;; 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 completion rules for the Git program. + +;;; Code: + +(require 'pcomplete) +(require 'vc-git) + +(defun pcmpl-git--expand-flags (args) + "In the list of ARGS, expand arguments of the form --[no-]flag." + (mapcan (lambda (arg) (if (string-search "[no-]" arg) + (list (string-replace "[no-]" "" arg) + (string-replace "[no-]" "no-" arg)) + (list arg))) + args)) + +(defun pcmpl-git--tracked-file-predicate (&rest args) + "Return a predicate function determining the Git status of a file. +Files listed by `git ls-files ARGS' satisfy the predicate." + (when-let ((files (mapcar #'expand-file-name + (ignore-errors + (apply #'process-lines + vc-git-program "ls-files" args))))) + (lambda (file) + (setq file (expand-file-name file)) + (if (string-suffix-p "/" file) + (seq-some (lambda (f) (string-prefix-p file f)) + files) + (member file files))))) + +(defun pcmpl-git--remote-refs (remote) + "List the locally known Git revisions from REMOTE." + (delq nil + (mapcar + (let ((re (concat "\\`" (regexp-quote remote) "/\\(.*\\)"))) + (lambda (s) (when (string-match re s) (match-string 1 s)))) + (vc-git-revision-table nil)))) + +;;;###autoload +(defun pcomplete/git () + "Completion for the `git' command." + (let ((subcommands (pcomplete-from-help `(,vc-git-program "help" "-a") + :margin "^\\( +\\)[a-z]" + :argument "[[:alnum:]-]+"))) + (while (not (member (pcomplete-arg 1) subcommands)) + (if (string-prefix-p "-" (pcomplete-arg)) + (pcomplete-here (pcomplete-from-help `(,vc-git-program "help") + :margin "\\(\\[\\)-" + :separator " | " + :description "\\`")) + (pcomplete-here (completion-table-merge + subcommands + (when (string-prefix-p "-" (pcomplete-arg 1)) + (pcomplete-entries)))))) + (let ((subcmd (pcomplete-arg 1))) + (while (pcase subcmd + ((guard (string-prefix-p "-" (pcomplete-arg))) + (pcomplete-here + (pcmpl-git--expand-flags + (pcomplete-from-help `(,vc-git-program "help" ,subcmd) + :argument + "-+\\(?:\\[no-\\]\\)?[a-z-]+=?")))) + ;; Complete modified tracked files + ((or "add" "commit" "restore") + (pcomplete-here + (pcomplete-entries + nil (pcmpl-git--tracked-file-predicate "-m")))) + ;; Complete all tracked files + ((or "mv" "rm" "grep" "status") + (pcomplete-here + (pcomplete-entries nil (pcmpl-git--tracked-file-predicate)))) + ;; Complete revisions + ((or "branch" "merge" "rebase" "switch") + (pcomplete-here (vc-git-revision-table nil))) + ;; Complete revisions and tracked files + ;; TODO: diff and log accept revision ranges + ((or "checkout" "reset" "show" "diff" "log") + (pcomplete-here + (completion-table-in-turn + (vc-git-revision-table nil) + (pcomplete-entries nil (pcmpl-git--tracked-file-predicate))))) + ;; Complete remotes and their revisions + ((or "fetch" "pull" "push") + (pcomplete-here (process-lines vc-git-program "remote")) + (pcomplete-here (pcmpl-git--remote-refs (pcomplete-arg 1))))))))) + +(provide 'pcmpl-git) +;;; pcmpl-git.el ends here diff --git a/lisp/pcmpl-gnu.el b/lisp/pcmpl-gnu.el index 3c9bf1ec9d..cdfde5640a 100644 --- a/lisp/pcmpl-gnu.el +++ b/lisp/pcmpl-gnu.el @@ -394,6 +394,40 @@ Return the new list." (while (pcomplete-here (pcomplete-dirs) nil #'identity)))) ;;;###autoload -(defalias 'pcomplete/gdb 'pcomplete/xargs) +(defun pcomplete/awk () + "Completion for the `awk' command." + (pcomplete-here-using-help "awk --help" + :margin "\t" + :separator " +" + :description "\0" + :metavar "[=a-z]+")) + +;;;###autoload +(defun pcomplete/gpg () + "Completion for the `gpg` command." + (pcomplete-here-using-help "gpg --help" :narrow-end "^ -se")) + +;;;###autoload +(defun pcomplete/gdb () + "Completion for the `gdb' command." + (while + (cond + ((string= "--args" (pcomplete-arg 1)) + (funcall pcomplete-command-completion-function) + (funcall (or (pcomplete-find-completion-function (pcomplete-arg 1)) + pcomplete-default-completion-function))) + ((string-prefix-p "-" (pcomplete-arg 0)) + (pcomplete-here (pcomplete-from-help "gdb --help"))) + (t (pcomplete-here (pcomplete-entries)))))) + +;;;###autoload +(defun pcomplete/emacs () + "Completion for the `emacs' command." + (pcomplete-here-using-help "emacs --help" :margin "^\\(\\)-")) + +;;;###autoload +(defun pcomplete/emacsclient () + "Completion for the `emacsclient' command." + (pcomplete-here-using-help "emacsclient --help" :margin "^\\(\\)-")) ;;; pcmpl-gnu.el ends here diff --git a/lisp/pcmpl-linux.el b/lisp/pcmpl-linux.el index 7c072f3d40..023c655a2a 100644 --- a/lisp/pcmpl-linux.el +++ b/lisp/pcmpl-linux.el @@ -30,6 +30,7 @@ (provide 'pcmpl-linux) (require 'pcomplete) +(eval-when-compile (require 'rx)) ;; Functions: @@ -111,4 +112,71 @@ Test is done using `equal'." (pcomplete-uniquify-list points) (cons "swap" (pcmpl-linux-mounted-directories)))))) +;;; systemd + +(defun pcmpl-linux--systemd-units (&rest args) + "Run `systemd list-units ARGS' and return the output as a list." + (with-temp-buffer + (apply #'call-process + "systemctl" nil '(t nil) nil + "list-units" "--full" "--legend=no" "--plain" args) + (goto-char (point-min)) + (let (result) + (while (re-search-forward (rx bol (group (+ (not space))) + (+ space) (+ (not space)) + (+ space) (group (+ (not space))) + (+ space) (+ (not space)) + (+ space) (group (* nonl))) + nil t) + (push (match-string 1) result) + (put-text-property 0 1 'pcomplete-annotation + (concat " " (match-string 2)) + (car result)) + (put-text-property 0 1 'pcomplete-description + (match-string 3) + (car result))) + (nreverse result)))) + +;;;###autoload +(defun pcomplete/systemctl () + "Completion for the `systemctl' command." + (let ((subcmds (pcomplete-from-help + "systemctl --help" + :margin (rx bol " " (group) alpha) + :argument (rx (+ (any alpha ?-))) + :metavar (rx (group (+ " " (>= 2 (any upper "[]|.")))))))) + (while (not (member (pcomplete-arg 1) subcmds)) + (if (string-prefix-p "-" (pcomplete-arg 0)) + (pcomplete-here (pcomplete-from-help "systemctl --help" + :metavar "[^ ]+" + :separator " \\(\\)-")) + (pcomplete-here subcmds))) + (let ((subcmd (pcomplete-arg 1)) + (context (if (member "--user" pcomplete-args) "--user" "--system"))) + (while (pcase subcmd + ((guard (string-prefix-p "-" (pcomplete-arg 0))) + (pcomplete-here + (pcomplete-from-help "systemctl --help"))) + ;; TODO: suggest only relevant units to each subcommand + ("start" + (pcomplete-here + (pcmpl-linux--systemd-units context "--state" "inactive,failed"))) + ((or "restart" "stop") + (pcomplete-here + (pcmpl-linux--systemd-units context "--state" "active"))) + (_ (pcomplete-here + (completion-table-in-turn + (pcmpl-linux--systemd-units context "--all") + (pcomplete-entries))))))))) + +;;;###autoload +(defun pcomplete/journalctl () + "Completion for the `journalctl' command." + (while (if (string-prefix-p "-" (pcomplete-arg 0)) + (pcomplete-here (pcomplete-from-help "journalctl --help" + :metavar "[^ ]+" + :separator " \\(\\)-")) + (pcomplete-here (mapcar (lambda (s) (concat s "=")) + (process-lines "journalctl" "--fields")))))) + ;;; pcmpl-linux.el ends here diff --git a/lisp/pcmpl-rpm.el b/lisp/pcmpl-rpm.el index f7925d9d9e..ebb6b72600 100644 --- a/lisp/pcmpl-rpm.el +++ b/lisp/pcmpl-rpm.el @@ -21,7 +21,8 @@ ;;; Commentary: -;; These functions provide completion rules for the `rpm' command. +;; These functions provide completion rules for the `rpm' command and +;; related tools. ;;; Code: @@ -378,6 +379,46 @@ (t (error "You must select a mode: -q, -i, -U, --verify, etc")))))) +;;; DNF + +(defvar pcmpl-rpm-dnf-cache-file "/var/cache/dnf/packages.db" + "Location of the DNF cache.") + +(defun pcmpl-rpm--dnf-packages (status) + (when (and (file-exists-p pcmpl-rpm-dnf-cache-file) + (executable-find "sqlite3")) + (with-temp-message + "Getting list of packages..." + (process-lines "sqlite3" "-batch" "-init" "/dev/null" + pcmpl-rpm-dnf-cache-file + (pcase-exhaustive status + ('available "select pkg from available") + ('installed "select pkg from installed") + ('not-installed "\ +select pkg from available where pkg not in (select pkg from installed)")))))) + +;;;###autoload +(defun pcomplete/dnf () + "Completion for the `dnf' command." + (let ((subcmds (pcomplete-from-help "dnf help" + :margin "^\\(\\)[a-z-]+ " + :argument "[a-z-]+"))) + (while (not (member (pcomplete-arg 1) subcmds)) + (pcomplete-here (completion-table-merge + subcmds + (pcomplete-from-help "dnf help")))) + (let ((subcmd (pcomplete-arg 1))) + (while (pcase subcmd + ((guard (pcomplete-match "\\`-" 0)) + (pcomplete-here + (pcomplete-from-help `("dnf" "help" ,subcmd)))) + ((or "downgrade" "reinstall" "remove") + (pcomplete-here (pcmpl-rpm--dnf-packages 'installed))) + ((or "install" "mark" "reinstall" "upgrade") + (pcomplete-here (pcmpl-rpm--dnf-packages 'not-installed))) + ((or "builddep" "changelog" "info" "list" "repoquery" "updateinfo") + (pcomplete-here (pcmpl-rpm--dnf-packages 'available)))))))) + (provide 'pcmpl-rpm) ;;; pcmpl-rpm.el ends here diff --git a/lisp/pcmpl-unix.el b/lisp/pcmpl-unix.el index 8774f091c8..0c32f814d0 100644 --- a/lisp/pcmpl-unix.el +++ b/lisp/pcmpl-unix.el @@ -25,7 +25,7 @@ (require 'pcomplete) -;; User Variables: +;;; User Variables (defcustom pcmpl-unix-group-file "/etc/group" "If non-nil, a string naming the group file on your system." @@ -56,7 +56,7 @@ being via `pcmpl-ssh-known-hosts-file'." :group 'pcmpl-unix :version "24.1") -;; Functions: +;;; Shell builtins and core utilities ;;;###autoload (defun pcomplete/cd () @@ -69,34 +69,38 @@ being via `pcmpl-ssh-known-hosts-file'." ;;;###autoload (defun pcomplete/rmdir () "Completion for `rmdir'." - (while (pcomplete-here (pcomplete-dirs)))) + (while (if (string-prefix-p "-" (pcomplete-arg)) + (pcomplete-here (pcomplete-from-help "rmdir --help")) + (pcomplete-here (pcomplete-dirs))))) ;;;###autoload (defun pcomplete/rm () - "Completion for `rm'." - (let ((pcomplete-help "(fileutils)rm invocation")) - (pcomplete-opt "dfirRv") - (while (pcomplete-here (pcomplete-all-entries) nil - #'expand-file-name)))) + "Completion for the `rm' command." + (pcomplete-here-using-help "rm --help")) ;;;###autoload (defun pcomplete/xargs () "Completion for `xargs'." (while (string-prefix-p "-" (pcomplete-arg 0)) - (pcomplete-here (funcall pcomplete-default-completion-function))) + (pcomplete-here (pcomplete-from-help "xargs --help")) + (when (pcomplete-match "\\`-[adEIiLnPs]\\'") (pcomplete-here))) (funcall pcomplete-command-completion-function) (funcall (or (pcomplete-find-completion-function (pcomplete-arg 1)) pcomplete-default-completion-function))) -;; FIXME: Add completion of sudo-specific arguments. -(defalias 'pcomplete/sudo #'pcomplete/xargs) - ;;;###autoload -(defalias 'pcomplete/time 'pcomplete/xargs) +(defun pcomplete/time () + "Completion for the `time' command." + (pcomplete-opt "p") + (funcall pcomplete-command-completion-function) + (funcall (or (pcomplete-find-completion-function (pcomplete-arg 1)) + pcomplete-default-completion-function))) ;;;###autoload (defun pcomplete/which () "Completion for `which'." + (while (string-prefix-p "-" (pcomplete-arg 0)) + (pcomplete-here (pcomplete-from-help "which --help"))) (while (pcomplete-here (funcall pcomplete-command-completion-function)))) (defun pcmpl-unix-read-passwd-file (file) @@ -128,25 +132,455 @@ documentation), this function returns nil." (if pcmpl-unix-passwd-file (pcmpl-unix-read-passwd-file pcmpl-unix-passwd-file))) +;;;###autoload +(defun pcomplete/cat () + "Completion for the `cat' command." + (pcomplete-here-using-help "cat --help")) + +;;;###autoload +(defun pcomplete/tac () + "Completion for the `tac' command." + (pcomplete-here-using-help "tac --help")) + +;;;###autoload +(defun pcomplete/nl () + "Completion for the `nl' command." + (pcomplete-here-using-help "nl --help")) + +;;;###autoload +(defun pcomplete/od () + "Completion for the `od' command." + (pcomplete-here-using-help "od --help")) + +;;;###autoload +(defun pcomplete/base32 () + "Completion for the `base32' and `base64' commands." + (pcomplete-here-using-help "base32 --help")) +;;;###autoload +(defalias 'pcomplete/base64 'pcomplete/base32) + +;;;###autoload +(defun pcomplete/basenc () + "Completion for the `basenc' command." + (pcomplete-here-using-help "basenc --help")) + +;;;###autoload +(defun pcomplete/fmt () + "Completion for the `fmt' command." + (pcomplete-here-using-help "fmt --help")) + +;;;###autoload +(defun pcomplete/pr () + "Completion for the `pr' command." + (pcomplete-here-using-help "pr --help")) + +;;;###autoload +(defun pcomplete/fold () + "Completion for the `fold' command." + (pcomplete-here-using-help "fold --help")) + +;;;###autoload +(defun pcomplete/head () + "Completion for the `head' command." + (pcomplete-here-using-help "head --help")) + +;;;###autoload +(defun pcomplete/tail () + "Completion for the `tail' command." + (pcomplete-here-using-help "tail --help")) + +;;;###autoload +(defun pcomplete/split () + "Completion for the `split' command." + (pcomplete-here-using-help "split --help")) + +;;;###autoload +(defun pcomplete/csplit () + "Completion for the `csplit' command." + (pcomplete-here-using-help "csplit --help")) + +;;;###autoload +(defun pcomplete/wc () + "Completion for the `wc' command." + (pcomplete-here-using-help "wc --help")) + +;;;###autoload +(defun pcomplete/sum () + "Completion for the `sum' command." + (pcomplete-here-using-help "sum --help")) + +;;;###autoload +(defun pcomplete/cksum () + "Completion for the `cksum' command." + (pcomplete-here-using-help "cksum --help")) + +;;;###autoload +(defun pcomplete/b2sum () + "Completion for the `b2sum' command." + (pcomplete-here-using-help "b2sum --help")) + +;;;###autoload +(defun pcomplete/md5sum () + "Completion for checksum commands." + (pcomplete-here-using-help "md5sum --help")) +;;;###autoload(defalias 'pcomplete/sha1sum 'pcomplete/md5sum) +;;;###autoload(defalias 'pcomplete/sha224sum 'pcomplete/md5sum) +;;;###autoload(defalias 'pcomplete/sha256sum 'pcomplete/md5sum) +;;;###autoload(defalias 'pcomplete/sha384sum 'pcomplete/md5sum) +;;;###autoload(defalias 'pcomplete/sha521sum 'pcomplete/md5sum) + +;;;###autoload +(defun pcomplete/sort () + "Completion for the `sort' command." + (pcomplete-here-using-help "sort --help")) + +;;;###autoload +(defun pcomplete/shuf () + "Completion for the `shuf' command." + (pcomplete-here-using-help "shuf --help")) + +;;;###autoload +(defun pcomplete/uniq () + "Completion for the `uniq' command." + (pcomplete-here-using-help "uniq --help")) + +;;;###autoload +(defun pcomplete/comm () + "Completion for the `comm' command." + (pcomplete-here-using-help "comm --help")) + +;;;###autoload +(defun pcomplete/ptx () + "Completion for the `ptx' command." + (pcomplete-here-using-help "ptx --help")) + +;;;###autoload +(defun pcomplete/tsort () + "Completion for the `tsort' command." + (pcomplete-here-using-help "tsort --help")) + +;;;###autoload +(defun pcomplete/cut () + "Completion for the `cut' command." + (pcomplete-here-using-help "cut --help")) + +;;;###autoload +(defun pcomplete/paste () + "Completion for the `paste' command." + (pcomplete-here-using-help "paste --help")) + +;;;###autoload +(defun pcomplete/join () + "Completion for the `join' command." + (pcomplete-here-using-help "join --help")) + +;;;###autoload +(defun pcomplete/tr () + "Completion for the `tr' command." + (pcomplete-here-using-help "tr --help")) + +;;;###autoload +(defun pcomplete/expand () + "Completion for the `expand' command." + (pcomplete-here-using-help "expand --help")) + +;;;###autoload +(defun pcomplete/unexpand () + "Completion for the `unexpand' command." + (pcomplete-here-using-help "unexpand --help")) + +;;;###autoload +(defun pcomplete/ls () + "Completion for the `ls' command." + (pcomplete-here-using-help "ls --help")) +;;;###autoload(defalias 'pcomplete/dir 'pcomplete/ls) +;;;###autoload(defalias 'pcomplete/vdir 'pcomplete/ls) + +;;;###autoload +(defun pcomplete/cp () + "Completion for the `cp' command." + (pcomplete-here-using-help "cp --help")) + +;;;###autoload +(defun pcomplete/dd () + "Completion for the `dd' command." + (let ((operands (pcomplete-from-help "dd --help" + :argument "[a-z]+=" + :narrow-start "\n\n" + :narrow-end "\n\n"))) + (while + (cond ((pcomplete-match "\\`[io]f=\\(.*\\)" 0) + (pcomplete-here (pcomplete-entries) + (pcomplete-match-string 1 0))) + (t (pcomplete-here operands)))))) + +;;;###autoload +(defun pcomplete/install () + "Completion for the `install' command." + (pcomplete-here-using-help "install --help")) + +;;;###autoload +(defun pcomplete/mv () + "Completion for the `mv' command." + (pcomplete-here-using-help "mv --help")) + +;;;###autoload +(defun pcomplete/shred () + "Completion for the `shred' command." + (pcomplete-here-using-help "shred --help")) + +;;;###autoload +(defun pcomplete/ln () + "Completion for the `ln' command." + (pcomplete-here-using-help "ln --help")) + +;;;###autoload +(defun pcomplete/mkdir () + "Completion for the `mkdir' command." + (pcomplete-here-using-help "mkdir --help")) + +;;;###autoload +(defun pcomplete/mkfifo () + "Completion for the `mkfifo' command." + (pcomplete-here-using-help "mkfifo --help")) + +;;;###autoload +(defun pcomplete/mknod () + "Completion for the `mknod' command." + (pcomplete-here-using-help "mknod --help")) + +;;;###autoload +(defun pcomplete/readlink () + "Completion for the `readlink' command." + (pcomplete-here-using-help "readlink --help")) + ;;;###autoload (defun pcomplete/chown () "Completion for the `chown' command." - (unless (pcomplete-match "\\`-") - (if (pcomplete-match "\\`[^.]*\\'" 0) - (pcomplete-here* (pcmpl-unix-user-names)) - (if (pcomplete-match "\\.\\([^.]*\\)\\'" 0) - (pcomplete-here* (pcmpl-unix-group-names) - (pcomplete-match-string 1 0)) - (pcomplete-here*)))) + (while (pcomplete-match "\\`-" 0) + (pcomplete-here (pcomplete-from-help "chown --help"))) + (if (pcomplete-match "\\`[^.]*\\'" 0) + (pcomplete-here* (pcmpl-unix-user-names)) + (if (pcomplete-match "\\.\\([^.]*\\)\\'" 0) + (pcomplete-here* (pcmpl-unix-group-names) + (pcomplete-match-string 1 0)) + (pcomplete-here*))) (while (pcomplete-here (pcomplete-entries)))) ;;;###autoload (defun pcomplete/chgrp () "Completion for the `chgrp' command." - (unless (pcomplete-match "\\`-") - (pcomplete-here* (pcmpl-unix-group-names))) + (while (pcomplete-match "\\`-" 0) + (pcomplete-here (pcomplete-from-help "chgrp --help"))) + (pcomplete-here* (pcmpl-unix-group-names)) (while (pcomplete-here (pcomplete-entries)))) +;;;###autoload +(defun pcomplete/chmod () + "Completion for the `chmod' command." + (pcomplete-here-using-help "chmod --help")) + +;;;###autoload +(defun pcomplete/touch () + "Completion for the `touch' command." + (pcomplete-here-using-help "touch --help")) + +;;;###autoload +(defun pcomplete/df () + "Completion for the `df' command." + (pcomplete-here-using-help "df --help")) + +;;;###autoload +(defun pcomplete/du () + "Completion for the `du' command." + (pcomplete-here-using-help "du --help")) + +;;;###autoload +(defun pcomplete/stat () + "Completion for the `stat' command." + (pcomplete-here-using-help "stat --help")) + +;;;###autoload +(defun pcomplete/sync () + "Completion for the `sync' command." + (pcomplete-here-using-help "sync --help")) + +;;;###autoload +(defun pcomplete/truncate () + "Completion for the `truncate' command." + (pcomplete-here-using-help "truncate --help")) + +;;;###autoload +(defun pcomplete/echo () + "Completion for the `echo' command." + (pcomplete-here-using-help '("echo" "--help"))) + +;;;###autoload +(defun pcomplete/test () + "Completion for the `test' command." + (pcomplete-here-using-help '("[" "--help") + :margin "^ +\\([A-Z]+1 \\)?")) +;;;###autoload(defalias (intern "pcomplete/[") 'pcomplete/test) + +;;;###autoload +(defun pcomplete/tee () + "Completion for the `tee' command." + (pcomplete-here-using-help "tee --help")) + +;;;###autoload +(defun pcomplete/basename () + "Completion for the `basename' command." + (pcomplete-here-using-help "basename --help")) + +;;;###autoload +(defun pcomplete/dirname () + "Completion for the `dirname' command." + (pcomplete-here-using-help "dirname --help")) + +;;;###autoload +(defun pcomplete/pathchk () + "Completion for the `pathchk' command." + (pcomplete-here-using-help "pathchk --help")) + +;;;###autoload +(defun pcomplete/mktemp () + "Completion for the `mktemp' command." + (pcomplete-here-using-help "mktemp --help")) + +;;;###autoload +(defun pcomplete/realpath () + "Completion for the `realpath' command." + (pcomplete-here-using-help "realpath --help")) + +;;;###autoload +(defun pcomplete/id () + "Completion for the `id' command." + (while (string-prefix-p "-" (pcomplete-arg 0)) + (pcomplete-here (pcomplete-from-help "id --help"))) + (while (pcomplete-here (pcmpl-unix-user-names)))) + +;;;###autoload +(defun pcomplete/groups () + "Completion for the `groups' command." + (while (pcomplete-here (pcmpl-unix-user-names)))) + +;;;###autoload +(defun pcomplete/who () + "Completion for the `who' command." + (pcomplete-here-using-help "who --help")) + +;;;###autoload +(defun pcomplete/date () + "Completion for the `date' command." + (pcomplete-here-using-help "date --help")) + +;;;###autoload +(defun pcomplete/nproc () + "Completion for the `nproc' command." + (pcomplete-here-using-help "nproc --help")) + +;;;###autoload +(defun pcomplete/uname () + "Completion for the `uname' command." + (pcomplete-here-using-help "uname --help")) + +;;;###autoload +(defun pcomplete/hostname () + "Completion for the `hostname' command." + (pcomplete-here-using-help "hostname --help")) + +;;;###autoload +(defun pcomplete/uptime () + "Completion for the `uptime' command." + (pcomplete-here-using-help "uptime --help")) + +;;;###autoload +(defun pcomplete/chcon () + "Completion for the `chcon' command." + (pcomplete-here-using-help "chcon --help")) + +;;;###autoload +(defun pcomplete/runcon () + "Completion for the `runcon' command." + (while (string-prefix-p "-" (pcomplete-arg 0)) + (pcomplete-here (pcomplete-from-help "runcon --help")) + (when (pcomplete-match "\\`-[turl]\\'" 0) (pcomplete-here))) + (funcall pcomplete-command-completion-function) + (funcall (or (pcomplete-find-completion-function (pcomplete-arg 1)) + pcomplete-default-completion-function))) + +;;;###autoload +(defun pcomplete/chroot () + "Completion for the `chroot' command." + (while (string-prefix-p "-" (pcomplete-arg 0)) + (pcomplete-here (pcomplete-from-help "chroot --help"))) + (pcomplete-here (pcomplete-dirs)) + (funcall pcomplete-command-completion-function) + (funcall (or (pcomplete-find-completion-function (pcomplete-arg 1)) + pcomplete-default-completion-function))) + +;;;###autoload +(defun pcomplete/env () + "Completion for the `env' command." + (while (string-prefix-p "-" (pcomplete-arg 0)) + (pcomplete-here (pcomplete-from-help "env --help")) + (when (pcomplete-match "\\`-[uCS]\\'") (pcomplete-here))) + (while (pcomplete-match "=" 0) (pcomplete-here)) ; FIXME: Complete env vars + (funcall pcomplete-command-completion-function) + (funcall (or (pcomplete-find-completion-function (pcomplete-arg 1)) + pcomplete-default-completion-function))) + +;;;###autoload +(defun pcomplete/nice () + "Completion for the `nice' command." + (while (string-prefix-p "-" (pcomplete-arg 0)) + (pcomplete-here (pcomplete-from-help "nice --help")) + (pcomplete-here)) + (funcall pcomplete-command-completion-function) + (funcall (or (pcomplete-find-completion-function (pcomplete-arg 1)) + pcomplete-default-completion-function))) + +;;;###autoload +(defun pcomplete/nohup () + "Completion for the `nohup' command." + (while (string-prefix-p "-" (pcomplete-arg 0)) + (pcomplete-here (pcomplete-from-help "nohup --help"))) + (funcall pcomplete-command-completion-function) + (funcall (or (pcomplete-find-completion-function (pcomplete-arg 1)) + pcomplete-default-completion-function))) + +;;;###autoload +(defun pcomplete/stdbuf () + "Completion for the `stdbuf' command." + (while (string-prefix-p "-" (pcomplete-arg 0)) + (pcomplete-here (pcomplete-from-help "stdbuf --help")) + (when (pcomplete-match "\\`-[ioe]\\'") (pcomplete-here))) + (funcall pcomplete-command-completion-function) + (funcall (or (pcomplete-find-completion-function (pcomplete-arg 1)) + pcomplete-default-completion-function))) + +;;;###autoload +(defun pcomplete/timeout () + "Completion for the `timeout' command." + (while (string-prefix-p "-" (pcomplete-arg 0)) + (pcomplete-here (pcomplete-from-help "timeout --help")) + (when (pcomplete-match "\\`-[ks]\\'") (pcomplete-here))) + (pcomplete-here) ; eat DURATION argument + (funcall pcomplete-command-completion-function) + (funcall (or (pcomplete-find-completion-function (pcomplete-arg 1)) + pcomplete-default-completion-function))) + +;;;###autoload +(defun pcomplete/numfmt () + "Completion for the `numfmt' command." + (pcomplete-here-using-help "numfmt --help")) + +;;;###autoload +(defun pcomplete/seq () + "Completion for the `seq' command." + (pcomplete-here-using-help "seq --help")) + +;;; Network commands ;; ssh support by Phil Hagelberg. ;; https://www.emacswiki.org/cgi-bin/wiki/pcmpl-ssh.el @@ -239,6 +673,18 @@ Includes files as well as host names followed by a colon." (pcomplete-opt "xl(pcmpl-unix-user-names)") (pcmpl-unix-complete-hostname)) +;;; Miscellaneous + +;;;###autoload +(defun pcomplete/sudo () + "Completion for the `sudo' command." + (while (string-prefix-p "-" (pcomplete-arg 0)) + (pcomplete-here (pcomplete-from-help "sudo --help")) + (when (pcomplete-match "\\`-[CDghpRtTUu]\\'") (pcomplete-here))) + (funcall pcomplete-command-completion-function) + (funcall (or (pcomplete-find-completion-function (pcomplete-arg 1)) + pcomplete-default-completion-function))) + (provide 'pcmpl-unix) ;;; pcmpl-unix.el ends here diff --git a/lisp/pcmpl-x.el b/lisp/pcmpl-x.el index 261a3d4e27..1ede867c5f 100644 --- a/lisp/pcmpl-x.el +++ b/lisp/pcmpl-x.el @@ -28,6 +28,22 @@ (eval-when-compile (require 'cl-lib)) (require 'pcomplete) +;;; TeX + +;;;###autoload +(defun pcomplete/tex () + "Completion for the `tex' command." + (pcomplete-here-using-help "tex --help" + :margin "^\\(?:\\[-no\\]\\)?\\(\\)-")) +;;;###autoload(defalias 'pcomplete/pdftex 'pcomplete/tex) +;;;###autoload(defalias 'pcomplete/latex 'pcomplete/tex) +;;;###autoload(defalias 'pcomplete/pdflatex 'pcomplete/tex) + +;;;###autoload +(defun pcomplete/luatex () + "Completion for the `luatex' command." + (pcomplete-here-using-help "luatex --help")) +;;;###autoload(defalias 'pcomplete/lualatex 'pcomplete/luatex) ;;;; tlmgr - https://www.tug.org/texlive/tlmgr.html @@ -142,6 +158,12 @@ (unless (pcomplete-match "^--" 0) (pcomplete-here* (pcomplete-dirs-or-entries))))))) +;;; Grep-like tools + +;;;###autoload +(defun pcomplete/rg () + "Completion for the `rg' command." + (pcomplete-here-using-help "rg --help")) ;;;; ack - https://betterthangrep.com @@ -288,6 +310,8 @@ long options." (pcmpl-x-ag-options)))) (pcomplete-here* (pcomplete-dirs-or-entries))))) +;;; Borland + ;;;###autoload (defun pcomplete/bcc32 () "Completion function for Borland's C++ compiler." @@ -321,5 +345,24 @@ long options." ;;;###autoload (defalias 'pcomplete/bcc 'pcomplete/bcc32) +;;; Network tools + +;;;###autoload +(defun pcomplete/rclone () + "Completion for the `rclone' command." + (let ((subcmds (pcomplete-from-help "rclone help" + :margin "^ " + :argument "[a-z]+" + :narrow-start "\n\n"))) + (while (not (member (pcomplete-arg 1) subcmds)) + (pcomplete-here (completion-table-merge + subcmds + (pcomplete-from-help "rclone help flags")))) + (let ((subcmd (pcomplete-arg 1))) + (while (if (pcomplete-match "\\`-" 0) + (pcomplete-here (pcomplete-from-help + `("rclone" ,subcmd "--help"))) + (pcomplete-here (pcomplete-entries))))))) + (provide 'pcmpl-x) ;;; pcmpl-x.el ends here diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index 0e3d1df781..6fe29d9dcf 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -119,6 +119,9 @@ ;;; Code: (require 'comint) +(eval-when-compile + (require 'cl-lib) + (require 'rx)) (defgroup pcomplete nil "Programmable completion." @@ -481,6 +484,14 @@ Same as `pcomplete' but using the standard completion UI." (when completion-ignore-case (setq table (completion-table-case-fold table))) (list beg (point) table + :annotation-function + (lambda (cand) + (when (stringp cand) + (get-text-property 0 'pcomplete-annotation cand))) + :company-docsig + (lambda (cand) + (when (stringp cand) + (get-text-property 0 'pcomplete-help cand))) :predicate pred :exit-function ;; If completion is finished, add a terminating space. @@ -1325,6 +1336,133 @@ If specific documentation can't be given, be generic." (pcomplete-read-hosts pcomplete-hosts-file 'pcomplete--host-name-cache 'pcomplete--host-name-cache-timestamp))) +;;; Parsing help messages + +(defvar pcomplete-from-help (make-hash-table :test #'equal) + "Memoization table for function `pcomplete-from-help'.") + +(cl-defun pcomplete-from-help (command + &rest args + &key + (margin (rx bol (+ " "))) + (argument (rx "-" (+ (any "-" alnum)) (? "="))) + (metavar (rx (? " ") + (or (+ (any alnum "_-")) + (seq "[" (+? nonl) "]") + (seq "<" (+? nonl) ">") + (seq "{" (+? nonl) "}")))) + (separator (rx ", " symbol-start)) + (description (rx (* nonl) + (* "\n" (>= 9 " ") (* nonl)))) + narrow-start + narrow-end) + "Parse output of COMMAND into a list of completion candidates. + +COMMAND can be a string to be executed in a shell or a list of +strings (program name and arguments). It should print a help +message. + +A list of arguments is collected after each match of MARGIN. +Each argument should match ARGUMENT, possibly followed by a match +of METAVAR. If a match of SEPARATOR follows, then more +argument-metavar pairs are collected. Finally, a match of +DESCRIPTION is collected. + +Keyword ARGS: + +MARGIN: regular expression after which argument descriptions are + to be found. Parsing continues at the end of the first match + group or, failing that, the entire match. + +ARGUMENT: regular expression matching an argument name. The + first match group (failing that, the entire match) is collected + as the argument name. Parsing continues at the end of the + second matching group (failing that, the first group or entire + match). + +METAVAR: regular expression matching an argument parameter name. + The first match group (failing that, the entire match) is + collected as the parameter name and used as completion + annotation. Parsing continues at the end of the second + matching group (failing that, the first group or entire match). + +SEPARATOR: regular expression matching the separator between + arguments. Parsing continues at the end of the first match + group (failing that, the entire match). + +DESCRIPTION: regular expression matching the description of an + argument. The first match group (failing that, the entire + match) is collected as the parameter name and used as + completion help. Parsing continues at the end of the first + matching group (failing that, the entire match). + +NARROW-START, NARROW-END: if non-nil, parsing of the help message + is narrowed to the region between the end of the first match + group (failing that, the entire match) of these regular + expressions." + (with-memoization (gethash (cons command args) pcomplete-from-help) + (with-temp-buffer + (let ((case-fold-search nil) + (default-directory (expand-file-name "~/")) + (command (if (stringp command) + (list shell-file-name + shell-command-switch + command) + command)) + i result) + (apply #'call-process (car command) nil t nil (cdr command)) + (goto-char (point-min)) + (narrow-to-region (or (and narrow-start + (re-search-forward narrow-start nil t) + (or (match-beginning 1) (match-beginning 0))) + (point-min)) + (or (and narrow-end + (re-search-forward narrow-end nil t) + (or (match-beginning 1) (match-beginning 0))) + (point-max))) + (goto-char (point-min)) + (while (re-search-forward margin nil t) + (goto-char (or (match-end 1) (match-end 0))) + (setq i 0) + (while (and (or (zerop i) + (and (looking-at separator) + (goto-char (or (match-end 1) + (match-end 0))))) + (looking-at argument)) + (setq i (1+ i)) + (goto-char (seq-some #'match-end '(2 1 0))) + (push (or (match-string 1) (match-string 0)) result) + (when (looking-at metavar) + (goto-char (seq-some #'match-end '(2 1 0))) + (put-text-property 0 1 + 'pcomplete-annotation + (or (match-string 1) (match-string 0)) + (car result)))) + (when (looking-at description) + (goto-char (seq-some #'match-end '(2 1 0))) + (let ((help (string-clean-whitespace + (or (match-string 1) (match-string 0)))) + (items (take i result))) + (while items + (put-text-property 0 1 'pcomplete-help help + (pop items)))))) + (nreverse result))))) + +(defun pcomplete-here-using-help (command &rest args) + "Perform completion for a simple command. +Offer switches and directory entries as completion candidates. +The switches are obtained by calling `pcomplete-from-help' with +COMMAND and ARGS as arguments." + (while (cond + ((string= "--" (pcomplete-arg 1)) + (while (pcomplete-here (pcomplete-entries)))) + ((pcomplete-match "\\`--[^=]+=\\(.*\\)" 0) + (pcomplete-here (pcomplete-entries) + (pcomplete-match-string 1 0))) + ((string-prefix-p "-" (pcomplete-arg 0)) + (pcomplete-here (apply #'pcomplete-from-help command args))) + (t (pcomplete-here (pcomplete-entries)))))) + (provide 'pcomplete) ;;; pcomplete.el ends here diff --git a/test/lisp/pcomplete-tests.el b/test/lisp/pcomplete-tests.el new file mode 100644 index 0000000000..00a82502f3 --- /dev/null +++ b/test/lisp/pcomplete-tests.el @@ -0,0 +1,100 @@ +;;; pcomplete-tests.el --- Tests for pcomplete.el -*- lexical-binding: t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'pcomplete) + +(ert-deftest pcomplete-test-parse-gpg-help () + (cl-letf ((pcomplete-from-help (make-hash-table :test #'equal)) + ((symbol-function 'call-process) + (lambda (&rest _) (insert "\ +gpg (GnuPG) 2.3.7 + +Commands: + + -s, --sign make a signature + --clear-sign make a clear text signature + -b, --detach-sign make a detached signature + --tofu-policy VALUE set the TOFU policy for a key + +Options to specify keys: + -r, --recipient USER-ID encrypt for USER-ID + -u, --local-user USER-ID use USER-ID to sign or decrypt + +(See the man page for a complete listing of all commands and options) + +Examples: + + -se -r Bob [file] sign and encrypt for user Bob + --clear-sign [file] make a clear text signature +")))) + (should + (equal-including-properties + (pcomplete-from-help "gpg --help" :narrow-end "^ -se") + '(#("-s" 0 1 (pcomplete-help "make a signature")) + #("--sign" 0 1 (pcomplete-help "make a signature")) + #("--clear-sign" 0 1 (pcomplete-help "make a clear text signature")) + #("-b" 0 1 (pcomplete-help "make a detached signature")) + #("--detach-sign" 0 1 (pcomplete-help "make a detached signature")) + #("--tofu-policy" 0 1 + (pcomplete-help "set the TOFU policy for a key" pcomplete-annotation " VALUE")) + #("-r" 0 1 (pcomplete-help "encrypt for USER-ID")) + #("--recipient" 0 1 + (pcomplete-help "encrypt for USER-ID" pcomplete-annotation " USER-ID")) + #("-u" 0 1 + (pcomplete-help "use USER-ID to sign or decrypt")) + #("--local-user" 0 1 + (pcomplete-help "use USER-ID to sign or decrypt" pcomplete-annotation " USER-ID"))))))) + +(ert-deftest pcomplete-test-parse-git-help () + (cl-letf ((pcomplete-from-help (make-hash-table :test #'equal)) + ((symbol-function 'call-process) + (lambda (&rest _) (insert "\ +usage: git [-v | --version] [-h | --help] [-C ] [-c =] + [--exec-path[=]] [--html-path] [--man-path] [--info-path] + [-p | --paginate | -P | --no-pager] [--no-replace-objects] [--bare] + [--git-dir=] [--work-tree=] [--namespace=] + [--super-prefix=] [--config-env==] + [] +")))) + (should + (equal-including-properties + (pcomplete-from-help "git help" + :margin "\\(\\[\\)-" + :separator " | " + :description "\\`") + '("-v" "--version" "-h" "--help" + #("-C" 0 1 (pcomplete-annotation " ")) + #("-c" 0 1 (pcomplete-annotation " ")) + #("--exec-path" 0 1 (pcomplete-annotation "[=]")) + "--html-path" "--man-path" "--info-path" + "-p" "--paginate" "-P" "--no-pager" + "--no-replace-objects" "--bare" + #("--git-dir=" 0 1 (pcomplete-annotation "")) + #("--work-tree=" 0 1 (pcomplete-annotation "")) + #("--namespace=" 0 1 (pcomplete-annotation "")) + #("--super-prefix=" 0 1 (pcomplete-annotation "")) + #("--config-env=" 0 1 (pcomplete-annotation ""))))))) + +(provide 'pcomplete-tests) +;;; pcomplete-tests.el ends here commit 05971d2b8d47e69e9585d0d6066b8a607555aa48 Author: Augusto Stoffel Date: Wed Sep 14 20:11:28 2022 +0200 ; * src/emacs.c (usage_message): Remove stray tabs. diff --git a/src/emacs.c b/src/emacs.c index 3c76841281..91bf0a9b59 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -299,7 +299,7 @@ Initialization options:\n\ -x to be used in #!/usr/bin/emacs -x\n\ and has approximately the same meaning\n\ as -Q --script\n\ ---terminal, -t DEVICE use DEVICE for terminal I/O\n \ +--terminal, -t DEVICE use DEVICE for terminal I/O\n\ --user, -u USER load ~USER/.emacs instead of your own\n\ \n\ ", commit 7e6923017163561d1b8cedf15aac42e01e493aee Author: Eli Zaretskii Date: Wed Sep 14 21:37:50 2022 +0300 ; * lisp/image/image-crop.el (image-elide, image-crop): Doc fixes. diff --git a/lisp/image/image-crop.el b/lisp/image/image-crop.el index 64db226d50..7716efcd54 100644 --- a/lisp/image/image-crop.el +++ b/lisp/image/image-crop.el @@ -100,12 +100,11 @@ image data.") ;;;###autoload (defun image-elide (color &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. + "Elide a rectangle from the image under point, filling it with COLOR. +If SQUARE is non-nil (interactively, prefix arg), elide a square +instead of a rectangle from the image. -Interatively, the user will be prompted for the color to use, and -defaults to black." +Interactively, prompt for COLOR to use, defaulting to black." (interactive (list (read-color "Use color: ") current-prefix-arg)) (image-crop square (if (string-empty-p color) @@ -114,14 +113,14 @@ defaults to black." ;;;###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 SQUARE is non-nil (interactively, prefix arg), crop a square +instead of a rectangle from the image. -If ELIDE, remove a rectangle from the image instead of cropping -the image. In that case ELIDE, should be the name of a color to -use. +If ELIDE is non-nil, remove a rectangle/square from the image +instead of cropping the image. In that case ELIDE should be +the name of a color to fill the rectangle. -After cropping an image, it can be saved by `M-x image-save' or +After cropping an image, you can save it by `M-x image-save' or \\\\[image-save] when point is over the image." (interactive "P") (unless (image-type-available-p 'svg) commit b525f201ba9f4f8862059a49947874a2bfa0d2f1 Author: Lars Ingebrigtsen Date: Wed Sep 14 20:21:54 2022 +0200 Allow specifying the color to use in image-elide * lisp/image/image-crop.el (image-crop-elide-command): Adjust to allow specifying the color. (image-elide): Prompt for a color. (image-crop--crop-image-update): Pass the color along. diff --git a/lisp/image/image-crop.el b/lisp/image/image-crop.el index a88b8ed842..64db226d50 100644 --- a/lisp/image/image-crop.el +++ b/lisp/image/image-crop.el @@ -48,7 +48,8 @@ The following `format-spec' elements are allowed: :version "29.1") (defcustom image-crop-elide-command '("convert" "-draw" "rectangle %l,%t %r,%b" - "-" "%f:-") + "-fill" "%c" + "-" "%f:-") "Command to make a rectangle inside an image. The following `format-spec' elements are allowed: @@ -56,12 +57,13 @@ The following `format-spec' elements are allowed: %t: Top. %r: Right. %b: Bottom. +%c: Color. %f: Result file type." :type '(repeat string) :version "29.1") (defcustom image-crop-crop-command '("convert" "+repage" "-crop" "%wx%h+%l+%t" - "-" "%f:-") + "-" "%f:-") "Command to crop an image. The following `format-spec' elements are allowed: @@ -97,12 +99,17 @@ original buffer text, and the second parameter is the cropped image data.") ;;;###autoload -(defun image-elide (&optional square) +(defun image-elide (color &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)) +rectangle from the image. + +Interatively, the user will be prompted for the color to use, and +defaults to black." + (interactive (list (read-color "Use color: ") + current-prefix-arg)) + (image-crop square (if (string-empty-p color) + "black" color))) ;;;###autoload (defun image-crop (&optional square elide) @@ -111,7 +118,8 @@ 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. +the image. In that case ELIDE, should be the name of a color to +use. After cropping an image, it can be saved by `M-x image-save' or \\\\[image-save] when point is over the image." @@ -217,6 +225,7 @@ After cropping an image, it can be saved by `M-x image-save' or (?t . ,top) (?r . ,(+ left width)) (?b . ,(+ top height)) + (?c . ,elide) (?f . ,(cadr (split-string type "/"))))) (image-crop--process image-crop-crop-command `((?l . ,left) commit 5543aea1b2b8c68481ae0ce2bb501d8484ef7f7c (refs/remotes/origin/emacs-28) Author: Stefan Kangas Date: Wed Sep 14 16:22:59 2022 +0200 Automate exporting etc/NEWS to HTML * admin/admin.el (make-news-html-file): New function. * .gitignore: Ignore generated "etc/NEWS*.html" file. diff --git a/.gitignore b/.gitignore index 2254b8a9c8..e48e359426 100644 --- a/.gitignore +++ b/.gitignore @@ -263,6 +263,7 @@ doc/misc/cc-mode.ss doc/misc/modus-themes.texi doc/misc/org.texi etc/DOC +etc/NEWS*.html etc/refcards/emacsver.tex gnustmp* /info/ diff --git a/admin/admin.el b/admin/admin.el index 67cbf85a32..12e6fcb7f8 100644 --- a/admin/admin.el +++ b/admin/admin.el @@ -770,6 +770,136 @@ Optional argument TYPE is type of output (nil means all)." (if (member type (list nil m)) (make-manuals-dist--1 root m)))) +(defun make-news-html-file (root version) + "Convert the NEWS file into an HTML file." + (interactive (let ((root + (if noninteractive + (or (pop command-line-args-left) + default-directory) + (read-directory-name "Emacs root directory: " + source-directory nil t)))) + (list root + (read-string "Version number: " emacs-version)))) + (unless (file-exists-p (expand-file-name "src/emacs.c" root)) + (user-error "%s doesn't seem to be the root of an Emacs source tree" root)) + (let* ((dir (make-temp-file "emacs-news-file" t)) + (orig (expand-file-name "etc/NEWS" root)) + (new (expand-file-name (format "NEWS.%s.org" version) dir)) + (html-file (format "%s.html" (file-name-base new))) + (copyright-years (format-time-string "%Y"))) + (unwind-protect + (progn + (copy-file orig new) + (find-file new) + + ;; Find the copyright range: + (goto-char (point-min)) + (re-search-forward "^Copyright (C) \\([0-9-]+\\) Free Software Foundation, Inc.") + (setq copyright-years (match-string 1)) + + ;; Get rid of some unnecessary stuff: + (replace-regexp-in-region "^---$" "" (point-min) (point-max)) + (replace-regexp-in-region "^\\+\\+\\+$" "" (point-min) (point-max)) + (dolist (str '(" \n" + "GNU Emacs NEWS -- history of user-visible changes." + "Temporary note:" + "+++ indicates that all relevant manuals in doc/ have been updated." + "--- means no change in the manuals is needed." + "When you add a new item, use the appropriate mark if you are sure it" + "applies, and please also update docstrings as needed." + "You can narrow news to a specific version by calling 'view-emacs-news'" + "with a prefix argument or by typing 'C-u C-h C-n'.")) + (replace-string-in-region str "" (point-min) (point-max))) + + ;; Use Org-mode markers for . + (replace-regexp-in-region + ;; This could probably be improved quite a bit... + (rx "'" (group (+ (not (any "'\n")))) "'") + "~\\1~" (point-min) (point-max)) + + ;; Format Emacs Lisp. + (while (re-search-forward "^ " nil t) + (backward-paragraph) + (insert "\n#+begin_src emacs-lisp") + (forward-paragraph) + (insert "#+end_src\n")) + + ;; Insert Org-mode export headers. + (goto-char (point-min)) + (insert (format + "\ +#+title: GNU Emacs %s NEWS -- history of user-visible changes +#+author: +#+options: author:nil creator:nil toc:1 num:2 *:nil \\n:nil +#+language: en +#+HTML_LINK_HOME: https://www.gnu.org/software/emacs +#+html_head_extra: +#+html_head_extra: +#+html_head_extra: + +#+BEGIN_EXPORT html +
+ +\" + +
+#+END_EXPORT\n\n" + version)) + (org-mode) + (let ((org-html-postamble + (format + " +

+Return to the GNU Emacs home page. +

+ +
+
+ +

+Please send FSF & GNU inquiries to +<gnu@gnu.org>. +There are also other ways to contact +the FSF. +Broken links and other corrections or suggestions can be sent to +<bug-gnu-emacs@gnu.org>. +

+
+ +

+ Copyright © %s Free Software Foundation, Inc. +

+ +

This page is licensed under +a CC-BY-SA +license.

+ + + +

+Updated: + +$Date: %s $ + +

+
+" + copyright-years + ;; e.g. "2022/09/13 09:13:13" + (format-time-string "%Y/%M/%y %H:%m:%S")))) + ;; Actually export. + (org-html-export-to-html) + ;; Kill the .org buffer. + (kill-buffer (current-buffer)) + ;; Move file into place. + (let ((old (expand-file-name html-file dir)) + (new (expand-file-name html-file (expand-file-name "etc" root)))) + (delete-file new) + (copy-file old new) + (find-file new)))) + (delete-directory dir t)))) + ;; Stuff to check new `defcustom's got :version tags. ;; Adapted from check-declare.el. commit 0df76e3e71de3051c70f8a055e155cb536fe3e1b Author: Lars Ingebrigtsen Date: Wed Sep 14 18:33:09 2022 +0200 Make image-crop variables into user options * lisp/image/image-crop.el (image-crop): New group. (image-crop-crop-command, image-crop-resize-command) (image-crop-elide-command, image-crop-crop-command): Make into defcustoms. diff --git a/lisp/image/image-crop.el b/lisp/image/image-crop.el index 2eadd0e108..a88b8ed842 100644 --- a/lisp/image/image-crop.el +++ b/lisp/image/image-crop.el @@ -30,18 +30,24 @@ (require 'svg) (require 'text-property-search) +(defgroup image-crop () + "Image cropping." + :group 'image) + (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:-") +(defcustom 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.") +%f: Result file type." + :type '(repeat string) + :version "29.1") -(defvar image-crop-elide-command '("convert" "-draw" "rectangle %l,%t %r,%b" +(defcustom image-crop-elide-command '("convert" "-draw" "rectangle %l,%t %r,%b" "-" "%f:-") "Command to make a rectangle inside an image. @@ -50,9 +56,11 @@ The following `format-spec' elements are allowed: %t: Top. %r: Right. %b: Bottom. -%f: Result file type.") +%f: Result file type." + :type '(repeat string) + :version "29.1") -(defvar image-crop-crop-command '("convert" "+repage" "-crop" "%wx%h+%l+%t" +(defcustom image-crop-crop-command '("convert" "+repage" "-crop" "%wx%h+%l+%t" "-" "%f:-") "Command to crop an image. @@ -61,14 +69,18 @@ The following `format-spec' elements are allowed: %t: Top. %w: Width. %h: Height. -%f: Result file type.") +%f: Result file type." + :type '(repeat string) + :version "29.1") -(defvar image-crop-rotate-command '("convert" "-rotate" "%r" "-" "%f:-") +(defcustom 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.") +%f: Result file type." + :type '(repeat string) + :version "29.1") (defvar image-crop-buffer-text-function #'image-crop--default-buffer-text "Function to return the buffer text for the cropped image. commit 9148892768148f872e83293193c7f04b5add3d44 Author: Stefan Kangas Date: Wed Sep 14 18:17:42 2022 +0200 Support hsetroot in wallpaper.el * lisp/image/wallpaper.el (wallpaper--default-commands) (wallpaper-command): Add "hsetroot". diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index d2b82a7af5..6d57691ff0 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -62,6 +62,7 @@ ("display" "-resize" "%wx%h" "-window" "root" "%f") ("feh" "--bg-max" "%f") ("xwallpaper" "--zoom" "%f") + ("hsetroot" "-full" "%f") ("xloadimage" "-onroot" "-fullscreen" "%f") ("xsetbg" " %f") ) @@ -152,6 +153,7 @@ native API will be used instead (see `haiku-set-wallpaper')." (const :tag "display (X Window System)" "display") (const :tag "feh (X Window System)" "feh") (const :tag "xwallpaper (X Window System)" "xwallpaper") + (const :tag "hsetroot (X Window System)" "hsetroot") (const :tag "xloadimage (X Window System)" "xloadimage") (const :tag "xsetbg (X Window System)" "xsetbg")) (const :tag "Other (specify)" string)) commit 80c516bbc8ae07c39ff4ba46585700a9fd3dfc37 Author: Stefan Kangas Date: Wed Sep 14 18:12:39 2022 +0200 ; Fix typo in wallpaper--default-commands * lisp/image/wallpaper.el (wallpaper--default-commands): Fix typo. diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index 03b6afa4e0..d2b82a7af5 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -52,7 +52,7 @@ ;; Sway (Wayland) ("swaybg" "-o" "*" "-i" "%f" "-m" "fill") ;; Wayland General - ("wbg" %f) + ("wbg" "%f") ;; Gnome ("gsettings" "set" "org.gnome.desktop.background" "picture-uri" "file://%f") ;; KDE Plasma commit 0c9d32b59ed25ee560119f5ebcd98506abe5d9aa Author: Stefan Kangas Date: Wed Sep 14 17:45:34 2022 +0200 ; * etc/NEWS: Fix typo. diff --git a/etc/NEWS b/etc/NEWS index 4c41715145..decaff7fe6 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2739,7 +2739,7 @@ but switching to `ash` is generally much preferable. 'pascal-last-completions', 'pascal-show-completions', 'pascal-toggle-completions', 'pcomplete-arg-quote-list', 'pcomplete-quote-argument', 'prolog-char-quote-workaround', -'python-buffer, 'python-guess-indent', 'python-indent', +'python-buffer', 'python-guess-indent', 'python-indent', 'python-info-ppss-comment-or-string-p', 'python-info-ppss-context', 'python-info-ppss-context-type', 'python-preoutput-result', 'python-proc', 'python-send-receive', 'python-send-string', commit 6a22f7e5b7b30fa4fff21c24bdfe7f150f1d0ff6 Author: Lars Ingebrigtsen Date: Wed Sep 14 17:54:05 2022 +0200 Regenerated ldefs-boot.el diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 909ecf773c..e84795547c 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -33558,12 +33558,10 @@ 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" "\ +(defun vc-git-annotate-switches-safe-p (switches) "\ 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)") +this list might be extended in the future." (equal switches "-w")) (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." @@ -34723,6 +34721,11 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t) (register-definition-prefixes "w32-vars" '("w32-")) + +;;; Generated autoloads from image/wallpaper.el + +(register-definition-prefixes "wallpaper" '("wallpaper-")) + ;;; Generated autoloads from emacs-lisp/warnings.el commit a5e156581517d93b837f59992de8a8568582f8a9 Author: Lars Ingebrigtsen Date: Wed Sep 14 17:53:41 2022 +0200 Speed up Emacs build by autoloading vc-git-annotate-switches-safe-p * lisp/vc/vc-git.el (vc-git-annotate-switches-safe-p): Put the definition into the loaddefs file. diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 8d8ea33f8b..b1025ed714 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -119,13 +119,17 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." (repeat :tag "Argument List" :value ("") string)) :version "23.1") +;; We put the entire function into the autoload file so that we don't +;; have to load a whole bunch of vc.*el files just to see whether the +;; file-local variable is safe. ;;;###autoload -(defun vc-git-annotate-switches-safe-p (switches) - "Check if local value of `vc-git-annotate-switches' is safe. +(progn + (defun vc-git-annotate-switches-safe-p (switches) + "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." - ;; TODO: Probably most options are perfectly safe. - (equal switches "-w")) + ;; TODO: Probably most options are perfectly safe. + (equal switches "-w"))) (defcustom vc-git-annotate-switches nil "String or list of strings specifying switches for Git blame under VC. commit 15f42f193ba85489ee2a1e4406dae7944eee97b8 Author: Lars Ingebrigtsen Date: Wed Sep 14 16:04:42 2022 +0200 Fix image-mode.el compilation * lisp/image/image-crop.el (text-property-search): Require. diff --git a/lisp/image/image-crop.el b/lisp/image/image-crop.el index 9bb04d4a3b..2eadd0e108 100644 --- a/lisp/image/image-crop.el +++ b/lisp/image/image-crop.el @@ -28,6 +28,7 @@ ;;; Code: (require 'svg) +(require 'text-property-search) (defvar image-crop-exif-rotate nil "If non-nil, rotate images by updating exif data. commit 576eba77d3798dde08ae575ab5a47ea48fc1f185 Author: Lars Ingebrigtsen Date: Wed Sep 14 16:04:23 2022 +0200 Make image cropping work in image-mode buffers * lisp/image-mode.el (image-mode): Update the buffer text after cropping (bug#57793). diff --git a/lisp/image-mode.el b/lisp/image-mode.el index dded6d4f38..bc0f7ccb04 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -667,6 +667,9 @@ Key bindings: "(New file)") "Empty buffer")) (image-mode--display) + (setq-local image-crop-buffer-text-function + ;; Use the binary image data directly for the buffer text. + (lambda (_text image) image)) ;; Ensure that we recognize externally parsed image formats in ;; commands like `n'. (when image-use-external-converter commit 997284d2a506dbaf80005dba5e8696d28dc9a0c3 Author: Lars Ingebrigtsen Date: Wed Sep 14 15:59:55 2022 +0200 Don't alter the buffer contents in image-crop by default * lisp/image/image-crop.el (image-crop-buffer-text-function): Allow modes to alter the textual representation. (image-crop): Delete the complete image data without assuming it's all on one line (which isn't the case in image-mode, for instance). (image-crop--crop-image-update, image-crop--insert-image-data): Use image-crop-buffer-text-function. (image-crop--default-buffer-text): New default action -- don't alter the buffer contents (bug#57793). diff --git a/lisp/image/image-crop.el b/lisp/image/image-crop.el index e5014c81db..9bb04d4a3b 100644 --- a/lisp/image/image-crop.el +++ b/lisp/image/image-crop.el @@ -69,6 +69,20 @@ The following `format-spec' elements are allowed: %r: Rotation (in degrees). %f: Result file type.") +(defvar image-crop-buffer-text-function #'image-crop--default-buffer-text + "Function to return the buffer text for the cropped image. +After cropping an image, the displayed image will be updated to +show the cropped image in the buffer. Different modes will have +different ways to represent this image data in a buffer. For +instance, an HTML-based mode might want to represent the image +with , but that's up to the mode. + +The default action is to not alter the buffer text at all. + +The function is called with two arguments: The first is the +original buffer text, and the second parameter is the cropped +image data.") + ;;;###autoload (defun image-elide (&optional square) "Elide a square from the image under point. @@ -113,7 +127,21 @@ After cropping an image, it can be saved by `M-x image-save' or (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))) + ;; We want to get the original text that's covered by the + ;; image so that we can restore it. + (image-start + (save-excursion + (let ((match (text-property-search-backward 'display image))) + (if match + (prop-match-end match) + (point-min))))) + (image-end + (save-excursion + (let ((match (text-property-search-forward 'display image))) + (if match + (prop-match-beginning match) + (point-max))))) + (text (buffer-substring image-start image-end)) (inhibit-read-only t) orig-data) (with-temp-buffer @@ -132,7 +160,7 @@ After cropping an image, it can be saved by `M-x image-save' or (svg-embed svg data type t :width (car size) :height (cdr size)) - (delete-region (pos-bol) (pos-eol)) + (delete-region image-start image-end) (svg-insert-image svg) (let ((area (condition-case _ (save-excursion @@ -146,13 +174,14 @@ After cropping an image, it can be saved by `M-x image-save' or (if elide "elided" "cropped")) (delete-region (pos-bol) (pos-eol)) (if area - (image-crop--crop-image-update area orig-data size type elide) + (image-crop--crop-image-update + area orig-data size type elide text) ;; 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) +(defun image-crop--crop-image-update (area data size type elide text) (let* ((image-scaling-factor 1) (osize (image-size (create-image data nil t) t)) (factor (/ (float (car osize)) (car size))) @@ -182,7 +211,8 @@ After cropping an image, it can be saved by `M-x image-save' or (?w . ,width) (?h . ,height) (?f . ,(cadr (split-string type "/")))))) - (buffer-string))))) + (buffer-string)) + text))) (defun image-crop--crop-image-1 (svg &optional square image-width image-height op) (track-mouse @@ -353,19 +383,12 @@ After cropping an image, it can be saved by `M-x image-save' or `((?w . ,(image-property image :width)) (?f . ,(cadr (split-string content-type "/"))))))))) -(defun image-crop--insert-image-data (image) +(defun image-crop--insert-image-data (image text) (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))) + (funcall image-crop-buffer-text-function text image) nil nil t)) (defun image-crop--process (command expansions) @@ -378,6 +401,9 @@ After cropping an image, it can be saved by `M-x image-save' or (format-spec elem expansions)) (cdr command)))) +(defun image-crop--default-buffer-text (text _image) + (substring-no-properties text)) + (provide 'image-crop) ;;; image-crop.el ends here commit cba866599c23a64018f820e3c34c4a6817d7313e Author: Mattias Engdegård Date: Wed Sep 14 14:36:24 2022 +0200 Raise default max-specpdl-size and max-lisp-eval-depth Recent changes have caused bootstrapping to fail for certain configurations, and it was likely getting close to the limits for others. This change raises the limits to those previously used when configured for nativecomp: max-specpdl-size raised from 1800 to 2500 max-lisp-eval-depth raised from 800 to 1600 * src/eval.c (init_eval_once): Raise limits. * doc/lispref/eval.texi (Eval): * doc/lispref/variables.texi (Local Variables): Document new values. diff --git a/doc/lispref/eval.texi b/doc/lispref/eval.texi index ed3cf56e09..6e29a5403f 100644 --- a/doc/lispref/eval.texi +++ b/doc/lispref/eval.texi @@ -846,7 +846,7 @@ The depth limit counts internal uses of @code{eval}, @code{apply}, and expressions, and recursive evaluation of function call arguments and function body forms, as well as explicit calls in Lisp code. -The default value of this variable is 800. If you set it to a value +The default value of this variable is 1600. If you set it to a value less than 100, Lisp will reset it to 100 if the given value is reached. Entry to the Lisp debugger increases the value, if there is little room left, to make sure the debugger itself has room to diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index 80d6a01412..975e945b34 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -374,7 +374,7 @@ that Lisp avoids infinite recursion on an ill-defined function. @code{max-lisp-eval-depth} provides another limit on depth of nesting. @xref{Definition of max-lisp-eval-depth,, Eval}. -The default value is 1600. Entry to the Lisp debugger increases the +The default value is 2500. Entry to the Lisp debugger increases the value, if there is little room left, to make sure the debugger itself has room to execute. @end defopt diff --git a/src/eval.c b/src/eval.c index 56b4296662..bd414fb868 100644 --- a/src/eval.c +++ b/src/eval.c @@ -211,15 +211,10 @@ backtrace_thread_next (struct thread_state *tstate, union specbinding *pdl) void init_eval_once (void) { - /* Don't forget to update docs (lispref node "Local Variables"). */ -#ifndef HAVE_NATIVE_COMP - max_specpdl_size = 1800; /* See bug#46818. */ - max_lisp_eval_depth = 800; -#else - /* Original values increased for comp.el. */ + /* Don't forget to update docs + (lispref nodes "Local Variables" and "Eval"). */ max_specpdl_size = 2500; max_lisp_eval_depth = 1600; -#endif Vrun_hooks = Qnil; pdumper_do_now_and_after_load (init_eval_once_for_pdumper); } commit 37fe0cd3580f7998bd407d9a089c8c899011f8ae Author: Stefan Kangas Date: Wed Sep 14 15:34:38 2022 +0200 Rename image transform commands to be less confusing * lisp/image-mode.el (image-transform-original): Rename from this... (image-transform-reset-to-original): ...to this. Make old name into an obsolete function alias and update all callers. (image-transform-reset): Rename from this... (image-transform-reset-to-initial): ...to this. Make old name into an obsolete function alias and update all callers. (Bug#51451) * doc/emacs/files.texi (Image Mode): Update for above change. diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi index 7f87e21a98..744b848335 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -2272,16 +2272,16 @@ behavior by using the options @code{image-auto-resize} and @findex image-transform-fit-to-window @findex image-transform-set-percent @findex image-transform-set-scale -@findex image-transform-reset +@findex image-transform-reset-to-initial To resize the image manually you can use the command @code{image-transform-fit-to-window} bound to @kbd{s w} that fits the image to both the window height and width. To scale the image to a percentage of its original size, use the command -@code{image-transform-set-percent} bound to @kbd{s p}. To scale -the image specifying a scale factor, use the command +@code{image-transform-set-percent} bound to @kbd{s p}. To scale the +image specifying a scale factor, use the command @code{image-transform-set-scale} bound to @kbd{s s}. To reset all -transformations to the initial state, use @code{image-transform-reset} -bound to @kbd{s 0}. +transformations to the initial state, use +@code{image-transform-reset-to-initial} bound to @kbd{s 0}. @findex image-next-file @findex image-previous-file diff --git a/etc/NEWS b/etc/NEWS index a529279994..4c41715145 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1988,6 +1988,14 @@ These commands horizontally and vertically flip the image under point. It allows setting the image size to a percentage of its original size, and is bound to "s p" in Image mode. ++++ +*** 'image-transform-original' renamed to 'image-transform-reset-to-original'. +The old name was confusing, and is now an obsolete function alias. + ++++ +*** 'image-transform-reset' renamed to 'image-transform-reset-to-initial'. +The old name was confusing, and is now an obsolete function alias. + ** Images +++ diff --git a/lisp/image-mode.el b/lisp/image-mode.el index f2ffbd8944..dded6d4f38 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -499,8 +499,8 @@ image as text, when opening such images in `image-mode'." "s s" #'image-transform-set-scale "s r" #'image-transform-set-rotation "s m" #'image-transform-set-smoothing - "s o" #'image-transform-original - "s 0" #'image-transform-reset + "s o" #'image-transform-reset-to-original + "s 0" #'image-transform-reset-to-initial ;; Multi-frame keys "RET" #'image-toggle-animation @@ -571,9 +571,9 @@ image as text, when opening such images in `image-mode'." :help "Set rotation angle of the image"] ["Set Smoothing..." image-transform-set-smoothing :help "Toggle smoothing"] - ["Original Size" image-transform-original + ["Original Size" image-transform-reset-to-original :help "Reset image to actual size"] - ["Reset to Default Size" image-transform-reset + ["Reset to Default Size" image-transform-reset-to-initial :help "Reset all image transformations to initial size"] "--" ["Show Thumbnails" @@ -1608,14 +1608,14 @@ ROTATION should be in degrees." (setq image--transform-smoothing smoothing) (image-toggle-display-image)) -(defun image-transform-original () +(defun image-transform-reset-to-original () "Display the current image with the original (actual) size and rotation." (interactive nil image-mode) (setq image-transform-resize nil image-transform-scale 1) (image-toggle-display-image)) -(defun image-transform-reset () +(defun image-transform-reset-to-initial () "Display the current image with the default (initial) size and rotation." (interactive nil image-mode) (setq image-transform-resize image-auto-resize @@ -1624,6 +1624,9 @@ ROTATION should be in degrees." image--transform-smoothing nil) (image-toggle-display-image)) +(define-obsolete-function-alias 'image-transform-original #'image-transform-reset-to-original "29.1") +(define-obsolete-function-alias 'image-transform-reset #'image-transform-reset-to-initial "29.1") + (provide 'image-mode) ;;; image-mode.el ends here diff --git a/lisp/image/image-dired.el b/lisp/image/image-dired.el index ff10be2ab4..75dcdd8cbc 100644 --- a/lisp/image/image-dired.el +++ b/lisp/image/image-dired.el @@ -1508,14 +1508,14 @@ Dired." (defun image-dired-display-current-image-full () "Display current image in full size." - (declare (obsolete image-transform-original "29.1")) + (declare (obsolete image-transform-reset-to-original "29.1")) (interactive nil image-dired-thumbnail-mode) (let ((file (image-dired-original-file-name))) (if file (progn (image-dired-display-image file) (with-current-buffer image-dired-display-image-buffer - (image-transform-original))) + (image-transform-reset-to-original))) (error "No original file name at point")))) (defun image-dired-display-current-image-sized () commit 600bb2d45f2a7b0c9a302fc26f7dd4448b904921 Author: Stefan Kangas Date: Wed Sep 14 15:31:45 2022 +0200 ; * doc/emacs/files.texi (Image Mode): Improve indexing. diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi index 5b3b15cd38..7f87e21a98 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -2270,6 +2270,7 @@ behavior by using the options @code{image-auto-resize} and @code{image-auto-resize-on-window-resize}. @findex image-transform-fit-to-window +@findex image-transform-set-percent @findex image-transform-set-scale @findex image-transform-reset To resize the image manually you can use the command commit 4209a4d3aec930f705605d1e9fb8a49e5806adf5 Author: Lars Ingebrigtsen Date: Wed Sep 14 15:26:30 2022 +0200 Remove the save-match-data from shell-command * lisp/simple.el (shell-command): Remove save-match-data, since we're (in many cases) altering the match data earlier in the function anyway (bug#57795). diff --git a/lisp/simple.el b/lisp/simple.el index 60f2ad3452..1b9bf9fa6d 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -4563,85 +4563,81 @@ impose the use of a shell (with its need to quote arguments)." (set-marker (mark-marker) (point) (current-buffer))))) ;; Output goes in a separate buffer. - ;; Preserve the match data in case called from a program. - ;; FIXME: It'd be ridiculous for an Elisp function to call - ;; shell-command and assume that it won't mess the match-data! - (save-match-data - (if (string-match "[ \t]*&[ \t]*\\'" command) - ;; Command ending with ampersand means asynchronous. - (let* ((buffer (get-buffer-create - (or output-buffer shell-command-buffer-name-async))) - (bname (buffer-name buffer)) - (proc (get-buffer-process buffer)) - (directory default-directory)) - ;; Remove the ampersand. - (setq command (substring command 0 (match-beginning 0))) - ;; Ask the user what to do with already running process. - (when proc - (cond - ((eq async-shell-command-buffer 'confirm-kill-process) - ;; If will kill a process, query first. - (shell-command--same-buffer-confirm "Kill it") - (kill-process proc)) - ((eq async-shell-command-buffer 'confirm-new-buffer) - ;; If will create a new buffer, query first. - (shell-command--same-buffer-confirm "Use a new buffer") - (setq buffer (generate-new-buffer bname))) - ((eq async-shell-command-buffer 'new-buffer) - ;; It will create a new buffer. - (setq buffer (generate-new-buffer bname))) - ((eq async-shell-command-buffer 'confirm-rename-buffer) - ;; If will rename the buffer, query first. - (shell-command--same-buffer-confirm "Rename it") - (with-current-buffer buffer - (rename-uniquely)) - (setq buffer (get-buffer-create bname))) - ((eq async-shell-command-buffer 'rename-buffer) - ;; It will rename the buffer. - (with-current-buffer buffer - (rename-uniquely)) - (setq buffer (get-buffer-create bname))))) - (with-current-buffer buffer - (shell-command-save-pos-or-erase) - (setq default-directory directory) - (require 'shell) - (let ((process-environment - (append - (and (natnump async-shell-command-width) - (list - (format "COLUMNS=%d" - async-shell-command-width))) - (comint-term-environment) - process-environment))) - (setq proc - (start-process-shell-command "Shell" buffer command))) - (setq mode-line-process '(":%s")) - (shell-mode) - (setq-local revert-buffer-function - (lambda (&rest _) - (async-shell-command command buffer))) - (set-process-sentinel proc #'shell-command-sentinel) - ;; Use the comint filter for proper handling of - ;; carriage motion (see comint-inhibit-carriage-motion). - (set-process-filter proc #'comint-output-filter) - (if async-shell-command-display-buffer - ;; Display buffer immediately. - (display-buffer buffer '(nil (allow-no-window . t))) - ;; Defer displaying buffer until first process output. - ;; Use disposable named advice so that the buffer is - ;; displayed at most once per process lifetime. - (let ((nonce (make-symbol "nonce"))) - (add-function :before (process-filter proc) - (lambda (proc _string) - (let ((buf (process-buffer proc))) - (when (buffer-live-p buf) - (remove-function (process-filter proc) - nonce) - (display-buffer buf)))) - `((name . ,nonce))))))) - ;; Otherwise, command is executed synchronously. - (shell-command-on-region (point) (point) command - output-buffer nil error-buffer))))))) + (if (string-match "[ \t]*&[ \t]*\\'" command) + ;; Command ending with ampersand means asynchronous. + (let* ((buffer (get-buffer-create + (or output-buffer shell-command-buffer-name-async))) + (bname (buffer-name buffer)) + (proc (get-buffer-process buffer)) + (directory default-directory)) + ;; Remove the ampersand. + (setq command (substring command 0 (match-beginning 0))) + ;; Ask the user what to do with already running process. + (when proc + (cond + ((eq async-shell-command-buffer 'confirm-kill-process) + ;; If will kill a process, query first. + (shell-command--same-buffer-confirm "Kill it") + (kill-process proc)) + ((eq async-shell-command-buffer 'confirm-new-buffer) + ;; If will create a new buffer, query first. + (shell-command--same-buffer-confirm "Use a new buffer") + (setq buffer (generate-new-buffer bname))) + ((eq async-shell-command-buffer 'new-buffer) + ;; It will create a new buffer. + (setq buffer (generate-new-buffer bname))) + ((eq async-shell-command-buffer 'confirm-rename-buffer) + ;; If will rename the buffer, query first. + (shell-command--same-buffer-confirm "Rename it") + (with-current-buffer buffer + (rename-uniquely)) + (setq buffer (get-buffer-create bname))) + ((eq async-shell-command-buffer 'rename-buffer) + ;; It will rename the buffer. + (with-current-buffer buffer + (rename-uniquely)) + (setq buffer (get-buffer-create bname))))) + (with-current-buffer buffer + (shell-command-save-pos-or-erase) + (setq default-directory directory) + (require 'shell) + (let ((process-environment + (append + (and (natnump async-shell-command-width) + (list + (format "COLUMNS=%d" + async-shell-command-width))) + (comint-term-environment) + process-environment))) + (setq proc + (start-process-shell-command "Shell" buffer command))) + (setq mode-line-process '(":%s")) + (shell-mode) + (setq-local revert-buffer-function + (lambda (&rest _) + (async-shell-command command buffer))) + (set-process-sentinel proc #'shell-command-sentinel) + ;; Use the comint filter for proper handling of + ;; carriage motion (see comint-inhibit-carriage-motion). + (set-process-filter proc #'comint-output-filter) + (if async-shell-command-display-buffer + ;; Display buffer immediately. + (display-buffer buffer '(nil (allow-no-window . t))) + ;; Defer displaying buffer until first process output. + ;; Use disposable named advice so that the buffer is + ;; displayed at most once per process lifetime. + (let ((nonce (make-symbol "nonce"))) + (add-function :before (process-filter proc) + (lambda (proc _string) + (let ((buf (process-buffer proc))) + (when (buffer-live-p buf) + (remove-function (process-filter proc) + nonce) + (display-buffer buf)))) + `((name . ,nonce))))))) + ;; Otherwise, command is executed synchronously. + (shell-command-on-region (point) (point) command + output-buffer nil error-buffer)))))) (defun shell-command--same-buffer-confirm (action) (let ((help-form commit 54803dad6d11a369c9f63c3263c8d24f1967201d Author: Lars Ingebrigtsen Date: Wed Sep 14 15:17:43 2022 +0200 Fix textsec-suspicious foreground color * lisp/international/textsec-check.el (textsec-suspicious): Set the foreground, too (bug#57796). diff --git a/lisp/international/textsec-check.el b/lisp/international/textsec-check.el index 567ef73feb..99ffd397e2 100644 --- a/lisp/international/textsec-check.el +++ b/lisp/international/textsec-check.el @@ -35,7 +35,7 @@ If nil, these checks are disabled." :version "29.1") (defface textsec-suspicious - '((t (:weight bold :background "red"))) + '((t (:weight bold :background "red" :foreground "white"))) "Face used to highlight suspicious strings.") ;;;###autoload commit c2c4c89dbc4be55114f2874284bf46cf5bb711ed Author: Lars Ingebrigtsen Date: Wed Sep 14 15:16:27 2022 +0200 Also use eww URL transformers in the actual links * lisp/net/eww.el (eww-mode): Use it to transform URLs (bug#57796). * lisp/net/shr.el (shr-url-transformer): New variable. (shr-tag-a): Use it. diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 35e5bdd734..34e74f8ffa 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -1180,6 +1180,7 @@ the like." '((url . eww--url-at-point)))) (setq-local bookmark-make-record-function #'eww-bookmark-make-record) (buffer-disable-undo) + (setq-local shr-url-transformer #'eww--transform-url) (setq buffer-read-only t)) (defun eww--url-at-point () diff --git a/lisp/net/shr.el b/lisp/net/shr.el index a06978d9ce..54ce9b1a41 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -295,6 +295,11 @@ and other things: (make-composed-keymap shr-map image-map) shr-map)) +(defvar shr-url-transformer #'identity + "Function to transform URLs. +It's called with the URL as the parameter, and should return the + URL to use.") + ;; Public functions and commands. (declare-function libxml-parse-html-region "xml.c" (start end &optional base-url discard-comments)) @@ -1489,7 +1494,9 @@ ones, in case fg and bg are nil." (dom-attr dom 'name)))) ; Obsolete since HTML5. (push (cons id (set-marker (make-marker) start)) shr--link-targets)) (when url - (shr-urlify (or shr-start start) (shr-expand-url url) title) + (shr-urlify (or shr-start start) + (funcall shr-url-transformer (shr-expand-url url)) + title) ;; Check whether the URL is suspicious. (when-let ((warning (or (textsec-suspicious-p (shr-expand-url url) 'url) commit d3188196cca68f79a18a6d8a331fd98d4b18c22c Author: Stefan Kangas Date: Wed Sep 14 15:01:58 2022 +0200 Add new command image-mode-wallpaper-set * lisp/image-mode.el (wallpaper): Require. (image-mode-wallpaper-set): New command. (image-mode-map): Bind above new command to "W". diff --git a/etc/NEWS b/etc/NEWS index 0023d5e2eb..a529279994 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1954,6 +1954,11 @@ up as necessary. Unlike 'image-transform-fit-both', this does not only scale the image down, but up as well. It is bound to "s w" in Image Mode by default. +--- +*** New command 'image-mode-wallpaper-set'. +This command sets the desktop background to the current image. It is +bound to "W" by default. + +++ *** 'image-transform-fit-to-(height|width)' are now obsolete. Use the new command 'image-transform-fit-to-window' instead. @@ -2048,8 +2053,8 @@ 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. +This command sets the desktop background 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'. diff --git a/lisp/image-mode.el b/lisp/image-mode.el index d27462ff0a..f2ffbd8944 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -45,6 +45,7 @@ (require 'image) (require 'exif) (require 'dired) +(require 'wallpaper) (eval-when-compile (require 'cl-lib)) ;;; Image mode window-info management. @@ -523,6 +524,9 @@ image as text, when opening such images in `image-mode'." "S-SPC" #'image-scroll-down "DEL" #'image-scroll-down + ;; Misc + "W" #'image-mode-wallpaper-set + ;; Remapped " " #'image-forward-hscroll " " #'image-backward-hscroll @@ -1387,7 +1391,18 @@ If no such buffer exists, it will be opened." (prog1 (bookmark-default-handler bmk) (when (not (string= image-type (bookmark-prop-get bmk 'image-type))) (image-toggle-display)))) + + +;;; Setting the wallpaper + +(defun image-mode-wallpaper-set () + "Set the desktop background to the current image. +This uses `wallpaper-set' (which see)." + (interactive nil image-mode) + (wallpaper-set buffer-file-name)) + +;;; Image transformation (defsubst image-transform-width (width height) "Return the bounding box width of a rotated WIDTH x HEIGHT rectangle. commit 37e1c896a02995c4a8ddc431bf14bf3fe5846390 Author: Stefan Kangas Date: Wed Sep 14 13:30:22 2022 +0200 ; * lisp/image/wallpaper.el: Minor doc fixes. diff --git a/etc/NEWS b/etc/NEWS index 5276a49d5c..0023d5e2eb 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1989,20 +1989,6 @@ 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 sets the -desktop background. - -On GNU/Linux and other Unix-like systems, it uses an external command -(such as "swaybg", "gm", "display" or "xloadimage"). A suitable -command should be detected automatically in most cases, but can also -be customized manually with the new user options 'wallpaper-command' -and 'wallpaper-command-args' if needed. - -On Haiku, it uses the new function `haiku-set-wallpaper', which does -not rely on any external command. - ** Image-Dired +++ @@ -2457,6 +2443,20 @@ 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 'wallpaper'. +This package provides the command `wallpaper-set', which sets the +desktop background. + +On GNU/Linux and other Unix-like systems, it uses an external command +(such as "swaybg", "gm", "display" or "xloadimage"). A suitable +command should be detected automatically in most cases, but can also +be customized manually with the new user options 'wallpaper-command' +and 'wallpaper-command-args' if needed. + +On Haiku, it uses the new function `haiku-set-wallpaper', which does +not rely on any external command. + +++ ** New package 'oclosure'. Allows the creation of "functions with slots" or "function objects" diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index a3bf44a5c3..03b6afa4e0 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -1,4 +1,4 @@ -;;; wallpaper.el --- Set desktop wallpaper from Emacs -*- lexical-binding: t; -*- +;;; wallpaper.el --- Change desktop background from Emacs -*- lexical-binding: t; -*- ;; Copyright (C) 2022 Free Software Foundation, Inc. @@ -65,7 +65,7 @@ ("xloadimage" "-onroot" "-fullscreen" "%f") ("xsetbg" " %f") ) - "Executable used for setting the wallpaper. + "List of executables and options used for setting the wallpaper. This is used by `wallpaper--find-command' to automatically set `wallpaper-command', and by `wallpaper--find-command-args' to set `wallpaper-command-args'. The commands will be tested in the @@ -115,8 +115,9 @@ will be replaced as described in `wallpaper-command-args'.") (defvar wallpaper-command-args) ; silence byte-compiler (defun wallpaper--set-wallpaper-command (sym val) - "Set `wallpaper-command', and update `wallpaper-command-args'." - ;; Note: `command-args' is used by `wallpaper--find-command-arguments'. + "Set `wallpaper-command', and update `wallpaper-command-args'. +Used to set `wallpaper-command'." + ;; Note: `wallpaper-command' is used by `wallpaper--find-command-arguments'. (prog1 (set-default sym val) (set-default 'wallpaper-command-args (wallpaper--find-command-arguments)))) @@ -136,7 +137,10 @@ Note: If you find that you need to use a command in your environment that is not automatically detected, 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]." +can also use \\[report-emacs-bug]. + +The value of this variable is ignored on Haiku systems, where a +native API will be used instead (see `haiku-set-wallpaper')." :type '(choice (radio @@ -166,7 +170,13 @@ 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')." +returned by `display-pixel-width'). + +If `wallpaper-set' is run from a TTY frame, it will prompt for a +height and width for \"%h\" and \"%w\" instead. + +The value of this variable is ignored on Haiku systems, where a +native API will be used instead (see `haiku-set-wallpaper')." :type '(repeat string) :group 'image :version "29.1") @@ -207,8 +217,9 @@ See also `wallpaper-default-width'.") "Set the desktop background to FILE in a graphical environment. On GNU/Linux and other Unix-like systems, this relies on an -external command. Which command is being used depends on the -user option `wallpaper-commands'. +external command. Which command to use is automatically detected +in most cases, but can be manually customized with the user +options `wallpaper-command' and `wallpaper-command-args'. On Haiku, no external command is needed, so the value of `wallpaper-commands' is ignored." commit 4e207423eb74fae014e40a3027919bb11beb29aa Author: Stefan Kangas Date: Wed Sep 14 13:22:22 2022 +0200 Add :type to wallpaper-command * lisp/image/wallpaper.el (wallpaper-command): Make it easier to customize by adding a :type declaration covering all supported values. diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index e25ce448c1..a3bf44a5c3 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -47,6 +47,7 @@ ;;; Finding the wallpaper command (defvar wallpaper--default-commands + ;; When updating this, also update the custom :type for `wallpaper-command'. '( ;; Sway (Wayland) ("swaybg" "-o" "*" "-i" "%f" "-m" "fill") @@ -124,16 +125,32 @@ will be replaced as described in `wallpaper-command-args'.") "Executable used for setting the wallpaper. A suitable command for your environment should be detected automatically, so there is usually no need to customize this. -However, if you do need to change this, you might also want to -customize `wallpaper-command-args' to match. + +If you set this to any supported command using customize or +`setopt', the user option `wallpaper-command-args' is +automatically updated to match. If you need to change this to an +unsupported command, you will want to manually customize +`wallpaper-command-args' to match. Note: If you find that you need to use a command in your environment that is not automatically detected, 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 '(choice string - (const :tag "Not set" nil)) + :type + '(choice + (radio + (const :tag "gsettings (GNOME)" "gsettings") + (const :tag "plasma-apply-wallpaperimage (KDE Plasma)" "plasma-apply-wallpaperimage") + (const :tag "swaybg (Wayland/Sway)" "swaybg") + (const :tag "wbg (Wayland)" "wbg") + (const :tag "gm (X Window System)" "gm") + (const :tag "display (X Window System)" "display") + (const :tag "feh (X Window System)" "feh") + (const :tag "xwallpaper (X Window System)" "xwallpaper") + (const :tag "xloadimage (X Window System)" "xloadimage") + (const :tag "xsetbg (X Window System)" "xsetbg")) + (const :tag "Other (specify)" string)) :set #'wallpaper--set-wallpaper-command :group 'image :version "29.1") commit 0f4839fb6e17b193a67dcb089fb8ff15138a4129 Author: Evan Klitzke Date: Wed Sep 14 14:32:29 2022 +0200 Add consteval and constinit keywords to cc-mode * lisp/progmodes/cc-langs.el (c-modifier-kwds): Add consteval and constinit keywords (introduced in C++20) (bug#51092). Copyright-paperwork-exempt: yes diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index 068b4a65b2..bf7eee2283 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -2594,8 +2594,8 @@ will be handled." t nil (c c++) '("extern" "inline" "register" "static") c (append '("auto") (c-lang-const c-modifier-kwds)) - c++ (append '("constexpr" "explicit" "friend" "mutable" "template" - "thread_local" "virtual") + c++ (append '("consteval" "constexpr" "constinit" "explicit" + "friend" "mutable" "template" "thread_local" "virtual") ;; "using" is now handled specially (2020-09-14). (c-lang-const c-modifier-kwds)) objc '("auto" "bycopy" "byref" "extern" "in" "inout" "oneway" "out" "static") commit 23a91163ed13548c52c282c776f9cc6be308f3a1 Author: Eli Zaretskii Date: Wed Sep 14 15:14:00 2022 +0300 * Makefile.in (uninstall): Remove the *.eln files. (Bug#57771) diff --git a/Makefile.in b/Makefile.in index c902b46ced..7beb5480a4 100644 --- a/Makefile.in +++ b/Makefile.in @@ -812,7 +812,7 @@ uninstall: uninstall-$(NTDIR) uninstall-doc rm -f "$(DESTDIR)$(includedir)/emacs-module.h" $(MAKE) -C lib-src uninstall -unset CDPATH; \ - for dir in "$(DESTDIR)${lispdir}" "$(DESTDIR)${etcdir}" ; do \ + for dir in "$(DESTDIR)${lispdir}" "$(DESTDIR)${etcdir}" "$(ELN_DESTDIR)" ; do \ if [ -d "$${dir}" ]; then \ case `cd "$${dir}" ; /bin/pwd` in \ "`cd ${srcdir} ; /bin/pwd`"* ) ;; \ commit 6a5043e9f6dc8120f82d13ebde976df5f0a2ea73 Author: Basil L. Contovounesios Date: Wed Sep 14 13:51:41 2022 +0300 Fix more misleading cl-case quoting in tests * test/lisp/dnd-tests.el (x-begin-drag): * test/lisp/so-long-tests/so-long-tests-helpers.el (so-long-tests-assert-active, so-long-tests-assert-reverted): Remove misleading quoting in cl-case clauses (bug#51368). diff --git a/test/lisp/dnd-tests.el b/test/lisp/dnd-tests.el index 88f6e69457..67b660fc12 100644 --- a/test/lisp/dnd-tests.el +++ b/test/lisp/dnd-tests.el @@ -52,13 +52,13 @@ ;; Verify that the action is valid and pretend the drag succeeded ;; (by returning the action). (cl-ecase action - ('XdndActionCopy action) - ('XdndActionMove action) - ('XdndActionLink action) + (XdndActionCopy action) + (XdndActionMove action) + (XdndActionLink action) ;; These two are not technically valid, but x-begin-drag accepts ;; them anyway. - ('XdndActionPrivate action) - ('XdndActionAsk 'XdndActionPrivate)))) + (XdndActionPrivate action) + (XdndActionAsk 'XdndActionPrivate)))) ;; This doesn't work during tests. (defalias 'gui-set-selection diff --git a/test/lisp/so-long-tests/so-long-tests-helpers.el b/test/lisp/so-long-tests/so-long-tests-helpers.el index 852e7811cc..79df532f89 100644 --- a/test/lisp/so-long-tests/so-long-tests-helpers.el +++ b/test/lisp/so-long-tests/so-long-tests-helpers.el @@ -41,14 +41,14 @@ (should (eq so-long--active t)) ;; pcase fails here in Emacs 24. (cl-case action - ('so-long-mode + (so-long-mode (should (eq major-mode 'so-long-mode)) (so-long-tests-assert-overrides) (so-long-tests-assert-preserved)) - ('so-long-minor-mode + (so-long-minor-mode (should (eq so-long-minor-mode t)) (so-long-tests-assert-overrides)) - ('longlines-mode + (longlines-mode (should (eq longlines-mode t)))))) (defun so-long-tests-assert-reverted (action) @@ -61,14 +61,14 @@ (should (eq so-long--active nil)) ;; pcase fails here in Emacs 24. (cl-case action - ('so-long-mode + (so-long-mode (should-not (eq major-mode 'so-long-mode)) (so-long-tests-assert-overrides-reverted) (so-long-tests-assert-preserved)) - ('so-long-minor-mode + (so-long-minor-mode (should-not (eq so-long-minor-mode t)) (so-long-tests-assert-overrides-reverted)) - ('longlines-mode + (longlines-mode (should-not (eq longlines-mode t)))))) (defun so-long-tests-assert-and-revert (action) commit 8c3b40254bfa29c843eb4ff967c5e6f7c717bb07 Author: Stefan Kangas Date: Wed Sep 14 12:12:46 2022 +0200 Make it easier to customize wallpaper command * lisp/image/wallpaper.el (wallpaper--default-commands): New defvar. (wallpaper--find-command): Use above new defvar. (wallpaper--find-command-arguments): New defun. (wallpaper-command): Rename from 'wallpaper-commands' and change type to string. Use 'wallpaper--find-command' to set it. (wallpaper-command-args): New defcustom. Use 'wallpaper--find-command-arguments' to set it. (wallpaper--set-wallpaper-command): New defun. Use as :set property for 'wallpaper-command'. (wallpaper-set): Use above new defcustoms to set the wallpaper. Suggested by Eli Zaretskii . diff --git a/etc/NEWS b/etc/NEWS index 7505a37c06..5276a49d5c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1997,7 +1997,8 @@ desktop background. On GNU/Linux and other Unix-like systems, it uses an external command (such as "swaybg", "gm", "display" or "xloadimage"). A suitable command should be detected automatically in most cases, but can also -be customized manually with the new user option `wallpaper-commands'. +be customized manually with the new user options 'wallpaper-command' +and 'wallpaper-command-args' if needed. On Haiku, it uses the new function `haiku-set-wallpaper', which does not rely on any external command. diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index 172164fdf9..e25ce448c1 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -35,14 +35,18 @@ ;; right, as there is no lack of platforms, window managers, desktop ;; environments and tools. However, it should be detected ;; automatically in most cases. If it doesn't work in your -;; environment, customize the user option `wallpaper-commands'. +;; environment, customize the user options `wallpaper-command' and +;; `wallpaper-command-args'. ;;; Code: (eval-when-compile (require 'subr-x)) (require 'xdg) -(defcustom wallpaper-commands + +;;; Finding the wallpaper command + +(defvar wallpaper--default-commands '( ;; Sway (Wayland) ("swaybg" "-o" "*" "-i" "%f" "-m" "fill") @@ -60,9 +64,11 @@ ("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. + "Executable used for setting the wallpaper. +This is used by `wallpaper--find-command' to automatically set +`wallpaper-command', and by `wallpaper--find-command-args' to set +`wallpaper-command-args'. The commands will be tested in the +order in which they appear. Every item in the list has the following form: @@ -71,29 +77,8 @@ Every item in the list has the following form: 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)))) +In each of the command line arguments, \"%f\", \"%h\" and \"%w\" +will be replaced as described in `wallpaper-command-args'.") (cl-defmethod wallpaper--check-command ((_type (eql 'gsettings))) (member "GNOME" (xdg-current-desktop))) @@ -112,12 +97,77 @@ You can also use \\[report-emacs-bug]." t) (defun wallpaper--find-command () - "Return a valid command for this system." + "Return a valid command to set the wallpaper in this environment." (catch 'found - (dolist (cmd wallpaper-commands) + (dolist (cmd wallpaper--default-commands) (if (and (wallpaper--check-command (intern (car cmd))) (executable-find (car cmd))) - (throw 'found cmd))))) + (throw 'found (car cmd)))))) + +(defvar wallpaper-command) ; silence byte-compiler +(defun wallpaper--find-command-arguments () + "Return command line arguments matching `wallpaper-command'." + (cdr (assoc wallpaper-command wallpaper--default-commands))) + + +;;; Customizable variables + +(defvar wallpaper-command-args) ; silence byte-compiler +(defun wallpaper--set-wallpaper-command (sym val) + "Set `wallpaper-command', and update `wallpaper-command-args'." + ;; Note: `command-args' is used by `wallpaper--find-command-arguments'. + (prog1 (set-default sym val) + (set-default 'wallpaper-command-args + (wallpaper--find-command-arguments)))) + +(defcustom wallpaper-command (wallpaper--find-command) + "Executable used for setting the wallpaper. +A suitable command for your environment should be detected +automatically, so there is usually no need to customize this. +However, if you do need to change this, you might also want to +customize `wallpaper-command-args' to match. + +Note: If you find that you need to use a command in your +environment that is not automatically detected, 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 '(choice string + (const :tag "Not set" nil)) + :set #'wallpaper--set-wallpaper-command + :group 'image + :version "29.1") + +(defcustom wallpaper-command-args (wallpaper--find-command-arguments) + "Command line arguments for `wallpaper-command'. +A suitable command for your environment should be detected +automatically, so there is usually no need to customize this. +However, if you do need to change this, you might also want to +customize `wallpaper-command' to match. + +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')." + :type '(repeat string) + :group 'image + :version "29.1") + + +;;; Utility functions + +(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)))) + + +;;; wallpaper-set (defvar wallpaper-default-width 1080 "Default width used by `wallpaper-set'. @@ -129,13 +179,13 @@ See also `wallpaper-default-height'.") This is only used when it can't be detected automatically. See also `wallpaper-default-width'.") -(declare-function haiku-set-wallpaper "term/haiku-win.el") - (defun wallpaper--get-height-or-width (desc fun default) (if (display-graphic-p) (funcall fun) (read-number (format "Wallpaper %s in pixels: " desc) default))) +(declare-function haiku-set-wallpaper "term/haiku-win.el") + (defun wallpaper-set (file) "Set the desktop background to FILE in a graphical environment. @@ -161,8 +211,7 @@ On Haiku, no external command is needed, so the value of (cond ((featurep 'haiku) (haiku-set-wallpaper file)) (t - (let* ((command (wallpaper--find-command)) - (fmt-spec `((?f . ,(expand-file-name file)) + (let* ((fmt-spec `((?f . ,(expand-file-name file)) (?h . ,(wallpaper--get-height-or-width "height" #'display-pixel-height @@ -173,14 +222,15 @@ On Haiku, no external command is needed, so the value of wallpaper-default-width)))) (bufname (format " *wallpaper-%s*" (random))) (process - (and command + (and wallpaper-command (apply #'start-process "set-wallpaper" bufname - (car command) + wallpaper-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)) + wallpaper-command-args))))) + (unless wallpaper-command + (error "Couldn't find a suitable command for setting the wallpaper")) + (wallpaper-debug "Using command %S %S" wallpaper-command + wallpaper-command-args) (setf (process-sentinel process) (lambda (process status) (unwind-protect commit 41a31553197911b6ccdb5da93801ff63cef9b3cf Author: Stefan Kangas Date: Wed Sep 14 11:10:10 2022 +0200 Improve wallpaper.el docs for recent changes * lisp/image/wallpaper.el: Fix documentation to better reflect that no external command is needed on Haiku. * etc/NEWS: Update entry on wallpaper.el. diff --git a/etc/NEWS b/etc/NEWS index 82168038c3..7505a37c06 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1991,9 +1991,16 @@ 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. +This library contains the command `wallpaper-set', which sets the +desktop background. + +On GNU/Linux and other Unix-like systems, it uses an external command +(such as "swaybg", "gm", "display" or "xloadimage"). A suitable +command should be detected automatically in most cases, but can also +be customized manually with the new user option `wallpaper-commands'. + +On Haiku, it uses the new function `haiku-set-wallpaper', which does +not rely on any external command. ** Image-Dired diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index a2b51d68d7..172164fdf9 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -1,4 +1,4 @@ -;;; wallpaper.el --- Set wallpaper using external command -*- lexical-binding: t; -*- +;;; wallpaper.el --- Set desktop wallpaper from Emacs -*- lexical-binding: t; -*- ;; Copyright (C) 2022 Free Software Foundation, Inc. @@ -22,13 +22,20 @@ ;;; 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. +;; This library provides the command `wallpaper-set', which sets the +;; desktop background. ;; -;; If this doesn't work in your environment, customize the user option -;; `wallpaper-commands'. +;; On GNU/Linux and other Unix-like systems, it uses an external +;; command to set the desktop background. +;; +;; On Haiku, it uses the `haiku-set-wallpaper' function, which does +;; not rely on any external commands. +;; +;; Finding an external command to use is obviously a bit tricky to get +;; right, as there is no lack of platforms, window managers, desktop +;; environments and tools. However, it should be detected +;; automatically in most cases. If it doesn't work in your +;; environment, customize the user option `wallpaper-commands'. ;;; Code: @@ -130,7 +137,14 @@ See also `wallpaper-default-width'.") (read-number (format "Wallpaper %s in pixels: " desc) default))) (defun wallpaper-set (file) - "Set the desktop background to FILE in a graphical environment." + "Set the desktop background to FILE in a graphical environment. + +On GNU/Linux and other Unix-like systems, this relies on an +external command. Which command is being used depends on the +user option `wallpaper-commands'. + +On Haiku, no external command is needed, so the value of +`wallpaper-commands' is ignored." (interactive (list (and (display-graphic-p) (read-file-name "Set desktop background to: " commit bfafe4aacceb213fbfd7d92bfd6362a13cbdc667 Author: Stefan Kangas Date: Wed Sep 14 10:52:39 2022 +0200 Allow setting wallpaper from TTY * lisp/image/wallpaper.el (wallpaper-set): Allow setting wallpaper when 'display-graphic-p' is nil. (wallpaper-default-width, wallpaper-default-height): New variables. (wallpaper--get-height-or-width): New helper function. diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index 1e921dc2c4..a2b51d68d7 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -112,8 +112,23 @@ You can also use \\[report-emacs-bug]." (executable-find (car cmd))) (throw 'found cmd))))) +(defvar wallpaper-default-width 1080 + "Default width used by `wallpaper-set'. +This is only used when it can't be detected automatically. +See also `wallpaper-default-height'.") + +(defvar wallpaper-default-height 1920 + "Default height used by `wallpaper-set'. +This is only used when it can't be detected automatically. +See also `wallpaper-default-width'.") + (declare-function haiku-set-wallpaper "term/haiku-win.el") +(defun wallpaper--get-height-or-width (desc fun default) + (if (display-graphic-p) + (funcall fun) + (read-number (format "Wallpaper %s in pixels: " desc) default))) + (defun wallpaper-set (file) "Set the desktop background to FILE in a graphical environment." (interactive (list (and @@ -129,35 +144,41 @@ You can also use \\[report-emacs-bug]." (error "No such file: %s" file)) (unless (file-readable-p file) (error "File is not readable: %s" file)) - (when (display-graphic-p) - (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)))) + (cond ((featurep 'haiku) + (haiku-set-wallpaper file)) + (t + (let* ((command (wallpaper--find-command)) + (fmt-spec `((?f . ,(expand-file-name file)) + (?h . ,(wallpaper--get-height-or-width + "height" + #'display-pixel-height + wallpaper-default-height)) + (?w . ,(wallpaper--get-height-or-width + "width" + #'display-pixel-width + wallpaper-default-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) commit ac479598f127b02d34f8c2f784386462605a4ba7 Author: Stefan Kangas Date: Wed Sep 14 10:41:07 2022 +0200 * lisp/image/wallpaper.el (wallpaper-commands): Add xwallpaper. diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index c31c54fd9f..1e921dc2c4 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -49,6 +49,7 @@ ("gm" "display" "-size" "%wx%h" "-window" "root" "%f") ("display" "-resize" "%wx%h" "-window" "root" "%f") ("feh" "--bg-max" "%f") + ("xwallpaper" "--zoom" "%f") ("xloadimage" "-onroot" "-fullscreen" "%f") ("xsetbg" " %f") ) commit 6f06353290532af03ee97055853d430c161fa493 Author: Stefan Kangas Date: Wed Sep 14 10:29:16 2022 +0200 Support recent KDE Plasma in wallpaper.el * lisp/image/wallpaper.el (wallpaper-commands): Support recent KDE Plasma. (wallpaper--check-command): New cl-defmethod. diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index 97789fe3f5..c31c54fd9f 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -43,6 +43,8 @@ ("wbg" %f) ;; Gnome ("gsettings" "set" "org.gnome.desktop.background" "picture-uri" "file://%f") + ;; KDE Plasma + ("plasma-apply-wallpaperimage" "%f") ;; Other / General X ("gm" "display" "-size" "%wx%h" "-window" "root" "%f") ("display" "-resize" "%wx%h" "-window" "root" "%f") @@ -88,6 +90,9 @@ You can also use \\[report-emacs-bug]." (cl-defmethod wallpaper--check-command ((_type (eql 'gsettings))) (member "GNOME" (xdg-current-desktop))) +(cl-defmethod wallpaper--check-command ((_type (eql 'plasma-apply-wallpaperimage))) + (member "KDE" (xdg-current-desktop))) + (cl-defmethod wallpaper--check-command ((_type (eql 'swaybg))) (and (getenv "WAYLAND_DISPLAY") (getenv "SWAYSOCK"))) commit d537e4c102c4b37cdbccc9517f569c685fec48d4 Author: Stefan Kangas Date: Wed Sep 14 10:26:07 2022 +0200 Fix desktop environment check on Ubuntu * lisp/image/wallpaper.el (xdg): Require. (wallpaper--check-command): Use xdg-current-desktop instead of reading XDG_CURRENT_DESKTOP directly. This fixes things on e.g. Ubuntu, where XDG_CURRENT_DESKTOP might contain a string like "ubuntu:GNOME". diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index 19741a20f1..97789fe3f5 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -33,6 +33,7 @@ ;;; Code: (eval-when-compile (require 'subr-x)) +(require 'xdg) (defcustom wallpaper-commands '( @@ -85,7 +86,7 @@ You can also use \\[report-emacs-bug]." (cdr args)))) (cl-defmethod wallpaper--check-command ((_type (eql 'gsettings))) - (equal (getenv "XDG_CURRENT_DESKTOP") "GNOME")) + (member "GNOME" (xdg-current-desktop))) (cl-defmethod wallpaper--check-command ((_type (eql 'swaybg))) (and (getenv "WAYLAND_DISPLAY") commit 7d315ce63090e9afe7f10853848f9781fd072c17 Author: Stefan Kangas Date: Wed Sep 14 10:15:08 2022 +0200 ; * etc/NEWS: Improve wording of 'xdg-state-home' entry. diff --git a/etc/NEWS b/etc/NEWS index 4053e39b77..82168038c3 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3452,11 +3452,13 @@ This means the vscroll will not be reset when set on a window that is ** XDG support --- -*** New function 'xdg-state-home' returns 'XDG_STATE_HOME' environment variable. -This new location, introduced in the XDG Base Directory Specification -version 0.8 (8th May 2021), "contains state data that should persist +*** New function 'xdg-state-home'. +It returns the new 'XDG_STATE_HOME' environment variable. It should +point to a file name that "contains state data that should persist between (application) restarts, but that is not important or portable enough to the user that it should be stored in $XDG_DATA_HOME". +(This variable was introduced in the XDG Base Directory Specification +version 0.8 released on May 8, 2021.) --- *** New function 'xdg-current-desktop'. commit fd70791218936da56a622707d3e09efc33feb16d Author: Stefan Kangas Date: Wed Sep 14 10:15:26 2022 +0200 Add new function xdg-current-desktop to xdg.el * lisp/xdg.el (xdg-current-desktop): New function. * test/lisp/xdg-tests.el (xdg-current-desktop): New test. diff --git a/etc/NEWS b/etc/NEWS index ae3f84c1b9..4053e39b77 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3458,6 +3458,14 @@ version 0.8 (8th May 2021), "contains state data that should persist between (application) restarts, but that is not important or portable enough to the user that it should be stored in $XDG_DATA_HOME". +--- +*** New function 'xdg-current-desktop'. +It returns a list of strings, corresponding to the colon-separated +list of names in the 'XDG_CURRENT_DESKTOP' environment variable, which +identify the current desktop environment. +(This variable was introduced in XDG Desktop Entry Specification +version 1.2.) + +++ ** New macro 'with-delayed-message'. This macro is like 'progn', but will output the specified message if diff --git a/lisp/xdg.el b/lisp/xdg.el index dd0d51290d..5d60aa2f28 100644 --- a/lisp/xdg.el +++ b/lisp/xdg.el @@ -281,6 +281,18 @@ Optional argument GROUP defaults to the string \"Desktop Entry\"." (when (null (string-match-p "[^[:blank:]]" (car res))) (pop res)) (nreverse res))) +(defun xdg-current-desktop () + "Return a list of strings identifying the current desktop environment. + +According to the XDG Desktop Entry Specification version 0.5: + + If $XDG_CURRENT_DESKTOP is set then it contains a + colon-separated list of strings ... $XDG_CURRENT_DESKTOP + should have been set by the login manager, according to the + value of the DesktopNames found in the session file." + (when-let ((ret (getenv "XDG_CURRENT_DESKTOP"))) + (string-split ret ":"))) + ;; MIME apps specification ;; https://standards.freedesktop.org/mime-apps-spec/mime-apps-spec-1.0.1.html diff --git a/test/lisp/xdg-tests.el b/test/lisp/xdg-tests.el index e8e103348b..882160743a 100644 --- a/test/lisp/xdg-tests.el +++ b/test/lisp/xdg-tests.el @@ -59,6 +59,16 @@ (should (equal (xdg-desktop-strings " ") nil)) (should (equal (xdg-desktop-strings "a; ;") '("a" " ")))) +(ert-deftest xdg-current-desktop () + (let ((env (getenv "XDG_CURRENT_DESKTOP"))) + (unwind-protect + (progn + (setenv "XDG_CURRENT_DESKTOP" "KDE") + (should (equal (xdg-current-desktop) '("KDE"))) + (setenv "XDG_CURRENT_DESKTOP" "ubuntu:GNOME") + (should (equal (xdg-current-desktop) '("ubuntu" "GNOME")))) + (setenv "XDG_CURRENT_DESKTOP" env)))) + (ert-deftest xdg-mime-associations () "Test reading MIME associations from files." (let* ((apps (ert-resource-file "mimeapps.list"))