From 6eb18a950db88515fa5103e1c7d9cd76980e5f91 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Mon, 8 Jun 2020 03:21:42 +0300 Subject: [PATCH 01/72] Move tab-bar and tab-line faces to faces.el (part of bug#41200) These are basic faces, so they need to be defined in faces.el, otherwise (get 'tab-line 'face) returns 0. * lisp/faces.el (tab-bar, tab-line): Move faces here from tab-bar.el and tab-line.el. * lisp/tab-bar.el (tab-bar): Move face to faces.el. (tab-bar-faces): Add '((tab-bar custom-face)) to the second arg MEMBERS of 'defgroup'. * lisp/tab-line.el (tab-line): Move face to faces.el. (tab-line-faces): Add '((tab-line custom-face)) to the second arg MEMBERS of 'defgroup'. --- lisp/faces.el | 27 +++++++++++++++++++++++++++ lisp/tab-bar.el | 15 +-------------- lisp/tab-line.el | 16 +--------------- 3 files changed, 29 insertions(+), 29 deletions(-) diff --git a/lisp/faces.el b/lisp/faces.el index 9a49ea81042..4d1d9561d49 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2738,6 +2738,33 @@ Note: Other faces cannot inherit from the cursor face." :version "21.1" :group 'basic-faces) +(defface tab-bar + '((((class color) (min-colors 88)) + :inherit variable-pitch + :background "grey85" + :foreground "black") + (((class mono)) + :background "grey") + (t + :inverse-video t)) + "Tab bar face." + :version "27.1" + :group 'basic-faces) + +(defface tab-line + '((((class color) (min-colors 88)) + :inherit variable-pitch + :height 0.9 + :background "grey85" + :foreground "black") + (((class mono)) + :background "grey") + (t + :inverse-video t)) + "Tab line face." + :version "27.1" + :group 'basic-faces) + (defface menu '((((type tty)) :inverse-video t) diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 5c237e7130e..d97ca37a731 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -44,25 +44,12 @@ :group 'convenience :version "27.1") -(defgroup tab-bar-faces nil +(defgroup tab-bar-faces '((tab-bar custom-face)) ; tab-bar is defined in faces.el "Faces used in the tab bar." :group 'tab-bar :group 'faces :version "27.1") -(defface tab-bar - '((((class color) (min-colors 88)) - :inherit variable-pitch - :background "grey85" - :foreground "black") - (((class mono)) - :background "grey") - (t - :inverse-video t)) - "Tab bar face." - :version "27.1" - :group 'tab-bar-faces) - (defface tab-bar-tab '((default :inherit tab-bar) diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 7a2bdc0b72f..e8c4dc4d93c 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -35,26 +35,12 @@ :group 'convenience :version "27.1") -(defgroup tab-line-faces nil +(defgroup tab-line-faces '((tab-line custom-face)) ; tab-line is defined in faces.el "Faces used in the tab line." :group 'tab-line :group 'faces :version "27.1") -(defface tab-line - '((((class color) (min-colors 88)) - :inherit variable-pitch - :height 0.9 - :background "grey85" - :foreground "black") - (((class mono)) - :background "grey") - (t - :inverse-video t)) - "Tab line face." - :version "27.1" - :group 'tab-line-faces) - (defface tab-line-tab '((default :inherit tab-line) From c43e5ed60d93bbe3f5f3936ccce6e77409cd6140 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Mon, 8 Jun 2020 03:30:27 +0300 Subject: [PATCH 02/72] * lisp/image-mode.el (image-transform-original): New command (bug#41222). (image-mode-map): Bind it to "so" and add to menu. --- lisp/image-mode.el | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 480b2e6b26e..b82c0669187 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -456,6 +456,7 @@ call." (define-key map "sb" 'image-transform-fit-both) (define-key map "ss" 'image-transform-set-scale) (define-key map "sr" 'image-transform-set-rotation) + (define-key map "so" 'image-transform-original) (define-key map "s0" 'image-transform-reset) ;; Multi-frame keys @@ -521,8 +522,10 @@ call." :help "Rotate the image"] ["Set Rotation..." image-transform-set-rotation :help "Set rotation angle of the image"] - ["Reset Transformations" image-transform-reset - :help "Reset all image transformations"] + ["Original Size" image-transform-original + :help "Reset image to actual size"] + ["Reset to Default Size" image-transform-reset + :help "Reset all image transformations to initial size"] "--" ["Show Thumbnails" (lambda () @@ -1382,8 +1385,15 @@ ROTATION should be in degrees." (setq image-transform-rotation (float (mod rotation 360))) (image-toggle-display-image)) +(defun image-transform-original () + "Display the current image with the original (actual) size and rotation." + (interactive) + (setq image-transform-resize nil + image-transform-scale 1) + (image-toggle-display-image)) + (defun image-transform-reset () - "Display the current image with the default size and rotation." + "Display the current image with the default (initial) size and rotation." (interactive) (setq image-transform-resize image-auto-resize image-transform-rotation 0.0 From 43ad7dc1af327486963e5e3a3ae8efdb454fd38d Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 6 Jun 2020 00:58:37 +0100 Subject: [PATCH 03/72] Clean up D-Bus documentation (bug#41744) * doc/lispref/errors.texi (Standard Errors): The error symbol dbus-error is defined even when Emacs is built without D-Bus. * doc/misc/dbus.texi (Bus Names, Introspection) (Nodes and Interfaces, Methods and Signal) (Properties and Annotations, Arguments and Signatures) (Synchronous Methods, Receiving Method Calls, Signals) (Alternative Buses, Errors and Events): Clarify wording. Fix indentation of and simplify examples where possible. Improve Texinfo markup and cross-referencing where possible. (Type Conversion): Ditto. Remove mentions of Emacs' fixnum range now that we have bignums. * lisp/net/dbus.el (dbus-return-values-table) (dbus-call-method-asynchronously, dbus-send-signal) (dbus-register-signal, dbus-register-method) (dbus-string-to-byte-array, dbus-byte-array-to-string) (dbus-escape-as-identifier, dbus-check-event, dbus-event-bus-name) (dbus-event-message-type, dbus-event-serial-number) (dbus-event-service-name, dbus-event-path-name) (dbus-event-interface-name, dbus-event-member-name) (dbus-list-activatable-names, dbus-list-queued-owners, dbus-ping) (dbus-introspect-get-interface-names, dbus-introspect-get-interface) (dbus-introspect-get-method, dbus-introspect-get-signal) (dbus-introspect-get-property, dbus-introspect-get-annotation-names) (dbus-introspect-get-annotation, dbus-introspect-get-argument-names) (dbus-introspect-get-argument, dbus-introspect-get-signature) (dbus-set-property, dbus-register-property) (dbus-get-all-managed-objects, dbus-init-bus): Clarify docstring and improve formatting where possible. (dbus-call-method): Ditto. Remove mentions of Emacs' fixnum range now that we have bignums. --- doc/lispref/errors.texi | 5 +- doc/misc/dbus.texi | 820 ++++++++++++++++++++-------------------- lisp/net/dbus.el | 228 +++++------ 3 files changed, 528 insertions(+), 525 deletions(-) diff --git a/doc/lispref/errors.texi b/doc/lispref/errors.texi index dc6877c9eca..cd8694be8a3 100644 --- a/doc/lispref/errors.texi +++ b/doc/lispref/errors.texi @@ -79,9 +79,8 @@ The message is @samp{Symbol's chain of variable indirections contains a loop}. @xref{Variable Aliases}. @item dbus-error -The message is @samp{D-Bus error}. This is only defined if Emacs was -compiled with D-Bus support. @xref{Errors and Events,,, dbus, D-Bus -integration in Emacs}. +The message is @samp{D-Bus error}. @xref{Errors and Events,,, dbus, +D-Bus integration in Emacs}. @item end-of-buffer The message is @samp{End of buffer}. @xref{Character Motion}. diff --git a/doc/misc/dbus.texi b/doc/misc/dbus.texi index 9e5f1ccc6fd..167d2bd5ac1 100644 --- a/doc/misc/dbus.texi +++ b/doc/misc/dbus.texi @@ -167,7 +167,7 @@ default) or the symbol @code{:session}. An activatable service is described in a service registration file. Under GNU/Linux, such files are located at @file{/usr/share/dbus-1/system-services/} (for the @code{:system} bus) or @file{/usr/share/dbus-1/services/}. An -activatable service is not necessarily registered at @var{bus} at already. +activatable service is not necessarily registered at @var{bus} already. The result is a list of strings, which is @code{nil} when there are no activatable service names at all. Example: @@ -180,8 +180,8 @@ activatable service names at all. Example: @end defun @defun dbus-list-names bus -All service names, which are registered at D-Bus @var{bus}, are -returned. The result is a list of strings, which is @code{nil} when +This function returns all service names, which are registered at D-Bus +@var{bus}. The result is a list of strings, which is @code{nil} when there are no registered service names at all. Well known names are strings like @samp{org.freedesktop.DBus}. Names starting with @samp{:} are unique names for services. @@ -191,10 +191,10 @@ strings like @samp{org.freedesktop.DBus}. Names starting with @end defun @defun dbus-list-known-names bus -Retrieves all registered services which correspond to a known name in @var{bus}. -A service has a known name if it doesn't start with @samp{:}. The -result is a list of strings, which is @code{nil} when there are no -known names at all. +This function retrieves all registered services which correspond to a +known name in @var{bus}. A service has a known name if it doesn't +start with @samp{:}. The result is a list of strings, which is +@code{nil} when there are no known names at all. @var{bus} must be either the symbol @code{:system} or the symbol @code{:session}. @@ -202,9 +202,9 @@ known names at all. @defun dbus-list-queued-owners bus service For a given service, registered at D-Bus @var{bus} under the name -@var{service}, all queued unique names are returned. The result is a -list of strings, or @code{nil} when there are no queued names for -@var{service} at all. +@var{service}, this function returns all queued unique names. The +result is a list of strings, or @code{nil} when there are no queued +names for @var{service} at all. @var{bus} must be either the symbol @code{:system} or the symbol @code{:session}. @var{service} must be a known service name as @@ -213,9 +213,9 @@ string. @defun dbus-get-name-owner bus service For a given service, registered at D-Bus @var{bus} under the name -@var{service}, the unique name of the name owner is returned. The -result is a string, or @code{nil} when there exist no name owner of -@var{service}. +@var{service}, this function returns the unique name of the name +owner. The result is a string, or @code{nil} when there is no name +owner of @var{service}. @var{bus} must be either the symbol @code{:system} or the symbol @code{:session}. @var{service} must be a known service name as @@ -223,26 +223,28 @@ string. @end defun @defun dbus-ping bus service &optional timeout -Check whether the service name @var{service} is registered at D-Bus -@var{bus}. @var{service} might not have been started yet, it is -autostarted if possible. The result is either @code{t} or @code{nil}. +This function checks whether the service name @var{service} is +registered at D-Bus @var{bus}. If @var{service} has not yet started, +it is autostarted if possible. The result is either @code{t} or +@code{nil}. @var{bus} must be either the symbol @code{:system} or the symbol @code{:session}. @var{service} must be a string. @var{timeout}, a nonnegative integer, specifies the maximum number of milliseconds -@code{dbus-ping} must return. The default value is 25,000. Example: +before @code{dbus-ping} must return. The default value is 25,000. +Example: @lisp (message - "%s screensaver on board." - (cond - ((dbus-ping :session "org.gnome.ScreenSaver" 100) "Gnome") - ((dbus-ping :session "org.freedesktop.ScreenSaver" 100) "KDE") - (t "No"))) + "%s screensaver on board." + (cond + ((dbus-ping :session "org.gnome.ScreenSaver" 100) "Gnome") + ((dbus-ping :session "org.freedesktop.ScreenSaver" 100) "KDE") + (t "No"))) @end lisp -If it shall be checked whether @var{service} is already running -without autostarting it, one shall apply +To check whether @var{service} is already running without autostarting +it, you can instead write: @lisp (member service (dbus-list-known-names bus)) @@ -250,8 +252,9 @@ without autostarting it, one shall apply @end defun @defun dbus-get-unique-name bus -The unique name, under which Emacs is registered at D-Bus @var{bus}, -is returned as string. +@anchor{dbus-get-unique-name} +This function returns the unique name, under which Emacs is registered +at D-Bus @var{bus}, as a string. @var{bus} must be either the symbol @code{:system} or the symbol @code{:session}. @@ -380,8 +383,8 @@ format. Example: @lisp (dbus-introspect - :system "org.freedesktop.Hal" - "/org/freedesktop/Hal/devices/computer") + :system "org.freedesktop.Hal" + "/org/freedesktop/Hal/devices/computer") @result{} " t or nil - DBUS_TYPE_BYTE => number - DBUS_TYPE_UINT16 => number + DBUS_TYPE_BYTE => natural number + DBUS_TYPE_UINT16 => natural number DBUS_TYPE_INT16 => integer - DBUS_TYPE_UINT32 => number or float - DBUS_TYPE_UNIX_FD => number or float - DBUS_TYPE_INT32 => integer or float - DBUS_TYPE_UINT64 => number or float - DBUS_TYPE_INT64 => integer or float + DBUS_TYPE_UINT32 => natural number + DBUS_TYPE_UNIX_FD => natural number + DBUS_TYPE_INT32 => integer + DBUS_TYPE_UINT64 => natural number + DBUS_TYPE_INT64 => integer DBUS_TYPE_DOUBLE => float DBUS_TYPE_STRING => string DBUS_TYPE_OBJECT_PATH => string @@ -268,9 +268,9 @@ input arguments. It follows the mapping rules: Example: \(dbus-call-method - :session \"org.gnome.seahorse\" \"/org/gnome/seahorse/keys/openpgp\" - \"org.gnome.seahorse.Keys\" \"GetKeyField\" - \"openpgp:657984B8C7A966DD\" \"simple-name\") + :session \"org.gnome.seahorse\" \"/org/gnome/seahorse/keys/openpgp\" + \"org.gnome.seahorse.Keys\" \"GetKeyField\" + \"openpgp:657984B8C7A966DD\" \"simple-name\") => (t (\"Philip R. Zimmermann\")) @@ -278,9 +278,9 @@ If the result of the METHOD call is just one value, the converted Lisp object is returned instead of a list containing this single Lisp object. \(dbus-call-method - :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\" - \"org.freedesktop.Hal.Device\" \"GetPropertyString\" - \"system.kernel.machine\") + :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\" + \"org.freedesktop.Hal.Device\" \"GetPropertyString\" + \"system.kernel.machine\") => \"i686\"" @@ -357,10 +357,10 @@ HANDLER is a Lisp function, which is called when the corresponding return message has arrived. If HANDLER is nil, no return message will be expected. -If the parameter `:timeout' is given, the following integer TIMEOUT -specifies the maximum number of milliseconds the method call must -return. The default value is 25,000. If the method call doesn't -return in time, a D-Bus error is raised. +If the parameter `:timeout' is given, the following integer +TIMEOUT specifies the maximum number of milliseconds before the +method call must return. The default value is 25,000. If the +method call doesn't return in time, a D-Bus error is raised. All other arguments ARGS are passed to METHOD as arguments. They are converted into D-Bus types via the following rules: @@ -377,19 +377,19 @@ type symbols, see Info node `(dbus)Type Conversion'. If HANDLER is a Lisp function, the function returns a key into the hash table `dbus-registered-objects-table'. The corresponding entry -in the hash table is removed, when the return message has been arrived, +in the hash table is removed, when the return message arrives, and HANDLER is called. Example: \(dbus-call-method-asynchronously - :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\" - \"org.freedesktop.Hal.Device\" \"GetPropertyString\" \\='message - \"system.kernel.machine\") + :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\" + \"org.freedesktop.Hal.Device\" \"GetPropertyString\" \\='message + \"system.kernel.machine\") - => (:serial :system 2) + -| i686 - -| i686" + => (:serial :system 2)" (or (featurep 'dbusbind) (signal 'dbus-error (list "Emacs not compiled with dbus support"))) @@ -438,8 +438,8 @@ type symbols, see Info node `(dbus)Type Conversion'. Example: \(dbus-send-signal - :session nil \"/org/gnu/Emacs\" \"org.gnu.Emacs.FileManager\" - \"FileModified\" \"/home/albinus/.emacs\")" + :session nil \"/org/gnu/Emacs\" \"org.gnu.Emacs.FileManager\" + \"FileModified\" \"/home/albinus/.emacs\")" (or (featurep 'dbusbind) (signal 'dbus-error (list "Emacs not compiled with dbus support"))) @@ -625,17 +625,17 @@ SERVICE is the D-Bus service name used by the sending D-Bus object. It can be either a known name or the unique name of the D-Bus object sending the signal. -PATH is the D-Bus object path SERVICE is registered. INTERFACE -is an interface offered by SERVICE. It must provide SIGNAL. -HANDLER is a Lisp function to be called when the signal is -received. It must accept as arguments the values SIGNAL is +PATH is the D-Bus object path SERVICE is registered at. +INTERFACE is an interface offered by SERVICE. It must provide +SIGNAL. HANDLER is a Lisp function to be called when the signal +is received. It must accept as arguments the values SIGNAL is sending. SERVICE, PATH, INTERFACE and SIGNAL can be nil. This is interpreted as a wildcard for the respective argument. The remaining arguments ARGS can be keywords or keyword string pairs. -The meaning is as follows: +Their meaning is as follows: `:argN' STRING: `:pathN' STRING: This stands for the Nth argument of the @@ -643,8 +643,9 @@ signal. `:pathN' arguments can be used for object path wildcard matches as specified by D-Bus, while an `:argN' argument requires an exact match. -`:arg-namespace' STRING: Register for the signals, which first -argument defines the service or interface namespace STRING. +`:arg-namespace' STRING: Register for those signals, whose first +argument names a service or interface within the namespace +STRING. `:path-namespace' STRING: Register for the object path namespace STRING. All signals sent from an object path, which has STRING as @@ -660,8 +661,8 @@ Example: (message \"Device %s added\" device)) \(dbus-register-signal - :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\" - \"org.freedesktop.Hal.Manager\" \"DeviceAdded\" \\='my-signal-handler) + :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\" + \"org.freedesktop.Hal.Manager\" \"DeviceAdded\" \\='my-signal-handler) => ((:signal :system \"org.freedesktop.Hal.Manager\" \"DeviceAdded\") (\"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\" my-signal-handler)) @@ -773,24 +774,24 @@ Example: (defun dbus-register-method (bus service path interface method handler &optional dont-register-service) - "Register for method METHOD on the D-Bus BUS. + "Register METHOD on the D-Bus BUS. BUS is either a Lisp symbol, `:system' or `:session', or a string denoting the bus address. SERVICE is the D-Bus service name of the D-Bus object METHOD is -registered for. It must be a known name (See discussion of +registered for. It must be a known name (see discussion of DONT-REGISTER-SERVICE below). -PATH is the D-Bus object path SERVICE is registered (See discussion of -DONT-REGISTER-SERVICE below). INTERFACE is the interface offered by -SERVICE. It must provide METHOD. +PATH is the D-Bus object path SERVICE is registered at (see +discussion of DONT-REGISTER-SERVICE below). INTERFACE is the +interface offered by SERVICE. It must provide METHOD. HANDLER is a Lisp function to be called when a method call is received. It must accept the input arguments of METHOD. The return value of HANDLER is used for composing the returning D-Bus message. -In case HANDLER shall return a reply message with an empty argument -list, HANDLER must return the symbol `:ignore'. +If HANDLER returns a reply message with an empty argument list, +HANDLER must return the symbol `:ignore'. When DONT-REGISTER-SERVICE is non-nil, the known name SERVICE is not registered. This means that other D-Bus clients have no way of @@ -888,8 +889,8 @@ association to the service from D-Bus." ;;; D-Bus type conversion. (defun dbus-string-to-byte-array (string) - "Transform STRING to list (:array :byte c1 :byte c2 ...). -STRING shall be UTF8 coded." + "Transform STRING to list (:array :byte C1 :byte C2 ...). +STRING shall be UTF-8 coded." (if (zerop (length string)) '(:array :signature "y") (let (result) @@ -897,7 +898,7 @@ STRING shall be UTF8 coded." (setq result (append result (list :byte elt))))))) (defun dbus-byte-array-to-string (byte-array &optional multibyte) - "Transform BYTE-ARRAY into UTF8 coded string. + "Transform BYTE-ARRAY into UTF-8 coded string. BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte array as produced by `dbus-string-to-byte-array'. The resulting string is unibyte encoded, unless MULTIBYTE is non-nil." @@ -920,9 +921,9 @@ lower-case hex digits: \"0123abc_xyz\\x01\\xff\" -> \"_30123abc_5fxyz_01_ff\" -i.e. similar to URI encoding, but with \"_\" taking the role of \"%\", -and a smaller allowed set. As a special case, \"\" is escaped to -\"_\". +i.e. similar to URI encoding, but with \"_\" taking the role of +\"%\", and a smaller allowed set. As a special case, \"\" is +escaped to \"_\". Returns the escaped string. Algorithm taken from telepathy-glib's `tp_escape_as_identifier'." @@ -963,8 +964,8 @@ the function which has been registered for this message. ARGS are the arguments passed to HANDLER, when it is called during event handling in `dbus-handle-event'. -This function raises a `dbus-error' signal in case the event is -not well formed." +This function signals a `dbus-error' if the event is not well +formed." (when dbus-debug (message "DBus-Event %s" event)) (unless (and (listp event) (eq (car event) 'dbus-event) @@ -1038,16 +1039,16 @@ If the HANDLER returns a `dbus-error', it is propagated as return message." "Return the bus name the event is coming from. The result is either a Lisp symbol, `:system' or `:session', or a string denoting the bus address. EVENT is a D-Bus event, see -`dbus-check-event'. This function raises a `dbus-error' signal -in case the event is not well formed." +`dbus-check-event'. This function signals a `dbus-error' if the +event is not well formed." (dbus-check-event event) (nth 1 event)) (defun dbus-event-message-type (event) "Return the message type of the corresponding D-Bus message. The result is a number. EVENT is a D-Bus event, see -`dbus-check-event'. This function raises a `dbus-error' signal -in case the event is not well formed." +`dbus-check-event'. This function signals a `dbus-error' if the +event is not well formed." (dbus-check-event event) (nth 2 event)) @@ -1055,41 +1056,40 @@ in case the event is not well formed." "Return the serial number of the corresponding D-Bus message. The result is a number. The serial number is needed for generating a reply message. EVENT is a D-Bus event, see -`dbus-check-event'. This function raises a `dbus-error' signal -in case the event is not well formed." +`dbus-check-event'. This function signals a `dbus-error' if the +event is not well formed." (dbus-check-event event) (nth 3 event)) (defun dbus-event-service-name (event) "Return the name of the D-Bus object the event is coming from. The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. -This function raises a `dbus-error' signal in case the event is -not well formed." +This function signals a `dbus-error' if the event is not well +formed." (dbus-check-event event) (nth 4 event)) (defun dbus-event-path-name (event) "Return the object path of the D-Bus object the event is coming from. The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. -This function raises a `dbus-error' signal in case the event is -not well formed." +This function signals a `dbus-error' if the event is not well +formed." (dbus-check-event event) (nth 5 event)) (defun dbus-event-interface-name (event) "Return the interface name of the D-Bus object the event is coming from. The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. -This function raises a `dbus-error' signal in case the event is -not well formed." +This function signals a `dbus-error' if the event is not well +formed." (dbus-check-event event) (nth 6 event)) (defun dbus-event-member-name (event) "Return the member name the event is coming from. -It is either a signal name or a method name. The result is a +It is either a signal name or a method name. The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. This -function raises a `dbus-error' signal in case the event is not -well formed." +function signals a `dbus-error' if the event is not well formed." (dbus-check-event event) (nth 7 event)) @@ -1097,10 +1097,10 @@ well formed." ;;; D-Bus registered names. (defun dbus-list-activatable-names (&optional bus) - "Return the D-Bus service names which can be activated as list. -If BUS is left nil, `:system' is assumed. The result is a list -of strings, which is nil when there are no activatable service -names at all." + "Return a list of the D-Bus service names which can be activated. +BUS defaults to `:system' when nil or omitted. The result is a +list of strings, which is nil when there are no activatable +service names at all." (dbus-ignore-errors (dbus-call-method (or bus :system) dbus-service-dbus @@ -1126,8 +1126,8 @@ A service has a known name if it doesn't start with \":\"." (defun dbus-list-queued-owners (bus service) "Return the unique names registered at D-Bus BUS and queued for SERVICE. -The result is a list of strings, or nil when there are no -queued name owners service names at all." +The result is a list of strings, or nil when there are no queued +name owner service names at all." (dbus-ignore-errors (dbus-call-method bus dbus-service-dbus dbus-path-dbus @@ -1144,13 +1144,13 @@ The result is either a string, or nil if there is no name owner." (defun dbus-ping (bus service &optional timeout) "Check whether SERVICE is registered for D-Bus BUS. TIMEOUT, a nonnegative integer, specifies the maximum number of -milliseconds `dbus-ping' must return. The default value is 25,000. +milliseconds before `dbus-ping' must return. The default value +is 25,000. -Note, that this autoloads SERVICE if it is not running yet. If -it shall be checked whether SERVICE is already running, one shall -apply +Note, that this autoloads SERVICE if it is not running yet. To +check whether SERVICE is already running, you can instead write - (member service \(dbus-list-known-names bus))" + (member service (dbus-list-known-names bus))" ;; "Ping" raises a D-Bus error if SERVICE does not exist. ;; Otherwise, it returns silently with nil. (condition-case nil @@ -1239,11 +1239,11 @@ It returns a list of strings, which are further object paths of SERVICE." "Return all interface names of SERVICE in D-Bus BUS at object path PATH. It returns a list of strings. -There will be always the default interface -\"org.freedesktop.DBus.Introspectable\". Another default -interface is \"org.freedesktop.DBus.Properties\". If present, -\"interface\" objects can also have \"property\" objects as -children, beside \"method\" and \"signal\" objects." +The default interface \"org.freedesktop.DBus.Introspectable\" is +always present. Another default interface is +\"org.freedesktop.DBus.Properties\". If present, \"interface\" +objects can also have \"property\" objects as children, beside +\"method\" and \"signal\" objects." (let ((object (dbus-introspect-xml bus service path)) result) (dolist (elt (xml-get-children object 'interface) (nreverse result)) @@ -1251,9 +1251,10 @@ children, beside \"method\" and \"signal\" objects." (defun dbus-introspect-get-interface (bus service path interface) "Return the INTERFACE of SERVICE in D-Bus BUS at object path PATH. -The return value is an XML object. INTERFACE must be a string, -element of the list returned by `dbus-introspect-get-interface-names'. -The resulting \"interface\" object can contain \"method\", \"signal\", +The return value is an XML object. INTERFACE must be a string +and a member of the list returned by +`dbus-introspect-get-interface-names'. The resulting +\"interface\" object can contain \"method\", \"signal\", \"property\" and \"annotation\" children." (let ((elt (xml-get-children (dbus-introspect-xml bus service path) 'interface))) @@ -1273,9 +1274,9 @@ SERVICE is a service of D-Bus BUS at object path PATH." (push (dbus-introspect-get-attribute elt "name") result)))) (defun dbus-introspect-get-method (bus service path interface method) - "Return method METHOD of interface INTERFACE as XML object. + "Return method METHOD of interface INTERFACE as an XML object. It must be located at SERVICE in D-Bus BUS at object path PATH. -METHOD must be a string, element of the list returned by +METHOD must be a string and a member of the list returned by `dbus-introspect-get-method-names'. The resulting \"method\" object can contain \"arg\" and \"annotation\" children." (let ((elt (xml-get-children @@ -1296,7 +1297,7 @@ SERVICE is a service of D-Bus BUS at object path PATH." (push (dbus-introspect-get-attribute elt "name") result)))) (defun dbus-introspect-get-signal (bus service path interface signal) - "Return signal SIGNAL of interface INTERFACE as XML object. + "Return signal SIGNAL of interface INTERFACE as an XML object. It must be located at SERVICE in D-Bus BUS at object path PATH. SIGNAL must be a string, element of the list returned by `dbus-introspect-get-signal-names'. The resulting \"signal\" @@ -1319,9 +1320,9 @@ SERVICE is a service of D-Bus BUS at object path PATH." (push (dbus-introspect-get-attribute elt "name") result)))) (defun dbus-introspect-get-property (bus service path interface property) - "Return PROPERTY of INTERFACE as XML object. + "Return PROPERTY of INTERFACE as an XML object. It must be located at SERVICE in D-Bus BUS at object path PATH. -PROPERTY must be a string, element of the list returned by +PROPERTY must be a string and a member of the list returned by `dbus-introspect-get-property-names'. The resulting PROPERTY object can contain \"annotation\" children." (let ((elt (xml-get-children @@ -1336,7 +1337,7 @@ object can contain \"annotation\" children." (defun dbus-introspect-get-annotation-names (bus service path interface &optional name) - "Return all annotation names as list of strings. + "Return all annotation names as a list of strings. If NAME is nil, the annotations are children of INTERFACE, otherwise NAME must be a \"method\", \"signal\", or \"property\" object, where the annotations belong to." @@ -1352,7 +1353,7 @@ object, where the annotations belong to." (defun dbus-introspect-get-annotation (bus service path interface name annotation) - "Return ANNOTATION as XML object. + "Return ANNOTATION as an XML object. If NAME is nil, ANNOTATION is a child of INTERFACE, otherwise NAME must be the name of a \"method\", \"signal\", or \"property\" object, where the ANNOTATION belongs to." @@ -1374,7 +1375,7 @@ NAME must be the name of a \"method\", \"signal\", or (car elt))) (defun dbus-introspect-get-argument-names (bus service path interface name) - "Return a list of all argument names as list of strings. + "Return a list of all argument names as a list of strings. NAME must be a \"method\" or \"signal\" object. Argument names are optional, the function can return nil @@ -1388,8 +1389,9 @@ therefore, even if the method or signal has arguments." (defun dbus-introspect-get-argument (bus service path interface name arg) "Return argument ARG as XML object. -NAME must be a \"method\" or \"signal\" object. ARG must be a string, -element of the list returned by `dbus-introspect-get-argument-names'." +NAME must be a \"method\" or \"signal\" object. ARG must be a +string and a member of the list returned by +`dbus-introspect-get-argument-names'." (let ((elt (xml-get-children (or (dbus-introspect-get-method bus service path interface name) (dbus-introspect-get-signal bus service path interface name)) @@ -1402,7 +1404,7 @@ element of the list returned by `dbus-introspect-get-argument-names'." (defun dbus-introspect-get-signature (bus service path interface name &optional direction) - "Return signature of a `method' or `signal', represented by NAME, as string. + "Return signature of a `method' or `signal' represented by NAME as a string. If NAME is a `method', DIRECTION can be either \"in\" or \"out\". If DIRECTION is nil, \"in\" is assumed. @@ -1450,9 +1452,8 @@ valid D-Bus value, or nil if there is no PROPERTY." (defun dbus-set-property (bus service path interface property value) "Set value of PROPERTY of INTERFACE to VALUE. -It will be checked at BUS, SERVICE, PATH. When the value has -been set successful, the result is VALUE. Otherwise, nil is -returned." +It will be checked at BUS, SERVICE, PATH. When the value is +successfully set return VALUE. Otherwise, return nil." (dbus-ignore-errors ;; "Set" requires a variant. (dbus-call-method @@ -1479,15 +1480,15 @@ nil is returned." (defun dbus-register-property (bus service path interface property access value &optional emits-signal dont-register-service) - "Register property PROPERTY on the D-Bus BUS. + "Register PROPERTY on the D-Bus BUS. BUS is either a Lisp symbol, `:system' or `:session', or a string denoting the bus address. SERVICE is the D-Bus service name of the D-Bus. It must be a -known name (See discussion of DONT-REGISTER-SERVICE below). +known name (see discussion of DONT-REGISTER-SERVICE below). -PATH is the D-Bus object path SERVICE is registered (See +PATH is the D-Bus object path SERVICE is registered at (see discussion of DONT-REGISTER-SERVICE below). INTERFACE is the name of the interface used at PATH, PROPERTY is the name of the property of INTERFACE. ACCESS indicates, whether the property @@ -1625,8 +1626,8 @@ It will be registered for all objects created by `dbus-register-property'." "Return all objects at BUS, SERVICE, PATH, and the children of PATH. The result is a list of objects. Every object is a cons of an existing path name, and the list of available interface objects. -An interface object is another cons, which car is the interface -name, and the cdr is the list of properties as returned by +An interface object is another cons, whose car is the interface +name and cdr is the list of properties as returned by `dbus-get-all-properties' for that path and interface. Example: \(dbus-get-all-managed-objects :session \"org.gnome.SettingsDaemon\" \"/\") @@ -1782,12 +1783,13 @@ can be a string denoting the address of the corresponding bus. For the system and session buses, this function is called when loading `dbus.el', there is no need to call it again. -The function returns a number, which counts the connections this Emacs -session has established to the BUS under the same unique name (see -`dbus-get-unique-name'). It depends on the libraries Emacs is linked -with, and on the environment Emacs is running. For example, if Emacs -is linked with the gtk toolkit, and it runs in a GTK-aware environment -like Gnome, another connection might already be established. +The function returns the number of connections this Emacs session +has established to the BUS under the same unique name (see +`dbus-get-unique-name'). It depends on the libraries Emacs is +linked with, and on the environment Emacs is running. For +example, if Emacs is linked with the GTK+ toolkit, and it runs in +a GTK+-aware environment like GNOME, another connection might +already be established. When PRIVATE is non-nil, a new connection is established instead of reusing an existing one. It results in a new unique name at the bus. From 6b9eac67590cf4396cdde5a21ace8e96d30a1ea2 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Tue, 9 Jun 2020 02:28:53 +0300 Subject: [PATCH 04/72] * lisp/simple.el (shell-command-on-region): Fix docstring. * lisp/simple.el (shell-command-on-region): Mention REGION-NONCONTIGUOUS-P in docstring (bug#41440) * etc/NEWS: Better example for 'windmove-display-default-keybindings'. --- etc/NEWS | 4 ++-- lisp/simple.el | 7 ++++++- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 58bd491753a..10a6e3946e7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -956,8 +956,8 @@ displays the buffer from the next command in that window. For example, 'S-M-right C-h i' displays the "*Info*" buffer in the right window, creating the window if necessary. A special key can be customized to display the buffer in the same window, for example, 'S-M-0 C-h e' -displays the "*Messages*" buffer in the same window. 'S-M-t C-h C-n' -displays NEWS in a new tab. +displays the "*Messages*" buffer in the same window. 'S-M-t C-h r' +displays the Emacs manual in a new tab. +++ *** Windmove also supports directional window deletion. diff --git a/lisp/simple.el b/lisp/simple.el index 6d7600e414c..1555b376a36 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -3914,7 +3914,12 @@ is used for ERROR-BUFFER. Optional seventh arg DISPLAY-ERROR-BUFFER, if non-nil, means to display the error buffer if there were any errors. When called -interactively, this is t." +interactively, this is t. + +Non-nil REGION-NONCONTIGUOUS-P means that the region is composed of +noncontiguous pieces. The most common example of this is a +rectangular region, where the pieces are separated by newline +characters." (interactive (let (string) (unless (mark) (user-error "The mark is not set now, so there is no region")) From 22f4fba8a903874ba63f8f479fa40b1dfe12850f Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Wed, 10 Jun 2020 02:03:06 +0300 Subject: [PATCH 05/72] * lisp/emulation/cua-rect.el (cua--rectangle-region-insert): New function. Add cua--insert-rectangle around region-insert-function (bug#41440). --- lisp/emulation/cua-rect.el | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el index e99bb33dfb1..663995a0a11 100644 --- a/lisp/emulation/cua-rect.el +++ b/lisp/emulation/cua-rect.el @@ -1412,7 +1412,7 @@ With prefix arg, indent to that column." (add-function :around region-extract-function #'cua--rectangle-region-extract) (add-function :around region-insert-function - #'cua--insert-rectangle) + #'cua--rectangle-region-insert) (add-function :around redisplay-highlight-region-function #'cua--rectangle-highlight-for-redisplay) @@ -1422,6 +1422,10 @@ With prefix arg, indent to that column." ;; already do it elsewhere. (funcall redisplay-unhighlight-region-function (nth 3 args)))) +(defun cua--rectangle-region-insert (orig &rest args) + (if (not cua--rectangle) (apply orig args) + (funcall #'cua--insert-rectangle (car args)))) + (defun cua--rectangle-region-extract (orig &optional delete) (cond ((not cua--rectangle) From 54efe18959591faa1087051c878abe470f53a28f Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Sat, 6 Jun 2020 12:13:15 -0700 Subject: [PATCH 06/72] Derive gnus-edit-form-mode from lisp-data-mode, fix mode map * lisp/gnus/gnus-eform.el (gnus-edit-form-mode): Derive from lisp-data-mode, which can be handy for users who have turned on things like paredit for lisp-data-mode. (gnus-edit-form-mode-map): Put creation of the map inside the defvar. --- lisp/gnus/gnus-eform.el | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el index 54118aad1e6..1bc1261ee8f 100644 --- a/lisp/gnus/gnus-eform.el +++ b/lisp/gnus/gnus-eform.el @@ -50,13 +50,13 @@ (defvar gnus-edit-form-buffer "*Gnus edit form*") (defvar gnus-edit-form-done-function nil) -(defvar gnus-edit-form-mode-map nil) -(unless gnus-edit-form-mode-map - (setq gnus-edit-form-mode-map (make-sparse-keymap)) - (set-keymap-parent gnus-edit-form-mode-map emacs-lisp-mode-map) - (gnus-define-keys gnus-edit-form-mode-map - "\C-c\C-c" gnus-edit-form-done - "\C-c\C-k" gnus-edit-form-exit)) +(defvar gnus-edit-form-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map emacs-lisp-mode-map) + (gnus-define-keys map + "\C-c\C-c" gnus-edit-form-done + "\C-c\C-k" gnus-edit-form-exit) + map)) (defun gnus-edit-form-make-menu-bar () (unless (boundp 'gnus-edit-form-menu) @@ -67,9 +67,9 @@ ["Exit" gnus-edit-form-exit t])) (gnus-run-hooks 'gnus-edit-form-menu-hook))) -(define-derived-mode gnus-edit-form-mode fundamental-mode "Edit Form" +(define-derived-mode gnus-edit-form-mode lisp-data-mode "Edit Form" "Major mode for editing forms. -It is a slightly enhanced emacs-lisp-mode. +It is a slightly enhanced `lisp-data-mode'. \\{gnus-edit-form-mode-map}" (when (gnus-visual-p 'group-menu 'menu) From 459bd56f46af8cd7c29965600c46387282c3c93f Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Fri, 12 Jun 2020 20:17:02 +0200 Subject: [PATCH 07/72] Further fixes while testing tramp-crypt * doc/misc/tramp.texi (External methods): Remove experimental note for rclone. (Keeping files encrypted): Mark file encryption as experimental. * lisp/net/tramp-adb.el (tramp-adb-file-name-handler-alist): Use `tramp-handle-file-truename'. (tramp-adb-handle-file-truename): Remove. * lisp/net/tramp-crypt.el (tramp-crypt-file-name-handler-alist): Add `file-writable-p'. (tramp-crypt-send-command): Return t if no error. (tramp-crypt-do-encrypt-or-decrypt-file-name) (tramp-crypt-do-encrypt-or-decrypt-file): Raise an error if it fails. (tramp-crypt-do-copy-or-rename-file): Flush file properties also when copying a directory. (tramp-crypt-handle-file-writable-p): New defun. (tramp-crypt-handle-insert-directory): Check for library `text-property-search'. * lisp/net/tramp-gvfs.el (tramp-gvfs-handle-set-file-uid-gid): Rename from `tramp-gvfs-set-file-uid-gid'. * lisp/net/tramp-sh.el (tramp-sh-handle-file-truename): Use `tramp-handle-file-truename' as fallback. * lisp/net/tramp.el (tramp-handle-file-truename): Let-bind `tramp-crypt-enabled' to nil. (tramp-handle-write-region): Set also file ownership. * test/lisp/net/tramp-tests.el (tramp-test17-insert-directory): Skip if needed. --- doc/misc/tramp.texi | 7 ++- lisp/net/tramp-adb.el | 100 +---------------------------- lisp/net/tramp-crypt.el | 118 ++++++++++++++++++++--------------- lisp/net/tramp-gvfs.el | 2 +- lisp/net/tramp-sh.el | 56 +---------------- lisp/net/tramp.el | 25 +++++--- test/lisp/net/tramp-tests.el | 3 + 7 files changed, 96 insertions(+), 215 deletions(-) diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 176d3a5b1e0..eb0bf743bec 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -1185,9 +1185,6 @@ for accessing the system storage, you shall prefer this. @ref{GVFS-based methods} for example, methods @option{gdrive} and @option{nextcloud}. -@strong{Note}: The @option{rclone} method is experimental, don't use -it in production systems! - @end table @@ -1732,6 +1729,7 @@ Convenience method to access vagrant boxes. It is often used in multi-hop file names like @file{@value{prefix}vagrant@value{postfixhop}box|sudo@value{postfixhop}box@value{postfix}/path/to/file}, where @samp{box} is the name of the vagrant box. + @end table @@ -2655,6 +2653,9 @@ to direct all auto saves to that location. @section Protect remote files by encryption @cindex Encrypt remote directories +@strong{Note}: File encryption in @value{tramp} is experimental, don't +use it in production systems! + Sometimes, it is desirable to protect files located on remote directories, like cloud storages. In order to do this, you might instruct @value{tramp} to encrypt all files copied to a given remote diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index b4a080ee0f6..fb98805cc39 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -136,7 +136,7 @@ It is used for TCP/IP devices." (file-selinux-context . tramp-handle-file-selinux-context) (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-adb-handle-file-system-info) - (file-truename . tramp-adb-handle-file-truename) + (file-truename . tramp-handle-file-truename) (file-writable-p . tramp-adb-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `get-file-buffer' performed by default handler. @@ -227,104 +227,6 @@ ARGUMENTS to pass to the OPERATION." (string-to-number (match-string 2)))) (* 1024 (string-to-number (match-string 3))))))))) -;; This is derived from `tramp-sh-handle-file-truename'. Maybe the -;; code could be shared? -(defun tramp-adb-handle-file-truename (filename) - "Like `file-truename' for Tramp files." - ;; Preserve trailing "/". - (funcall - (if (directory-name-p filename) #'file-name-as-directory #'identity) - ;; Quote properly. - (funcall - (if (tramp-compat-file-name-quoted-p filename) - #'tramp-compat-file-name-quote #'identity) - (with-parsed-tramp-file-name - (tramp-compat-file-name-unquote (expand-file-name filename)) nil - (tramp-make-tramp-file-name - v - (with-tramp-file-property v localname "file-truename" - (let (result) ; result steps in reverse order - (tramp-message v 4 "Finding true name for `%s'" filename) - (let* ((steps (split-string localname "/" 'omit)) - (localnamedir (tramp-run-real-handler - 'file-name-as-directory (list localname))) - (is-dir (string= localname localnamedir)) - (thisstep nil) - (numchase 0) - ;; Don't make the following value larger than - ;; necessary. People expect an error message in a - ;; timely fashion when something is wrong; otherwise - ;; they might think that Emacs is hung. Of course, - ;; correctness has to come first. - (numchase-limit 20) - symlink-target) - (while (and steps (< numchase numchase-limit)) - (setq thisstep (pop steps)) - (tramp-message - v 5 "Check %s" - (string-join - (append '("") (reverse result) (list thisstep)) "/")) - (setq symlink-target - (tramp-compat-file-attribute-type - (file-attributes - (tramp-make-tramp-file-name - v - (string-join - (append - '("") (reverse result) (list thisstep)) "/"))))) - (cond ((string= "." thisstep) - (tramp-message v 5 "Ignoring step `.'")) - ((string= ".." thisstep) - (tramp-message v 5 "Processing step `..'") - (pop result)) - ((stringp symlink-target) - ;; It's a symlink, follow it. - (tramp-message v 5 "Follow symlink to %s" symlink-target) - (setq numchase (1+ numchase)) - (when (file-name-absolute-p symlink-target) - (setq result nil)) - ;; If the symlink was absolute, we'll get a string - ;; like "/user@host:/some/target"; extract the - ;; "/some/target" part from it. - (when (tramp-tramp-file-p symlink-target) - (unless (tramp-equal-remote filename symlink-target) - (tramp-error - v 'file-error - "Symlink target `%s' on wrong host" symlink-target)) - (setq symlink-target localname)) - (setq steps - (append (split-string symlink-target "/" 'omit) - steps))) - (t - ;; It's a file. - (setq result (cons thisstep result))))) - (when (>= numchase numchase-limit) - (tramp-error - v 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit)) - (setq result (reverse result)) - ;; Combine list to form string. - (setq result - (if result - (string-join (cons "" result) "/") - "/")) - (when (and is-dir (or (string-empty-p result) - (not (string= (substring result -1) "/")))) - (setq result (concat result "/")))) - - ;; Detect cycle. - (when (and (file-symlink-p filename) - (string-equal result localname)) - (tramp-error - v 'file-error - "Apparent cycle of symbolic links for %s" filename)) - ;; If the resulting localname looks remote, we must quote it - ;; for security reasons. - (when (file-remote-p result) - (setq result (tramp-compat-file-name-quote result 'top))) - (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result))))))) - (defun tramp-adb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." (unless id-format (setq id-format 'integer)) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 664f4413473..e63d83628a3 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -24,7 +24,7 @@ ;;; Commentary: ;; Access functions for crypted remote files. It uses encfs to -;; encrypt/ decrypt the files on a remote directory. A remote +;; encrypt / decrypt the files on a remote directory. A remote ;; directory, which shall include crypted files, must be declared in ;; `tramp-crypt-directories' via command `tramp-crypt-add-directory'. ;; All files in that directory, including all subdirectories, are @@ -189,8 +189,8 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (file-selinux-context . ignore) (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-crypt-handle-file-system-info) - ;; (file-truename . tramp-crypt-handle-file-truename) - ;; (file-writable-p . ignore) + ;; `file-truename' performed by default handler. + (file-writable-p . tramp-crypt-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-crypt-handle-insert-directory) @@ -351,7 +351,7 @@ connection if a previous connection has died for some reason." (defun tramp-crypt-send-command (vec &rest args) "Send encfsctl command to connection VEC. -ARGS are the arguments." +ARGS are the arguments. It returns t if ran successful, and nil otherwise." (tramp-crypt-maybe-open-connection vec) (with-current-buffer (tramp-get-connection-buffer vec) (erase-buffer)) @@ -380,11 +380,12 @@ ARGS are the arguments." ;; Save the password. (ignore-errors (and (functionp tramp-password-save-function) - (funcall tramp-password-save-function))))))) + (funcall tramp-password-save-function))) + t)))) (defun tramp-crypt-do-encrypt-or-decrypt-file-name (op name) - "Return encrypted/ decrypted NAME if NAME belongs to a crypted directory. -OP must be `encrypt' or `decrypt'. + "Return encrypted / decrypted NAME if NAME belongs to a crypted directory. +OP must be `encrypt' or `decrypt'. Raise an error if this fails. Otherwise, return NAME." (if-let ((tramp-crypt-enabled t) (dir (tramp-crypt-file-name-p name)) @@ -399,9 +400,12 @@ Otherwise, return NAME." (unless (string-equal localname "/") (with-tramp-file-property crypt-vec localname (concat (symbol-name op) "-file-name") - (tramp-crypt-send-command - crypt-vec (if (eq op 'encrypt) "encode" "decode") - (tramp-compat-temporary-file-directory) localname) + (unless (tramp-crypt-send-command + crypt-vec (if (eq op 'encrypt) "encode" "decode") + (tramp-compat-temporary-file-directory) localname) + (tramp-error + crypt-vec "%s of file name %s failed." + (if (eq op 'encrypt) "Encoding" "Decoding") name)) (with-current-buffer (tramp-get-connection-buffer crypt-vec) (goto-char (point-min)) (buffer-substring (point-min) (point-at-eol))))))) @@ -419,9 +423,10 @@ Otherwise, return NAME." (tramp-crypt-do-encrypt-or-decrypt-file-name 'decrypt name)) (defun tramp-crypt-do-encrypt-or-decrypt-file (op root infile outfile) - "Encrypt/ decrypt file INFILE to OUTFILE according to crypted directory ROOT. + "Encrypt / decrypt file INFILE to OUTFILE according to crypted directory ROOT. Both files must be local files. OP must be `encrypt' or `decrypt'. -If OP ist `decrypt', the basename of INFILE must be an encrypted file name." +If OP ist `decrypt', the basename of INFILE must be an encrypted file name. +Raise an error if this fails." (when-let ((tramp-crypt-enabled t) (dir (tramp-crypt-file-name-p root)) (crypt-vec (tramp-crypt-dissect-file-name dir))) @@ -429,10 +434,13 @@ If OP ist `decrypt', the basename of INFILE must be an encrypted file name." (if (eq op 'decrypt) 'binary coding-system-for-read)) (coding-system-for-write (if (eq op 'encrypt) 'binary coding-system-for-write))) - (tramp-crypt-send-command - crypt-vec "cat" (and (eq op 'encrypt) "--reverse") - (file-name-directory infile) - (concat "/" (file-name-nondirectory infile))) + (unless (tramp-crypt-send-command + crypt-vec "cat" (and (eq op 'encrypt) "--reverse") + (file-name-directory infile) + (concat "/" (file-name-nondirectory infile))) + (tramp-error + crypt-vec "%s of file %s failed." + (if (eq op 'encrypt) "Encrypting" "Decrypting") infile)) (with-current-buffer (tramp-get-connection-buffer crypt-vec) (write-region nil nil outfile))))) @@ -520,16 +528,17 @@ absolute file names." (error "Unknown operation `%s', must be `copy' or `rename'" op)) (setq filename (file-truename filename)) - (if (file-directory-p filename) - (progn - (copy-directory filename newname keep-date t) - (when (eq op 'rename) (delete-directory filename 'recursive))) + (let ((t1 (tramp-crypt-file-name-p filename)) + (t2 (tramp-crypt-file-name-p newname)) + (encrypt-filename (tramp-crypt-encrypt-file-name filename)) + (encrypt-newname (tramp-crypt-encrypt-file-name newname)) + (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) - (let ((t1 (tramp-crypt-file-name-p filename)) - (t2 (tramp-crypt-file-name-p newname)) - (encrypt-filename (tramp-crypt-encrypt-file-name filename)) - (encrypt-newname (tramp-crypt-encrypt-file-name newname)) - (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) + (if (file-directory-p filename) + (progn + (copy-directory filename newname keep-date t) + (when (eq op 'rename) + (delete-directory filename 'recursive))) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) @@ -581,15 +590,15 @@ absolute file names." (rename-file filename tmpfile1 t)) (tramp-crypt-encrypt-file t2 tmpfile1 tmpfile2) (rename-file tmpfile2 encrypt-newname ok-if-already-exists))) - (delete-directory tmpdir 'recursive))) + (delete-directory tmpdir 'recursive)))))) - (when (and t1 (eq op 'rename)) - (with-parsed-tramp-file-name filename v1 - (tramp-flush-file-properties v1 v1-localname))) + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-properties v1 v1-localname))) - (when t2 - (with-parsed-tramp-file-name newname v2 - (tramp-flush-file-properties v2 v2-localname)))))))) + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-properties v2 v2-localname))))) (defun tramp-crypt-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -692,28 +701,35 @@ absolute file names." ;; #'file-system-info. 'file-system-info (list (tramp-crypt-encrypt-file-name filename)))) +(defun tramp-crypt-handle-file-writable-p (filename) + "Like `file-writable-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-writable-p (tramp-crypt-encrypt-file-name filename)))) + (defun tramp-crypt-handle-insert-directory (filename switches &optional wildcard full-directory-p) "Like `insert-directory' for Tramp files." - (let (tramp-crypt-enabled) - (tramp-handle-insert-directory - (tramp-crypt-encrypt-file-name filename) - switches wildcard full-directory-p) - (let* ((filename (file-name-as-directory filename)) - (enc (tramp-crypt-encrypt-file-name filename)) - match string) - (goto-char (point-min)) - (while (setq match (text-property-search-forward 'dired-filename t t)) - (setq string - (buffer-substring - (prop-match-beginning match) (prop-match-end match)) - string (if (file-name-absolute-p string) - (tramp-crypt-decrypt-file-name string) - (substring - (tramp-crypt-decrypt-file-name (concat enc string)) - (length filename)))) - (delete-region (prop-match-beginning match) (prop-match-end match)) - (insert (propertize string 'dired-filename t)))))) + ;; This package has been added to Emacs 27.1. + (when (load "text-property-search" 'noerror 'nomessage) + (let (tramp-crypt-enabled) + (tramp-handle-insert-directory + (tramp-crypt-encrypt-file-name filename) + switches wildcard full-directory-p) + (let* ((filename (file-name-as-directory filename)) + (enc (tramp-crypt-encrypt-file-name filename)) + match string) + (goto-char (point-min)) + (while (setq match (text-property-search-forward 'dired-filename t t)) + (setq string + (buffer-substring + (prop-match-beginning match) (prop-match-end match)) + string (if (file-name-absolute-p string) + (tramp-crypt-decrypt-file-name string) + (substring + (tramp-crypt-decrypt-file-name (concat enc string)) + (length filename)))) + (delete-region (prop-match-beginning match) (prop-match-end match)) + (insert (propertize string 'dired-filename t))))))) (defun tramp-crypt-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 704d65cd55e..89e9b132304 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1589,7 +1589,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (current-time) time))))) -(defun tramp-gvfs-set-file-uid-gid (filename &optional uid gid) +(defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index a3ce436e42a..bcbb7240ec6 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1153,59 +1153,9 @@ component is used as the target of the symlink." (tramp-shell-quote-argument localname))))) ;; Do it yourself. - (t (let ((steps (split-string localname "/" 'omit)) - (thisstep nil) - (numchase 0) - ;; Don't make the following value larger than - ;; necessary. People expect an error message in a - ;; timely fashion when something is wrong; - ;; otherwise they might think that Emacs is hung. - ;; Of course, correctness has to come first. - (numchase-limit 20) - symlink-target) - (while (and steps (< numchase numchase-limit)) - (setq thisstep (pop steps)) - (tramp-message - v 5 "Check %s" - (string-join - (append '("") (reverse result) (list thisstep)) "/")) - (setq symlink-target - (tramp-compat-file-attribute-type - (file-attributes - (tramp-make-tramp-file-name - v - (string-join - (append - '("") (reverse result) (list thisstep)) "/") - 'nohop)))) - (cond ((string= "." thisstep) - (tramp-message v 5 "Ignoring step `.'")) - ((string= ".." thisstep) - (tramp-message v 5 "Processing step `..'") - (pop result)) - ((stringp symlink-target) - ;; It's a symlink, follow it. - (tramp-message - v 5 "Follow symlink to %s" symlink-target) - (setq numchase (1+ numchase)) - (when (file-name-absolute-p symlink-target) - (setq result nil)) - (setq steps - (append - (split-string symlink-target "/" 'omit) - steps))) - (t - ;; It's a file. - (setq result (cons thisstep result))))) - (when (>= numchase numchase-limit) - (tramp-error - v 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit)) - (setq result (reverse result) - ;; Combine list to form string. - result - (if result (string-join (cons "" result) "/") "/")) - (when (string-empty-p result) (setq result "/"))))) + (t (setq + result + (tramp-file-local-name (tramp-handle-file-truename filename))))) ;; Detect cycle. (when (and (file-symlink-p filename) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index f1db6a7be29..b045e411093 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3381,6 +3381,8 @@ User is always nil." ;; something is wrong; otherwise they might think that Emacs ;; is hung. Of course, correctness has to come first. (numchase-limit 20) + ;; Unquoting could enable encryption. + tramp-crypt-enabled symlink-target) (with-parsed-tramp-file-name result v1 ;; We cache only the localname. @@ -3900,7 +3902,11 @@ of." (let ((tmpfile (tramp-compat-make-temp-file filename)) (modes (tramp-default-file-modes - filename (and (eq mustbenew 'excl) 'nofollow)))) + filename (and (eq mustbenew 'excl) 'nofollow))) + (uid (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer))) + (gid (tramp-compat-file-attribute-group-id + (file-attributes filename 'integer)))) (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; The permissions of the temporary file should be set. If @@ -3919,15 +3925,18 @@ of." (error (delete-file tmpfile) (tramp-error - v 'file-error "Couldn't write region to `%s'" filename)))) + v 'file-error "Couldn't write region to `%s'" filename))) - (tramp-flush-file-properties v localname) + (tramp-flush-file-properties v localname) - ;; Set file modification time. - (when (or (eq visit t) (stringp visit)) - (set-visited-file-modtime - (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) + ;; Set file modification time. + (when (or (eq visit t) (stringp visit)) + (set-visited-file-modtime + (tramp-compat-file-attribute-modification-time + (file-attributes filename)))) + + ;; Set the ownership. + (tramp-set-file-uid-gid filename uid gid)) ;; The end. (when (and (null noninteractive) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 578da4171c7..9667b34c667 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2925,6 +2925,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; (this is performed by `dired'). If FULL is nil, it shows just ;; one file. So we refrain from testing. (skip-unless (not (tramp--test-ange-ftp-p))) + ;; `insert-directory' of crypted remote directories works only since + ;; Emacs 27.1. + (skip-unless (or (not (tramp--test-crypt-p)) (tramp--test-emacs27-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 From a3474c59dee35d687f773993869f84eb5f9d2eda Mon Sep 17 00:00:00 2001 From: Konstantin Kharlamov Date: Wed, 3 Jun 2020 14:51:03 +0300 Subject: [PATCH 08/72] Highlight typed variables in Python * progmodes/python.el (python-font-lock-keywords-maximum-decoration): Recognize typed variables like "foo: int = 1" as well. (Bug#41684) --- lisp/progmodes/python.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 1ca9f019638..aec27a58dea 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -633,6 +633,8 @@ builtins.") (,(lambda (limit) (let ((re (python-rx (group (+ (any word ?. ?_))) (? ?\[ (+ (not (any ?\]))) ?\]) (* space) + ;; A type, like " : int ". + (? ?: (* space) (+ (any word ?. ?_)) (* space)) assignment-operator)) (res nil)) (while (and (setq res (re-search-forward re limit t)) From f4b99b34ed182082a17516ab5f99953275cb171d Mon Sep 17 00:00:00 2001 From: Philip K Date: Sat, 30 May 2020 21:47:51 +0200 Subject: [PATCH 09/72] Mark python-shell-virtualenv-root as safe for directories * lisp/progmodes/python.el (python-shell-virtualenv-root): Require a directory name. (Bug#41619) --- lisp/progmodes/python.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index aec27a58dea..0ce80db1993 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -2092,7 +2092,8 @@ executed through tramp connections." This variable, when set to a string, makes the environment to be modified such that shells are started within the specified virtualenv." - :type '(choice (const nil) string) + :type '(choice (const nil) directory) + :safe #'file-directory-p :group 'python) (defcustom python-shell-setup-codes nil From 6cdecc2659a290f4a9eddb498978e3b07d5cbc58 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 13 Jun 2020 17:53:59 +0100 Subject: [PATCH 10/72] Revert markup change in with-coding-priority docs This partially reverts commit fc759eb9b3 "Fix with-coding-priority markup in Elisp manual" of 2019-10-13T15:36:02Z!contovob@tcd.ie. For discussion, see the following thread: https://lists.gnu.org/archive/html/emacs-devel/2019-10/msg00550.html https://lists.gnu.org/archive/html/emacs-devel/2020-06/msg00473.html * doc/lispref/nonascii.texi (Specifying Coding Systems): Use more specific cross-reference to progn even if info.el displays it suboptimally. --- doc/lispref/nonascii.texi | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/lispref/nonascii.texi b/doc/lispref/nonascii.texi index 51831a05cc2..c6c78ec096e 100644 --- a/doc/lispref/nonascii.texi +++ b/doc/lispref/nonascii.texi @@ -1823,9 +1823,9 @@ than all the rest. @defmac with-coding-priority coding-systems &rest body This macro executes @var{body}, like @code{progn} does -(@pxref{Sequencing}), with @var{coding-systems} at the front of the -priority list for coding systems. @var{coding-systems} should be a -list of coding systems to prefer during execution of @var{body}. +(@pxref{Sequencing, progn}), with @var{coding-systems} at the front of +the priority list for coding systems. @var{coding-systems} should be +a list of coding systems to prefer during execution of @var{body}. @end defmac @node Explicit Encoding From 4823fa1077e4330bd2574eb54731bb32e6370034 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Sat, 13 Jun 2020 10:42:47 -0700 Subject: [PATCH 11/72] Tag a test as unstable * test/lisp/calendar/lunar-tests.el (lunar-test-phase-list): Mark as unstable. Eg fails on hydra.nixos.org. --- test/lisp/calendar/lunar-tests.el | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test/lisp/calendar/lunar-tests.el b/test/lisp/calendar/lunar-tests.el index 8d8a988e503..d2647aac03a 100644 --- a/test/lisp/calendar/lunar-tests.el +++ b/test/lisp/calendar/lunar-tests.el @@ -42,7 +42,12 @@ (with-lunar-test (should (equal (eclipse-check 1 1) "** Eclipse **")))) +;; This fails in certain time zones. +;; Eg TZ=America/Phoenix make lisp/calendar/lunar-tests +;; Similarly with TZ=UTC. +;; Daylight saving related? (ert-deftest lunar-test-phase-list () + :tags '(:unstable) (with-lunar-test (should (equal (lunar-phase-list 3 1871) '(((3 20 1871) "11:03pm" 0 "") From 079b0dc430ef9e9a6564c7138fd2f319bf9bc7dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jo=C3=A3o=20T=C3=A1vora?= Date: Sat, 13 Jun 2020 18:45:40 +0100 Subject: [PATCH 12/72] Delete, don't kill, dir dir fragments in icomplete-fido-backward-updir Reported by: Andrew Schwartzmeyer * lisp/icomplete.el (icomplete-fido-backward-updir): Don't save dir fragments to kill ring. --- lisp/icomplete.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/icomplete.el b/lisp/icomplete.el index 60ef0247bae..3747ae3d281 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -300,7 +300,10 @@ if that doesn't produce a completion match." (interactive) (if (and (eq (char-before) ?/) (eq (icomplete--category) 'file)) - (zap-up-to-char -1 ?/) + (save-excursion + (goto-char (1- (point))) + (when (search-backward "/" (point-min) t) + (delete-region (1+ (point)) (point-max)))) (call-interactively 'backward-delete-char))) (defvar icomplete-fido-mode-map From 82a632edc8b80bf16d9b9f205474bf9724b084c0 Mon Sep 17 00:00:00 2001 From: "Michael R. Mauger" Date: Sun, 29 Mar 2020 20:52:10 -0400 Subject: [PATCH 13/72] 2020-03-29 Michael R. Mauger * lisp/progmodes/sql.el (sql-add-product): Re-correct argument spec. Previous change was due to my mistake; I have resolved back to the prior behavior (Bug#39960). * test/lisp/progmodes/sql-tests.el (sql-test-add-product): Added test to insure I don't make the same mistake again. --- lisp/progmodes/sql.el | 2 +- test/lisp/progmodes/sql-tests.el | 8 +++++++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 6fd750d3963..c86fc59ac16 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -2683,7 +2683,7 @@ highlighting rules in SQL mode.") nil 'require-match init 'sql-product-history init)))) -(defun sql-add-product (product display &optional plist) +(defun sql-add-product (product display &rest plist) "Add support for a database product in `sql-mode'. Add PRODUCT to `sql-product-alist' which enables `sql-mode' to diff --git a/test/lisp/progmodes/sql-tests.el b/test/lisp/progmodes/sql-tests.el index 65ed76bfb5d..91805ab7251 100644 --- a/test/lisp/progmodes/sql-tests.el +++ b/test/lisp/progmodes/sql-tests.el @@ -187,7 +187,13 @@ Perform ACTION and validate results" (sql-add-product 'xyz "XyzDb") (should (equal (pp-to-string (assoc 'xyz sql-product-alist)) - "(xyz :name \"XyzDb\")\n")))) + "(xyz :name \"XyzDb\")\n"))) + + (sql-test-product-feature-harness + (sql-add-product 'stu "StuDb" :X 1 :Y "2") + + (should (equal (pp-to-string (assoc 'stu sql-product-alist)) + "(stu :name \"StuDb\" :X 1 :Y \"2\")\n")))) (ert-deftest sql-test-add-existing-product () "Add a product that already exists." From b3e7d046c3a94556fcaf6f9ce72aa2ecb20262a6 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sun, 14 Jun 2020 15:31:17 +0200 Subject: [PATCH 14/72] Rearrange detecting remote uid and gid in Tramp * lisp/net/tramp-adb.el (tramp-adb-file-name-handler-alist): * lisp/net/tramp-archive.el (tramp-archive-file-name-handler-alist): * lisp/net/tramp-rclone.el (tramp-rclone-file-name-handler-alist): * lisp/net/tramp-smb.el (tramp-smb-file-name-handler-alist): Add `tramp-get-remote-gid' and 'tramp-get-remote-uid'. * lisp/net/tramp-crypt.el (tramp-crypt-file-name-handler-alist): Add `file-ownership-preserved-p'. (tramp-crypt-add-directory): Check, that NAME is not quoted. (tramp-crypt-handle-file-ownership-preserved-p): New defun. (tramp-crypt-handle-insert-directory): Fix docstring. * lisp/net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist): Add `tramp-get-remote-gid' and 'tramp-get-remote-uid'. (tramp-gvfs-handle-file-readable-p): Call `tramp-get-remote-uid'. (tramp-gvfs-handle-get-remote-uid) (tramp-gvfs-handle-get-remote-gid): Rename from `tramp-gvfs-get-remote-{uid,gid}'. Do not cache result. (tramp-gvfs-maybe-open-connection): No special handling for remote uid and gid. * lisp/net/tramp-sh.el (tramp-sh-file-name-handler-alist): Add `tramp-get-remote-gid' and 'tramp-get-remote-uid'. (tramp-sh-handle-get-remote-uid, tramp-sh-handle-get-remote-gid): Rename from `tramp-get-remote-{uid,gid}'. Do not cache result. (tramp-sh-handle-file-ownership-preserved-p): Distinguish by GROUP when caching. * lisp/net/tramp-sudoedit.el (tramp-sudoedit-file-name-handler-alist): Add `tramp-get-remote-gid' and 'tramp-get-remote-uid'. (tramp-sudoedit-handle-get-remote-uid) (tramp-sudoedit-handle-get-remote-gid): Rename from `tramp-sudoedit-get-remote-{uid,gid}'. Do not cache result. (tramp-sudoedit-handle-set-file-uid-gid) (tramp-sudoedit-handle-write-region): Call `tramp-get-remote-uid' and `tramp-get-remote-gid'. (tramp-sudoedit-maybe-open-connection): No special handling for remote uid and gid. * lisp/net/tramp.el (tramp-file-name-for-operation): Add `tramp-get-remote-gid' and 'tramp-get-remote-uid'. (tramp-handle-write-region, tramp-check-cached-permissions): Call `tramp-get-remote-uid' and `tramp-get-remote-gid'. (tramp-get-remote-uid, tramp-get-remote-gid): New defuns. (tramp-local-host-p): Simplify `tramp-get-remote-uid' call. * test/lisp/net/tramp-tests.el (tramp-test17-dired-with-wildcards) Skip if needed. --- lisp/net/tramp-adb.el | 2 ++ lisp/net/tramp-archive.el | 4 ++- lisp/net/tramp-crypt.el | 14 ++++++-- lisp/net/tramp-gvfs.el | 68 +++++++++++++---------------------- lisp/net/tramp-rclone.el | 2 ++ lisp/net/tramp-sh.el | 70 ++++++++++++++---------------------- lisp/net/tramp-smb.el | 2 ++ lisp/net/tramp-sudoedit.el | 37 ++++++++----------- lisp/net/tramp.el | 51 +++++++++++++++++++------- test/lisp/net/tramp-tests.el | 2 ++ 10 files changed, 126 insertions(+), 126 deletions(-) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index fb98805cc39..a7a5047ed49 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -160,6 +160,8 @@ It is used for TCP/IP devices." (start-file-process . tramp-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 24ee6fa51f3..9502cc35300 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -279,7 +279,9 @@ It must be supported by libarchive(3).") (start-file-process . tramp-archive-handle-not-implemented) ;; `substitute-in-file-name' performed by default handler. (temporary-file-directory . tramp-archive-handle-temporary-file-directory) - ;; `tramp-set-file-uid-gid' performed by default handler. + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) + (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index e63d83628a3..4f01f1bf6c4 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -182,7 +182,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (file-notify-add-watch . ignore) (file-notify-rm-watch . ignore) (file-notify-valid-p . ignore) - ;; (file-ownership-preserved-p . ignore) + (file-ownership-preserved-p . tramp-crypt-handle-file-ownership-preserved-p) (file-readable-p . tramp-crypt-handle-file-readable-p) (file-regular-p . tramp-handle-file-regular-p) ;; `file-remote-p' performed by default handler. @@ -213,6 +213,8 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (start-file-process . ignore) ;; `substitute-in-file-name' performed by default handler. ;; (temporary-file-directory . tramp-crypt-handle-temporary-file-directory) + ;; `tramp-get-remote-gid' performed by default handler. + ;; `tramp-get-remote-uid' performed by default handler. (tramp-set-file-uid-gid . tramp-crypt-handle-set-file-uid-gid) ;; (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -465,6 +467,8 @@ directory. File names will be also encrypted." (tramp-user-error nil "Feature is not enabled.")) (unless (and (tramp-tramp-file-p name) (file-directory-p name)) (tramp-user-error nil "%s must be an existing remote directory." name)) + (when (tramp-compat-file-name-quoted-p name) + (tramp-user-error nil "%s must not be quoted." name)) (setq name (file-name-as-directory (expand-file-name name))) (unless (member name tramp-crypt-directories) (setq tramp-crypt-directories (cons name tramp-crypt-directories))) @@ -694,6 +698,11 @@ absolute file names." (let (tramp-crypt-enabled) (file-readable-p (tramp-crypt-encrypt-file-name filename)))) +(defun tramp-crypt-handle-file-ownership-preserved-p (filename &optional group) + "Like `file-ownership-preserved-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-ownership-preserved-p (tramp-crypt-encrypt-file-name filename) group))) + (defun tramp-crypt-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." (tramp-crypt-run-real-handler @@ -708,7 +717,8 @@ absolute file names." (defun tramp-crypt-handle-insert-directory (filename switches &optional wildcard full-directory-p) - "Like `insert-directory' for Tramp files." + "Like `insert-directory' for Tramp files. +WILDCARD is not supported." ;; This package has been added to Emacs 27.1. (when (load "text-property-search" 'noerror 'nomessage) (let (tramp-crypt-enabled) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 89e9b132304..36166ad1966 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -821,6 +821,8 @@ It has been changed in GVFS 1.14.") (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . tramp-gvfs-handle-get-remote-gid) + (tramp-get-remote-uid . tramp-gvfs-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-gvfs-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -1506,7 +1508,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." ;; If the user is different from what we guess to be ;; the user, we don't know. Let's check, whether ;; access is restricted explicitly. - (and (/= (tramp-gvfs-get-remote-uid v 'integer) + (and (/= (tramp-get-remote-uid v 'integer) (tramp-compat-file-attribute-user-id (file-attributes filename 'integer))) (not @@ -1589,6 +1591,26 @@ If FILE-SYSTEM is non-nil, return file system attributes." (current-time) time))))) +(defun tramp-gvfs-handle-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (if (equal id-format 'string) + (tramp-file-name-user vec) + (when-let + ((localname (tramp-get-connection-property vec "default-location" nil))) + (tramp-compat-file-attribute-user-id + (file-attributes + (tramp-make-tramp-file-name vec localname) id-format))))) + +(defun tramp-gvfs-handle-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (when-let + ((localname (tramp-get-connection-property vec "default-location" nil))) + (tramp-compat-file-attribute-group-id + (file-attributes + (tramp-make-tramp-file-name vec localname) id-format)))) + (defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." (with-parsed-tramp-file-name filename nil @@ -2057,39 +2079,6 @@ and \"org.gtk.Private.RemoteVolumeMonitor.VolumeRemoved\" signals." ;; Connection functions. -(defun tramp-gvfs-get-remote-uid (vec id-format) - "The uid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "uid-%s" id-format) - (let ((user (tramp-file-name-user vec)) - (localname - (tramp-get-connection-property vec "default-location" nil))) - (cond - ((and (equal id-format 'string) user)) - (localname - (tramp-compat-file-attribute-user-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format))) - ((equal id-format 'integer) tramp-unknown-id-integer) - ((equal id-format 'string) tramp-unknown-id-string))))) - -(defun tramp-gvfs-get-remote-gid (vec id-format) - "The gid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "gid-%s" id-format) - (let ((localname - (tramp-get-connection-property vec "default-location" nil))) - (cond - (localname - (tramp-compat-file-attribute-group-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format))) - ((equal id-format 'integer) tramp-unknown-id-integer) - ((equal id-format 'string) tramp-unknown-id-string))))) - -(defvar tramp-gvfs-get-remote-uid-gid-in-progress nil - "Indication, that remote uid and gid determination is in progress.") - (defun tramp-gvfs-get-remote-prefix (vec) "The prefix of the remote connection VEC. This is relevant for GNOME Online Accounts." @@ -2229,16 +2218,7 @@ connection if a previous connection has died for some reason." ;; Mark it as connected. (tramp-set-connection-property - (tramp-get-connection-process vec) "connected" t)))) - - ;; In `tramp-check-cached-permissions', the connection properties - ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. - (unless tramp-gvfs-get-remote-uid-gid-in-progress - (let ((tramp-gvfs-get-remote-uid-gid-in-progress t)) - (tramp-gvfs-get-remote-uid vec 'integer) - (tramp-gvfs-get-remote-gid vec 'integer) - (tramp-gvfs-get-remote-uid vec 'string) - (tramp-gvfs-get-remote-gid vec 'string)))) + (tramp-get-connection-process vec) "connected" t))))) (defun tramp-gvfs-gio-tool-p (vec) "Check, whether the gio tool is available." diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 08bba33afed..f635d3cbb68 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -135,6 +135,8 @@ (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index bcbb7240ec6..fad841a6ace 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1039,6 +1039,8 @@ of command line.") (start-file-process . tramp-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . tramp-sh-handle-get-remote-gid) + (tramp-get-remote-uid . tramp-sh-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . tramp-sh-handle-vc-registered) @@ -1467,6 +1469,26 @@ of." (if (eq flag 'nofollow) "-h" "") (tramp-shell-quote-argument localname))))))) +(defun tramp-sh-handle-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (ignore-errors + (cond + ((tramp-get-remote-id vec) (tramp-get-remote-uid-with-id vec id-format)) + ((tramp-get-remote-perl vec) (tramp-get-remote-uid-with-perl vec id-format)) + ((tramp-get-remote-python vec) + (tramp-get-remote-uid-with-python vec id-format))))) + +(defun tramp-sh-handle-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (ignore-errors + (cond + ((tramp-get-remote-id vec) (tramp-get-remote-gid-with-id vec id-format)) + ((tramp-get-remote-perl vec) (tramp-get-remote-gid-with-perl vec id-format)) + ((tramp-get-remote-python vec) + (tramp-get-remote-gid-with-python vec id-format))))) + (defun tramp-sh-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." ;; Modern Unices allow chown only for root. So we might need @@ -1669,8 +1691,10 @@ of." (defun tramp-sh-handle-file-ownership-preserved-p (filename &optional group) "Like `file-ownership-preserved-p' for Tramp files." (with-parsed-tramp-file-name filename nil - (with-tramp-file-property v localname "file-ownership-preserved-p" - (let ((attributes (file-attributes filename))) + (with-tramp-file-property + v localname + (format "file-ownership-preserved-p%s" (if group "-group" "")) + (let ((attributes (file-attributes filename 'integer))) ;; Return t if the file doesn't exist, since it's true that no ;; information would be lost by an (attempted) delete and create. (or (null attributes) @@ -5778,27 +5802,6 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." "import os; print (os.getuid())" "import os, pwd; print ('\\\"' + pwd.getpwuid(os.getuid())[0] + '\\\"')")))) -(defun tramp-get-remote-uid (vec id-format) - "The uid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "uid-%s" id-format) - (let ((res - (ignore-errors - (cond - ((tramp-get-remote-id vec) - (tramp-get-remote-uid-with-id vec id-format)) - ((tramp-get-remote-perl vec) - (tramp-get-remote-uid-with-perl vec id-format)) - ((tramp-get-remote-python vec) - (tramp-get-remote-uid-with-python vec id-format)))))) - ;; Ensure there is a valid result. - (cond - ((and (equal id-format 'integer) (not (integerp res))) - tramp-unknown-id-integer) - ((and (equal id-format 'string) (not (stringp res))) - tramp-unknown-id-string) - (t res))))) - (defun tramp-get-remote-gid-with-id (vec id-format) "Implement `tramp-get-remote-gid' for Tramp files using `id'." (tramp-send-command-and-read @@ -5829,27 +5832,6 @@ ID-FORMAT valid values are `string' and `integer'." "import os; print (os.getgid())" "import os, grp; print ('\\\"' + grp.getgrgid(os.getgid())[0] + '\\\"')")))) -(defun tramp-get-remote-gid (vec id-format) - "The gid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "gid-%s" id-format) - (let ((res - (ignore-errors - (cond - ((tramp-get-remote-id vec) - (tramp-get-remote-gid-with-id vec id-format)) - ((tramp-get-remote-perl vec) - (tramp-get-remote-gid-with-perl vec id-format)) - ((tramp-get-remote-python vec) - (tramp-get-remote-gid-with-python vec id-format)))))) - ;; Ensure there is a valid result. - (cond - ((and (equal id-format 'integer) (not (integerp res))) - tramp-unknown-id-integer) - ((and (equal id-format 'string) (not (stringp res))) - tramp-unknown-id-string) - (t res))))) - (defun tramp-get-remote-busybox (vec) "Determine remote `busybox' command." (with-tramp-connection-property vec "busybox" diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 2088d236288..3980add7c41 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -293,6 +293,8 @@ See `tramp-actions-before-shell' for more info.") (start-file-process . tramp-smb-handle-start-file-process) (substitute-in-file-name . tramp-smb-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 68e68a242c9..05242ffd970 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -132,6 +132,8 @@ See `tramp-actions-before-shell' for more info.") (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . tramp-sudoedit-handle-get-remote-gid) + (tramp-get-remote-uid . tramp-sudoedit-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sudoedit-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -689,21 +691,19 @@ component is used as the target of the symlink." (tramp-flush-file-property v localname "file-selinux-context")) t))))) -(defun tramp-sudoedit-get-remote-uid (vec id-format) +(defun tramp-sudoedit-handle-get-remote-uid (vec id-format) "The uid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "uid-%s" id-format) - (if (equal id-format 'integer) - (tramp-sudoedit-send-command-and-read vec "id" "-u") - (tramp-sudoedit-send-command-string vec "id" "-un")))) + (if (equal id-format 'integer) + (tramp-sudoedit-send-command-and-read vec "id" "-u") + (tramp-sudoedit-send-command-string vec "id" "-un"))) -(defun tramp-sudoedit-get-remote-gid (vec id-format) +(defun tramp-sudoedit-handle-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "gid-%s" id-format) - (if (equal id-format 'integer) - (tramp-sudoedit-send-command-and-read vec "id" "-g") - (tramp-sudoedit-send-command-string vec "id" "-gn")))) + (if (equal id-format 'integer) + (tramp-sudoedit-send-command-and-read vec "id" "-g") + (tramp-sudoedit-send-command-string vec "id" "-gn"))) (defun tramp-sudoedit-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." @@ -711,8 +711,8 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-sudoedit-send-command v "chown" (format "%d:%d" - (or uid (tramp-sudoedit-get-remote-uid v 'integer)) - (or gid (tramp-sudoedit-get-remote-gid v 'integer))) + (or uid (tramp-get-remote-uid v 'integer)) + (or gid (tramp-get-remote-gid v 'integer))) (tramp-unquote-file-local-name filename)))) (defun tramp-sudoedit-handle-write-region @@ -721,10 +721,10 @@ ID-FORMAT valid values are `string' and `integer'." (with-parsed-tramp-file-name filename nil (let* ((uid (or (tramp-compat-file-attribute-user-id (file-attributes filename 'integer)) - (tramp-sudoedit-get-remote-uid v 'integer))) + (tramp-get-remote-uid v 'integer))) (gid (or (tramp-compat-file-attribute-group-id (file-attributes filename 'integer)) - (tramp-sudoedit-get-remote-gid v 'integer))) + (tramp-get-remote-gid v 'integer))) (flag (and (eq mustbenew 'excl) 'nofollow)) (modes (tramp-default-file-modes filename flag))) (prog1 @@ -785,14 +785,7 @@ connection if a previous connection has died for some reason." (tramp-set-connection-local-variables vec) ;; Mark it as connected. - (tramp-set-connection-property p "connected" t)) - - ;; In `tramp-check-cached-permissions', the connection properties - ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. - (tramp-sudoedit-get-remote-uid vec 'integer) - (tramp-sudoedit-get-remote-gid vec 'integer) - (tramp-sudoedit-get-remote-uid vec 'string) - (tramp-sudoedit-get-remote-gid vec 'string))) + (tramp-set-connection-property p "connected" t)))) (defun tramp-sudoedit-send-command (vec &rest args) "Send commands ARGS to connection VEC. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index b045e411093..f3c065e9e7a 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2280,6 +2280,9 @@ Must be handled by the callers." (when (processp (nth 0 args)) (with-current-buffer (process-buffer (nth 0 args)) default-directory))) + ;; VEC. + ((member operation '(tramp-get-remote-gid tramp-get-remote-uid)) + (tramp-make-tramp-file-name (nth 0 args))) ;; Unknown file primitive. (t (error "Unknown file I/O primitive: %s" operation)))) @@ -3903,10 +3906,12 @@ of." (let ((tmpfile (tramp-compat-make-temp-file filename)) (modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) - (uid (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer))) - (gid (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)))) + (uid (or (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer)) + (tramp-get-remote-uid v 'integer))) + (gid (or (tramp-compat-file-attribute-group-id + (file-attributes filename 'integer)) + (tramp-get-remote-gid v 'integer)))) (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; The permissions of the temporary file should be set. If @@ -4612,12 +4617,8 @@ be granted." (concat "file-attributes-" suffix) nil) (file-attributes (tramp-make-tramp-file-name vec) (intern suffix)))) - (remote-uid - (tramp-get-connection-property - vec (concat "uid-" suffix) nil)) - (remote-gid - (tramp-get-connection-property - vec (concat "gid-" suffix) nil)) + (remote-uid (tramp-get-remote-uid vec (intern suffix))) + (remote-gid (tramp-get-remote-gid vec (intern suffix))) (unknown-id (if (string-equal suffix "string") tramp-unknown-id-string tramp-unknown-id-integer))) @@ -4651,6 +4652,32 @@ be granted." (tramp-compat-file-attribute-group-id file-attr)))))))))))) +(defun tramp-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (with-tramp-connection-property vec (format "uid-%s" id-format) + (or (when-let + ((handler + (find-file-name-handler + (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid))) + (funcall handler #'tramp-get-remote-uid vec id-format)) + ;; Ensure there is a valid result. + (and (equal id-format 'integer) tramp-unknown-id-integer) + (and (equal id-format 'string) tramp-unknown-id-string)))) + +(defun tramp-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (with-tramp-connection-property vec (format "gid-%s" id-format) + (or (when-let + ((handler + (find-file-name-handler + (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid))) + (funcall handler #'tramp-get-remote-gid vec id-format)) + ;; Ensure there is a valid result. + (and (equal id-format 'integer) tramp-unknown-id-integer) + (and (equal id-format 'string) tramp-unknown-id-string)))) + (defun tramp-local-host-p (vec) "Return t if this points to the local host, nil otherwise. This handles also chrooted environments, which are not regarded as local." @@ -4673,9 +4700,7 @@ This handles also chrooted environments, which are not regarded as local." vec (tramp-compat-temporary-file-directory) 'nohop)) ;; On some systems, chown runs only for root. (or (zerop (user-uid)) - ;; This is defined in tramp-sh.el. Let's assume this is - ;; loaded already. - (zerop (tramp-compat-funcall 'tramp-get-remote-uid vec 'integer)))))) + (zerop (tramp-get-remote-uid vec 'integer)))))) (defun tramp-get-remote-tmpdir (vec) "Return directory for temporary files on the remote host identified by VEC." diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 9667b34c667..cb30a360225 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2998,6 +2998,8 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) + ;; Wildcards are not supported in tramp-crypt.el. + (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 26.1. (skip-unless (fboundp 'insert-directory-wildcard-in-dir-p)) From 62cf8f1649468fc2f6c4f8926ab5c4bb184bfbe8 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sun, 14 Jun 2020 18:18:13 +0200 Subject: [PATCH 15/72] Ensure that getters and setters can be edebugged at the same time. It's necessary to add a name suffix to setters defined with 'gv-define-setter' so that Edebug can distinguish between the getter and the setter (Bug#41853). * lisp/emacs-lisp/gv.el (gv-define-setter): Add a name suffix to setter definitions. * test/lisp/emacs-lisp/gv-tests.el (gv-setter-edebug): New regression test. --- lisp/emacs-lisp/gv.el | 2 +- test/lisp/emacs-lisp/gv-tests.el | 19 +++++++++++++++++++ 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 096036a0ffa..513bd328899 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -224,7 +224,7 @@ The first arg in ARGLIST (the one that receives VAL) receives an expression which can do arbitrary things, whereas the other arguments are all guaranteed to be pure and copyable. Example use: (gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))" - (declare (indent 2) (debug (&define name sexp def-body))) + (declare (indent 2) (debug (&define name :name gv-setter sexp def-body))) `(gv-define-expander ,name (lambda (do &rest args) (declare-function diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el index 7fa4cd50b08..7a8402be074 100644 --- a/test/lisp/emacs-lisp/gv-tests.el +++ b/test/lisp/emacs-lisp/gv-tests.el @@ -19,6 +19,7 @@ ;;; Code: +(require 'edebug) (require 'ert) (eval-when-compile (require 'cl-lib)) @@ -137,6 +138,24 @@ (should (equal (buffer-string) "Symbol's function definition is void: \\(setf\\ gv-test-foo\\)\n"))))) +(ert-deftest gv-setter-edebug () + "Check that a setter can be defined and edebugged together with +its getter (Bug#41853)." + (with-temp-buffer + (let ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop)) + (dolist (form '((defun gv-setter-edebug-help (b) b) + (defun gv-setter-edebug-get (a b) + (get a (gv-setter-edebug-help b))) + (gv-define-setter gv-setter-edebug-get (x a b) + `(setf (get ,a (gv-setter-edebug-help ,b)) ,x)) + (push 123 (gv-setter-edebug-get 'gv-setter-edebug + 'gv-setter-edebug-prop)))) + (print form (current-buffer))) + ;; Only check whether evaluation works in general. + (eval-buffer))) + (should (equal (get 'gv-setter-edebug 'gv-setter-edebug-prop) '(123)))) + ;; `ert-deftest' messes up macroexpansion when the test file itself is ;; compiled (see Bug #24402). From e96f78fca672c74b7bf1120b7683a50295418725 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Wed, 10 Jun 2020 19:01:03 +0200 Subject: [PATCH 16/72] Band-aid for edebugging generator bodies (Bug#40434). Edebug doesn't support them well. Rather than trying to fix Edebug, disable instrumentation for now to prevent annoying bugs. * lisp/emacs-lisp/generator.el (iter-defun, iter-lambda, iter-make) (iter-do): Don't attempt to instrument bodies that are mangled by the CPS transformer. * test/lisp/emacs-lisp/generator-tests.el (generator-tests-edebug): New regression test. --- lisp/emacs-lisp/generator.el | 8 ++++---- test/lisp/emacs-lisp/generator-tests.el | 9 +++++++++ 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index ba344eb5150..c95c758a571 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -673,7 +673,7 @@ When called as a function, NAME returns an iterator value that encapsulates the state of a computation that produces a sequence of values. Callers can retrieve each value using `iter-next'." (declare (indent defun) - (debug (&define name lambda-list lambda-doc def-body)) + (debug (&define name lambda-list lambda-doc &rest sexp)) (doc-string 3)) (cl-assert lexical-binding) (let* ((parsed-body (macroexp-parse-body body)) @@ -687,14 +687,14 @@ of values. Callers can retrieve each value using `iter-next'." "Return a lambda generator. `iter-lambda' is to `iter-defun' as `lambda' is to `defun'." (declare (indent defun) - (debug (&define lambda-list lambda-doc def-body))) + (debug (&define lambda-list lambda-doc &rest sexp))) (cl-assert lexical-binding) `(lambda ,arglist ,(cps-generate-evaluator body))) (defmacro iter-make (&rest body) "Return a new iterator." - (declare (debug t)) + (declare (debug (&rest sexp))) (cps-generate-evaluator body)) (defconst iter-empty (lambda (_op _val) (signal 'iter-end-of-sequence nil)) @@ -720,7 +720,7 @@ is blocked." Evaluate BODY with VAR bound to each value from ITERATOR. Return the value with which ITERATOR finished iteration." (declare (indent 1) - (debug ((symbolp form) body))) + (debug ((symbolp form) &rest sexp))) (let ((done-symbol (cps--gensym "iter-do-iterator-done")) (condition-symbol (cps--gensym "iter-do-condition")) (it-symbol (cps--gensym "iter-do-iterator")) diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index bcfab201636..9b1a573ea6a 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -304,4 +304,13 @@ identical output." (1+ it))))))) -2))) +(ert-deftest generator-tests-edebug () + "Check that Bug#40434 is fixed." + (with-temp-buffer + (prin1 '(iter-defun generator-tests-edebug () + (iter-yield 123)) + (current-buffer)) + (edebug-defun)) + (should (eql (iter-next (generator-tests-edebug)) 123))) + ;;; generator-tests.el ends here From 4f92cf14f395577572d451c0488ade952bc3cbaa Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Sun, 14 Jun 2020 18:24:14 +0200 Subject: [PATCH 17/72] Add new VC command `repository-url' * lisp/vc/vc.el: Document repository-url command. * lisp/vc/vc-bzr.el (vc-bzr-repository-url): New defun. * lisp/vc/vc-git.el (vc-git-repository-url): New defun. * lisp/vc/vc-hg.el (vc-hg-repository-url): New defun. * lisp/vc/vc-svn.el (vc-svn-repository-url): New defun. --- lisp/vc/vc-bzr.el | 9 +++++++++ lisp/vc/vc-git.el | 7 +++++++ lisp/vc/vc-hg.el | 7 +++++++ lisp/vc/vc-svn.el | 9 ++++++++- lisp/vc/vc.el | 4 ++++ 5 files changed, 35 insertions(+), 1 deletion(-) diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el index e5d307e7ede..21c7e7cfab1 100644 --- a/lisp/vc/vc-bzr.el +++ b/lisp/vc/vc-bzr.el @@ -1316,6 +1316,15 @@ stream. Standard error output is discarded." vc-bzr-revision-keywords)) string pred))))) +(defun vc-bzr-repository-url (file-or-dir) + (let ((default-directory (vc-bzr-root file-or-dir))) + (with-temp-buffer + (vc-bzr-command "info" (current-buffer) 0 nil) + (goto-char (point-min)) + (if (re-search-forward "parent branch: \\(.*\\)$" nil t) + (match-string 1) + (error "Cannot determine Bzr repository URL"))))) + (provide 'vc-bzr) ;;; vc-bzr.el ends here diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index dcb52282656..261e4c7aa47 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -101,6 +101,7 @@ ;; - rename-file (old new) OK ;; - find-file-hook () OK ;; - conflicted-files OK +;; - repository-url (file-or-dir) OK ;;; Code: @@ -1082,6 +1083,12 @@ This prompts for a branch to merge from." "DU" "AA" "UU")) (push (expand-file-name file directory) files))))))) +(defun vc-git-repository-url (file-or-dir) + (let ((default-directory (vc-git-root file-or-dir))) + (with-temp-buffer + (vc-git-command (current-buffer) 0 nil "remote" "get-url" "origin") + (buffer-substring-no-properties (point-min) (1- (point-max)))))) + ;; Everywhere but here, follows vc-git-command, which uses vc-do-command ;; from vc-dispatcher. (autoload 'vc-resynch-buffer "vc-dispatcher") diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 40d75738063..25ca4ed55fd 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -1525,6 +1525,13 @@ This function differs from vc-do-command in that it invokes (defun vc-hg-root (file) (vc-find-root file ".hg")) +(defun vc-hg-repository-url (file-or-dir) + (let ((default-directory (vc-hg-root file-or-dir))) + (with-temp-buffer + (vc-hg-command (current-buffer) 0 nil + "config" "paths.default") + (buffer-substring-no-properties (point-min) (1- (point-max)))))) + (provide 'vc-hg) ;;; vc-hg.el ends here diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el index d039bf3c6a3..6ab07c1476d 100644 --- a/lisp/vc/vc-svn.el +++ b/lisp/vc/vc-svn.el @@ -816,7 +816,14 @@ Set file properties accordingly. If FILENAME is non-nil, return its status." (push (match-string 1 loglines) vc-svn-revisions) (setq start (+ start (match-end 0))) (setq loglines (buffer-substring-no-properties start (point-max))))) - vc-svn-revisions))) + vc-svn-revisions))) + +(defun vc-svn-repository-url (file-or-dir) + (let ((default-directory (vc-svn-root file-or-dir))) + (with-temp-buffer + (vc-svn-command (current-buffer) 0 nil + "info" "--show-item" "repos-root-url") + (buffer-substring-no-properties (point-min) (1- (point-max)))))) (provide 'vc-svn) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index c640ba0420e..5c335ebfaa2 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -553,6 +553,10 @@ ;; Return the list of files where conflict resolution is needed in ;; the project that contains DIR. ;; FIXME: what should it do with non-text conflicts? +;; +;; - repository-url (file) +;; +;; Returns the URL of the repository of the current checkout. ;;; Changes from the pre-25.1 API: ;; From 2e80328ba683e6205cd65bd3fb69da2563183e66 Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Mon, 15 Jun 2020 08:56:11 +0200 Subject: [PATCH 18/72] Add optional remote-name argument to VC repository-url command * lisp/vc/vc.el: Document new remote-name argument of VC repository-url command. * lisp/vc/vc-git.el (vc-git-repository-url): Add and use new arg. * lisp/vc/vc-hg.el (vc-hg-repository-url): Add and use new arg. * lisp/vc/vc-bzr.el (vc-bzr-repository-url): Add new arg but ignore it. * lisp/vc/vc-svn.el (vc-svn-repository-url): Add new arg but ignore it. --- lisp/vc/vc-bzr.el | 2 +- lisp/vc/vc-git.el | 5 +++-- lisp/vc/vc-hg.el | 5 +++-- lisp/vc/vc-svn.el | 2 +- lisp/vc/vc.el | 7 +++++-- 5 files changed, 13 insertions(+), 8 deletions(-) diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el index 21c7e7cfab1..f98730ed221 100644 --- a/lisp/vc/vc-bzr.el +++ b/lisp/vc/vc-bzr.el @@ -1316,7 +1316,7 @@ stream. Standard error output is discarded." vc-bzr-revision-keywords)) string pred))))) -(defun vc-bzr-repository-url (file-or-dir) +(defun vc-bzr-repository-url (file-or-dir &optional _remote-name) (let ((default-directory (vc-bzr-root file-or-dir))) (with-temp-buffer (vc-bzr-command "info" (current-buffer) 0 nil) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 261e4c7aa47..636f9dfd0ca 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1083,10 +1083,11 @@ This prompts for a branch to merge from." "DU" "AA" "UU")) (push (expand-file-name file directory) files))))))) -(defun vc-git-repository-url (file-or-dir) +(defun vc-git-repository-url (file-or-dir &optional remote-name) (let ((default-directory (vc-git-root file-or-dir))) (with-temp-buffer - (vc-git-command (current-buffer) 0 nil "remote" "get-url" "origin") + (vc-git-command (current-buffer) 0 nil "remote" "get-url" + (or remote-name "origin")) (buffer-substring-no-properties (point-min) (1- (point-max)))))) ;; Everywhere but here, follows vc-git-command, which uses vc-do-command diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 25ca4ed55fd..95ced7b8d09 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -1525,11 +1525,12 @@ This function differs from vc-do-command in that it invokes (defun vc-hg-root (file) (vc-find-root file ".hg")) -(defun vc-hg-repository-url (file-or-dir) +(defun vc-hg-repository-url (file-or-dir &optional remote-name) (let ((default-directory (vc-hg-root file-or-dir))) (with-temp-buffer (vc-hg-command (current-buffer) 0 nil - "config" "paths.default") + "config" + (concat "paths." (or remote-name "default"))) (buffer-substring-no-properties (point-min) (1- (point-max)))))) (provide 'vc-hg) diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el index 6ab07c1476d..e108b3a340f 100644 --- a/lisp/vc/vc-svn.el +++ b/lisp/vc/vc-svn.el @@ -818,7 +818,7 @@ Set file properties accordingly. If FILENAME is non-nil, return its status." (setq loglines (buffer-substring-no-properties start (point-max))))) vc-svn-revisions))) -(defun vc-svn-repository-url (file-or-dir) +(defun vc-svn-repository-url (file-or-dir &optional _remote-name) (let ((default-directory (vc-svn-root file-or-dir))) (with-temp-buffer (vc-svn-command (current-buffer) 0 nil diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 5c335ebfaa2..ce947d21f95 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -554,9 +554,12 @@ ;; the project that contains DIR. ;; FIXME: what should it do with non-text conflicts? ;; -;; - repository-url (file) +;; - repository-url (file-or-dir &optional remote-name) ;; -;; Returns the URL of the repository of the current checkout. +;; Returns the URL of the repository of the current checkout +;; containing FILE-OR-DIR. The optional REMOTE-NAME specifies the +;; remote (in Git parlance) whose URL is to be returned. It has +;; only a meaning for distributed VCS and is ignored otherwise. ;;; Changes from the pre-25.1 API: ;; From 1507d61ebc5b572f6c9173ce9d76de379d919a94 Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Mon, 15 Jun 2020 09:07:12 +0200 Subject: [PATCH 19/72] Use vc-git-repository-url in vc-git-dir-extra-headers * lisp/vc/vc-git.el (vc-git-dir-extra-headers): Use vc-git-repository-url for getting the remote's URL. --- lisp/vc/vc-git.el | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 636f9dfd0ca..96ee59db8e6 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -748,13 +748,7 @@ or an empty string if none." (when (string-match "\\([^\n]+\\)" remote) (setq remote (match-string 1 remote))) (when remote - (setq remote-url - (with-output-to-string - (with-current-buffer standard-output - (vc-git--out-ok "config" - (concat "remote." remote ".url")))))) - (when (string-match "\\([^\n]+\\)" remote-url) - (setq remote-url (match-string 1 remote-url)))) + (setq remote-url (vc-git-repository-url dir remote)))) (setq branch "not (detached HEAD)")) (when stash-list (let* ((len (length stash-list)) @@ -821,10 +815,10 @@ or an empty string if none." (when (file-exists-p (expand-file-name ".git/rebase-apply" (vc-git-root dir))) (propertize "\nRebase : in progress" 'face 'font-lock-warning-face)) (if stash-list - (concat - (propertize "\nStash : " 'face 'font-lock-type-face) - stash-button - stash-string) + (concat + (propertize "\nStash : " 'face 'font-lock-type-face) + stash-button + stash-string) (concat (propertize "\nStash : " 'face 'font-lock-type-face) (propertize "Nothing stashed" From 4503dcf635aae4d40024267d373332bab588009f Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Mon, 15 Jun 2020 16:24:22 +0200 Subject: [PATCH 20/72] Fix some Tramp problems seen during tests * lisp/net/tramp-crypt.el (tramp-crypt-file-name-handler-alist): Add `access-file'. (tramp-crypt-file-name-for-operation): Rewrite. Take second argument into account. (tramp-crypt-file-name-handler): Use it. (tramp-crypt-send-command): Set buffer multibyte (but utf8 files still don't work). (tramp-crypt-handle-access-file): New defun. (tramp-crypt-do-copy-or-rename-file): Short track if both files are on a crypted remote dir. * lisp/net/tramp.el (file-notify-rm-watch): Declare. (tramp-inhibit-progress-reporter): New defvar. (tramp-message): Display message only if not suppressed by progress reporter. (with-tramp-progress-reporter): Suppress concurrent progress reporter messages. (tramp-file-notify-process-sentinel): Simplify. --- lisp/net/tramp-crypt.el | 42 +++++++++++++++++++++++++++++++++++------ lisp/net/tramp.el | 19 +++++++++++++++---- 2 files changed, 51 insertions(+), 10 deletions(-) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 4f01f1bf6c4..2eb3b9f8b7d 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -145,7 +145,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-crypt-file-name-handler-alist - '(;; (access-file . tramp-crypt-handle-access-file) + '((access-file . tramp-crypt-handle-access-file) ;; (add-name-to-file . tramp-crypt-handle-not-implemented) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) @@ -225,9 +225,14 @@ Operations not mentioned here will be handled by the default Emacs primitives.") (defsubst tramp-crypt-file-name-for-operation (operation &rest args) "Like `tramp-file-name-for-operation', but for crypted remote files." - (cl-letf (((symbol-function #'tramp-tramp-file-p) - #'tramp-crypt-file-name-p)) - (apply #'tramp-file-name-for-operation operation args))) + (let ((tfnfo (apply #'tramp-file-name-for-operation operation args))) + ;; `tramp-file-name-for-operation' returns already the first argument + ;; if it is remote. So we check a possible second argument. + (unless (tramp-crypt-file-name-p tfnfo) + (setq tfnfo (apply + #'tramp-file-name-for-operation + operation (cons temporary-file-directory (cdr args))))) + tfnfo)) (defun tramp-crypt-run-real-handler (operation args) "Invoke normal file name handler for OPERATION. @@ -246,7 +251,8 @@ arguments to pass to the OPERATION." "Invoke the crypted remote file related OPERATION. First arg specifies the OPERATION, second arg ARGS is a list of arguments to pass to the OPERATION." - (if-let ((filename (apply #'tramp-file-name-for-operation operation args)) + (if-let ((filename + (apply #'tramp-crypt-file-name-for-operation operation args)) (fn (and (tramp-crypt-file-name-p filename) (assoc operation tramp-crypt-file-name-handler-alist)))) (save-match-data (apply (cdr fn) args)) @@ -356,7 +362,8 @@ connection if a previous connection has died for some reason." ARGS are the arguments. It returns t if ran successful, and nil otherwise." (tramp-crypt-maybe-open-connection vec) (with-current-buffer (tramp-get-connection-buffer vec) - (erase-buffer)) + (erase-buffer) + (set-buffer-multibyte nil)) (with-temp-buffer (let* (;; Don't check for a proper method. (non-essential t) @@ -511,6 +518,21 @@ localname." ;; File name primitives. +(defun tramp-crypt-handle-access-file (filename string) + "Like `access-file' for Tramp files." + (let* ((encrypt-filename (tramp-crypt-encrypt-file-name filename)) + (encrypt-regexp (concat (regexp-quote encrypt-filename) "\\'")) + tramp-crypt-enabled) + (condition-case err + (access-file encrypt-filename string) + (error + (when (and (eq (car err) 'file-missing) (stringp (cadr err)) + (string-match-p encrypt-regexp (cadr err))) + (setcar + (cdr err) + (replace-regexp-in-string encrypt-regexp filename (cadr err)))) + (signal (car err) (cdr err)))))) + (defun tramp-crypt-do-copy-or-rename-file (op filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) @@ -576,6 +598,14 @@ absolute file names." (file-name-nondirectory encrypt-newname) tmpdir)) tramp-crypt-enabled) (cond + ;; Source and target file are on a crypted remote directory. + ((and t1 t2) + (if (eq op 'copy) + (copy-file + encrypt-filename encrypt-newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes) + (rename-file + encrypt-filename encrypt-newname ok-if-already-exists))) ;; Source file is on a crypted remote directory. (t1 (if (eq op 'copy) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index f3c065e9e7a..3a8a51fd4ad 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -64,6 +64,7 @@ ;; Pacify byte-compiler. (require 'cl-lib) +(declare-function file-notify-rm-watch "filenotify") (declare-function netrc-parse "netrc") (defvar auto-save-file-name-transforms) @@ -1780,6 +1781,10 @@ ARGUMENTS to actually emit the message (if applicable)." (put #'tramp-debug-message 'tramp-suppress-trace t) +(defvar tramp-inhibit-progress-reporter nil + "Show Tramp progress reporter in the minibuffer. +This variable is used to disable concurrent progress reporter messages.") + (defsubst tramp-message (vec-or-proc level fmt-string &rest arguments) "Emit a message depending on verbosity level. VEC-OR-PROC identifies the Tramp buffer to use. It can be either a @@ -1795,8 +1800,9 @@ control string and the remaining ARGUMENTS to actually emit the message (if applicable)." (ignore-errors (when (<= level tramp-verbose) - ;; Display only when there is a minimum level. - (when (<= level 3) + ;; Display only when there is a minimum level, and the progress + ;; reporter doesn't suppress further messages. + (when (and (<= level 3) (null tramp-inhibit-progress-reporter)) (apply #'message (concat (cond @@ -2014,7 +2020,12 @@ without a visible progress reporter." (run-at-time 3 0.1 #'tramp-progress-reporter-update pr)))) (unwind-protect ;; Execute the body. - (prog1 (progn ,@body) (setq cookie "done")) + (prog1 + ;; Suppress concurrent progress reporter messages. + (let ((tramp-inhibit-progress-reporter + (or tramp-inhibit-progress-reporter tm))) + ,@body) + (setq cookie "done")) ;; Stop progress reporter. (if tm (cancel-timer tm)) (tramp-message ,vec ,level "%s...%s" ,message cookie))))) @@ -3995,7 +4006,7 @@ of." "Call `file-notify-rm-watch'." (unless (process-live-p proc) (tramp-message proc 5 "Sentinel called: `%S' `%s'" proc event) - (tramp-compat-funcall 'file-notify-rm-watch proc))) + (file-notify-rm-watch proc))) ;;; Functions for establishing connection: From a71d1787f128c642f8a1fb297ef5043e20218646 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Tue, 16 Jun 2020 12:34:00 +0200 Subject: [PATCH 21/72] * doc/misc/tramp.texi (Predefined connection information): Add "tmpdir". --- doc/misc/tramp.texi | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 9f216d339f2..3ee01e1568a 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -2023,6 +2023,12 @@ reestablished. A value of @code{nil} disables this feature. Most of the methods do not set this property except the @option{sudo} and @option{doas} methods, which use predefined values. +@item @t{"tmpdir"} + +The temporary directory on the remote host. If not specified, the +default value is @t{"/data/local/tmp"} for the @option{adb} method, +@t{"/C$/Temp"} for the @option{smb} method, and @t{"/tmp"} otherwise. + @item @t{"posix"} Connections using the @option{smb} method check, whether the remote From a77ac015b3fecc4a63ae42712b693e3158fc5452 Mon Sep 17 00:00:00 2001 From: David Edmondson Date: Sat, 28 Mar 2020 19:03:58 +0000 Subject: [PATCH 22/72] gnus-cloud: Improve cloud sync After replaying a set of actions downloaded by gnus-cloud, persist the highest sequence number seen as the local `gnus-cloud-sequence' number, in order that a future download will not unnecessarily replay previously seen actions and any future uploads from this emacs instance use a higher sequence number than that downloaded. Remove the test on whether individual newsrc entries are older than the current time, as that is always going to be the case. --- lisp/gnus/gnus-cloud.el | 52 ++++++++++++++++++++--------------------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index da6231d7330..7ea691e7220 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -223,13 +223,10 @@ easy interactive way to set this from the Server buffer." (t (gnus-message 1 "Unknown type %s; ignoring" type)))))) -(defun gnus-cloud-update-newsrc-data (group elem &optional force-older) - "Update the newsrc data for GROUP from ELEM. -Use old data if FORCE-OLDER is not nil." +(defun gnus-cloud-update-newsrc-data (group elem) + "Update the newsrc data for GROUP from ELEM." (let* ((contents (plist-get elem :contents)) (date (or (plist-get elem :timestamp) "0")) - (now (gnus-cloud-timestamp nil)) - (newer (string-lessp date now)) (group-info (gnus-get-info group))) (if (and contents (stringp (nth 0 contents)) @@ -238,15 +235,13 @@ Use old data if FORCE-OLDER is not nil." (if (equal (format "%S" group-info) (format "%S" contents)) (gnus-message 3 "Skipping cloud update of group %s, the info is the same" group) - (if (and newer (not force-older)) - (gnus-message 3 "Skipping outdated cloud info for group %s, the info is from %s (now is %s)" group date now) - (when (or (not gnus-cloud-interactive) - (gnus-y-or-n-p - (format "%s has older different info in the cloud as of %s, update it here? " - group date))) - (gnus-message 2 "Installing cloud update of group %s" group) - (gnus-set-info group contents) - (gnus-group-update-group group)))) + (when (or (not gnus-cloud-interactive) + (gnus-y-or-n-p + (format "%s has different info in the cloud from %s, update it here? " + group date))) + (gnus-message 2 "Installing cloud update of group %s" group) + (gnus-set-info group contents) + (gnus-group-update-group group))) (gnus-error 1 "Sorry, group %s is not subscribed" group)) (gnus-error 1 "Sorry, could not update newsrc for group %s (invalid data %S)" group elem)))) @@ -380,8 +375,9 @@ When FULL is t, upload everything, not just a difference from the last full." (gnus-cloud-files-to-upload full) (gnus-cloud-collect-full-newsrc))) (group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))) + (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0))) (insert (format "Subject: (sequence: %s type: %s storage-method: %s)\n" - (or gnus-cloud-sequence "UNKNOWN") + gnus-cloud-sequence (if full :full :partial) gnus-cloud-storage-method)) (insert "From: nobody@gnus.cloud.invalid\n") @@ -390,7 +386,6 @@ When FULL is t, upload everything, not just a difference from the last full." (if (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method t t) (progn - (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0))) (gnus-cloud-add-timestamps elems) (gnus-message 3 "Uploaded Gnus Cloud data successfully to %s" group) (gnus-group-refresh-group group)) @@ -459,18 +454,21 @@ instead of `gnus-cloud-sequence'. When UPDATE is t, returns the result of calling `gnus-cloud-update-all'. Otherwise, returns the Gnus Cloud data chunks." (let ((articles nil) + (highest-sequence-seen gnus-cloud-sequence) chunks) (dolist (header (gnus-cloud-available-chunks)) - (when (> (gnus-cloud-chunk-sequence (mail-header-subject header)) - (or sequence-override gnus-cloud-sequence -1)) + (let ((this-sequence (gnus-cloud-chunk-sequence (mail-header-subject header)))) + (when (> this-sequence (or sequence-override gnus-cloud-sequence -1)) - (if (string-match (format "storage-method: %s" gnus-cloud-storage-method) - (mail-header-subject header)) - (push (mail-header-number header) articles) - (gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s" - (mail-header-number header) - gnus-cloud-storage-method - (mail-header-subject header))))) + (if (string-match (format "storage-method: %s" gnus-cloud-storage-method) + (mail-header-subject header)) + (progn + (push (mail-header-number header) articles) + (setq highest-sequence-seen (max highest-sequence-seen this-sequence))) + (gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s" + (mail-header-number header) + gnus-cloud-storage-method + (mail-header-subject header)))))) (when articles (nnimap-request-articles (nreverse articles) gnus-cloud-group-name) (with-current-buffer nntp-server-buffer @@ -480,7 +478,9 @@ Otherwise, returns the Gnus Cloud data chunks." (push (gnus-cloud-parse-chunk) chunks) (forward-line 1)))) (if update - (mapcar #'gnus-cloud-update-all chunks) + (progn + (mapcar #'gnus-cloud-update-all chunks) + (setq gnus-cloud-sequence highest-sequence-seen)) chunks))) (defun gnus-cloud-server-p (server) From 6e777a66397659de5e0e15067b440fd7013a2796 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Wed, 17 Jun 2020 00:50:31 +0300 Subject: [PATCH 23/72] Make project file name completion adhere to customization * lisp/progmodes/project.el (project-find-file-in): Bind completion-ignore-case to the value of read-file-name-completion-ignore-case (bug#41902). --- lisp/progmodes/project.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index f3df44fa7ba..22e57b4fe6f 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -644,6 +644,7 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in (defun project-find-file-in (filename dirs project) "Complete FILENAME in DIRS in PROJECT and visit the result." (let* ((all-files (project-files project dirs)) + (completion-ignore-case read-file-name-completion-ignore-case) (file (funcall project-read-file-name-function "Find file" all-files nil nil filename))) From 1d2c0a25274263acc06533b5b3c0e3cf01b303ea Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Wed, 17 Jun 2020 01:24:01 +0300 Subject: [PATCH 24/72] Change the key for project-find-regexp * lisp/progmodes/project.el (project-switch-commands): Change the key for 'project-find-regexp' to 'g', which seems to be the consensus. --- lisp/progmodes/project.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 22e57b4fe6f..ebb833776ea 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -821,7 +821,7 @@ It's also possible to enter an arbitrary directory." ;;;###autoload (defvar project-switch-commands '((?f "Find file" project-find-file) - (?r "Find regexp" project-find-regexp) + (?g "Find regexp" project-find-regexp) (?d "Dired" project-dired) (?v "VC-Dir" project-vc-dir) (?s "Shell" project-shell) From 3bff583337153371ac41a92713377ffe8e3dd376 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Wed, 17 Jun 2020 01:27:37 +0300 Subject: [PATCH 25/72] Bump the project.el package version * lisp/progmodes/project.el: Bump the package version. --- lisp/progmodes/project.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index ebb833776ea..0921922f5d8 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1,7 +1,7 @@ ;;; project.el --- Operations on the current project -*- lexical-binding: t; -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. -;; Version: 0.3.0 +;; Version: 0.4.0 ;; Package-Requires: ((emacs "26.3")) ;; This is a GNU ELPA :core package. Avoid using functionality that @@ -824,7 +824,6 @@ It's also possible to enter an arbitrary directory." (?g "Find regexp" project-find-regexp) (?d "Dired" project-dired) (?v "VC-Dir" project-vc-dir) - (?s "Shell" project-shell) (?e "Eshell" project-eshell)) "Alist mapping keys to project switching menu entries. Used by `project-switch-project' to construct a dispatch menu of From 1dff0a89497fec15297a97fcd643ea8475f704da Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Wed, 17 Jun 2020 01:58:32 +0300 Subject: [PATCH 26/72] * lisp/image-mode.el (image-toggle-display-image): Fix fit of rotated images. When fitting rotated image to width and height, swap width and height when changing orientation between portrait and landscape (bug#41886). --- lisp/image-mode.el | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/lisp/image-mode.el b/lisp/image-mode.el index b82c0669187..1bb213c2489 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -810,8 +810,12 @@ was inserted." filename)) ;; If we have a `fit-width' or a `fit-height', don't limit ;; the size of the image to the window size. - (edges (and (eq image-transform-resize t) - (window-inside-pixel-edges (get-buffer-window)))) + (edges (when (eq image-transform-resize t) + (window-inside-pixel-edges (get-buffer-window)))) + (max-width (when edges + (- (nth 2 edges) (nth 0 edges)))) + (max-height (when edges + (- (nth 3 edges) (nth 1 edges)))) (type (if (image--imagemagick-wanted-p filename) 'imagemagick (image-type file-or-data nil data-p))) @@ -827,14 +831,18 @@ was inserted." (ignore-error exif-error (exif-parse-buffer))) 0.0))) + ;; Swap width and height when changing orientation + ;; between portrait and landscape. + (when (and edges (zerop (mod (+ image-transform-rotation 90) 180))) + (setq max-width (prog1 max-height (setq max-height max-width)))) ;; :scale 1: If we do not set this, create-image will apply ;; default scaling based on font size. (setq image (if (not edges) (create-image file-or-data type data-p :scale 1) (create-image file-or-data type data-p :scale 1 - :max-width (- (nth 2 edges) (nth 0 edges)) - :max-height (- (nth 3 edges) (nth 1 edges))))) + :max-width max-width + :max-height max-height))) ;; Discard any stale image data before looking it up again. (image-flush image) From cd4f75bb86e160158786b0d5a07319a49c3ad7b8 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Wed, 17 Jun 2020 02:14:12 +0300 Subject: [PATCH 27/72] Rename default function to next-error-buffer-unnavigated-current (bug#40919) * lisp/simple.el (next-error-find-buffer-function): Rename default function from next-error-no-navigation-try-current to next-error-buffer-unnavigated-current. --- lisp/simple.el | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/lisp/simple.el b/lisp/simple.el index 1555b376a36..e4958de113e 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -199,7 +199,7 @@ rejected, and the function returns nil." (and extra-test-inclusive (funcall extra-test-inclusive)))))) -(defcustom next-error-find-buffer-function #'next-error-no-navigation-try-current +(defcustom next-error-find-buffer-function #'next-error-buffer-unnavigated-current "Function called to find a `next-error' capable buffer. This functions takes the same three arguments as the function `next-error-find-buffer', and should return the buffer to be @@ -212,7 +212,7 @@ all other buffers." (const :tag "Single next-error capable buffer on selected frame" next-error-buffer-on-selected-frame) (const :tag "Current buffer if next-error capable and outside navigation" - next-error-no-navigation-try-current) + next-error-buffer-unnavigated-current) (function :tag "Other function")) :group 'next-error :version "27.1") @@ -242,10 +242,9 @@ from which next-error navigated, and a target buffer TO-BUFFER." (if (eq (length window-buffers) 1) (car window-buffers)))) -(defun next-error-no-navigation-try-current (&optional - avoid-current - extra-test-inclusive - extra-test-exclusive) +(defun next-error-buffer-unnavigated-current (&optional avoid-current + extra-test-inclusive + extra-test-exclusive) "Try the current buffer when outside navigation. But return nil if we navigated to the current buffer by the means of `next-error' command. Othewise, return it if it's next-error From 9682aa2f2493c89af1894ad2d52543d57f4958a5 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Wed, 17 Jun 2020 02:18:11 +0300 Subject: [PATCH 28/72] * lisp/dired-aux.el (dired-vc-deduce-fileset): Add autoload cookie. --- lisp/dired-aux.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 24ebfa4b0de..0d481f4ac19 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -3087,6 +3087,7 @@ in the Dired buffer." (declare-function vc-compatible-state "vc") +;;;###autoload (defun dired-vc-deduce-fileset (&optional state-model-only-files not-state-changing) (let ((backend (vc-responsible-backend default-directory)) (files (dired-get-marked-files nil nil nil nil t)) From 01e86b9fdf9858ca6b491a247dffcb2fcada5728 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Wed, 17 Jun 2020 01:10:20 +0100 Subject: [PATCH 29/72] Fix recentf typo in Emacs manual * doc/emacs/files.texi (File Conveniences): Fix misspelling of recentf-list. --- doc/emacs/files.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi index 56ce7fdea19..b95203b1f44 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -2098,8 +2098,8 @@ recently-opened files, reading file names from a buffer. If you enable Recentf mode, with @kbd{M-x recentf-mode}, the @samp{File} menu includes a submenu containing a list of recently opened files. @kbd{M-x recentf-save-list} saves the current -@code{recent-file-list} to a file, and @kbd{M-x recentf-edit-list} -edits it. +@code{recentf-list} to a file, and @kbd{M-x recentf-edit-list} edits +it. @c FIXME partial-completion-mode (complete.el) is obsolete. The @kbd{M-x ffap} command generalizes @code{find-file} with more From 229995ba2cd9f6d0a749a38c106cbfbfd04119a8 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Wed, 17 Jun 2020 12:53:40 +0100 Subject: [PATCH 30/72] Fix some Texinfo markup * doc/misc/gnus-faq.texi (FAQ 3-11): * doc/emacs/frames.texi (Tab Bars): Consistently use @var with lower-case metasyntactic variables and @minus instead of a dash. (Text-Only Mouse): * doc/emacs/files.texi (Auto Revert): * doc/emacs/misc.texi (emacsclient Options) (Embedded WebKit Widgets): * doc/lispref/control.texi (pcase Macro): * doc/lispref/debugging.texi (Backtraces): * doc/lispref/files.texi (Truenames): * doc/lispref/frames.texi (Management Parameters): * doc/lispref/os.texi (Time Calculations): * doc/lispref/text.texi (Parsing JSON): * doc/misc/efaq-w32.texi (Other versions of Emacs, Debugging) (Swap Caps NT, Printing, Bash, Developing with Emacs): * doc/misc/efaq.texi (New in Emacs 25): * doc/misc/emacs-gnutls.texi (Help For Users): * doc/misc/message.texi (Using S/MIME, Passphrase caching): * test/manual/etags/tex-src/gzip.texi (Overview): Use @. when a sentence in the middle of a paragraph ends with an upper-case letter as per "(texinfo) Ending a Sentence". --- doc/emacs/files.texi | 2 +- doc/emacs/frames.texi | 21 +++++++++++---------- doc/emacs/misc.texi | 6 +++--- doc/lispref/control.texi | 2 +- doc/lispref/debugging.texi | 2 +- doc/lispref/files.texi | 2 +- doc/lispref/frames.texi | 2 +- doc/lispref/os.texi | 2 +- doc/lispref/text.texi | 2 +- doc/misc/efaq-w32.texi | 14 +++++++------- doc/misc/efaq.texi | 2 +- doc/misc/emacs-gnutls.texi | 2 +- doc/misc/gnus-faq.texi | 5 +++-- doc/misc/message.texi | 4 ++-- test/manual/etags/tex-src/gzip.texi | 2 +- 15 files changed, 36 insertions(+), 34 deletions(-) diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi index b95203b1f44..5998326ffef 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -1003,7 +1003,7 @@ variable @code{auto-revert-remote-files} to non-@code{nil}. @vindex auto-revert-use-notify @vindex auto-revert-interval By default, Auto Revert mode works using @dfn{file notifications}, -whereby changes in the filesystem are reported to Emacs by the OS. +whereby changes in the filesystem are reported to Emacs by the OS@. You can disable use of file notifications by customizing the variable @code{auto-revert-use-notify} to a @code{nil} value, then Emacs will check for file changes by polling every five seconds. You can change diff --git a/doc/emacs/frames.texi b/doc/emacs/frames.texi index 8f448e1aedc..e0eabe38d06 100644 --- a/doc/emacs/frames.texi +++ b/doc/emacs/frames.texi @@ -1362,15 +1362,16 @@ a recently used tab. @findex tab-next Switch to the next tab. If you repeat this command, it cycles through all the tabs on the selected frame. With a positive numeric argument -N, it switches to the next Nth tab; with a negative argument −N, it -switches back to the previous Nth tab. +@var{n}, it switches to the next @var{n}th tab; with a negative +argument @minus{}@var{n}, it switches back to the previous @var{n}th +tab. @item S-C-@key{TAB} @kindex S-C-TAB @findex tab-previous -Switch to the previous tab. With a positive numeric argument N, it -switches to the previous Nth tab; with a negative argument −N, it -switches back to the next Nth tab. +Switch to the previous tab. With a positive numeric argument @var{n}, +it switches to the previous @var{n}th tab; with a negative argument +@minus{}@var{n}, it switches back to the next @var{n}th tab. @item C-x t @key{RET} @var{tabname} @key{RET} Switch to the tab by its name, with completion on all tab names. @@ -1392,7 +1393,7 @@ to select the tab by its number. @findex tab-recent Switch to the recent tab. The key combination is the modifier key defined by @code{tab-bar-select-tab-modifiers} and the key @kbd{0}. -With a numeric argument N, switch to the Nth recent tab. +With a numeric argument @var{n}, switch to the @var{n}th recent tab. @end table The following commands can be used to operate on tabs: @@ -1406,9 +1407,9 @@ variable @code{tab-bar-tab-name-function}. @item C-x t m @findex tab-move -Move the current tab N positions to the right with a positive numeric -argument N. With a negative argument −N, move the current tab -N positions to the left. +Move the current tab @var{n} positions to the right with a positive +numeric argument @var{n}. With a negative argument @minus{}@var{n}, +move the current tab @var{n} positions to the left. @end table @findex tab-bar-history-mode @@ -1621,7 +1622,7 @@ again. enable mouse support. You must have the gpm server installed and running on your system in order for this to work. Note that when this mode is enabled, you cannot use the mouse to transfer text -between Emacs and other programs which use GPM. This is due to +between Emacs and other programs which use GPM@. This is due to limitations in GPM and the Linux kernel. @iftex diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index 47f195d0b20..2f02c702512 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -1968,12 +1968,12 @@ evaluate, @emph{not} as a list of files to visit. @item -f @var{server-file} @itemx --server-file=@var{server-file} Specify a server file (@pxref{TCP Emacs server}) for connecting to an -Emacs server via TCP. Alternatively, you can set the +Emacs server via TCP@. Alternatively, you can set the @env{EMACS_SERVER_FILE} environment variable to point to the server file. (The command-line option overrides the environment variable.) An Emacs server usually uses a local socket to listen for connections, -but also supports connections over TCP. To connect to a TCP Emacs +but also supports connections over TCP@. To connect to a TCP Emacs server, @command{emacsclient} needs to read a @dfn{server file} containing the connection details of the Emacs server. The name of this file is specified with this option, either as a file name @@ -2882,7 +2882,7 @@ widget. The URL normally defaults to the URL at or before point, but if there is an active region (@pxref{Mark}), the default URL comes from the region instead, after removing any whitespace from it. The command then creates a new buffer with the embedded browser showing -the specified URL. The buffer is put in the Xwidget-WebKit mode +the specified URL@. The buffer is put in the Xwidget-WebKit mode (similar to Image mode, @pxref{Image Mode}), which provides one-key commands for scrolling the widget, changing its size, and reloading it. Type @w{@kbd{C-h b}} in that buffer to see the key diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 58f93366fe9..01ae94ea7dd 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -835,7 +835,7 @@ the second and subsequent occurrences do not expand to re-binding, but instead expand to an equality test using @code{eq}. The following example features a @code{pcase} form -with two clauses and two @var{seqpat}, A and B. +with two clauses and two @var{seqpat}, A and B@. Both A and B first check that @var{expval} is a pair (using @code{pred}), and then bind symbols to the @code{car} and @code{cdr} diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi index 24ec656028f..29a0ab71ea4 100644 --- a/doc/lispref/debugging.texi +++ b/doc/lispref/debugging.texi @@ -402,7 +402,7 @@ assumptions are false if the debugger is running interpreted. @cindex backtrace buffer Debugger mode is derived from Backtrace mode, which is also used to -show backtraces by Edebug and ERT. (@pxref{Edebug}, and @ref{Top,the +show backtraces by Edebug and ERT@. (@pxref{Edebug}, and @ref{Top,the ERT manual,, ert, ERT: Emacs Lisp Regression Testing}.) @cindex stack frame diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index bdda59f415d..6ca2834fbd4 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -1190,7 +1190,7 @@ inconclusive, the function returns @code{t} on Cygwin and @code{nil} on macOS. Currently this function always returns @code{nil} on platforms other -than MS-DOS, MS-Windows, Cygwin, and macOS. It does not detect +than MS-DOS, MS-Windows, Cygwin, and macOS@. It does not detect case-insensitivity of mounted filesystems, such as Samba shares or NFS-mounted Windows volumes. On remote hosts, it assumes @code{t} for the @samp{smb} method. For all other connection methods, runtime diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index 26546ab0964..7b37472f133 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -2173,7 +2173,7 @@ it on an undecorated frame. @item override-redirect @cindex override redirect frames If non-@code{nil}, this means that this is an @dfn{override redirect} -frame---a frame not handled by window managers under X. Override +frame---a frame not handled by window managers under X@. Override redirect frames have no window manager decorations, can be positioned and resized only via Emacs' positioning and resizing functions and are usually drawn on top of all other frames. Setting this parameter has diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index d600916d985..1c3be1c7ef6 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -1988,7 +1988,7 @@ The result is @code{nil} if either argument is a NaN. This returns the time difference @var{t1} @minus{} @var{t2} between two time values, as a Lisp time value. The result is exact and its clock resolution is no worse than the worse of its two arguments' resolutions. -The result is floating-point only if it is infinite or a NaN. +The result is floating-point only if it is infinite or a NaN@. If you need the difference in units of elapsed seconds, you can convert it with @code{time-convert} or @code{float-time}. @xref{Time Conversion}. diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 0bbb0aa8dc0..5d83e7bd6cc 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -5216,7 +5216,7 @@ Signaled when encountering invalid JSON syntax. @end table Only top-level values (arrays and objects) can be serialized to -JSON. The subobjects within these top-level values can be of any +JSON@. The subobjects within these top-level values can be of any type. Likewise, the parsing functions will only return vectors, hashtables, alists, and plists. diff --git a/doc/misc/efaq-w32.texi b/doc/misc/efaq-w32.texi index 83dd176f984..bbfc86b111e 100644 --- a/doc/misc/efaq-w32.texi +++ b/doc/misc/efaq-w32.texi @@ -143,7 +143,7 @@ executable, using the MinGW GCC compiler and development tools. @cindex DOS port @cindex Windows 3.11 port -Emacs can also be compiled for MSDOS. When run on recent MS Windows, +Emacs can also be compiled for MSDOS@. When run on recent MS Windows, it supports long file names, and uses the Windows clipboard. See the @file{msdos} directory in the Emacs sources for building instructions (requires DJGPP). @@ -222,7 +222,7 @@ specific notes about debugging Emacs. @cindex debugging Emacs with GDB GDB is the GNU debugger, which can be used to debug Emacs when it has -been compiled with MinGW GCC. The best results will be obtained if +been compiled with MinGW GCC@. The best results will be obtained if you start gdb from the @file{src} directory as @kbd{gdb ./emacs.exe}. This will load the init file @file{.gdbinit}@footnote{ Latest versions of GDB might refuse to load the init file for security @@ -592,7 +592,7 @@ Subject: Re: Re[2]: problem with caps/ctrl swap on NT 4.0 @end ignore @smallexample It's a binary value that lets you map keystrokes in the low-level keyboard -drivers in NT. As a result you don't have to worry about applications +drivers in NT@. As a result you don't have to worry about applications bypassing mappings that you've done at a higher level (i.e., it just works). Here's the format of the value: @@ -1187,7 +1187,7 @@ A lot of effort has gone into making it easier to print from Emacs on MS Windows, but this has still been insufficient to keep up with changes in printing technology from text and postscript based printers connected via ports that can be accessed directly, to graphical -printers that are only accessible via USB. For details, see +printers that are only accessible via USB@. For details, see @uref{http://www.emacswiki.org/emacs/PrintingFromEmacs, Emacs Wiki}, @uref{http://www.emacswiki.org/emacs/PrintWithWebBrowser}, and @uref{http://www.emacswiki.org/emacs/PrintFromWindowsExplorer}. @@ -1398,7 +1398,7 @@ default shell in Emacs, you can place the following in your init file: @end example WARNING: Some versions of bash set and use the environment variable -PID. For some as yet unknown reason, if @env{PID} is set and Emacs +PID@. For some as yet unknown reason, if @env{PID} is set and Emacs passes it on to bash subshells, bash dies (Emacs can inherit the @env{PID} variable if it's started from a bash shell). If you clear the @env{PID} variable in your init file, you should be able to @@ -1890,9 +1890,9 @@ need to use. @node MSVC @section How do I use Emacs with Microsoft Visual C++ -There are two ways you can use Emacs in conjunction with MSVC. You +There are two ways you can use Emacs in conjunction with MSVC@. You can use Emacs as the editor, and do everything else in the DevStudio -IDE. Or you can use Emacs as an IDE, calling the MSVC command line +IDE@. Or you can use Emacs as an IDE, calling the MSVC command line tools to build your project. @menu diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index 132e8ffaa93..b2ed60b8d80 100644 --- a/doc/misc/efaq.texi +++ b/doc/misc/efaq.texi @@ -1125,7 +1125,7 @@ scanning of @code{#define}d symbols. @cindex xref @item -New package Xref replaces Etags's front-end and UI. Xref provides a +New package Xref replaces Etags's front-end and UI@. Xref provides a generic framework and new commands to find and move to definitions of functions, macros, data structures etc., as well as go back to the location where you were before moving to a definition. It supersedes diff --git a/doc/misc/emacs-gnutls.texi b/doc/misc/emacs-gnutls.texi index 555a4b1b56e..7c57cc032c7 100644 --- a/doc/misc/emacs-gnutls.texi +++ b/doc/misc/emacs-gnutls.texi @@ -134,7 +134,7 @@ order: @file{/etc/ssl/certs/ca-certificates.crt} for Debian, Ubuntu, Gentoo and Arch Linux; @file{/etc/pki/tls/certs/ca-bundle.crt} for Fedora and RHEL; @file{/etc/ssl/ca-bundle.pem} for Suse; @file{/usr/ssl/certs/ca-bundle.crt} for Cygwin; -@file{/usr/local/share/certs/ca-root-nss.crt} for FreeBSD. You can +@file{/usr/local/share/certs/ca-root-nss.crt} for FreeBSD@. You can easily customize @code{gnutls-trustfiles} to be something else, but let us know if you do, so we can make the change to benefit the other users of that platform. diff --git a/doc/misc/gnus-faq.texi b/doc/misc/gnus-faq.texi index fd285396c40..9c1d2d0160a 100644 --- a/doc/misc/gnus-faq.texi +++ b/doc/misc/gnus-faq.texi @@ -689,8 +689,9 @@ retrieves via POP3? @subsubheading Answer Yes, if the POP3 server supports the UIDL control (maybe almost servers -do it nowadays). To do that, add a @code{:leave VALUE} pair to each -POP3 mail source. @xref{Mail Source Specifiers}, for details on VALUE. +do it nowadays). To do that, add a @code{:leave @var{value}} pair to +each POP3 mail source. @xref{Mail Source Specifiers}, for details on +@var{value}. @node FAQ 4 - Reading messages @subsection Reading messages diff --git a/doc/misc/message.texi b/doc/misc/message.texi index f9527ee7864..bdd31b1fe49 100644 --- a/doc/misc/message.texi +++ b/doc/misc/message.texi @@ -1116,7 +1116,7 @@ is used. The choice between EasyPG and OpenSSL is controlled by the variable @code{mml-smime-use}, which needs to be set to the value @code{epg} -for EasyPG. Depending on your version of Emacs that value may be the +for EasyPG@. Depending on your version of Emacs that value may be the default; if not, you can either customize that variable or place the following line in your @file{.emacs} file (that line needs to be placed above other code related to message/gnus/encryption): @@ -1232,7 +1232,7 @@ decryption/sign operation. @xref{Agent Options, , , gnupg, Using the GNU Privacy Guard}. How to use @command{gpg-agent} in Emacs depends on your version of -GnuPG. With GnuPG version 2.1, @command{gpg-agent} is started +GnuPG@. With GnuPG version 2.1, @command{gpg-agent} is started automatically if necessary. With older versions you may need to run the following command from the shell before starting Emacs. diff --git a/test/manual/etags/tex-src/gzip.texi b/test/manual/etags/tex-src/gzip.texi index ea5f7f5879e..72c5c7e93b6 100644 --- a/test/manual/etags/tex-src/gzip.texi +++ b/test/manual/etags/tex-src/gzip.texi @@ -148,7 +148,7 @@ input and writes the uncompressed data on standard output. @code{zcat} will uncompress files that have the correct magic number whether they have a @samp{.gz} suffix or not. -@code{gzip} uses the Lempel-Ziv algorithm used in @code{zip} and PKZIP. +@code{gzip} uses the Lempel-Ziv algorithm used in @code{zip} and PKZIP@. The amount of compression obtained depends on the size of the input and the distribution of common substrings. Typically, text such as source code or English is reduced by 60-70%. Compression is generally much From 5502eedf90d0da27df0c6c1fa33389d849d59a80 Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Thu, 11 Jun 2020 17:02:02 +0200 Subject: [PATCH 31/72] Auto-setup for bug-reference-mode Tries to guess suitable bug-reference-bug-regexp and bug-reference-url-format values based on version control URL (in file buffers) and mail information (in Gnus summary and article buffers). * lisp/progmodes/bug-reference.el (bug-reference--maybe-setup-from-vc): New defun. (bug-reference-setup-from-vc-alist): New defvar defining setup rules based on version control URL. (bug-reference-try-setup-from-vc): New defun using above defvar. (bug-reference--maybe-setup-from-mail): New defun. (bug-reference-setup-from-mail-alist): New defvar defining setup rules based on mail/newsgroups and header values. (bug-reference-try-setup-from-gnus): New defun using above defvar. (bug-reference--try-setup-gnus-article): New defun. (bug-reference--run-auto-setup): New defun. (bug-reference-mode): Call bug-reference--run-auto-setup as :after-hook. (bug-reference-prog-mode): Call bug-reference--run-auto-setup as :after-hook. --- lisp/progmodes/bug-reference.el | 218 ++++++++++++++++++++++++++++++++ lisp/vc/vc.el | 10 +- 2 files changed, 225 insertions(+), 3 deletions(-) diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 02af263ec34..50bd3661eff 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -139,12 +139,229 @@ The second subexpression should match the bug reference (usually a number)." (when url (browse-url url)))))) +(defun bug-reference--maybe-setup-from-vc (url url-rx bug-rx bug-url-fmt) + (when (string-match url-rx url) + (setq-local bug-reference-bug-regexp bug-rx) + (setq-local bug-reference-url-format + (let (groups) + (dotimes (i (/ (length (match-data)) 2)) + (push (match-string i url) groups)) + (funcall bug-url-fmt (nreverse groups)))))) + +(defvar bug-reference-setup-from-vc-alist + `(;; + ;; GNU projects on savannah. + ;; + ;; Not all of them use debbugs but that doesn't really matter + ;; because the auto-setup is only performed if + ;; `bug-reference-url-format' and `bug-reference-bug-regexp' + ;; aren't set already. + ("git\\.\\(?:sv\\|savannah\\)\\.gnu\\.org:" + "\\<\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)\\>" + ,(lambda (_) "https://debbugs.gnu.org/%s")) + ;; + ;; GitHub projects. + ;; + ;; Here #17 may refer to either an issue or a pull request but + ;; visiting the issue/17 web page will automatically redirect to + ;; the pull/17 page if 17 is a PR. Explicit user/project#17 links + ;; to possibly different projects are also supported. + ("[/@]github.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git" + "\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>" + ,(lambda (groups) + (let ((ns-project (nth 1 groups))) + (lambda () + (concat "https://github.com/" + (or + ;; Explicit user/proj#18 link. + (match-string 1) + ns-project) + "/issues/" + (match-string 2)))))) + ;; + ;; GitLab projects. + ;; + ;; Here #18 is an issue and !17 is a merge request. Explicit + ;; namespace/project#18 or namespace/project!17 references to + ;; possibly different projects are also supported. + ("[/@]gitlab.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git" + "\\(?1:[.A-Za-z0-9_/-]+\\)?\\(?3:[#!]\\)\\(?2:[0-9]+\\)\\>" + ,(lambda (groups) + (let ((ns-project (nth 1 groups))) + (lambda () + (concat "https://gitlab.com/" + (or (match-string 1) + ns-project) + "/-/" + (if (string= (match-string 3) "#") + "issues/" + "merge_requests/") + (match-string 2))))))) + "An alist for setting up `bug-reference-mode' based on VC URL. + +Each element has the form (URL-REGEXP BUG-REGEXP URL-FORMAT-FN). + +URL-REGEXP is matched against the version control URL of the +current buffer's file. If it matches, BUG-REGEXP is set as +`bug-reference-bug-regexp'. URL-FORMAT-FN is a function of one +argument that receives a list of the groups 0 to N of matching +URL-REGEXP against the VCS URL and returns the value to be set as +`bug-reference-url-format'.") + +(defun bug-reference-try-setup-from-vc () + "Try setting up `bug-reference-mode' based on VC information. +Test each configuration in `bug-reference-setup-from-vc-alist' +and apply it if applicable." + (when buffer-file-name + (let* ((backend (vc-responsible-backend buffer-file-name t)) + (url + (or (ignore-errors + (vc-call-backend backend 'repository-url "upstream")) + (ignore-errors + (vc-call-backend backend 'repository-url))))) + (when url + (catch 'found + (dolist (config bug-reference-setup-from-vc-alist) + (when (apply #'bug-reference--maybe-setup-from-vc + url config) + (throw 'found t)))))))) + +(defvar bug-reference-setup-from-mail-alist + `((,(regexp-opt '("emacs" "auctex" "gnus") 'words) + ,(regexp-opt '("@debbugs.gnu.org" "-devel@gnu.org" + ;; List-Id of Gnus devel mailing list. + "ding.gnus.org")) + "\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)" + "https://debbugs.gnu.org/%s")) + "An alist for setting up `bug-reference-mode' in mail modes. + +This takes action if `bug-reference-mode' is enabled in group and +message buffers of Emacs mail clients. Currently, only Gnus is +supported. + +Each element has the form + + (GROUP-REGEXP HEADER-REGEXP BUG-REGEXP URL-FORMAT) + +GROUP-REGEXP is a regexp matched against the current mail folder +or newsgroup name. HEADER-REGEXP is a regexp matched against the +From, To, Cc, Newsgroup, and List-ID header values of the current +mail or newsgroup message. If any of those matches, BUG-REGEXP +is set as `bug-reference-bug-regexp' and URL-FORMAT is set as +`bug-reference-url-format'. + +Note: In Gnus, if a summary buffer has been set up based on +GROUP-REGEXP, all article buffers opened from there will get the +same `bug-reference-url-format' and `bug-reference-url-format'.") + +(defvar gnus-newsgroup-name) + +(defun bug-reference--maybe-setup-from-mail (group header-values) + "Set up according to mail GROUP or HEADER-VALUES. +Group is a mail group/folder name and HEADER-VALUES is a list of +mail header values, e.g., the values of From, To, Cc, List-ID, +and Newsgroup. + +If any GROUP-REGEXP or HEADER-REGEXP of +`bug-reference-setup-from-mail-alist' matches GROUP or any +element in HEADER-VALUES, the corresponding BUG-REGEXP and +URL-FORMAT are set." + (catch 'setup-done + (dolist (config bug-reference-setup-from-mail-alist) + (when (or + (and group + (car config) + (string-match-p (car config) group)) + (and header-values + (nth 1 config) + (catch 'matching-header + (dolist (h header-values) + (when (and h (string-match-p (nth 1 config) h)) + (throw 'matching-header t)))))) + (setq-local bug-reference-bug-regexp (nth 2 config)) + (setq-local bug-reference-url-format (nth 3 config)) + (throw 'setup-done t))))) + +(defun bug-reference-try-setup-from-gnus () + "Try setting up `bug-reference-mode' based on Gnus group or article. +Test each configuration in `bug-reference-setup-from-mail-alist' +and set it if applicable." + (when (and (derived-mode-p 'gnus-summary-mode) + (bound-and-true-p gnus-newsgroup-name)) + ;; Gnus reuses its article buffer so we have to check whenever the + ;; article changes. + (add-hook 'gnus-article-prepare-hook + #'bug-reference--try-setup-gnus-article) + (bug-reference--maybe-setup-from-mail gnus-newsgroup-name nil))) + +(defvar gnus-article-buffer) +(defvar gnus-original-article-buffer) +(defvar gnus-summary-buffer) + +(defun bug-reference--try-setup-gnus-article () + (with-demoted-errors + "Error in bug-reference--try-setup-gnus-article: %S" + (when (and bug-reference-mode ;; Only if enabled in article buffers. + (derived-mode-p + 'gnus-article-mode + ;; Apparently, gnus-article-prepare-hook is run in the + ;; summary buffer... + 'gnus-summary-mode) + gnus-article-buffer + gnus-original-article-buffer + (buffer-live-p (get-buffer gnus-article-buffer)) + (buffer-live-p (get-buffer gnus-original-article-buffer))) + (with-current-buffer gnus-article-buffer + (catch 'setup-done + ;; Copy over the values from the summary buffer. + (when (and gnus-summary-buffer + (buffer-live-p gnus-summary-buffer)) + (setq-local bug-reference-bug-regexp + (with-current-buffer gnus-summary-buffer + bug-reference-bug-regexp)) + (setq-local bug-reference-url-format + (with-current-buffer gnus-summary-buffer + bug-reference-url-format)) + (when (and bug-reference-bug-regexp + bug-reference-url-format) + (throw 'setup-done t))) + ;; If the summary had no values, try setting according to + ;; the values of the From, To, and Cc headers. + (let (header-values) + (with-current-buffer + (get-buffer gnus-original-article-buffer) + (save-excursion + (goto-char (point-min)) + ;; The Newsgroup is omitted because we already matched + ;; based on group name in the summary buffer. + (dolist (field '("list-id" "to" "from" "cc")) + (let ((val (mail-fetch-field field))) + (when val + (push val header-values)))))) + (bug-reference--maybe-setup-from-mail nil header-values))))))) + +(defun bug-reference--run-auto-setup () + (when (or bug-reference-mode + bug-reference-prog-mode) + ;; Automatic setup only if the variables aren't already set, e.g., + ;; by a local variables section in the file. + (unless (and bug-reference-bug-regexp + bug-reference-url-format) + (with-demoted-errors + "Error during bug-reference auto-setup: %S" + (catch 'setup + (dolist (f (list #'bug-reference-try-setup-from-vc + #'bug-reference-try-setup-from-gnus)) + (when (funcall f) + (throw 'setup t)))))))) + ;;;###autoload (define-minor-mode bug-reference-mode "Toggle hyperlinking bug references in the buffer (Bug Reference mode)." nil "" nil + :after-hook (bug-reference--run-auto-setup) (if bug-reference-mode (jit-lock-register #'bug-reference-fontify) (jit-lock-unregister #'bug-reference-fontify) @@ -158,6 +375,7 @@ The second subexpression should match the bug reference (usually a number)." nil "" nil + :after-hook (bug-reference--run-auto-setup) (if bug-reference-prog-mode (jit-lock-register #'bug-reference-fontify) (jit-lock-unregister #'bug-reference-fontify) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index ce947d21f95..9b12d449785 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -964,7 +964,7 @@ use." (throw 'found bk)))) ;;;###autoload -(defun vc-responsible-backend (file) +(defun vc-responsible-backend (file &optional no-error) "Return the name of a backend system that is responsible for FILE. If FILE is already registered, return the @@ -974,7 +974,10 @@ responsible for FILE is returned. Note that if FILE is a symbolic link, it will not be resolved -- the responsible backend system for the symbolic link itself will -be reported." +be reported. + +If NO-ERROR is nil, signal an error that no VC backend is +responsible for the given file." (or (and (not (file-directory-p file)) (vc-backend file)) (catch 'found ;; First try: find a responsible backend. If this is for registration, @@ -982,7 +985,8 @@ be reported." (dolist (backend vc-handled-backends) (and (vc-call-backend backend 'responsible-p file) (throw 'found backend)))) - (error "No VC backend is responsible for %s" file))) + (unless no-error + (error "No VC backend is responsible for %s" file)))) (defun vc-expand-dirs (file-or-dir-list backend) "Expands directories in a file list specification. From e2f443df17710c74fa6a2e51dd061f7e898d48e6 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Thu, 18 Jun 2020 01:09:29 +0300 Subject: [PATCH 32/72] vc-git-dir-extra-headers: Fix recent breakage * lisp/vc/vc-git.el (vc-git-dir-extra-headers): Account for 'remote' being set to "" when not found (https://lists.gnu.org/archive/html/emacs-devel/2020-06/msg00582.html). (vc-git-dir-extra-headers): Check the value of remote-url instead. --- lisp/vc/vc-git.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 96ee59db8e6..1cd2a7bb133 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -747,7 +747,7 @@ or an empty string if none." (concat "branch." branch ".remote"))))) (when (string-match "\\([^\n]+\\)" remote) (setq remote (match-string 1 remote))) - (when remote + (when (> (length remote) 0) (setq remote-url (vc-git-repository-url dir remote)))) (setq branch "not (detached HEAD)")) (when stash-list @@ -803,7 +803,7 @@ or an empty string if none." (propertize "Branch : " 'face 'font-lock-type-face) (propertize branch 'face 'font-lock-variable-name-face) - (when remote + (when remote-url (concat "\n" (propertize "Remote : " 'face 'font-lock-type-face) From 2cc48d3d10a7a0e3ced644c75972e2af2364e68b Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Thu, 18 Jun 2020 01:30:32 +0300 Subject: [PATCH 33/72] Fix setting project-vc-merge-submodules via .dir-locals.el * lisp/progmodes/project.el (project--vc-merge-submodules-p): New function. (project-try-vc, project--vc-list-files): Use it. --- lisp/progmodes/project.el | 34 ++++++++++++++++++++-------------- 1 file changed, 20 insertions(+), 14 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 0921922f5d8..1c1891fcf55 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -306,7 +306,7 @@ backend implementation of `project-external-roots'.") (if (and ;; FIXME: Invalidate the cache when the value ;; of this variable changes. - project-vc-merge-submodules + (project--vc-merge-submodules-p root) (project--submodule-p root)) (let* ((parent (file-name-directory (directory-file-name root)))) @@ -396,19 +396,20 @@ backend implementation of `project-external-roots'.") (split-string (apply #'vc-git--run-command-string nil "ls-files" args) "\0" t))) - ;; Unfortunately, 'ls-files --recurse-submodules' conflicts with '-o'. - (let* ((submodules (project--git-submodules)) - (sub-files - (mapcar - (lambda (module) - (when (file-directory-p module) - (project--vc-list-files - (concat default-directory module) - backend - extra-ignores))) - submodules))) - (setq files - (apply #'nconc files sub-files))) + (when (project--vc-merge-submodules-p default-directory) + ;; Unfortunately, 'ls-files --recurse-submodules' conflicts with '-o'. + (let* ((submodules (project--git-submodules)) + (sub-files + (mapcar + (lambda (module) + (when (file-directory-p module) + (project--vc-list-files + (concat default-directory module) + backend + extra-ignores))) + submodules))) + (setq files + (apply #'nconc files sub-files)))) ;; 'git ls-files' returns duplicate entries for merge conflicts. ;; XXX: Better solutions welcome, but this seems cheap enough. (delete-consecutive-dups files))) @@ -429,6 +430,11 @@ backend implementation of `project-external-roots'.") (lambda (s) (concat default-directory s)) (split-string (buffer-string) "\0" t))))))) +(defun project--vc-merge-submodules-p (dir) + (project--value-in-dir + 'project-vc-merge-submodules + dir)) + (defun project--git-submodules () ;; 'git submodule foreach' is much slower. (condition-case nil From 2f231fcfb763626b8a4ede7da0f80da14a122ca9 Mon Sep 17 00:00:00 2001 From: Theodor Thornhill Date: Thu, 18 Jun 2020 02:05:31 +0300 Subject: [PATCH 34/72] Add global bindings for project commands * lisp/progmodes/project.el (project-prefix-map): New variable. Add the new keymap to ctl-x-map. --- lisp/progmodes/project.el | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 1c1891fcf55..14aafdf2899 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -490,6 +490,23 @@ DIRS must contain directory names." ;; Sidestep the issue of expanded/abbreviated file names here. (cl-set-difference files dirs :test #'file-in-directory-p)) +;;;###autoload +(defvar project-prefix-map + (let ((map (make-sparse-keymap))) + (define-key map "f" 'project-find-file) + (define-key map "s" 'project-shell) + (define-key map "d" 'project-dired) + (define-key map "v" 'project-vc-dir) + (define-key map "c" 'project-compile) + (define-key map "e" 'project-eshell) + (define-key map "p" 'project-switch-project) + (define-key map "g" 'project-find-regexp) + (define-key map "r" 'project-query-replace-regexp) + map) + "Keymap for project commands.") + +;;;###autoload (define-key ctl-x-map "p" project-prefix-map) + (defun project--value-in-dir (var dir) (with-temp-buffer (setq default-directory dir) From eb3b03c1c686e20c55eeaa21652b318251e16458 Mon Sep 17 00:00:00 2001 From: Theodor Thornhill Date: Thu, 18 Jun 2020 02:09:41 +0300 Subject: [PATCH 35/72] New command: project-switch-to-buffer * lisp/progmodes/project.el (project-switch-to-buffer): New command. --- lisp/progmodes/project.el | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 14aafdf2899..d8f56acedf3 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -768,6 +768,19 @@ Arguments the same as in `compile'." (default-directory (project-root pr))) (compile command comint))) +;;;###autoload +(defun project-switch-to-buffer () + "Switch to a buffer in the current project." + (interactive) + (let ((root (project-root (project-current t)))) + (switch-to-buffer + (read-buffer + "Switch to buffer: " nil t + (lambda (buffer) + ;; BUFFER is an entry (BUF-NAME . BUF-OBJ) of Vbuffer_alist. + (when-let ((file (buffer-file-name (cdr buffer)))) + (file-in-directory-p file root))))))) + ;;; Project list From 4b9b9cb43a84c1d4c018b9fe1153685e57ffcaa4 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Thu, 18 Jun 2020 02:10:33 +0300 Subject: [PATCH 36/72] ; Add a heading and a binding --- lisp/progmodes/project.el | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index d8f56acedf3..e772570b9e1 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -490,10 +490,14 @@ DIRS must contain directory names." ;; Sidestep the issue of expanded/abbreviated file names here. (cl-set-difference files dirs :test #'file-in-directory-p)) + +;;; Project commands + ;;;###autoload (defvar project-prefix-map (let ((map (make-sparse-keymap))) (define-key map "f" 'project-find-file) + (define-key map "b" 'project-switch-to-buffer) (define-key map "s" 'project-shell) (define-key map "d" 'project-dired) (define-key map "v" 'project-vc-dir) From 7c177ecb8407633e624cd7e12a0c0d12b8990c32 Mon Sep 17 00:00:00 2001 From: Philip K Date: Thu, 18 Jun 2020 04:00:38 +0300 Subject: [PATCH 37/72] New command: project-kill-buffers * lisp/progmodes/project.el (project-kill-buffers-skip-conditions): New variable. (project--buffer-list): New function. (project-kill-buffers): New command (bug#41868). --- lisp/progmodes/project.el | 41 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index e772570b9e1..e24d81c1b43 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -785,6 +785,47 @@ Arguments the same as in `compile'." (when-let ((file (buffer-file-name (cdr buffer)))) (file-in-directory-p file root))))))) +(defcustom project-kill-buffers-skip-conditions + '("\\*Help\\*") + "Conditions for buffers `project-kill-buffers' should not kill. +Each condition is either a regular expression matching a buffer +name, or a predicate function that takes a buffer object as +argument and returns non-nil if it matches. Buffers that match +any of the conditions will not be killed." + :type '(repeat (choice regexp function)) + :version "28.1") + +(defun project--buffer-list (pr) + "Return the list of all buffers in project PR." + (let ((root (project-root pr)) + bufs) + (dolist (buf (buffer-list)) + (let ((filename (or (buffer-file-name buf) + (buffer-local-value 'default-directory buf)))) + (when (and filename (file-in-directory-p filename root)) + (push buf bufs)))) + (nreverse bufs))) + +;;;###autoload +(defun project-kill-buffers () + "Kill all live buffers belonging to the current project. +Certain buffers may be ignored, depending on the value of +`project-kill-buffers-skip-conditions'." + (interactive) + (let ((pr (project-current t)) bufs) + (dolist (buf (project--buffer-list pr)) + (unless (seq-some + (lambda (c) + (cond ((stringp c) + (string-match-p c (buffer-name buf))) + ((functionp c) + (funcall c buf)))) + project-kill-buffers-skip-conditions) + (push buf bufs))) + (when (yes-or-no-p (format "Kill %d buffers in %s? " + (length bufs) (project-root pr))) + (mapc #'kill-buffer bufs)))) + ;;; Project list From a4f1d681c10e39429d4ba6d9ca42b009a7b003fb Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Thu, 18 Jun 2020 07:53:45 +0200 Subject: [PATCH 38/72] Bind default-directory to given DIR. Otherwise, "git config branch..remote" would return the global default "origin" instead of the actual, project-specific remote name. * lisp/vc/vc-git.el (vc-git-dir-extra-headers): Bind default-directory to given DIR. --- lisp/vc/vc-git.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 1cd2a7bb133..b5cb842aeee 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -735,6 +735,7 @@ or an empty string if none." (with-current-buffer standard-output (vc-git--out-ok "symbolic-ref" "HEAD")))) (stash-list (vc-git-stash-list)) + (default-directory dir) branch remote remote-url stash-button stash-string) (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str) From dcdf6d712416f76a5c29801e97c7f8d923d1a031 Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Thu, 18 Jun 2020 10:39:01 +0200 Subject: [PATCH 39/72] Make bug-reference auto-setup work in vc-dir or Magit like modes * lisp/progmodes/bug-reference.el (bug-reference-try-setup-from-vc): Use default-directory if not in a file-visiting buffer to determine VC URL. --- lisp/progmodes/bug-reference.el | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 50bd3661eff..e142c693503 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -212,8 +212,11 @@ URL-REGEXP against the VCS URL and returns the value to be set as "Try setting up `bug-reference-mode' based on VC information. Test each configuration in `bug-reference-setup-from-vc-alist' and apply it if applicable." - (when buffer-file-name - (let* ((backend (vc-responsible-backend buffer-file-name t)) + (let ((file-or-dir (or buffer-file-name + ;; Catches modes such as vc-dir and Magit. + default-directory)))) + (when file-or-dir + (let* ((backend (vc-responsible-backend file-or-dir t)) (url (or (ignore-errors (vc-call-backend backend 'repository-url "upstream")) From 7d7bd1b2d3b1a943dbe5253490de2b6a94ffcb37 Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Thu, 18 Jun 2020 12:44:42 +0200 Subject: [PATCH 40/72] ;Fix error in commit dcdf6d7124 --- lisp/progmodes/bug-reference.el | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index e142c693503..9df51c1242a 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -214,20 +214,20 @@ Test each configuration in `bug-reference-setup-from-vc-alist' and apply it if applicable." (let ((file-or-dir (or buffer-file-name ;; Catches modes such as vc-dir and Magit. - default-directory)))) - (when file-or-dir - (let* ((backend (vc-responsible-backend file-or-dir t)) - (url - (or (ignore-errors - (vc-call-backend backend 'repository-url "upstream")) - (ignore-errors - (vc-call-backend backend 'repository-url))))) - (when url - (catch 'found - (dolist (config bug-reference-setup-from-vc-alist) - (when (apply #'bug-reference--maybe-setup-from-vc - url config) - (throw 'found t)))))))) + default-directory))) + (when file-or-dir + (let* ((backend (vc-responsible-backend file-or-dir t)) + (url + (or (ignore-errors + (vc-call-backend backend 'repository-url "upstream")) + (ignore-errors + (vc-call-backend backend 'repository-url))))) + (when url + (catch 'found + (dolist (config bug-reference-setup-from-vc-alist) + (when (apply #'bug-reference--maybe-setup-from-vc + url config) + (throw 'found t))))))))) (defvar bug-reference-setup-from-mail-alist `((,(regexp-opt '("emacs" "auctex" "gnus") 'words) From 97d1f672ac1529ac07a999405f630cb19a1010eb Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 6 Jun 2020 13:20:06 +0100 Subject: [PATCH 41/72] Various dbus.el cleanups (bug#41744) * etc/NEWS: Announce removal of aliases obsolete since Emacs 24.3. * lisp/net/dbus.el: Remove unneeded dependency on cl-lib.el. Quote function symbols as such. (dbus-ignore-errors): Don't add macro name to font-lock keywords, as emacs-lisp-mode now dynamically fontifies new macro definitions. (dbus-event-error-hooks, dbus-call-method-non-blocking): Remove aliases obsolete since Emacs 24.3. (dbus-register-signal, dbus-escape-as-identifier): Simplify. Use regexp \` and \' in place of ^ and $. (dbus--parse-xml-buffer): New function for libxml2 compatibility. (dbus-introspect-xml): Use it. (dbus-string-to-byte-array, dbus-byte-array-to-string) (dbus-unescape-from-identifier, dbus-list-known-names) (dbus-introspect-get-all-nodes, dbus-get-all-properties) (dbus-get-all-managed-objects): Simplify. (dbus--introspect-names, dbus--introspect-name): New convenience functions. (dbus-introspect-get-node-names) (dbus-introspect-get-interface-names) (dbus-introspect-get-interface, dbus-introspect-get-method-names) (dbus-introspect-get-method, dbus-introspect-get-signal-names) (dbus-introspect-get-signal, dbus-introspect-get-property-names) (dbus-introspect-get-property) (dbus-introspect-get-annotation-names) (dbus-introspect-get-annotation) (dbus-introspect-get-argument-names, dbus-introspect-get-argument): Use them to DRY. * test/lisp/net/dbus-tests.el (dbus-test-all): Quote function symbols as such. --- etc/NEWS | 10 ++ lisp/net/dbus.el | 271 ++++++++++++++---------------------- test/lisp/net/dbus-tests.el | 4 +- 3 files changed, 119 insertions(+), 166 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index b0c523672e8..d702f758f23 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -451,6 +451,16 @@ https://www.w3.org/TR/xml/#charsets). Now it rejects such strings. ** The metamail.el library is now marked obsolete. +** D-Bus + +--- +*** Some obsolete variable and function aliases have been removed. +In Emacs 24.3, the variable 'dbus-event-error-hooks' was renamed to +'dbus-event-error-functions' and the function +'dbus-call-method-non-blocking' was renamed to 'dbus-call-method'. +The old names, which were kept as obsolete aliases of the new names, +have now been removed. + * New Modes and Packages in Emacs 28.1 diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 06bd9e567fe..fdd726ff613 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -51,9 +51,6 @@ (unless (boundp 'dbus-debug) (defvar dbus-debug nil)) -;; Pacify byte compiler. -(eval-when-compile (require 'cl-lib)) - (require 'xml) (defconst dbus-service-dbus "org.freedesktop.DBus" @@ -169,10 +166,7 @@ Otherwise, return result of last form in BODY, or all other errors." `(condition-case err (progn ,@body) (dbus-error (when dbus-debug (signal (car err) (cdr err)))))) -(font-lock-add-keywords 'emacs-lisp-mode '("\\")) -(define-obsolete-variable-alias 'dbus-event-error-hooks - 'dbus-event-error-functions "24.3") (defvar dbus-event-error-functions '(dbus-notice-synchronous-call-errors) "Functions to be called when a D-Bus error happens in the event handler. Every function must accept two arguments, the event and the error variable @@ -181,7 +175,7 @@ caught in `condition-case' by `dbus-error'.") ;;; Basic D-Bus message functions. -(defvar dbus-return-values-table (make-hash-table :test 'equal) +(defvar dbus-return-values-table (make-hash-table :test #'equal) "Hash table for temporarily storing arguments of reply messages. A key in this hash table is a list (:serial BUS SERIAL), like in `dbus-registered-objects-table'. BUS is either a Lisp symbol, @@ -301,8 +295,8 @@ object is returned instead of a list containing this single Lisp object. (check-interval 0.001) (key (apply - 'dbus-message-internal dbus-message-type-method-call - bus service path interface method 'dbus-call-method-handler args)) + #'dbus-message-internal dbus-message-type-method-call + bus service path interface method #'dbus-call-method-handler args)) (result (cons :pending nil))) ;; Wait until `dbus-call-method-handler' has put the result into @@ -338,10 +332,6 @@ object is returned instead of a list containing this single Lisp object. (cdr result)) (remhash key dbus-return-values-table)))) -;; `dbus-call-method' works non-blocking now. -(defalias 'dbus-call-method-non-blocking 'dbus-call-method) -(make-obsolete 'dbus-call-method-non-blocking 'dbus-call-method "24.3") - (defun dbus-call-method-asynchronously (bus service path interface method handler &rest args) "Call METHOD on the D-Bus BUS asynchronously. @@ -406,7 +396,7 @@ Example: (or (null handler) (functionp handler) (signal 'wrong-type-argument (list 'functionp handler))) - (apply 'dbus-message-internal dbus-message-type-method-call + (apply #'dbus-message-internal dbus-message-type-method-call bus service path interface method handler args)) (defun dbus-send-signal (bus service path interface signal &rest args) @@ -454,7 +444,7 @@ Example: (or (stringp signal) (signal 'wrong-type-argument (list 'stringp signal))) - (apply 'dbus-message-internal dbus-message-type-signal + (apply #'dbus-message-internal dbus-message-type-signal bus service path interface signal args)) (defun dbus-method-return-internal (bus service serial &rest args) @@ -470,7 +460,7 @@ This is an internal function, it shall not be used outside dbus.el." (or (natnump serial) (signal 'wrong-type-argument (list 'natnump serial))) - (apply 'dbus-message-internal dbus-message-type-method-return + (apply #'dbus-message-internal dbus-message-type-method-return bus service serial args)) (defun dbus-method-error-internal (bus service serial &rest args) @@ -486,7 +476,7 @@ This is an internal function, it shall not be used outside dbus.el." (or (natnump serial) (signal 'wrong-type-argument (list 'natnump serial))) - (apply 'dbus-message-internal dbus-message-type-error + (apply #'dbus-message-internal dbus-message-type-error bus service serial args)) @@ -552,13 +542,13 @@ placed in the queue. `:already-owner': Service is already the primary owner." ;; Add Peer handler. - (dbus-register-method - bus service nil dbus-interface-peer "Ping" 'dbus-peer-handler 'dont-register) + (dbus-register-method bus service nil dbus-interface-peer "Ping" + #'dbus-peer-handler 'dont-register) ;; Add ObjectManager handler. (dbus-register-method bus service nil dbus-interface-objectmanager "GetManagedObjects" - 'dbus-managed-objects-handler 'dont-register) + #'dbus-managed-objects-handler 'dont-register) (let ((arg 0) reply) @@ -681,7 +671,7 @@ Example: (if (and (stringp service) (not (zerop (length service))) (not (string-equal service dbus-service-dbus)) - (not (string-match "^:" service))) + (/= (string-to-char service) ?:)) (setq uname (dbus-get-name-owner bus service)) (setq uname service)) @@ -710,7 +700,7 @@ Example: ;; `:arg0' .. `:arg63', `:path0' .. `:path63'. ((and (keywordp key) (string-match - "^:\\(arg\\|path\\)\\([[:digit:]]+\\)$" + "\\`:\\(arg\\|path\\)\\([[:digit:]]+\\)\\'" (symbol-name key))) (setq counter (match-string 2 (symbol-name key)) args (cdr args) @@ -726,9 +716,7 @@ Example: "path" "") value)) ;; `:arg-namespace', `:path-namespace'. - ((and (keywordp key) - (string-match - "^:\\(arg\\|path\\)-namespace$" (symbol-name key))) + ((memq key '(:arg-namespace :path-namespace)) (setq args (cdr args) value (car args)) (unless (stringp value) @@ -736,8 +724,7 @@ Example: (list "Wrong argument" key value))) (format ",%s='%s'" - (if (string-equal (match-string 1 (symbol-name key)) "path") - "path_namespace" "arg0namespace") + (if (eq key :path-namespace) "path_namespace" "arg0namespace") value)) ;; `:eavesdrop'. ((eq key :eavesdrop) @@ -751,11 +738,11 @@ Example: bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "AddMatch" rule) (dbus-error - (if (not (string-match "eavesdrop" rule)) + (if (not (string-match-p "eavesdrop" rule)) (signal (car err) (cdr err)) ;; The D-Bus spec says we shall fall back to a rule without eavesdrop. (when dbus-debug (message "Removing eavesdrop from rule %s" rule)) - (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule)) + (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule t t)) (dbus-call-method bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "AddMatch" rule)))) @@ -893,9 +880,7 @@ association to the service from D-Bus." STRING shall be UTF-8 coded." (if (zerop (length string)) '(:array :signature "y") - (let (result) - (dolist (elt (string-to-list string) (append '(:array) result)) - (setq result (append result (list :byte elt))))))) + (cons :array (mapcan (lambda (c) (list :byte c)) string)))) (defun dbus-byte-array-to-string (byte-array &optional multibyte) "Transform BYTE-ARRAY into UTF-8 coded string. @@ -903,12 +888,9 @@ BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte array as produced by `dbus-string-to-byte-array'. The resulting string is unibyte encoded, unless MULTIBYTE is non-nil." (apply - (if multibyte 'string 'unibyte-string) - (if (equal byte-array '(:array :signature "y")) - nil - (let (result) - (dolist (elt byte-array result) - (when (characterp elt) (setq result (append result `(,elt))))))))) + (if multibyte #'string #'unibyte-string) + (unless (equal byte-array '(:array :signature "y")) + (seq-filter #'characterp byte-array)))) (defun dbus-escape-as-identifier (string) "Escape an arbitrary STRING so it follows the rules for a C identifier. @@ -930,9 +912,9 @@ telepathy-glib's `tp_escape_as_identifier'." (if (zerop (length string)) "_" (replace-regexp-in-string - "^[0-9]\\|[^A-Za-z0-9]" + "\\`[0-9]\\|[^A-Za-z0-9]" (lambda (x) (format "_%2x" (aref x 0))) - string))) + string nil t))) (defun dbus-unescape-from-identifier (string) "Retrieve the original string from the encoded STRING as unibyte string. @@ -942,7 +924,7 @@ STRING must have been encoded with `dbus-escape-as-identifier'." (replace-regexp-in-string "_.." (lambda (x) (byte-to-string (string-to-number (substring x 1) 16))) - string))) + string nil t))) ;;; D-Bus events. @@ -1020,7 +1002,7 @@ If the HANDLER returns a `dbus-error', it is propagated as return message." (if (eq result :ignore) (dbus-method-return-internal (nth 1 event) (nth 4 event) (nth 3 event)) - (apply 'dbus-method-return-internal + (apply #'dbus-method-return-internal (nth 1 event) (nth 4 event) (nth 3 event) (if (consp result) result (list result))))))) ;; Error handling. @@ -1119,10 +1101,9 @@ unique names for services." (defun dbus-list-known-names (bus) "Retrieve all services which correspond to a known name in BUS. A service has a known name if it doesn't start with \":\"." - (let (result) - (dolist (name (dbus-list-names bus) (nreverse result)) - (unless (string-equal ":" (substring name 0 1)) - (push name result))))) + (seq-remove (lambda (name) + (= (string-to-char name) ?:)) + (dbus-list-names bus))) (defun dbus-list-queued-owners (bus service) "Return the unique names registered at D-Bus BUS and queued for SERVICE. @@ -1182,6 +1163,18 @@ It will be registered for all objects created by `dbus-register-service'." ;;; D-Bus introspection. +(defsubst dbus--introspect-names (object tag) + "Return the names of the children of OBJECT with TAG." + (mapcar (lambda (elt) + (dbus-introspect-get-attribute elt "name")) + (xml-get-children object tag))) + +(defsubst dbus--introspect-name (object tag name) + "Return the first child of OBJECT with TAG, whose name is NAME." + (seq-find (lambda (elt) + (string-equal (dbus-introspect-get-attribute elt "name") name)) + (xml-get-children object tag))) + (defun dbus-introspect (bus service path) "Return all interfaces and sub-nodes of SERVICE, registered at object path PATH at bus BUS. @@ -1197,17 +1190,25 @@ XML format." bus service path dbus-interface-introspectable "Introspect" :timeout 1000))) +(defalias 'dbus--parse-xml-buffer + (if (libxml-available-p) + (lambda () + (xml-remove-comments (point-min) (point-max)) + (libxml-parse-xml-region (point-min) (point-max))) + (lambda () + (car (xml-parse-region (point-min) (point-max))))) + "Compatibility shim for `libxml-parse-xml-region'.") + (defun dbus-introspect-xml (bus service path) "Return the introspection data of SERVICE in D-Bus BUS at object path PATH. The data are a parsed list. The root object is a \"node\", representing the object path PATH. The root object can contain \"interface\" and further \"node\" objects." - ;; We don't want to raise errors. - (xml-node-name - (ignore-errors - (with-temp-buffer - (insert (dbus-introspect bus service path)) - (xml-parse-region (point-min) (point-max)))))) + (with-temp-buffer + ;; We don't want to raise errors. + (ignore-errors + (insert (dbus-introspect bus service path)) + (dbus--parse-xml-buffer)))) (defun dbus-introspect-get-attribute (object attribute) "Return the ATTRIBUTE value of D-Bus introspection OBJECT. @@ -1219,21 +1220,15 @@ the D-Bus specification." "Return all node names of SERVICE in D-Bus BUS at object path PATH. It returns a list of strings. The node names stand for further object paths of the D-Bus service." - (let ((object (dbus-introspect-xml bus service path)) - result) - (dolist (elt (xml-get-children object 'node) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names (dbus-introspect-xml bus service path) 'node)) (defun dbus-introspect-get-all-nodes (bus service path) "Return all node names of SERVICE in D-Bus BUS at object path PATH. It returns a list of strings, which are further object paths of SERVICE." - (let ((result (list path))) - (dolist (elt - (dbus-introspect-get-node-names bus service path) - result) - (setq elt (expand-file-name elt path)) - (setq result - (append result (dbus-introspect-get-all-nodes bus service elt)))))) + (cons path (mapcan (lambda (elt) + (setq elt (expand-file-name elt path)) + (dbus-introspect-get-all-nodes bus service elt)) + (dbus-introspect-get-node-names bus service path)))) (defun dbus-introspect-get-interface-names (bus service path) "Return all interface names of SERVICE in D-Bus BUS at object path PATH. @@ -1244,10 +1239,7 @@ always present. Another default interface is \"org.freedesktop.DBus.Properties\". If present, \"interface\" objects can also have \"property\" objects as children, beside \"method\" and \"signal\" objects." - (let ((object (dbus-introspect-xml bus service path)) - result) - (dolist (elt (xml-get-children object 'interface) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names (dbus-introspect-xml bus service path) 'interface)) (defun dbus-introspect-get-interface (bus service path interface) "Return the INTERFACE of SERVICE in D-Bus BUS at object path PATH. @@ -1256,22 +1248,14 @@ and a member of the list returned by `dbus-introspect-get-interface-names'. The resulting \"interface\" object can contain \"method\", \"signal\", \"property\" and \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-xml bus service path) 'interface))) - (while (and elt - (not (string-equal - interface - (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name (dbus-introspect-xml bus service path) + 'interface interface)) (defun dbus-introspect-get-method-names (bus service path interface) "Return a list of strings of all method names of INTERFACE. SERVICE is a service of D-Bus BUS at object path PATH." - (let ((object (dbus-introspect-get-interface bus service path interface)) - result) - (dolist (elt (xml-get-children object 'method) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (dbus-introspect-get-interface bus service path interface) 'method)) (defun dbus-introspect-get-method (bus service path interface method) "Return method METHOD of interface INTERFACE as an XML object. @@ -1279,22 +1263,15 @@ It must be located at SERVICE in D-Bus BUS at object path PATH. METHOD must be a string and a member of the list returned by `dbus-introspect-get-method-names'. The resulting \"method\" object can contain \"arg\" and \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-get-interface bus service path interface) - 'method))) - (while (and elt - (not (string-equal - method (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (dbus-introspect-get-interface bus service path interface) + 'method method)) (defun dbus-introspect-get-signal-names (bus service path interface) "Return a list of strings of all signal names of INTERFACE. SERVICE is a service of D-Bus BUS at object path PATH." - (let ((object (dbus-introspect-get-interface bus service path interface)) - result) - (dolist (elt (xml-get-children object 'signal) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (dbus-introspect-get-interface bus service path interface) 'signal)) (defun dbus-introspect-get-signal (bus service path interface signal) "Return signal SIGNAL of interface INTERFACE as an XML object. @@ -1302,22 +1279,15 @@ It must be located at SERVICE in D-Bus BUS at object path PATH. SIGNAL must be a string, element of the list returned by `dbus-introspect-get-signal-names'. The resulting \"signal\" object can contain \"arg\" and \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-get-interface bus service path interface) - 'signal))) - (while (and elt - (not (string-equal - signal (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (dbus-introspect-get-interface bus service path interface) + 'signal signal)) (defun dbus-introspect-get-property-names (bus service path interface) "Return a list of strings of all property names of INTERFACE. SERVICE is a service of D-Bus BUS at object path PATH." - (let ((object (dbus-introspect-get-interface bus service path interface)) - result) - (dolist (elt (xml-get-children object 'property) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (dbus-introspect-get-interface bus service path interface) 'property)) (defun dbus-introspect-get-property (bus service path interface property) "Return PROPERTY of INTERFACE as an XML object. @@ -1325,15 +1295,9 @@ It must be located at SERVICE in D-Bus BUS at object path PATH. PROPERTY must be a string and a member of the list returned by `dbus-introspect-get-property-names'. The resulting PROPERTY object can contain \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-get-interface bus service path interface) - 'property))) - (while (and elt - (not (string-equal - property - (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (dbus-introspect-get-interface bus service path interface) + 'property property)) (defun dbus-introspect-get-annotation-names (bus service path interface &optional name) @@ -1341,15 +1305,13 @@ object can contain \"annotation\" children." If NAME is nil, the annotations are children of INTERFACE, otherwise NAME must be a \"method\", \"signal\", or \"property\" object, where the annotations belong to." - (let ((object - (if name - (or (dbus-introspect-get-method bus service path interface name) - (dbus-introspect-get-signal bus service path interface name) - (dbus-introspect-get-property bus service path interface name)) - (dbus-introspect-get-interface bus service path interface))) - result) - (dolist (elt (xml-get-children object 'annotation) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (if name + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name) + (dbus-introspect-get-property bus service path interface name)) + (dbus-introspect-get-interface bus service path interface)) + 'annotation)) (defun dbus-introspect-get-annotation (bus service path interface name annotation) @@ -1357,22 +1319,13 @@ object, where the annotations belong to." If NAME is nil, ANNOTATION is a child of INTERFACE, otherwise NAME must be the name of a \"method\", \"signal\", or \"property\" object, where the ANNOTATION belongs to." - (let ((elt (xml-get-children - (if name - (or (dbus-introspect-get-method - bus service path interface name) - (dbus-introspect-get-signal - bus service path interface name) - (dbus-introspect-get-property - bus service path interface name)) - (dbus-introspect-get-interface bus service path interface)) - 'annotation))) - (while (and elt - (not (string-equal - annotation - (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (if name + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name) + (dbus-introspect-get-property bus service path interface name)) + (dbus-introspect-get-interface bus service path interface)) + 'annotation annotation)) (defun dbus-introspect-get-argument-names (bus service path interface name) "Return a list of all argument names as a list of strings. @@ -1380,27 +1333,20 @@ NAME must be a \"method\" or \"signal\" object. Argument names are optional, the function can return nil therefore, even if the method or signal has arguments." - (let ((object - (or (dbus-introspect-get-method bus service path interface name) - (dbus-introspect-get-signal bus service path interface name))) - result) - (dolist (elt (xml-get-children object 'arg) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name)) + 'arg)) (defun dbus-introspect-get-argument (bus service path interface name arg) "Return argument ARG as XML object. NAME must be a \"method\" or \"signal\" object. ARG must be a string and a member of the list returned by `dbus-introspect-get-argument-names'." - (let ((elt (xml-get-children - (or (dbus-introspect-get-method bus service path interface name) - (dbus-introspect-get-signal bus service path interface name)) - 'arg))) - (while (and elt - (not (string-equal - arg (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name)) + 'arg arg)) (defun dbus-introspect-get-signature (bus service path interface name &optional direction) @@ -1469,13 +1415,10 @@ name of the property, and its value. If there are no properties, nil is returned." (dbus-ignore-errors ;; "GetAll" returns "a{sv}". - (let (result) - (dolist (dict - (dbus-call-method - bus service path dbus-interface-properties - "GetAll" :timeout 500 interface) - (nreverse result)) - (push (cons (car dict) (cl-caadr dict)) result))))) + (mapcar (lambda (dict) + (cons (car dict) (caadr dict))) + (dbus-call-method bus service path dbus-interface-properties + "GetAll" :timeout 500 interface)))) (defun dbus-register-property (bus service path interface property access value @@ -1520,13 +1463,13 @@ clients from discovering the still incomplete interface." ;; Add handlers for the three property-related methods. (dbus-register-method bus service path dbus-interface-properties "Get" - 'dbus-property-handler 'dont-register) + #'dbus-property-handler 'dont-register) (dbus-register-method bus service path dbus-interface-properties "GetAll" - 'dbus-property-handler 'dont-register) + #'dbus-property-handler 'dont-register) (dbus-register-method bus service path dbus-interface-properties "Set" - 'dbus-property-handler 'dont-register) + #'dbus-property-handler 'dont-register) ;; Register SERVICE. (unless (or dont-register-service (member service (dbus-list-names bus))) @@ -1673,7 +1616,7 @@ and \"org.freedesktop.DBus.Properties.GetAll\", which is slow." (if (cadr entry2) ;; "sv". (dolist (entry3 (cadr entry2)) - (setcdr entry3 (cl-caadr entry3))) + (setcdr entry3 (caadr entry3))) (setcdr entry2 nil))))) ;; Fallback: collect the information. Slooow! @@ -1730,7 +1673,7 @@ It will be registered for all objects created by `dbus-register-service'." (append (butlast last-input-event 4) (list object dbus-interface-properties - "GetAll" 'dbus-property-handler)))) + "GetAll" #'dbus-property-handler)))) (dbus-property-handler interface)))) (cdr (assoc object result))))))))) dbus-registered-objects-table) diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index e263c4563fe..45c98513653 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -176,8 +176,8 @@ This includes initialization and closing the bus." (defun dbus-test-all (&optional interactive) "Run all tests for \\[dbus]." (interactive "p") - (funcall - (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) "^dbus")) + (funcall (if interactive #'ert-run-tests-interactively #'ert-run-tests-batch) + "^dbus")) (provide 'dbus-tests) ;;; dbus-tests.el ends here From 0185d76e7426eb1b58a9b60b0d18e763ddf57dea Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Fri, 29 May 2020 19:56:14 +0100 Subject: [PATCH 42/72] Fix and extend format-spec (bug#41758) * lisp/format-spec.el: Use lexical-binding. Remove dependence on subr-x.el. (format-spec-make): Clarify docstring. (format-spec--parse-modifiers): Rename to... (format-spec--parse-flags): ...this and simplify. In particular, don't bother parsing :space-pad which is redundant and unused. (format-spec--pad): Remove, replacing with... (format-spec--do-flags): ...this new helper function which performs more of format-spec's supported text manipulation. (format-spec): Autoload. Allow optional argument to take on special values 'ignore' and 'delete' for more control over what happens when a replacement for a format specification isn't provided. Bring back proper support for a precision modifier similar to that of 'format'. * lisp/battery.el (battery-format): Rewrite in terms of format-spec. (battery-echo-area-format, battery-mode-line-format): Mention support of format-spec syntax in docstrings. * doc/lispref/strings.texi (Custom Format Strings): * etc/NEWS: Document and announce these changes. * lisp/dired-aux.el (dired-do-compress-to): * lisp/erc/erc-match.el (erc-log-matches): * lisp/erc/erc.el (erc-update-mode-line-buffer): * lisp/gnus/gnus-sieve.el (gnus-sieve-update): * lisp/gnus/gssapi.el (open-gssapi-stream): * lisp/gnus/mail-source.el (mail-source-fetch-file) (mail-source-fetch-directory, mail-source-fetch-pop) (mail-source-fetch-imap): * lisp/gnus/message.el (message-insert-formatted-citation-line): * lisp/image-dired.el: * lisp/net/eww.el: * lisp/net/imap.el (imap-kerberos4-open, imap-gssapi-open) (imap-shell-open): * lisp/net/network-stream.el (network-stream-open-shell): * lisp/obsolete/tls.el (open-tls-stream): * lisp/textmodes/tex-mode.el: Remove extraneous loads and autoloads of format-spec now that it is autoloaded and simplify its uses where possible. * test/lisp/battery-tests.el (battery-format): Test new format-spec support. * test/lisp/format-spec-tests.el (test-format-spec): Rename to... (format-spec) ...this, extending test cases. (test-format-unknown): Rename to... (format-spec-unknown): ...this, extending test cases. (test-format-modifiers): Rename to... (format-spec-flags): ...this. (format-spec-make, format-spec-parse-flags, format-spec-do-flags) (format-spec-do-flags-truncate, format-spec-do-flags-pad) (format-spec-do-flags-chop, format-spec-do-flags-case): New tests. --- doc/lispref/strings.texi | 35 +++++-- etc/NEWS | 17 ++++ lisp/battery.el | 18 ++-- lisp/dired-aux.el | 15 ++- lisp/erc/erc-match.el | 19 ++-- lisp/erc/erc.el | 21 ++-- lisp/format-spec.el | 181 ++++++++++++++++++--------------- lisp/gnus/gnus-sieve.el | 10 +- lisp/gnus/gssapi.el | 11 +- lisp/gnus/mail-source.el | 30 +++--- lisp/gnus/message.el | 137 +++++++++++-------------- lisp/image-dired.el | 1 - lisp/net/eww.el | 1 - lisp/net/imap.el | 30 ++---- lisp/net/network-stream.el | 13 +-- lisp/obsolete/tls.el | 16 +-- lisp/textmodes/tex-mode.el | 3 - test/lisp/battery-tests.el | 4 +- test/lisp/format-spec-tests.el | 135 ++++++++++++++++++++++-- 19 files changed, 407 insertions(+), 290 deletions(-) diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi index 4a7bda57c4e..2ef88b90254 100644 --- a/doc/lispref/strings.texi +++ b/doc/lispref/strings.texi @@ -1152,7 +1152,7 @@ The function @code{format-spec} described in this section performs a similar function to @code{format}, except it operates on format control strings that use arbitrary specification characters. -@defun format-spec template spec-alist &optional only-present +@defun format-spec template spec-alist &optional ignore-missing This function returns a string produced from the format string @var{template} according to conversions specified in @var{spec-alist}, which is an alist (@pxref{Association Lists}) of the form @@ -1185,12 +1185,15 @@ The order of specifications in @var{template} need not correspond to the order of associations in @var{spec-alist}. @end itemize -The optional argument @var{only-present} indicates how to handle +The optional argument @var{ignore-missing} indicates how to handle specification characters in @var{template} that are not found in @var{spec-alist}. If it is @code{nil} or omitted, the function -signals an error. Otherwise, those format specifications and any -occurrences of @samp{%%} in @var{template} are left verbatim in the -output, including their text properties, if any. +signals an error; if it is @code{ignore}, those format specifications +are left verbatim in the output, including their text properties, if +any; if it is @code{delete}, those format specifications are removed +from the output; any other non-@code{nil} value is handled like +@code{ignore}, but any occurrences of @samp{%%} are also left verbatim +in the output. @end defun The syntax of format specifications accepted by @code{format-spec} is @@ -1238,7 +1241,7 @@ the right rather than the left. @item < This flag causes the substitution to be truncated on the left to the -given width, if specified. +given width and precision, if specified. @item > This flag causes the substitution to be truncated on the right to the @@ -1257,9 +1260,12 @@ The result of using contradictory flags (for instance, both upper and lower case) is undefined. As is the case with @code{format}, a format specification can include -a width, which is a decimal number that appears after any flags. If a -substitution contains fewer characters than its specified width, it is -padded on the left: +a width, which is a decimal number that appears after any flags, and a +precision, which is a decimal-point @samp{.} followed by a decimal +number that appears after any flags and width. + +If a substitution contains fewer characters than its specified width, +it is padded on the left: @example @group @@ -1269,6 +1275,17 @@ padded on the left: @end group @end example +If a substitution contains more characters than its specified +precision, it is truncated on the right: + +@example +@group +(format-spec "%.2a is truncated on the right" + '((?a . "alpha"))) + @result{} "al is truncated on the right" +@end group +@end example + Here is a more complicated example that combines several aforementioned features: diff --git a/etc/NEWS b/etc/NEWS index d702f758f23..4d730228139 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -461,6 +461,16 @@ In Emacs 24.3, the variable 'dbus-event-error-hooks' was renamed to The old names, which were kept as obsolete aliases of the new names, have now been removed. +** Battery + +--- +*** A richer syntax can be used to format battery status information. +The user options 'battery-mode-line-format' and +'battery-echo-area-format' now support the full formatting syntax of +the function 'format-spec' documented under '(elisp) Custom Format +Strings'. The new syntax includes specifiers for padding and +truncation, amongst other things. + * New Modes and Packages in Emacs 28.1 @@ -578,6 +588,13 @@ for encoding and decoding without having to bind It controls, whether 'process-file' returns a string when a remote process is interrupted by a signal. ++++ +** The behavior of 'format-spec' is now closer to that of 'format'. +In order for the two functions to behave more consistently, +'format-spec' now pads and truncates based on string width rather than +length, and also supports format specifications that include a +truncating precision field, such as '%.2a'. + * Changes in Emacs 28.1 on Non-Free Operating Systems diff --git a/lisp/battery.el b/lisp/battery.el index b8855a8ce37..38728196507 100644 --- a/lisp/battery.el +++ b/lisp/battery.el @@ -121,7 +121,10 @@ string are substituted as defined by the current value of the variable %p Battery load percentage %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours -%t Remaining time (to charge or discharge) in the form `h:min'" +%t Remaining time (to charge or discharge) in the form `h:min' + +The full `format-spec' formatting syntax is supported." + :link '(info-link "(elisp) Custom Format Strings") :type '(choice string (const nil))) (defvar battery-mode-line-string nil @@ -153,7 +156,10 @@ string are substituted as defined by the current value of the variable %p Battery load percentage %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours -%t Remaining time (to charge or discharge) in the form `h:min'" +%t Remaining time (to charge or discharge) in the form `h:min' + +The full `format-spec' formatting syntax is supported." + :link '(info-link "(elisp) Custom Format Strings") :type '(choice string (const nil))) (defcustom battery-update-interval 60 @@ -823,13 +829,7 @@ The following %-sequences are provided: (defun battery-format (format alist) "Substitute %-sequences in FORMAT." - (replace-regexp-in-string - "%." - (lambda (str) - (let ((char (aref str 1))) - (if (eq char ?%) "%" - (or (cdr (assoc char alist)) "")))) - format t t)) + (format-spec format alist 'delete)) (defun battery-search-for-one-match-in-files (files regexp match-num) "Search REGEXP in the content of the files listed in FILES. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 0d481f4ac19..efb214088d8 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1064,8 +1064,6 @@ corresponding command. Within CMD, %i denotes the input file(s), and %o denotes the output file. %i path(s) are relative, while %o is absolute.") -(declare-function format-spec "format-spec.el" (format specification)) - ;;;###autoload (defun dired-do-compress-to () "Compress selected files and directories to an archive. @@ -1073,7 +1071,6 @@ Prompt for the archive file name. Choose the archiving command based on the archive file-name extension and `dired-compress-files-alist'." (interactive) - (require 'format-spec) (let* ((in-files (dired-get-marked-files nil nil nil nil t)) (out-file (expand-file-name (read-file-name "Compress to: "))) (rule (cl-find-if @@ -1093,12 +1090,12 @@ and `dired-compress-files-alist'." (when (zerop (dired-shell-command (format-spec (cdr rule) - `((?\o . ,(shell-quote-argument out-file)) - (?\i . ,(mapconcat - (lambda (file-desc) - (shell-quote-argument (file-name-nondirectory - file-desc))) - in-files " ")))))) + `((?o . ,(shell-quote-argument out-file)) + (?i . ,(mapconcat + (lambda (in-file) + (shell-quote-argument + (file-name-nondirectory in-file))) + in-files " ")))))) (message (ngettext "Compressed %d file to %s" "Compressed %d files to %s" (length in-files)) diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index 3107ff2ccd1..0e98f2bc613 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -555,16 +555,15 @@ See `erc-log-match-format'." (and (eq erc-log-matches-flag 'away) (erc-away-time))) match-buffer-name) - (let ((line (format-spec erc-log-match-format - (format-spec-make - ?n nick - ?t (format-time-string - (or (and (boundp 'erc-timestamp-format) - erc-timestamp-format) - "[%Y-%m-%d %H:%M] ")) - ?c (or (erc-default-target) "") - ?m message - ?u nickuserhost)))) + (let ((line (format-spec + erc-log-match-format + `((?n . ,nick) + (?t . ,(format-time-string + (or (bound-and-true-p erc-timestamp-format) + "[%Y-%m-%d %H:%M] "))) + (?c . ,(or (erc-default-target) "")) + (?m . ,message) + (?u . ,nickuserhost))))) (with-current-buffer (erc-log-matches-make-buffer match-buffer-name) (let ((inhibit-read-only t)) (goto-char (point-max)) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index cfde84e19aa..38807787945 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -6391,17 +6391,16 @@ if `erc-away' is non-nil." (defun erc-update-mode-line-buffer (buffer) "Update the mode line in a single ERC buffer BUFFER." (with-current-buffer buffer - (let ((spec (format-spec-make - ?a (erc-format-away-status) - ?l (erc-format-lag-time) - ?m (erc-format-channel-modes) - ?n (or (erc-current-nick) "") - ?N (erc-format-network) - ?o (or (erc-controls-strip erc-channel-topic) "") - ?p (erc-port-to-string erc-session-port) - ?s (erc-format-target-and/or-server) - ?S (erc-format-target-and/or-network) - ?t (erc-format-target))) + (let ((spec `((?a . ,(erc-format-away-status)) + (?l . ,(erc-format-lag-time)) + (?m . ,(erc-format-channel-modes)) + (?n . ,(or (erc-current-nick) "")) + (?N . ,(erc-format-network)) + (?o . ,(or (erc-controls-strip erc-channel-topic) "")) + (?p . ,(erc-port-to-string erc-session-port)) + (?s . ,(erc-format-target-and/or-server)) + (?S . ,(erc-format-target-and/or-network)) + (?t . ,(erc-format-target)))) (process-status (cond ((and (erc-server-process-alive) (not erc-server-connected)) ":connecting") diff --git a/lisp/format-spec.el b/lisp/format-spec.el index 9278bd74c42..6af79a44167 100644 --- a/lisp/format-spec.el +++ b/lisp/format-spec.el @@ -1,4 +1,4 @@ -;;; format-spec.el --- functions for formatting arbitrary formatting strings +;;; format-spec.el --- format arbitrary formatting strings -*- lexical-binding: t -*- ;; Copyright (C) 1999-2020 Free Software Foundation, Inc. @@ -24,10 +24,8 @@ ;;; Code: -(eval-when-compile - (require 'subr-x)) - -(defun format-spec (format specification &optional only-present) +;;;###autoload +(defun format-spec (format specification &optional ignore-missing) "Return a string based on FORMAT and SPECIFICATION. FORMAT is a string containing `format'-like specs like \"su - %u %k\". SPECIFICATION is an alist mapping format specification characters @@ -39,22 +37,22 @@ For instance: \\=`((?u . ,(user-login-name)) (?l . \"ls\"))) -Each %-spec may contain optional flag and width modifiers, as -follows: +Each %-spec may contain optional flag, width, and precision +modifiers, as follows: - %character + %character The following flags are allowed: * 0: Pad to the width, if given, with zeros instead of spaces. * -: Pad to the width, if given, on the right instead of the left. -* <: Truncate to the width, if given, on the left. -* >: Truncate to the width, if given, on the right. +* <: Truncate to the width and precision, if given, on the left. +* >: Truncate to the width and precision, if given, on the right. * ^: Convert to upper case. * _: Convert to lower case. -The width modifier behaves like the corresponding one in `format' -when applied to %s. +The width and truncation modifiers behave like the corresponding +ones in `format' when applied to %s. For example, \"%<010b\" means \"substitute into the output the value associated with ?b in SPECIFICATION, either padding it with @@ -64,89 +62,108 @@ characters wide\". Any text properties of FORMAT are copied to the result, with any text properties of a %-spec itself copied to its substitution. -ONLY-PRESENT indicates how to handle %-spec characters not +IGNORE-MISSING indicates how to handle %-spec characters not present in SPECIFICATION. If it is nil or omitted, emit an -error; otherwise leave those %-specs and any occurrences of -\"%%\" in FORMAT verbatim in the result, including their text -properties, if any." +error; if it is the symbol `ignore', leave those %-specs verbatim +in the result, including their text properties, if any; if it is +the symbol `delete', remove those %-specs from the result; +otherwise do the same as for the symbol `ignore', but also leave +any occurrences of \"%%\" in FORMAT verbatim in the result." (with-temp-buffer (insert format) (goto-char (point-min)) (while (search-forward "%" nil t) (cond - ;; Quoted percent sign. - ((eq (char-after) ?%) - (unless only-present - (delete-char 1))) - ;; Valid format spec. - ((looking-at "\\([-0 _^<>]*\\)\\([0-9.]*\\)\\([a-zA-Z]\\)") - (let* ((modifiers (match-string 1)) - (num (match-string 2)) - (spec (string-to-char (match-string 3))) - (val (assq spec specification))) - (if (not val) - (unless only-present - (error "Invalid format character: `%%%c'" spec)) - (setq val (cdr val) - modifiers (format-spec--parse-modifiers modifiers)) - ;; Pad result to desired length. - (let ((text (format "%s" val))) - (when num - (setq num (string-to-number num)) - (setq text (format-spec--pad text num modifiers)) - (when (> (length text) num) - (cond - ((memq :chop-left modifiers) - (setq text (substring text (- (length text) num)))) - ((memq :chop-right modifiers) - (setq text (substring text 0 num)))))) - (when (memq :uppercase modifiers) - (setq text (upcase text))) - (when (memq :lowercase modifiers) - (setq text (downcase text))) - ;; Insert first, to preserve text properties. - (insert-and-inherit text) - ;; Delete the specifier body. - (delete-region (+ (match-beginning 0) (length text)) - (+ (match-end 0) (length text))) - ;; Delete the percent sign. - (delete-region (1- (match-beginning 0)) (match-beginning 0)))))) - ;; Signal an error on bogus format strings. - (t - (unless only-present - (error "Invalid format string"))))) + ;; Quoted percent sign. + ((= (following-char) ?%) + (when (memq ignore-missing '(nil ignore delete)) + (delete-char 1))) + ;; Valid format spec. + ((looking-at (rx (? (group (+ (in " 0<>^_-")))) + (? (group (+ digit))) + (? (group ?. (+ digit))) + (group alpha))) + (let* ((beg (point)) + (end (match-end 0)) + (flags (match-string 1)) + (width (match-string 2)) + (trunc (match-string 3)) + (char (string-to-char (match-string 4))) + (text (assq char specification))) + (cond (text + ;; Handle flags. + (setq text (format-spec--do-flags + (format "%s" (cdr text)) + (format-spec--parse-flags flags) + (and width (string-to-number width)) + (and trunc (car (read-from-string trunc 1))))) + ;; Insert first, to preserve text properties. + (insert-and-inherit text) + ;; Delete the specifier body. + (delete-region (point) (+ end (length text))) + ;; Delete the percent sign. + (delete-region (1- beg) beg)) + ((eq ignore-missing 'delete) + ;; Delete the whole format spec. + (delete-region (1- beg) end)) + ((not ignore-missing) + (error "Invalid format character: `%%%c'" char))))) + ;; Signal an error on bogus format strings. + ((not ignore-missing) + (error "Invalid format string")))) (buffer-string))) -(defun format-spec--pad (text total-length modifiers) - (if (> (length text) total-length) - ;; The text is longer than the specified length; do nothing. - text - (let ((padding (make-string (- total-length (length text)) - (if (memq :zero-pad modifiers) - ?0 - ?\s)))) - (if (memq :right-pad modifiers) - (concat text padding) - (concat padding text))))) +(defun format-spec--do-flags (str flags width trunc) + "Return STR formatted according to FLAGS, WIDTH, and TRUNC. +FLAGS is a list of keywords as returned by +`format-spec--parse-flags'. WIDTH and TRUNC are either nil or +string widths corresponding to `format-spec' modifiers." + (let (diff str-width) + ;; Truncate original string first, like `format' does. + (when trunc + (setq str-width (string-width str)) + (when (> (setq diff (- str-width trunc)) 0) + (setq str (if (memq :chop-left flags) + (truncate-string-to-width str str-width diff) + (format (format "%%.%ds" trunc) str)) + ;; We know the new width so save it for later. + str-width trunc))) + ;; Pad or chop to width. + (when width + (setq str-width (or str-width (string-width str)) + diff (- width str-width)) + (cond ((zerop diff)) + ((> diff 0) + (let ((pad (make-string diff (if (memq :pad-zero flags) ?0 ?\s)))) + (setq str (if (memq :pad-right flags) + (concat str pad) + (concat pad str))))) + ((memq :chop-left flags) + (setq str (truncate-string-to-width str str-width (- diff)))) + ((memq :chop-right flags) + (setq str (format (format "%%.%ds" width) str)))))) + ;; Fiddle case. + (cond ((memq :upcase flags) + (upcase str)) + ((memq :downcase flags) + (downcase str)) + (str))) -(defun format-spec--parse-modifiers (modifiers) +(defun format-spec--parse-flags (flags) + "Convert sequence of FLAGS to list of human-readable keywords." (mapcan (lambda (char) - (when-let ((modifier - (pcase char - (?0 :zero-pad) - (?\s :space-pad) - (?^ :uppercase) - (?_ :lowercase) - (?- :right-pad) - (?< :chop-left) - (?> :chop-right)))) - (list modifier))) - modifiers)) + (pcase char + (?0 (list :pad-zero)) + (?- (list :pad-right)) + (?< (list :chop-left)) + (?> (list :chop-right)) + (?^ (list :upcase)) + (?_ (list :downcase)))) + flags)) (defun format-spec-make (&rest pairs) "Return an alist suitable for use in `format-spec' based on PAIRS. -PAIRS is a list where every other element is a character and a value, -starting with a character." +PAIRS is a property list with characters as keys." (let (alist) (while pairs (unless (cdr pairs) diff --git a/lisp/gnus/gnus-sieve.el b/lisp/gnus/gnus-sieve.el index 278e3a5d6f3..5d8f9b55deb 100644 --- a/lisp/gnus/gnus-sieve.el +++ b/lisp/gnus/gnus-sieve.el @@ -29,8 +29,6 @@ (require 'gnus) (require 'gnus-sum) -(require 'format-spec) -(autoload 'sieve-mode "sieve-mode") (eval-when-compile (require 'sieve)) @@ -88,10 +86,10 @@ See the documentation for these variables and functions for details." (save-buffer) (shell-command (format-spec gnus-sieve-update-shell-command - (format-spec-make ?f gnus-sieve-file - ?s (or (cadr (gnus-server-get-method - nil gnus-sieve-select-method)) - ""))))) + `((?f . ,gnus-sieve-file) + (?s . ,(or (cadr (gnus-server-get-method + nil gnus-sieve-select-method)) + "")))))) ;;;###autoload (defun gnus-sieve-generate () diff --git a/lisp/gnus/gssapi.el b/lisp/gnus/gssapi.el index 218a1542e3a..485d58ad94e 100644 --- a/lisp/gnus/gssapi.el +++ b/lisp/gnus/gssapi.el @@ -25,8 +25,6 @@ ;;; Code: -(require 'format-spec) - (defcustom gssapi-program (list (concat "gsasl %s %p " "--mechanism GSSAPI " @@ -53,12 +51,9 @@ tried until a successful connection is made." (coding-system-for-write 'binary) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l user)))) + (format-spec cmd `((?s . ,server) + (?p . ,(number-to-string port)) + (?l . ,user))))) response) (when process (while (and (memq (process-status process) '(open run)) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index acf35a376a9..43180726c45 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -24,7 +24,6 @@ ;;; Code: -(require 'format-spec) (eval-when-compile (require 'cl-lib) (require 'imap)) @@ -769,14 +768,14 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) "Fetcher for single-file sources." (mail-source-bind (file source) (mail-source-run-script - prescript (format-spec-make ?t mail-source-crash-box) + prescript `((?t . ,mail-source-crash-box)) prescript-delay) (let ((mail-source-string (format "file:%s" path))) (if (mail-source-movemail path mail-source-crash-box) (prog1 (mail-source-callback callback path) (mail-source-run-script - postscript (format-spec-make ?t mail-source-crash-box)) + postscript `((?t . ,mail-source-crash-box))) (mail-source-delete-crash-box)) 0)))) @@ -784,7 +783,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) "Fetcher for directory sources." (mail-source-bind (directory source) (mail-source-run-script - prescript (format-spec-make ?t path) prescript-delay) + prescript `((?t . ,path)) prescript-delay) (let ((found 0) (mail-source-string (format "directory:%s" path))) (dolist (file (directory-files @@ -793,7 +792,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (funcall predicate file) (mail-source-movemail file mail-source-crash-box)) (cl-incf found (mail-source-callback callback file)) - (mail-source-run-script postscript (format-spec-make ?t path)) + (mail-source-run-script postscript `((?t . ,path))) (mail-source-delete-crash-box))) found))) @@ -803,8 +802,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) ;; fixme: deal with stream type in format specs (mail-source-run-script prescript - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user)) prescript-delay) (let ((from (format "%s:%s:%s" server user port)) (mail-source-string (format "pop:%s@%s" user server)) @@ -825,8 +824,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (mail-source-fetch-with-program (format-spec program - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)))) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user))))) (function (funcall function mail-source-crash-box)) ;; The default is to use pop3.el. @@ -863,8 +862,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (setq mail-source-new-mail-available nil)) (mail-source-run-script postscript - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user))) (mail-source-delete-crash-box))) ;; We nix out the password in case the error ;; was because of a wrong password being given. @@ -1077,8 +1076,9 @@ This only works when `display-time' is enabled." "Fetcher for imap sources." (mail-source-bind (imap source) (mail-source-run-script - prescript (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user) + prescript + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user)) prescript-delay) (let ((from (format "%s:%s:%s" server user port)) (found 0) @@ -1143,8 +1143,8 @@ This only works when `display-time' is enabled." (kill-buffer buf) (mail-source-run-script postscript - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user))) found))) (provide 'mail-source) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 5a6827af762..fb560f0eab8 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -42,13 +42,12 @@ (require 'mail-parse) (require 'mml) (require 'rfc822) -(require 'format-spec) (require 'dired) (require 'mm-util) (require 'rfc2047) (require 'puny) -(require 'rmc) ; read-multiple-choice -(eval-when-compile (require 'subr-x)) ; when-let* +(require 'rmc) ; read-multiple-choice +(eval-when-compile (require 'subr-x)) (autoload 'mailclient-send-it "mailclient") @@ -440,8 +439,8 @@ whitespace)." (defcustom message-elide-ellipsis "\n[...]\n\n" "The string which is inserted for elided text. -This is a format-spec string, and you can use %l to say how many -lines were removed, and %c to say how many characters were +This is a `format-spec' string, and you can use %l to say how +many lines were removed, and %c to say how many characters were removed." :type 'string :link '(custom-manual "(message)Various Commands") @@ -3977,7 +3976,6 @@ This function uses `mail-citation-hook' if that is non-nil." "Cite function in the standard Message manner." (message-cite-original-1 nil)) -(autoload 'format-spec "format-spec") (autoload 'gnus-date-get-time "gnus-util") (defun message-insert-formatted-citation-line (&optional from date tz) @@ -4002,20 +4000,18 @@ See `message-citation-line-format'." (when (or message-reply-headers (and from date)) (unless from (setq from (mail-header-from message-reply-headers))) - (let* ((data (condition-case () - (funcall (if (boundp 'gnus-extract-address-components) - gnus-extract-address-components - 'mail-extract-address-components) - from) - (error nil))) + (let* ((data (ignore-errors + (funcall (or (bound-and-true-p + gnus-extract-address-components) + #'mail-extract-address-components) + from))) (name (car data)) (fname name) (lname name) - (net (car (cdr data))) - (name-or-net (or (car data) - (car (cdr data)) from)) + (net (cadr data)) + (name-or-net (or name net from)) (time - (when (string-match "%[^fnNFL]" message-citation-line-format) + (when (string-match-p "%[^FLNfn]" message-citation-line-format) (cond ((numberp (car-safe date)) date) ;; backward compatibility (date (gnus-date-get-time date)) (t @@ -4024,68 +4020,53 @@ See `message-citation-line-format'." (tz (or tz (when (stringp date) (nth 8 (parse-time-string date))))) - (flist - (let ((i ?A) lst) - (when (stringp name) - ;; Guess first name and last name: - (let* ((names (delq - nil - (mapcar - (lambda (x) - (if (string-match "\\`\\(\\w\\|[-.]\\)+\\'" - x) - x - nil)) - (split-string name "[ \t]+")))) - (count (length names))) - (cond ((= count 1) - (setq fname (car names) - lname "")) - ((or (= count 2) (= count 3)) - (setq fname (car names) - lname (mapconcat 'identity (cdr names) " "))) - ((> count 3) - (setq fname (mapconcat 'identity - (butlast names (- count 2)) - " ") - lname (mapconcat 'identity - (nthcdr 2 names) - " ")))) - (when (string-match "\\(.*\\),\\'" fname) - (let ((newlname (match-string 1 fname))) - (setq fname lname lname newlname))))) - ;; The following letters are not used in `format-time-string': - (push ?E lst) (push "" lst) - (push ?F lst) (push (or fname name-or-net) lst) - ;; We might want to use "" instead of "" later. - (push ?J lst) (push "" lst) - (push ?K lst) (push "" lst) - (push ?L lst) (push lname lst) - (push ?N lst) (push name-or-net lst) - (push ?O lst) (push "" lst) - (push ?P lst) (push "

" lst) - (push ?Q lst) (push "" lst) - (push ?f lst) (push from lst) - (push ?i lst) (push "" lst) - (push ?n lst) (push net lst) - (push ?o lst) (push "" lst) - (push ?q lst) (push "" lst) - (push ?t lst) (push "" lst) - (push ?v lst) (push "" lst) - ;; Delegate the rest to `format-time-string': - (while (<= i ?z) - (when (and (not (memq i lst)) - ;; Skip (Z,a) - (or (<= i ?Z) - (>= i ?a))) - (push i lst) - (push (condition-case nil - (format-time-string (format "%%%c" i) time tz) - (error (format ">%c<" i))) - lst)) - (setq i (1+ i))) - (reverse lst))) - (spec (apply 'format-spec-make flist))) + spec) + (when (stringp name) + ;; Guess first name and last name: + (let* ((names (seq-filter + (lambda (s) + (string-match-p (rx bos (+ (in word ?. ?-)) eos) s)) + (split-string name "[ \t]+"))) + (count (length names))) + (cond ((= count 1) + (setq fname (car names) + lname "")) + ((or (= count 2) (= count 3)) + (setq fname (car names) + lname (string-join (cdr names) " "))) + ((> count 3) + (setq fname (string-join (butlast names (- count 2)) + " ") + lname (string-join (nthcdr 2 names) " ")))) + (when (string-match "\\(.*\\),\\'" fname) + (let ((newlname (match-string 1 fname))) + (setq fname lname lname newlname))))) + ;; The following letters are not used in `format-time-string': + (push (cons ?E "") spec) + (push (cons ?F (or fname name-or-net)) spec) + ;; We might want to use "" instead of "" later. + (push (cons ?J "") spec) + (push (cons ?K "") spec) + (push (cons ?L lname) spec) + (push (cons ?N name-or-net) spec) + (push (cons ?O "") spec) + (push (cons ?P "

") spec) + (push (cons ?Q "") spec) + (push (cons ?f from) spec) + (push (cons ?i "") spec) + (push (cons ?n net) spec) + (push (cons ?o "") spec) + (push (cons ?q "") spec) + (push (cons ?t "") spec) + (push (cons ?v "") spec) + ;; Delegate the rest to `format-time-string': + (dolist (c (nconc (number-sequence ?A ?Z) + (number-sequence ?a ?z))) + (unless (assq c spec) + (push (cons c (condition-case nil + (format-time-string (format "%%%c" c) time tz) + (error (format ">%c<" c)))) + spec))) (insert (format-spec message-citation-line-format spec))) (newline))) diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 1cc38ba714b..6f297672caf 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -149,7 +149,6 @@ ;;; Code: (require 'dired) -(require 'format-spec) (require 'image-mode) (require 'widget) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 2a70560ca7b..cf31d37f072 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -25,7 +25,6 @@ ;;; Code: (require 'cl-lib) -(require 'format-spec) (require 'shr) (require 'url) (require 'url-queue) diff --git a/lisp/net/imap.el b/lisp/net/imap.el index aa10f0291fd..a492dc8c798 100644 --- a/lisp/net/imap.el +++ b/lisp/net/imap.el @@ -136,7 +136,6 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) -(require 'format-spec) (require 'utf7) (require 'rfc2104) ;; Hmm... digest-md5 is not part of Emacs. @@ -517,12 +516,9 @@ sure of changing the value of `foo'." (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l imap-default-user)))) + (format-spec cmd `((?s . ,server) + (?p . ,(number-to-string port)) + (?l . ,imap-default-user))))) response) (when process (with-current-buffer buffer @@ -583,12 +579,9 @@ sure of changing the value of `foo'." (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l imap-default-user)))) + (format-spec cmd `((?s . ,server) + (?p . ,(number-to-string port)) + (?l . ,imap-default-user))))) response) (when process (with-current-buffer buffer @@ -701,13 +694,10 @@ sure of changing the value of `foo'." (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?g imap-shell-host - ?p (number-to-string port) - ?l imap-default-user))))) + (format-spec cmd `((?s . ,server) + (?g . ,imap-shell-host) + (?p . ,(number-to-string port)) + (?l . ,imap-default-user)))))) (when process (while (and (memq (process-status process) '(open run)) (set-buffer buffer) ;; XXX "blue moon" nntp.el bug diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index 1d5cf382a84..1c371f59870 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -170,8 +170,8 @@ a greeting from the server. :nowait, if non-nil, says the connection should be made asynchronously, if possible. -:shell-command is a format-spec string that can be used if :type -is `shell'. It has two specs, %s for host and %p for port +:shell-command is a `format-spec' string that can be used if +:type is `shell'. It has two specs, %s for host and %p for port number. Example: \"ssh gateway nc %s %p\". :tls-parameters is a list that should be supplied if you're @@ -453,11 +453,7 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (network-stream-command stream capability-command eo-capa) 'tls))))))) -(declare-function format-spec "format-spec" (format spec)) -(declare-function format-spec-make "format-spec" (&rest pairs)) - (defun network-stream-open-shell (name buffer host service parameters) - (require 'format-spec) (let* ((capability-command (plist-get parameters :capability-command)) (eoc (plist-get parameters :end-of-command)) (start (with-current-buffer buffer (point))) @@ -467,9 +463,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." shell-command-switch (format-spec (plist-get parameters :shell-command) - (format-spec-make - ?s host - ?p service)))))) + `((?s . ,host) + (?p . ,service))))))) (when coding (if (consp coding) (set-process-coding-system stream (car coding) diff --git a/lisp/obsolete/tls.el b/lisp/obsolete/tls.el index cd091c0108e..d1b215cbfb8 100644 --- a/lisp/obsolete/tls.el +++ b/lisp/obsolete/tls.el @@ -47,9 +47,6 @@ (require 'gnutls) -(autoload 'format-spec "format-spec") -(autoload 'format-spec-make "format-spec") - (defgroup tls nil "Transport Layer Security (TLS) parameters." :group 'comm) @@ -224,14 +221,11 @@ Fourth arg PORT is an integer specifying a port to connect to." (while (and (not done) (setq cmd (pop cmds))) (let ((process-connection-type tls-process-connection-type) (formatted-cmd - (format-spec - cmd - (format-spec-make - ?t (car (gnutls-trustfiles)) - ?h host - ?p (if (integerp port) - (int-to-string port) - port))))) + (format-spec cmd `((?t . ,(car (gnutls-trustfiles))) + (?h . ,host) + (?p . ,(if (integerp port) + (number-to-string port) + port)))))) (message "Opening TLS connection with `%s'..." formatted-cmd) (setq process (start-process name buffer shell-file-name shell-command-switch diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 1b302e34a73..e3d5759579a 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -2295,9 +2295,6 @@ FILE is typically the output DVI or PDF file." (setq uptodate nil))))) uptodate))) - -(autoload 'format-spec "format-spec") - (defvar tex-executable-cache nil) (defun tex-executable-exists-p (name) "Like `executable-find' but with a cache." diff --git a/test/lisp/battery-tests.el b/test/lisp/battery-tests.el index 052ae49a800..4cb7470d884 100644 --- a/test/lisp/battery-tests.el +++ b/test/lisp/battery-tests.el @@ -52,7 +52,7 @@ "Test `battery-format'." (should (equal (battery-format "" ()) "")) (should (equal (battery-format "" '((?b . "-"))) "")) - (should (equal (battery-format "%a%b%p%%" '((?b . "-") (?p . "99"))) - "-99%"))) + (should (equal (battery-format "%2a%-3b%.1p%%" '((?b . "-") (?p . "99"))) + "- 9%"))) ;;; battery-tests.el ends here diff --git a/test/lisp/format-spec-tests.el b/test/lisp/format-spec-tests.el index 23ee88c5269..11882217afb 100644 --- a/test/lisp/format-spec-tests.el +++ b/test/lisp/format-spec-tests.el @@ -22,22 +22,145 @@ (require 'ert) (require 'format-spec) -(ert-deftest test-format-spec () +(ert-deftest format-spec-make () + "Test `format-spec-make'." + (should-not (format-spec-make)) + (should-error (format-spec-make ?b)) + (should (equal (format-spec-make ?b "b") '((?b . "b")))) + (should-error (format-spec-make ?b "b" ?a)) + (should (equal (format-spec-make ?b "b" ?a 'a) + '((?b . "b") + (?a . a))))) + +(ert-deftest format-spec-parse-flags () + "Test `format-spec--parse-flags'." + (should-not (format-spec--parse-flags nil)) + (should-not (format-spec--parse-flags "")) + (should (equal (format-spec--parse-flags "-") '(:pad-right))) + (should (equal (format-spec--parse-flags " 0") '(:pad-zero))) + (should (equal (format-spec--parse-flags " -x0y< >^_z ") + '(:pad-right :pad-zero :chop-left :chop-right + :upcase :downcase)))) + +(ert-deftest format-spec-do-flags () + "Test `format-spec--do-flags'." + (should (equal (format-spec--do-flags "" () nil nil) "")) + (dolist (flag '(:pad-zero :pad-right :upcase :downcase + :chop-left :chop-right)) + (should (equal (format-spec--do-flags "" (list flag) nil nil) ""))) + (should (equal (format-spec--do-flags "FOOBAR" '(:downcase :chop-right) 5 2) + " fo")) + (should (equal (format-spec--do-flags + "foobar" '(:pad-zero :pad-right :upcase :chop-left) 5 2) + "AR000"))) + +(ert-deftest format-spec-do-flags-truncate () + "Test `format-spec--do-flags' truncation." + (let (flags) + (should (equal (format-spec--do-flags "" flags nil 0) "")) + (should (equal (format-spec--do-flags "" flags nil 1) "")) + (should (equal (format-spec--do-flags "a" flags nil 0) "")) + (should (equal (format-spec--do-flags "a" flags nil 1) "a")) + (should (equal (format-spec--do-flags "a" flags nil 2) "a")) + (should (equal (format-spec--do-flags "asd" flags nil 0) "")) + (should (equal (format-spec--do-flags "asd" flags nil 1) "a"))) + (let ((flags '(:chop-left))) + (should (equal (format-spec--do-flags "" flags nil 0) "")) + (should (equal (format-spec--do-flags "" flags nil 1) "")) + (should (equal (format-spec--do-flags "a" flags nil 0) "")) + (should (equal (format-spec--do-flags "a" flags nil 1) "a")) + (should (equal (format-spec--do-flags "a" flags nil 2) "a")) + (should (equal (format-spec--do-flags "asd" flags nil 0) "")) + (should (equal (format-spec--do-flags "asd" flags nil 1) "d")))) + +(ert-deftest format-spec-do-flags-pad () + "Test `format-spec--do-flags' padding." + (let (flags) + (should (equal (format-spec--do-flags "" flags 0 nil) "")) + (should (equal (format-spec--do-flags "" flags 1 nil) " ")) + (should (equal (format-spec--do-flags "a" flags 0 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 2 nil) " a"))) + (let ((flags '(:pad-zero))) + (should (equal (format-spec--do-flags "" flags 0 nil) "")) + (should (equal (format-spec--do-flags "" flags 1 nil) "0")) + (should (equal (format-spec--do-flags "a" flags 0 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 2 nil) "0a"))) + (let ((flags '(:pad-right))) + (should (equal (format-spec--do-flags "" flags 0 nil) "")) + (should (equal (format-spec--do-flags "" flags 1 nil) " ")) + (should (equal (format-spec--do-flags "a" flags 0 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 2 nil) "a "))) + (let ((flags '(:pad-right :pad-zero))) + (should (equal (format-spec--do-flags "" flags 0 nil) "")) + (should (equal (format-spec--do-flags "" flags 1 nil) "0")) + (should (equal (format-spec--do-flags "a" flags 0 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 2 nil) "a0")))) + +(ert-deftest format-spec-do-flags-chop () + "Test `format-spec--do-flags' chopping." + (let ((flags '(:chop-left))) + (should (equal (format-spec--do-flags "a" flags 0 nil) "")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "asd" flags 0 nil) "")) + (should (equal (format-spec--do-flags "asd" flags 1 nil) "d"))) + (let ((flags '(:chop-right))) + (should (equal (format-spec--do-flags "a" flags 0 nil) "")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "asd" flags 0 nil) "")) + (should (equal (format-spec--do-flags "asd" flags 1 nil) "a")))) + +(ert-deftest format-spec-do-flags-case () + "Test `format-spec--do-flags' case fiddling." + (dolist (flag '(:pad-zero :pad-right :chop-left :chop-right)) + (let ((flags (list flag))) + (should (equal (format-spec--do-flags "a" flags nil nil) "a")) + (should (equal (format-spec--do-flags "A" flags nil nil) "A"))) + (let ((flags (list flag :downcase))) + (should (equal (format-spec--do-flags "a" flags nil nil) "a")) + (should (equal (format-spec--do-flags "A" flags nil nil) "a"))) + (let ((flags (list flag :upcase))) + (should (equal (format-spec--do-flags "a" flags nil nil) "A")) + (should (equal (format-spec--do-flags "A" flags nil nil) "A"))))) + +(ert-deftest format-spec () + (should (equal (format-spec "" ()) "")) + (should (equal (format-spec "a" ()) "a")) + (should (equal (format-spec "b" '((?b . "bar"))) "b")) + (should (equal (format-spec "%%%b%%b%b%%" '((?b . "bar"))) "%bar%bbar%")) (should (equal (format-spec "foo %b zot" `((?b . "bar"))) "foo bar zot")) (should (equal (format-spec "foo %-10b zot" '((?b . "bar"))) "foo bar zot")) (should (equal (format-spec "foo %10b zot" '((?b . "bar"))) - "foo bar zot"))) + "foo bar zot")) + (should (equal-including-properties + (format-spec (propertize "a" 'a 'b) '((?a . "foo"))) + #("a" 0 1 (a b)))) + (let ((fmt (concat (propertize "%a" 'a 'b) + (propertize "%%" 'c 'd) + "%b" + (propertize "%b" 'e 'f)))) + (should (equal-including-properties + (format-spec fmt '((?b . "asd") (?a . "fgh"))) + #("fgh%asdasd" 0 3 (a b) 3 4 (c d) 7 10 (e f)))))) -(ert-deftest test-format-unknown () +(ert-deftest format-spec-unknown () (should-error (format-spec "foo %b %z zot" '((?b . "bar")))) + (should-error (format-spec "foo %b %%%z zot" '((?b . "bar")))) (should (equal (format-spec "foo %b %z zot" '((?b . "bar")) t) "foo bar %z zot")) - (should (equal (format-spec "foo %b %z %% zot" '((?b . "bar")) t) - "foo bar %z %% zot"))) + (should (equal (format-spec "foo %4b %%%4z %%4 zot" '((?b . "bar")) t) + "foo bar %%%4z %%4 zot")) + (should (equal (format-spec "foo %4b %%%4z %%4 zot" '((?b . "bar")) 'ignore) + "foo bar %%4z %4 zot")) + (should (equal (format-spec "foo %4b %%%4z %%4 zot" '((?b . "bar")) 'delete) + "foo bar % %4 zot"))) -(ert-deftest test-format-modifiers () +(ert-deftest format-spec-flags () (should (equal (format-spec "foo %10b zot" '((?b . "bar"))) "foo bar zot")) (should (equal (format-spec "foo % 10b zot" '((?b . "bar"))) From 23a148c9506f2a5bce71bd5c8822bb7cde6697e8 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Thu, 11 Jun 2020 13:48:37 +0100 Subject: [PATCH 43/72] Various battery.el improvements (bug#41808) * lisp/battery.el: Mention BSD support in Commentary. Don't load preloaded lisp/emacs-lisp/timer.el. (battery--files): New function. (battery--find-linux-sysfs-batteries): Use it and make fewer syscalls. (battery-status-function): Perform GNU/Linux checks in increasing order of obsolescence: sysfs, ACPI, and then APM. Simplify Darwin check. Add :version tag now that battery-upower is the default. (battery-echo-area-format, battery-mode-line-format): Mention %s. (battery-load-low, battery-load-critical): New faces. (battery-update): Display battery-mode-line-format even if percentage is N/A. Apply faces battery-load-low or battery-load-critical according to the percentage, but append them so they don't override user customizations. Update all mode lines since we are in global-mode-string. (battery-linux-proc-apm-regexp): Mark as obsolete, replacing with... (battery--linux-proc-apm): ...this new rx definition. (battery-linux-proc-apm): Use it. Fix indentation. Simplify. (battery--acpi-rate, battery--acpi-capacity): New rx definitions. (battery-linux-proc-acpi): Use them. Fix pathological whitespace regexps. Simplify. (battery-linux-sysfs): Fix docstring and indentation. Reduce number of file searches. Simplify. (battery-bsd-apm): Fix docstring. Simplify. (battery-pmset): Fix docstring. Simplify ID regexp. * lisp/emacs-lisp/rx.el (rx-define): Indent as a defun. * test/lisp/battery-tests.el (battery-linux-proc-apm-regexp): Test new battery--linux-proc-apm rx definition. (battery-acpi-rate-regexp, battery-acpi-capacity-regexp): New tests. --- lisp/battery.el | 363 ++++++++++++++++++++----------------- lisp/emacs-lisp/rx.el | 2 +- test/lisp/battery-tests.el | 39 +++- 3 files changed, 229 insertions(+), 175 deletions(-) diff --git a/lisp/battery.el b/lisp/battery.el index 38728196507..f6f70b2f16d 100644 --- a/lisp/battery.el +++ b/lisp/battery.el @@ -23,18 +23,18 @@ ;;; Commentary: -;; There is at present support for GNU/Linux, macOS, and Windows. +;; There is at present support for GNU/Linux, BSD, macOS, and Windows. ;; This library supports: ;; - UPower (https://upower.freedesktop.org) via D-Bus API. -;; - the `/sys/class/power_supply/' files of Linux >= 2.6.39. -;; - the `/proc/acpi/' directory structure of Linux 2.4.20 and 2.6. -;; - the `/proc/apm' file format of Linux version 1.3.58 or newer. +;; - The `/sys/class/power_supply/' files of Linux >= 2.6.39. +;; - The `/proc/acpi/' directory structure of Linux 2.4.20 and 2.6. +;; - The `/proc/apm' file format of Linux version 1.3.58 or newer. +;; - BSD by using the `apm' program. ;; - Darwin (macOS) by using the `pmset' program. ;; - Windows via the GetSystemPowerStatus API call. ;;; Code: -(require 'timer) (require 'dbus) (eval-when-compile (require 'cl-lib)) @@ -60,37 +60,39 @@ If set to nil, then autodetect `:battery' device." (defconst battery-upower-dbus-service "org.freedesktop.UPower" "Well-known UPower service name for the D-Bus system.") +(defun battery--files (dir) + "Return a list of absolute file names in DIR or nil on error. +Value does not include \".\" or \"..\"." + (ignore-errors (directory-files dir t directory-files-no-dot-files-regexp))) + (defun battery--find-linux-sysfs-batteries () - (let ((dirs nil)) - (dolist (file (directory-files "/sys/class/power_supply/" t)) - (when (and (or (file-directory-p file) - (file-symlink-p file)) - (file-exists-p (expand-file-name "capacity" file))) - (push file dirs))) + "Return a list of all sysfs battery directories." + (let (dirs) + (dolist (dir (battery--files "/sys/class/power_supply/")) + (when (file-exists-p (expand-file-name "capacity" dir)) + (push dir dirs))) (nreverse dirs))) (defcustom battery-status-function (cond ((dbus-ping :system battery-upower-dbus-service) #'battery-upower) ((and (eq system-type 'gnu/linux) - (file-readable-p "/proc/apm")) - #'battery-linux-proc-apm) + (battery--find-linux-sysfs-batteries)) + #'battery-linux-sysfs) ((and (eq system-type 'gnu/linux) (file-directory-p "/proc/acpi/battery")) #'battery-linux-proc-acpi) ((and (eq system-type 'gnu/linux) - (file-directory-p "/sys/class/power_supply/") - (battery--find-linux-sysfs-batteries)) - #'battery-linux-sysfs) + (file-readable-p "/proc/apm")) + #'battery-linux-proc-apm) ((and (eq system-type 'berkeley-unix) (file-executable-p "/usr/sbin/apm")) #'battery-bsd-apm) ((and (eq system-type 'darwin) - (condition-case nil - (with-temp-buffer - (and (eq (call-process "pmset" nil t nil "-g" "ps") 0) - (> (buffer-size) 0))) - (error nil))) + (ignore-errors + (with-temp-buffer + (and (eq (call-process "pmset" nil t nil "-g" "ps") 0) + (not (bobp)))))) #'battery-pmset) ((fboundp 'w32-battery-status) #'w32-battery-status)) @@ -102,6 +104,7 @@ Its cons cells are of the form CONVERSION is the character code of a \"conversion specification\" introduced by a `%' character in a control string." + :version "28.1" :type '(choice (const nil) function)) (defcustom battery-echo-area-format @@ -113,12 +116,13 @@ string are substituted as defined by the current value of the variable `battery-status-function'. Here are the ones generally available: %c Current capacity (mAh or mWh) %r Current rate of charge or discharge +%L AC line status (verbose) %B Battery status (verbose) %b Battery status: empty means high, `-' means low, `!' means critical, and `+' means charging %d Temperature (in degrees Celsius) -%L AC line status (verbose) %p Battery load percentage +%s Remaining time (to charge or discharge) in seconds %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours %t Remaining time (to charge or discharge) in the form `h:min' @@ -137,7 +141,7 @@ The full `format-spec' formatting syntax is supported." :type 'integer) (defcustom battery-mode-line-format - (cond ((eq battery-status-function 'battery-linux-proc-acpi) + (cond ((eq battery-status-function #'battery-linux-proc-acpi) "[%b%p%%,%d°C]") (battery-status-function "[%b%p%%]")) @@ -148,12 +152,13 @@ string are substituted as defined by the current value of the variable `battery-status-function'. Here are the ones generally available: %c Current capacity (mAh or mWh) %r Current rate of charge or discharge +%L AC line status (verbose) %B Battery status (verbose) %b Battery status: empty means high, `-' means low, `!' means critical, and `+' means charging %d Temperature (in degrees Celsius) -%L AC line status (verbose) %p Battery load percentage +%s Remaining time (to charge or discharge) in seconds %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours %t Remaining time (to charge or discharge) in the form `h:min' @@ -176,6 +181,18 @@ A battery load percentage below this number is considered low." A battery load percentage below this number is considered critical." :type 'integer) +(defface battery-load-low + '((t :inherit warning)) + "Face used in mode line string when battery load is low. +See the option `battery-load-low'." + :version "28.1") + +(defface battery-load-critical + '((t :inherit error)) + "Face used in mode line string when battery load is critical. +See the option `battery-load-critical'." + :version "28.1") + (defvar battery-update-timer nil "Interval timer object.") @@ -208,7 +225,7 @@ seconds." (delq 'battery-mode-line-string global-mode-string)) (add-to-list 'global-mode-string 'battery-mode-line-string t) (setq battery-update-timer (run-at-time nil battery-update-interval - 'battery-update-handler)) + #'battery-update-handler)) (battery-update)) (message "Battery status not available") (setq display-battery-mode nil))) @@ -220,34 +237,42 @@ seconds." (defun battery-update () "Update battery status information in the mode line." (let* ((data (and battery-status-function (funcall battery-status-function))) - (percentage (car (read-from-string (cdr (assq ?p data)))))) - (setq battery-mode-line-string - (propertize (if (and battery-mode-line-format - (numberp percentage) - (<= percentage battery-mode-line-limit)) - (battery-format battery-mode-line-format data) - "") - 'face - (and (numberp percentage) - (<= percentage battery-load-critical) - 'error) - 'help-echo "Battery status information"))) - (force-mode-line-update)) + (percentage (car (read-from-string (cdr (assq ?p data))))) + (res (and battery-mode-line-format + (or (not (numberp percentage)) + (<= percentage battery-mode-line-limit)) + (battery-format battery-mode-line-format data))) + (len (length res))) + (unless (zerop len) + (cond ((not (numberp percentage))) + ((< percentage battery-load-critical) + (add-face-text-property 0 len 'battery-load-critical t res)) + ((< percentage battery-load-low) + (add-face-text-property 0 len 'battery-load-low t res))) + (put-text-property 0 len 'help-echo "Battery status information" res)) + (setq battery-mode-line-string (or res ""))) + (force-mode-line-update t)) + ;;; `/proc/apm' interface for Linux. -(defconst battery-linux-proc-apm-regexp - (concat "^\\([^ ]+\\)" ; Driver version. - " \\([^ ]+\\)" ; APM BIOS version. - " 0x\\([0-9a-f]+\\)" ; APM BIOS flags. - " 0x\\([0-9a-f]+\\)" ; AC line status. - " 0x\\([0-9a-f]+\\)" ; Battery status. - " 0x\\([0-9a-f]+\\)" ; Battery flags. - " \\(-?[0-9]+\\)%" ; Load percentage. - " \\(-?[0-9]+\\)" ; Remaining time. - " \\(.*\\)" ; Time unit. - "$") +;; Regular expression matching contents of `/proc/apm'. +(rx-define battery--linux-proc-apm + (: bol (group (+ (not ?\s))) ; Driver version. + " " (group (+ (not ?\s))) ; APM BIOS version. + " 0x" (group (+ xdigit)) ; APM BIOS flags. + " 0x" (group (+ xdigit)) ; AC line status. + " 0x" (group (+ xdigit)) ; Battery status. + " 0x" (group (+ xdigit)) ; Battery flags. + " " (group (? ?-) (+ digit)) ?% ; Load percentage. + " " (group (? ?-) (+ digit)) ; Remaining time. + " " (group (* nonl)) ; Time unit + eol)) + +(defconst battery-linux-proc-apm-regexp (rx battery--linux-proc-apm) "Regular expression matching contents of `/proc/apm'.") +(make-obsolete-variable 'battery-linux-proc-apm-regexp + "it is no longer used." "28.1") (defun battery-linux-proc-apm () "Get APM status information from Linux (the kernel). @@ -267,12 +292,12 @@ The following %-sequences are provided: %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours %t Remaining time (to charge or discharge) in the form `h:min'" - (let (driver-version bios-version bios-interface line-status - battery-status battery-status-symbol load-percentage - seconds minutes hours remaining-time tem) + (let ( driver-version bios-version bios-interface line-status + battery-status battery-status-symbol load-percentage + seconds minutes hours remaining-time tem ) (with-temp-buffer (ignore-errors (insert-file-contents "/proc/apm")) - (when (re-search-forward battery-linux-proc-apm-regexp) + (when (re-search-forward (rx battery--linux-proc-apm) nil t) (setq driver-version (match-string 1)) (setq bios-version (match-string 2)) (setq tem (string-to-number (match-string 3) 16)) @@ -285,9 +310,7 @@ The following %-sequences are provided: (cond ((= tem 0) (setq line-status "off-line")) ((= tem 1) (setq line-status "on-line")) ((= tem 2) (setq line-status "on backup"))) - (setq tem (string-to-number (match-string 6) 16)) - (if (= tem 255) - (setq battery-status "N/A") + (unless (= (string-to-number (match-string 6) 16) 255) (setq tem (string-to-number (match-string 5) 16)) (cond ((= tem 0) (setq battery-status "high" battery-status-symbol "")) @@ -304,7 +327,7 @@ The following %-sequences are provided: (setq minutes (/ seconds 60) hours (/ seconds 3600)) (setq remaining-time - (format "%d:%02d" hours (- minutes (* 60 hours)))))))) + (format "%d:%02d" hours (% minutes 60))))))) (list (cons ?v (or driver-version "N/A")) (cons ?V (or bios-version "N/A")) (cons ?I (or bios-interface "N/A")) @@ -312,27 +335,31 @@ The following %-sequences are provided: (cons ?B (or battery-status "N/A")) (cons ?b (or battery-status-symbol "")) (cons ?p (or load-percentage "N/A")) - (cons ?s (or (and seconds (number-to-string seconds)) "N/A")) - (cons ?m (or (and minutes (number-to-string minutes)) "N/A")) - (cons ?h (or (and hours (number-to-string hours)) "N/A")) + (cons ?s (if seconds (number-to-string seconds) "N/A")) + (cons ?m (if minutes (number-to-string minutes) "N/A")) + (cons ?h (if hours (number-to-string hours) "N/A")) (cons ?t (or remaining-time "N/A"))))) ;;; `/proc/acpi/' interface for Linux. +(rx-define battery--acpi-rate (&rest hour) + (: (group (+ digit)) " " (group ?m (in "AW") hour))) +(rx-define battery--acpi-capacity (battery--acpi-rate ?h)) + (defun battery-linux-proc-acpi () "Get ACPI status information from Linux (the kernel). -This function works only with the `/proc/acpi/' format introduced -in Linux version 2.4.20 and 2.6.0. +This function works only with the `/proc/acpi/' interface +introduced in Linux version 2.4.20 and 2.6.0. The following %-sequences are provided: %c Current capacity (mAh) -%r Current rate +%r Current rate of charge or discharge +%L AC line status (verbose) %B Battery status (verbose) %b Battery status, empty means high, `-' means low, `!' means critical, and `+' means charging %d Temperature (in degrees Celsius) -%L AC line status (verbose) %p Battery load percentage %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours @@ -348,45 +375,51 @@ The following %-sequences are provided: ;; information together since displaying for a variable amount of ;; batteries seems overkill for format-strings. (with-temp-buffer - (dolist (dir (ignore-errors (directory-files "/proc/acpi/battery/" - t "\\`[^.]"))) - (erase-buffer) - (ignore-errors (insert-file-contents (expand-file-name "state" dir))) - (when (re-search-forward "present: +yes$" nil t) - (and (re-search-forward "charging state: +\\(.*\\)$" nil t) + (dolist (dir (battery--files "/proc/acpi/battery/")) + (ignore-errors + (insert-file-contents (expand-file-name "state" dir) nil nil nil t)) + (goto-char (point-min)) + (when (re-search-forward (rx "present:" (+ space) "yes" eol) nil t) + (and (re-search-forward (rx "charging state:" (+ space) + (group (not space) (* nonl)) eol) + nil t) (member charging-state '("unknown" "charged" nil)) ;; On most multi-battery systems, most of the time only one ;; battery is "charging"/"discharging", the others are ;; "unknown". (setq charging-state (match-string 1))) - (when (re-search-forward "present rate: +\\([0-9]+\\) \\(m[AW]\\)$" + (when (re-search-forward (rx "present rate:" (+ space) + (battery--acpi-rate) eol) nil t) (setq rate (+ (or rate 0) (string-to-number (match-string 1)))) (when (> rate 0) - (setq rate-type (or (and rate-type - (if (string= rate-type (match-string 2)) - rate-type - (error - "Inconsistent rate types (%s vs. %s)" - rate-type (match-string 2)))) - (match-string 2))))) - (when (re-search-forward "remaining capacity: +\\([0-9]+\\) m[AW]h$" + (cond ((not rate-type) + (setq rate-type (match-string 2))) + ((not (string= rate-type (match-string 2))) + (error "Inconsistent rate types (%s vs. %s)" + rate-type (match-string 2)))))) + (when (re-search-forward (rx "remaining capacity:" (+ space) + battery--acpi-capacity eol) nil t) (setq capacity (+ (or capacity 0) (string-to-number (match-string 1)))))) (goto-char (point-max)) (ignore-errors (insert-file-contents (expand-file-name "info" dir))) - (when (re-search-forward "present: +yes$" nil t) - (when (re-search-forward "design capacity: +\\([0-9]+\\) m[AW]h$" + (when (re-search-forward (rx "present:" (+ space) "yes" eol) nil t) + (when (re-search-forward (rx "design capacity:" (+ space) + battery--acpi-capacity eol) nil t) (cl-incf design-capacity (string-to-number (match-string 1)))) - (when (re-search-forward "last full capacity: +\\([0-9]+\\) m[AW]h$" + (when (re-search-forward (rx "last full capacity:" (+ space) + battery--acpi-capacity eol) nil t) (cl-incf last-full-capacity (string-to-number (match-string 1)))) - (when (re-search-forward - "design capacity warning: +\\([0-9]+\\) m[AW]h$" nil t) + (when (re-search-forward (rx "design capacity warning:" (+ space) + battery--acpi-capacity eol) + nil t) (cl-incf warn (string-to-number (match-string 1)))) - (when (re-search-forward "design capacity low: +\\([0-9]+\\) m[AW]h$" + (when (re-search-forward (rx "design capacity low:" (+ space) + battery--acpi-capacity eol) nil t) (cl-incf low (string-to-number (match-string 1))))))) (setq full-capacity (if (> last-full-capacity 0) @@ -400,79 +433,70 @@ The following %-sequences are provided: 60) rate)) hours (/ minutes 60))) - (list (cons ?c (or (and capacity (number-to-string capacity)) "N/A")) + (list (cons ?c (if capacity (number-to-string capacity) "N/A")) (cons ?L (or (battery-search-for-one-match-in-files - (mapcar (lambda (e) (concat e "/state")) - (ignore-errors - (directory-files "/proc/acpi/ac_adapter/" - t "\\`[^.]"))) - "state: +\\(.*\\)$" 1) - + (mapcar (lambda (d) (expand-file-name "state" d)) + (battery--files "/proc/acpi/ac_adapter/")) + (rx "state:" (+ space) (group (not space) (* nonl)) eol) + 1) "N/A")) (cons ?d (or (battery-search-for-one-match-in-files - (mapcar (lambda (e) (concat e "/temperature")) - (ignore-errors - (directory-files "/proc/acpi/thermal_zone/" - t "\\`[^.]"))) - "temperature: +\\([0-9]+\\) C$" 1) - + (mapcar (lambda (d) (expand-file-name "temperature" d)) + (battery--files "/proc/acpi/thermal_zone/")) + (rx "temperature:" (+ space) (group (+ digit)) " C" eol) + 1) "N/A")) - (cons ?r (or (and rate (concat (number-to-string rate) " " - rate-type)) "N/A")) + (cons ?r (if rate + (concat (number-to-string rate) " " rate-type) + "N/A")) (cons ?B (or charging-state "N/A")) - (cons ?b (or (and (string= charging-state "charging") "+") - (and capacity (< capacity low) "!") - (and capacity (< capacity warn) "-") - "")) - (cons ?h (or (and hours (number-to-string hours)) "N/A")) - (cons ?m (or (and minutes (number-to-string minutes)) "N/A")) - (cons ?t (or (and minutes - (format "%d:%02d" hours (- minutes (* 60 hours)))) - "N/A")) - (cons ?p (or (and full-capacity capacity - (> full-capacity 0) - (number-to-string - (floor (* 100 capacity) full-capacity))) - "N/A"))))) + (cons ?b (cond ((string= charging-state "charging") "+") + ((and capacity (< capacity low)) "!") + ((and capacity (< capacity warn)) "-") + (""))) + (cons ?h (if hours (number-to-string hours) "N/A")) + (cons ?m (if minutes (number-to-string minutes) "N/A")) + (cons ?t (if minutes (format "%d:%02d" hours (% minutes 60)) "N/A")) + (cons ?p (if (and full-capacity capacity (> full-capacity 0)) + (number-to-string (floor (* 100 capacity) full-capacity)) + "N/A"))))) ;;; `/sys/class/power_supply/BATN' interface for Linux. (defun battery-linux-sysfs () - "Get ACPI status information from Linux kernel. + "Get sysfs status information from Linux kernel. This function works only with the new `/sys/class/power_supply/' -format introduced in Linux version 2.4.25. +interface introduced in Linux version 2.4.25. The following %-sequences are provided: %c Current capacity (mAh or mWh) -%r Current rate +%r Current rate of charge or discharge +%L Power source (verbose) %B Battery status (verbose) %b Battery status, empty means high, `-' means low, `!' means critical, and `+' means charging %d Temperature (in degrees Celsius) %p Battery load percentage -%L AC line status (verbose) %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours %t Remaining time (to charge or discharge) in the form `h:min'" - (let (charging-state temperature hours percentage-now - ;; Some batteries report charges and current, other energy and power. + (let (;; Some batteries report charges and current, others energy and power. ;; In order to reliably be able to combine those data, we convert them ;; all to energy/power (since we can't combine different charges if ;; they're not at the same voltage). (energy-full 0.0) (energy-now 0.0) (power-now 0.0) - (voltage-now 10.8)) ;Arbitrary default, in case the info is missing. + (voltage-now 10.8) ; Arbitrary default, in case the info is missing. + charging-state temperature hours percentage-now) ;; SysFS provides information about each battery present in the ;; system in a separate subdirectory. We are going to merge the ;; available information together. (with-temp-buffer - (dolist (dir (ignore-errors - (battery--find-linux-sysfs-batteries))) - (erase-buffer) - (ignore-errors (insert-file-contents - (expand-file-name "uevent" dir))) + (dolist (dir (battery--find-linux-sysfs-batteries)) + (ignore-errors + (insert-file-contents (expand-file-name "uevent" dir) nil nil nil t)) (goto-char (point-min)) (when (re-search-forward "POWER_SUPPLY_VOLTAGE_NOW=\\([0-9]*\\)$" nil t) @@ -508,7 +532,7 @@ The following %-sequences are provided: voltage-now)) (cl-incf energy-now (* (string-to-number now-string) voltage-now))) - ((and (progn (goto-char (point-min)) t) + ((and (goto-char (point-min)) (re-search-forward "POWER_SUPPLY_ENERGY_FULL=\\([0-9]*\\)$" nil t) (setq full-string (match-string 1)) @@ -517,7 +541,6 @@ The following %-sequences are provided: (setq now-string (match-string 1))) (cl-incf energy-full (string-to-number full-string)) (cl-incf energy-now (string-to-number now-string))))) - (goto-char (point-min)) (unless (zerop power-now) (let ((remaining (if (string= charging-state "Discharging") energy-now @@ -525,9 +548,9 @@ The following %-sequences are provided: (setq hours (/ remaining power-now))))))) (when (and (> energy-full 0) (> energy-now 0)) (setq percentage-now (/ (* 100 energy-now) energy-full))) - (list (cons ?c (cond ((or (> energy-full 0) (> energy-now 0)) - (number-to-string (/ energy-now voltage-now))) - (t "N/A"))) + (list (cons ?c (if (or (> energy-full 0) (> energy-now 0)) + (number-to-string (/ energy-now voltage-now)) + "N/A")) (cons ?r (if (> power-now 0.0) (format "%.1f" (/ power-now 1000000.0)) "N/A")) @@ -538,27 +561,20 @@ The following %-sequences are provided: "N/A")) (cons ?d (or temperature "N/A")) (cons ?B (or charging-state "N/A")) - (cons ?b (or (and (string= charging-state "Charging") "+") - (and percentage-now (< percentage-now battery-load-critical) "!") - (and percentage-now (< percentage-now battery-load-low) "-") - "")) - (cons ?p (cond - ((and percentage-now (format "%.1f" percentage-now))) - (t "N/A"))) - (cons ?L (cond - ((battery-search-for-one-match-in-files - (list "/sys/class/power_supply/AC/online" - "/sys/class/power_supply/ACAD/online" - "/sys/class/power_supply/ADP1/online") - "1" 0) - "AC") - ((battery-search-for-one-match-in-files - (list "/sys/class/power_supply/AC/online" - "/sys/class/power_supply/ACAD/online" - "/sys/class/power_supply/ADP1/online") - "0" 0) - "BAT") - (t "N/A")))))) + (cons ?b (cond ((string= charging-state "Charging") "+") + ((not percentage-now) "") + ((< percentage-now battery-load-critical) "!") + ((< percentage-now battery-load-low) "-") + (""))) + (cons ?p (if percentage-now (format "%.1f" percentage-now) "N/A")) + (cons ?L (pcase (battery-search-for-one-match-in-files + '("/sys/class/power_supply/AC/online" + "/sys/class/power_supply/ACAD/online" + "/sys/class/power_supply/ADP1/online") + (rx (in "01")) 0) + ("0" "BAT") + ("1" "AC") + (_ "N/A")))))) ;;; `upowerd' interface. @@ -681,19 +697,20 @@ The following %-sequences are provided: ;;; `apm' interface for BSD. + (defun battery-bsd-apm () "Get APM status information from BSD apm binary. The following %-sequences are provided: +%P Advanced power saving mode state (verbose) %L AC line status (verbose) %B Battery status (verbose) %b Battery status, empty means high, `-' means low, - `!' means critical, and `+' means charging -%P Advanced power saving mode state (verbose) -%p Battery charge percentage -%s Remaining battery charge time in seconds -%m Remaining battery charge time in minutes -%h Remaining battery charge time in hours -%t Remaining battery charge time in the form `h:min'" + `!' means critical, and `+' means charging +%p Battery load percentage +%s Remaining time (to charge or discharge) in seconds +%m Remaining time (to charge or discharge) in minutes +%h Remaining time (to charge or discharge) in hours +%t Remaining time (to charge or discharge) in the form `h:min'" (let* ((os-name (car (split-string ;; FIXME: Can't we use something like `system-type'? (shell-command-to-string "/usr/bin/uname")))) @@ -759,7 +776,7 @@ The following %-sequences are provided: (setq seconds (string-to-number battery-life) minutes (truncate seconds 60))) (setq hours (truncate minutes 60) - remaining-time (format "%d:%02d" hours (mod minutes 60)))) + remaining-time (format "%d:%02d" hours (% minutes 60)))) (list (cons ?L (or line-status "N/A")) (cons ?B (or (car battery-status) "N/A")) (cons ?b (or (cdr battery-status) "N/A")) @@ -767,9 +784,9 @@ The following %-sequences are provided: "N/A" battery-percentage)) (cons ?P (or apm-mode "N/A")) - (cons ?s (or (and seconds (number-to-string seconds)) "N/A")) - (cons ?m (or (and minutes (number-to-string minutes)) "N/A")) - (cons ?h (or (and hours (number-to-string hours)) "N/A")) + (cons ?s (if seconds (number-to-string seconds) "N/A")) + (cons ?m (if minutes (number-to-string minutes) "N/A")) + (cons ?h (if hours (number-to-string hours) "N/A")) (cons ?t (or remaining-time "N/A"))))) @@ -784,21 +801,25 @@ The following %-sequences are provided: %b Battery status, empty means high, `-' means low, `!' means critical, and `+' means charging %p Battery load percentage -%h Remaining time in hours -%m Remaining time in minutes -%t Remaining time in the form `h:min'" - (let (power-source load-percentage battery-status battery-status-symbol - remaining-time hours minutes) +%m Remaining time (to charge or discharge) in minutes +%h Remaining time (to charge or discharge) in hours +%t Remaining time (to charge or discharge) in the form `h:min'" + (let ( power-source load-percentage battery-status battery-status-symbol + remaining-time hours minutes ) (with-temp-buffer (ignore-errors (call-process "pmset" nil t nil "-g" "ps")) (goto-char (point-min)) - (when (re-search-forward "\\(?:Currentl?y\\|Now\\) drawing from '\\(AC\\|Battery\\) Power'" nil t) + (when (re-search-forward ;; Handle old typo in output. + "\\(?:Currentl?y\\|Now\\) drawing from '\\(AC\\|Battery\\) Power'" + nil t) (setq power-source (match-string 1)) - (when (re-search-forward "^ -InternalBattery-0\\([ \t]+(id=[0-9]+)\\)*[ \t]+" nil t) + (when (re-search-forward (rx bol " -InternalBattery-0" (+ space) + (* "(id=" (+ digit) ")" (+ space))) + nil t) (when (looking-at "\\([0-9]\\{1,3\\}\\)%") (setq load-percentage (match-string 1)) (goto-char (match-end 0)) - (cond ((looking-at "; charging") + (cond ((looking-at-p "; charging") (setq battery-status "charging" battery-status-symbol "+")) ((< (string-to-number load-percentage) battery-load-critical) diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index aa4b2addd47..88bb0a8bd6c 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1381,7 +1381,7 @@ To make local rx extensions, use `rx-let' for `rx', For more details, see Info node `(elisp) Extending Rx'. \(fn NAME [(ARGS...)] RX)" - (declare (indent 1)) + (declare (indent defun)) `(eval-and-compile (put ',name 'rx-definition ',(rx--make-binding name definition)) ',name)) diff --git a/test/lisp/battery-tests.el b/test/lisp/battery-tests.el index 4cb7470d884..92ab013f040 100644 --- a/test/lisp/battery-tests.el +++ b/test/lisp/battery-tests.el @@ -22,9 +22,9 @@ (require 'battery) (ert-deftest battery-linux-proc-apm-regexp () - "Test `battery-linux-proc-apm-regexp'." + "Test `rx' definition `battery--linux-proc-apm'." (let ((str "1.16 1.2 0x07 0x01 0xff 0x80 -1% -1 ?")) - (should (string-match battery-linux-proc-apm-regexp str)) + (should (string-match (rx battery--linux-proc-apm) str)) (should (equal (match-string 0 str) str)) (should (equal (match-string 1 str) "1.16")) (should (equal (match-string 2 str) "1.2")) @@ -36,7 +36,7 @@ (should (equal (match-string 8 str) "-1")) (should (equal (match-string 9 str) "?"))) (let ((str "1.16 1.2 0x03 0x00 0x00 0x01 99% 1792 min")) - (should (string-match battery-linux-proc-apm-regexp str)) + (should (string-match (rx battery--linux-proc-apm) str)) (should (equal (match-string 0 str) str)) (should (equal (match-string 1 str) "1.16")) (should (equal (match-string 2 str) "1.2")) @@ -48,6 +48,39 @@ (should (equal (match-string 8 str) "1792")) (should (equal (match-string 9 str) "min")))) +(ert-deftest battery-acpi-rate-regexp () + "Test `rx' definition `battery--acpi-rate'." + (let ((str "01 mA")) + (should (string-match (rx (battery--acpi-rate)) str)) + (should (equal (match-string 0 str) str)) + (should (equal (match-string 1 str) "01")) + (should (equal (match-string 2 str) "mA"))) + (let ((str "23 mW")) + (should (string-match (rx (battery--acpi-rate)) str)) + (should (equal (match-string 0 str) str)) + (should (equal (match-string 1 str) "23")) + (should (equal (match-string 2 str) "mW"))) + (let ((str "23 mWh")) + (should (string-match (rx (battery--acpi-rate)) str)) + (should (equal (match-string 0 str) "23 mW")) + (should (equal (match-string 1 str) "23")) + (should (equal (match-string 2 str) "mW"))) + (should-not (string-match (rx (battery--acpi-rate) eos) "45 mWh"))) + +(ert-deftest battery-acpi-capacity-regexp () + "Test `rx' definition `battery--acpi-capacity'." + (let ((str "01 mAh")) + (should (string-match (rx battery--acpi-capacity) str)) + (should (equal (match-string 0 str) str)) + (should (equal (match-string 1 str) "01")) + (should (equal (match-string 2 str) "mAh"))) + (let ((str "23 mWh")) + (should (string-match (rx battery--acpi-capacity) str)) + (should (equal (match-string 0 str) str)) + (should (equal (match-string 1 str) "23")) + (should (equal (match-string 2 str) "mWh"))) + (should-not (string-match (rx battery--acpi-capacity eos) "45 mW"))) + (ert-deftest battery-format () "Test `battery-format'." (should (equal (battery-format "" ()) "")) From 453d30d92cbf940567869d4705c1fcfe57725825 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Thu, 11 Jun 2020 13:49:31 +0100 Subject: [PATCH 44/72] Improve battery.el UPower support For discussion, see the following threads: https://lists.gnu.org/archive/html/emacs-devel/2020-01/msg00843.html https://lists.gnu.org/archive/html/emacs-devel/2020-02/msg00042.html https://lists.gnu.org/archive/html/emacs-devel/2020-02/msg00282.html * etc/NEWS: Announce that battery-upower is enabled by default. * lisp/battery.el (battery-upower-device): Accept both battery and line power device names, or a list thereof (bug#39491). (battery-upower-line-power-device): Remove user option; superseded by battery-upower-device. (battery-upower-subscribe): New user option. (battery-status-function): Check whether a UPower service is provided without activating it. (display-battery-mode): Subscribe to UPower signals when using battery-upower. (battery-upower): Merge data from multiple power sources. Calculate terse battery status %b based on average battery load percentage rather than coarse and often missing BatteryLevel (bug#39491). Add support for average temperature %d. (battery-upower-dbus-service) (battery-upower-dbus-interface) (battery-upower-dbus-path) (battery-upower-dbus-device-interface) (battery-upower-dbus-device-path) (battery-upower-device-all-properties): Rename to... (battery-upower-service) (battery-upower-interface) (battery-upower-path) (battery-upower-device-interface) (battery-upower-device-path) (battery--upower-device-properties): ...these, respectively. (battery-upower-device-list): Rename to... (battery--upower-devices) ...this. Return a flat list of device names determined by battery-upower-device. (battery-upower-types, battery-upower-states) (battery-upower-device-property, battery-upower-device-autodetect): Remove. (battery--upower-signals): New variable. (battery--upower-signal-handler, battery--upower-props-changed) (battery--upower-unsubscribe, battery--upower-subsribe) (battery--upower-state): New functions. * test/lisp/battery-tests.el (battery-upower-state) (battery-upower-state-unknown): New tests. --- etc/NEWS | 10 ++ lisp/battery.el | 282 +++++++++++++++++++++++-------------- test/lisp/battery-tests.el | 63 +++++++++ 3 files changed, 250 insertions(+), 105 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 4d730228139..2ddb5fb089d 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -463,6 +463,16 @@ have now been removed. ** Battery +--- +*** UPower is now the default battery status backend when available. +UPower support via the function 'battery-upower' was added in Emacs +26.1, but was disabled by default. It is now the default value of +'battery-status-function' when the system provides a UPower D-Bus +service. The user options 'battery-upower-device' and +'battery-upower-subscribe' control which power sources to query and +whether to respond to status change notifications in addition to +polling, respectively. + --- *** A richer syntax can be used to format battery status information. The user options 'battery-mode-line-format' and diff --git a/lisp/battery.el b/lisp/battery.el index f6f70b2f16d..e568ab52460 100644 --- a/lisp/battery.el +++ b/lisp/battery.el @@ -44,21 +44,40 @@ :group 'hardware) (defcustom battery-upower-device nil - "UPower device of the `:battery' type. -Use `battery-upower-device-list' to list all available UPower devices. -If set to nil, then autodetect `:battery' device." - :version "28.1" - :type '(choice string (const :tag "Autodetect" nil))) + "Preferred UPower device name(s). +When `battery-status-function' is set to `battery-upower', this +user option specifies which power sources to query for status +information and merge into a single report. -(defcustom battery-upower-line-power-device nil - "UPower device of the `:line-power' type. -Use `battery-upower-device-list' to list all available UPower devices. -If set to nil, then autodetect `:battery' device." +When nil (the default), `battery-upower' queries all present +battery and line power devices as determined by the UPower +EnumerateDevices method. A string or a nonempty list of strings +names particular devices to query instead. UPower battery and +line power device names typically follow the patterns +\"battery_BATN\" and \"line_power_ACN\", respectively, with N +starting at 0 when present. Device names should not include the +leading D-Bus path \"/org/freedesktop/UPower/devices/\"." :version "28.1" - :type '(choice string (const :tag "Autodetect" nil))) + :type '(choice (const :tag "Autodetect all devices" nil) + (string :tag "Device") + (repeat :tag "Devices" string))) -(defconst battery-upower-dbus-service "org.freedesktop.UPower" - "Well-known UPower service name for the D-Bus system.") +(defcustom battery-upower-subscribe t + "Whether to subscribe to UPower device change signals. +When nil, battery status information is polled every +`battery-update-interval' seconds. When non-nil (the default), +the battery status is also updated whenever a power source is +added or removed, or when the system starts or stops running on +battery power. + +This only takes effect when `battery-status-function' is set to +`battery-upower' before enabling `display-battery-mode'." + :version "28.1" + :type 'boolean) + +(defconst battery-upower-service "org.freedesktop.UPower" + "Well-known name of the UPower D-Bus service. +See URL `https://upower.freedesktop.org/docs/ref-dbus.html'.") (defun battery--files (dir) "Return a list of absolute file names in DIR or nil on error. @@ -74,7 +93,7 @@ Value does not include \".\" or \"..\"." (nreverse dirs))) (defcustom battery-status-function - (cond ((dbus-ping :system battery-upower-dbus-service) + (cond ((member battery-upower-service (dbus-list-activatable-names)) #'battery-upower) ((and (eq system-type 'gnu/linux) (battery--find-linux-sysfs-batteries)) @@ -219,11 +238,15 @@ seconds." (setq battery-mode-line-string "") (or global-mode-string (setq global-mode-string '(""))) (and battery-update-timer (cancel-timer battery-update-timer)) + (battery--upower-unsubscribe) (if (and battery-status-function battery-mode-line-format) (if (not display-battery-mode) (setq global-mode-string (delq 'battery-mode-line-string global-mode-string)) (add-to-list 'global-mode-string 'battery-mode-line-string t) + (and (eq battery-status-function #'battery-upower) + battery-upower-subscribe + (battery--upower-subsribe)) (setq battery-update-timer (run-at-time nil battery-update-interval #'battery-update-handler)) (battery-update)) @@ -577,123 +600,172 @@ The following %-sequences are provided: (_ "N/A")))))) -;;; `upowerd' interface. -(defconst battery-upower-dbus-interface "org.freedesktop.UPower" - "The interface to UPower. -See URL `https://upower.freedesktop.org/docs/'.") +;;; UPower interface. -(defconst battery-upower-dbus-path "/org/freedesktop/UPower" - "D-Bus path to talk to UPower service.") +(defconst battery-upower-interface "org.freedesktop.UPower" + "Name of the UPower D-Bus interface. +See URL `https://upower.freedesktop.org/docs/UPower.html'.") -(defconst battery-upower-dbus-device-interface - (concat battery-upower-dbus-interface ".Device") - "The Device interface of the UPower. +(defconst battery-upower-path "/org/freedesktop/UPower" + "D-Bus object providing `battery-upower-interface'.") + +(defconst battery-upower-device-interface "org.freedesktop.UPower.Device" + "Name of the UPower Device D-Bus interface. See URL `https://upower.freedesktop.org/docs/Device.html'.") -(defconst battery-upower-dbus-device-path - (concat battery-upower-dbus-path "/devices") - "D-Bus path to talk to devices part of the UPower service.") +(defconst battery-upower-device-path "/org/freedesktop/UPower/devices" + "D-Bus object providing `battery-upower-device-interface'.") -(defconst battery-upower-types - '((0 . :unknown) (1 . :line-power) (2 . :battery) - (3 . :ups) (4 . :monitor) (5 . :mouse) - (6 . :keyboard) (7 . :pda) (8 . :phone)) - "Type of the device.") +(defvar battery--upower-signals nil + "Handles for UPower signal subscriptions.") -(defconst battery-upower-states - '((0 . "unknown") (1 . "charging") (2 . "discharging") - (3 . "empty") (4 . "fully-charged") (5 . "pending-charge") - (6 . "pending-discharge")) - "Alist of battery power states. -Only valid for `:battery' devices.") +(defun battery--upower-signal-handler (&rest _) + "Update battery status on receiving a UPower D-Bus signal." + (timer-event-handler battery-update-timer)) -(defun battery-upower-device-property (device property) - "Get value of the single PROPERTY for the UPower DEVICE." - (dbus-get-property - :system battery-upower-dbus-service - (expand-file-name device battery-upower-dbus-device-path) - battery-upower-dbus-device-interface - property)) +(defun battery--upower-props-changed (_interface changed _invalidated) + "Update status when system starts/stops running on battery. +Intended as a UPower PropertiesChanged signal handler." + (when (assoc "OnBattery" changed) + (battery--upower-signal-handler))) -(defun battery-upower-device-all-properties (device) +(defun battery--upower-unsubscribe () + "Unsubscribe from UPower device change signals." + (mapc #'dbus-unregister-object battery--upower-signals) + (setq battery--upower-signals ())) + +(defun battery--upower-subsribe () + "Subscribe to UPower device change signals." + (push (dbus-register-signal :system battery-upower-service + battery-upower-path + dbus-interface-properties + "PropertiesChanged" + #'battery--upower-props-changed) + battery--upower-signals) + (dolist (method '("DeviceAdded" "DeviceRemoved")) + (push (dbus-register-signal :system battery-upower-service + battery-upower-path + battery-upower-interface + method #'battery--upower-signal-handler) + battery--upower-signals))) + +(defun battery--upower-device-properties (device) "Return value for all available properties for the UPower DEVICE." (dbus-get-all-properties - :system battery-upower-dbus-service - (expand-file-name device battery-upower-dbus-device-path) - battery-upower-dbus-device-interface)) + :system battery-upower-service + (expand-file-name device battery-upower-device-path) + battery-upower-device-interface)) -(defun battery-upower-device-list () - "Return list of all available UPower devices. -Each element is the cons cell in form: (DEVICE . DEVICE-TYPE)." - (mapcar (lambda (device-path) - (let* ((device (file-relative-name - device-path battery-upower-dbus-device-path)) - (type-num (battery-upower-device-property device "Type"))) - (cons device (or (cdr (assq type-num battery-upower-types)) - :unknown)))) - (dbus-call-method :system battery-upower-dbus-service - battery-upower-dbus-path - battery-upower-dbus-interface - "EnumerateDevices"))) +(defun battery--upower-devices () + "List all UPower devices according to `battery-upower-device'." + (cond ((stringp battery-upower-device) + (list battery-upower-device)) + (battery-upower-device) + ((dbus-call-method :system battery-upower-service + battery-upower-path + battery-upower-interface + "EnumerateDevices")))) -(defun battery-upower-device-autodetect (device-type) - "Return first matching UPower device of DEVICE-TYPE." - (car (rassq device-type (battery-upower-device-list)))) +(defun battery--upower-state (props state) + "Merge the UPower battery state in PROPS with STATE. +This is an extension of the UPower DisplayDevice algorithm for +merging multiple battery states into one. PROPS is an alist of +battery properties from `battery-upower-device-interface', and +STATE is a symbol representing the state to merge with." + ;; Map UPower enum into our printable symbols. + (let* ((new (pcase (cdr (assoc "State" props)) + (1 'charging) + (2 'discharging) + (3 'empty) + (4 'fully-charged) + (5 'pending-charge) + (6 'pending-discharge))) + ;; Unknown state represented by nil. + (either (delq nil (list new state)))) + ;; Earlier states override later ones. + (car (cond ((memq 'charging either)) + ((memq 'discharging either)) + ((memq 'pending-charge either)) + ((memq 'pending-discharge either)) + ;; Only options left are full or empty, + ;; but if they conflict return nil. + ((null (cdr either)) either) + ((apply #'eq either) either))))) (defun battery-upower () - "Get battery status from dbus Upower interface. -This function works only in systems with `upowerd' daemon -running. + "Get battery status from UPower D-Bus interface. +This function works only in systems that provide a UPower D-Bus +service. The following %-sequences are provided: %c Current capacity (mWh) -%p Battery load percentage -%r Current rate +%r Current rate of charge or discharge +%L AC line status (verbose) %B Battery status (verbose) %b Battery status: empty means high, `-' means low, `!' means critical, and `+' means charging -%L AC line status (verbose) +%d Temperature (in degrees Celsius) +%p Battery load percentage %s Remaining time (to charge or discharge) in seconds %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours %t Remaining time (to charge or discharge) in the form `h:min'" - (let* ((bat-device (or battery-upower-device - (battery-upower-device-autodetect :battery))) - (bat-props (when bat-device - (battery-upower-device-all-properties bat-device))) - (percents (cdr (assoc "Percentage" bat-props))) - (time-to-empty (cdr (assoc "TimeToEmpty" bat-props))) - (time-to-full (cdr (assoc "TimeToFull" bat-props))) - (state (cdr (assoc "State" bat-props))) - (level (cdr (assoc "BatteryLevel" bat-props))) - (energy (cdr (assoc "Energy" bat-props))) - (energy-rate (cdr (assoc "EnergyRate" bat-props))) - (lp-device (or battery-upower-line-power-device - (battery-upower-device-autodetect :line-power))) - (online-p (when lp-device - (battery-upower-device-property lp-device "Online"))) - (seconds (if online-p time-to-full time-to-empty)) - (minutes (when seconds (/ seconds 60))) - (hours (when minutes (/ minutes 60))) - (remaining-time (when hours - (format "%d:%02d" hours (mod minutes 60))))) - (list (cons ?c (if energy (number-to-string (round (* 1000 energy))) "N/A")) - (cons ?p (if percents (number-to-string (round percents)) "N/A")) - (cons ?r (if energy-rate - (concat (number-to-string energy-rate) " W") + (let ((count 0) props type line-status state load temperature + secs mins hrs total-energy total-rate total-tte total-ttf) + ;; Merge information from all available or specified UPower + ;; devices like other `battery-status-function's. + (dolist (device (battery--upower-devices)) + (setq props (battery--upower-device-properties device)) + (setq type (cdr (assoc "Type" props))) + (cond + ((and (eq type 1) (not (eq line-status 'online))) + ;; It's a line power device: `online' if currently providing + ;; power, any other non-nil value if simply present. + (setq line-status (if (cdr (assoc "Online" props)) 'online t))) + ((and (eq type 2) (cdr (assoc "IsPresent" props))) + ;; It's a battery. + (setq count (1+ count)) + (setq state (battery--upower-state props state)) + (let ((energy (cdr (assoc "Energy" props))) + (rate (cdr (assoc "EnergyRate" props))) + (percent (cdr (assoc "Percentage" props))) + (temp (cdr (assoc "Temperature" props))) + (tte (cdr (assoc "TimeToEmpty" props))) + (ttf (cdr (assoc "TimeToFull" props)))) + (when energy (setq total-energy (+ (or total-energy 0) energy))) + (when rate (setq total-rate (+ (or total-rate 0) rate))) + (when percent (setq load (+ (or load 0) percent))) + (when temp (setq temperature (+ (or temperature 0) temp))) + (when tte (setq total-tte (+ (or total-tte 0) tte))) + (when ttf (setq total-ttf (+ (or total-ttf 0) ttf))))))) + (when (> count 1) + ;; Averages over multiple batteries. + (when load (setq load (/ load count))) + (when temperature (setq temperature (/ temperature count)))) + (when (setq secs (if (eq line-status 'online) total-ttf total-tte)) + (setq mins (/ secs 60)) + (setq hrs (/ secs 3600))) + (list (cons ?c (if total-energy + (format "%.0f" (* total-energy 1000)) "N/A")) - (cons ?B (if state - (cdr (assq state battery-upower-states)) - "unknown")) - (cons ?b (cond ((= level 3) "-") - ((= level 4) "!") - (online-p "+") - (t ""))) - (cons ?L (if online-p "on-line" (if lp-device "off-line" "unknown"))) - (cons ?s (if seconds (number-to-string seconds) "N/A")) - (cons ?m (if minutes (number-to-string minutes) "N/A")) - (cons ?h (if hours (number-to-string hours) "N/A")) - (cons ?t (or remaining-time "N/A"))))) + (cons ?r (if total-rate (format "%.1f W" total-rate) "N/A")) + (cons ?L (cond ((eq line-status 'online) "on-line") + (line-status "off-line") + ("N/A"))) + (cons ?B (format "%s" (or state 'unknown))) + (cons ?b (cond ((eq state 'charging) "+") + ((and load (< load battery-load-critical)) "!") + ((and load (< load battery-load-low)) "-") + (""))) + ;; Zero usually means unknown. + (cons ?d (if (and temperature (/= temperature 0)) + (format "%.0f" temperature) + "N/A")) + (cons ?p (if load (format "%.0f" load) "N/A")) + (cons ?s (if secs (number-to-string secs) "N/A")) + (cons ?m (if mins (number-to-string mins) "N/A")) + (cons ?h (if hrs (number-to-string hrs) "N/A")) + (cons ?t (if hrs (format "%d:%02d" hrs (% mins 60)) "N/A"))))) ;;; `apm' interface for BSD. diff --git a/test/lisp/battery-tests.el b/test/lisp/battery-tests.el index 92ab013f040..8d7cc7fccf3 100644 --- a/test/lisp/battery-tests.el +++ b/test/lisp/battery-tests.el @@ -81,6 +81,69 @@ (should (equal (match-string 2 str) "mWh"))) (should-not (string-match (rx battery--acpi-capacity eos) "45 mW"))) +(ert-deftest battery-upower-state () + "Test `battery--upower-state'." + ;; Charging. + (dolist (total '(nil charging discharging empty fully-charged + pending-charge pending-discharge)) + (should (eq (battery--upower-state '(("State" . 1)) total) 'charging))) + (dolist (state '(nil 0 1 2 3 4 5 6)) + (should (eq (battery--upower-state `(("State" . ,state)) 'charging) + 'charging))) + ;; Discharging. + (dolist (total '(nil discharging empty fully-charged + pending-charge pending-discharge)) + (should (eq (battery--upower-state '(("State" . 2)) total) 'discharging))) + (dolist (state '(nil 0 2 3 4 5 6)) + (should (eq (battery--upower-state `(("State" . ,state)) 'discharging) + 'discharging))) + ;; Pending charge. + (dolist (total '(nil empty fully-charged pending-charge pending-discharge)) + (should (eq (battery--upower-state '(("State" . 5)) total) + 'pending-charge))) + (dolist (state '(nil 0 3 4 5 6)) + (should (eq (battery--upower-state `(("State" . ,state)) 'pending-charge) + 'pending-charge))) + ;; Pending discharge. + (dolist (total '(nil empty fully-charged pending-discharge)) + (should (eq (battery--upower-state '(("State" . 6)) total) + 'pending-discharge))) + (dolist (state '(nil 0 3 4 6)) + (should (eq (battery--upower-state `(("State" . ,state)) 'pending-discharge) + 'pending-discharge))) + ;; Empty. + (dolist (total '(nil empty)) + (should (eq (battery--upower-state '(("State" . 3)) total) 'empty))) + (dolist (state '(nil 0 3)) + (should (eq (battery--upower-state `(("State" . ,state)) 'empty) 'empty))) + ;; Fully charged. + (dolist (total '(nil fully-charged)) + (should (eq (battery--upower-state '(("State" . 4)) total) 'fully-charged))) + (dolist (state '(nil 0 4)) + (should (eq (battery--upower-state `(("State" . ,state)) 'fully-charged) + 'fully-charged)))) + +(ert-deftest battery-upower-state-unknown () + "Test `battery--upower-state' with unknown states." + ;; Unknown running total retains new state. + (should-not (battery--upower-state () nil)) + (should-not (battery--upower-state '(("State" . state)) nil)) + (should-not (battery--upower-state '(("State" . 0)) nil)) + (should (eq (battery--upower-state '(("State" . 1)) nil) 'charging)) + (should (eq (battery--upower-state '(("State" . 2)) nil) 'discharging)) + (should (eq (battery--upower-state '(("State" . 3)) nil) 'empty)) + (should (eq (battery--upower-state '(("State" . 4)) nil) 'fully-charged)) + (should (eq (battery--upower-state '(("State" . 5)) nil) 'pending-charge)) + (should (eq (battery--upower-state '(("State" . 6)) nil) 'pending-discharge)) + ;; Unknown new state retains running total. + (dolist (props '(() (("State" . state)) (("State" . 0)))) + (dolist (total '(nil charging discharging empty fully-charged + pending-charge pending-discharge)) + (should (eq (battery--upower-state props total) total)))) + ;; Conflicting empty and fully-charged. + (should-not (battery--upower-state '(("State" . 3)) 'fully-charged)) + (should-not (battery--upower-state '(("State" . 4)) 'empty))) + (ert-deftest battery-format () "Test `battery-format'." (should (equal (battery-format "" ()) "")) From 3dd6b23cdfa64bdff2bdc9e7fbf9844a2ed6cd8f Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Fri, 8 May 2020 00:25:38 +0100 Subject: [PATCH 45/72] Propertize all shr fragment IDs as shr-target-id * lisp/net/shr.el (shr-target-id): Add docstring. (shr-descend, shr-tag-a): Display dummy anchor characters as the empty string. Give all relevant 'id' or 'name' fragment identifier attributes the shr-target-id text property. This ensures that cached content, such as tables, retains the property across renders. (Bug#40532) * lisp/net/eww.el: (eww-display-html): Adapt shr-target-id property search accordingly. --- lisp/net/eww.el | 19 ++++++++++--------- lisp/net/shr.el | 25 +++++++++++++------------ 2 files changed, 23 insertions(+), 21 deletions(-) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index cf31d37f072..2f6528de948 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -25,13 +25,14 @@ ;;; Code: (require 'cl-lib) -(require 'shr) -(require 'url) -(require 'url-queue) -(require 'thingatpt) (require 'mm-url) (require 'puny) -(eval-when-compile (require 'subr-x)) ;; for string-trim +(require 'shr) +(require 'text-property-search) +(require 'thingatpt) +(require 'url) +(require 'url-queue) +(eval-when-compile (require 'subr-x)) (defgroup eww nil "Emacs Web Wowser" @@ -542,10 +543,10 @@ Currently this means either text/html or application/xhtml+xml." (goto-char point)) (shr-target-id (goto-char (point-min)) - (let ((point (next-single-property-change - (point-min) 'shr-target-id))) - (when point - (goto-char point)))) + (let ((match (text-property-search-forward + 'shr-target-id shr-target-id t))) + (when match + (goto-char (prop-match-beginning match))))) (t (goto-char (point-min)) ;; Don't leave point inside forms, because the normal eww diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 03260c9e70a..a3f04968a27 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -185,13 +185,15 @@ and other things: (defvar shr-depth 0) (defvar shr-warning nil) (defvar shr-ignore-cache nil) -(defvar shr-target-id nil) (defvar shr-table-separator-length 1) (defvar shr-table-separator-pixel-width 0) (defvar shr-table-id nil) (defvar shr-current-font nil) (defvar shr-internal-bullet nil) +(defvar shr-target-id nil + "Target fragment identifier anchor.") + (defvar shr-map (let ((map (make-sparse-keymap))) (define-key map "a" 'shr-show-alt-text) @@ -526,13 +528,13 @@ size, and full-buffer size." (funcall function dom)) (t (shr-generic dom))) - (when (and shr-target-id - (equal (dom-attr dom 'id) shr-target-id)) + (when-let* ((id (dom-attr dom 'id))) ;; If the element was empty, we don't have anything to put the ;; anchor on. So just insert a dummy character. (when (= start (point)) - (insert "*")) - (put-text-property start (1+ start) 'shr-target-id shr-target-id)) + (insert ?*) + (put-text-property (1- (point)) (point) 'display "")) + (put-text-property start (1+ start) 'shr-target-id id)) ;; If style is set, then this node has set the color. (when style (shr-colorize-region @@ -1486,14 +1488,13 @@ ones, in case fg and bg are nil." (start (point)) shr-start) (shr-generic dom) - (when (and shr-target-id - (equal (dom-attr dom 'name) shr-target-id)) - ;; We have a zero-length element, so just - ;; insert... something. + (when-let* ((id (unless (dom-attr dom 'id) ; Handled by `shr-descend'. + (dom-attr dom 'name)))) ; Obsolete since HTML5. + ;; We have an empty element, so just insert... something. (when (= start (point)) - (shr-ensure-newline) - (insert " ")) - (put-text-property start (1+ start) 'shr-target-id shr-target-id)) + (insert ?\s) + (put-text-property (1- (point)) (point) 'display "")) + (put-text-property start (1+ start) 'shr-target-id id)) (when url (shr-urlify (or shr-start start) (shr-expand-url url) title)))) From 363d981811ef828606c0344a9d525b444551c7de Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Thu, 18 Jun 2020 18:42:28 +0300 Subject: [PATCH 46/72] Add binding for project-kill-buffers * lisp/progmodes/project.el (project-prefix-map): Add binding for project-kill-buffers (bug#41868). --- lisp/progmodes/project.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index e24d81c1b43..7a41df614b9 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -503,6 +503,7 @@ DIRS must contain directory names." (define-key map "v" 'project-vc-dir) (define-key map "c" 'project-compile) (define-key map "e" 'project-eshell) + (define-key map "k" 'project-kill-buffers) (define-key map "p" 'project-switch-project) (define-key map "g" 'project-find-regexp) (define-key map "r" 'project-query-replace-regexp) From 7a37460f929a5ea3c9ea7b7ca8d5cc1575dea686 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Thu, 18 Jun 2020 20:00:26 +0200 Subject: [PATCH 47/72] Some Tramp cleanups, mainly in tramp-crypt.el * lisp/net/tramp-crypt.el (tramp-crypt-file-name-handler-alist): Add `add-name-to-file', `make-directory-internal', `make-nearby-temp-file', `temporary-file-directory' and `unhandled-file-name-directory'. (tramp-crypt-file-name-for-operation): Use `tramp-compat-temporary-file-directory'. (tramp-crypt-do-encrypt-or-decrypt-file-name) (tramp-crypt-do-encrypt-or-decrypt-file): Fix syntax error in `tramp-error'. * lisp/net/tramp.el (tramp-autoload-file-name-handler): * lisp/net/tramp-rclone.el (tramp-rclone-mounted-p) (tramp-rclone-flush-directory-cache): Use `tramp-compat-temporary-file-directory'. --- lisp/net/tramp-crypt.el | 18 +++++++++--------- lisp/net/tramp-rclone.el | 5 +++-- lisp/net/tramp.el | 2 +- 3 files changed, 13 insertions(+), 12 deletions(-) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 2eb3b9f8b7d..c859af83cd6 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -146,7 +146,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." ;;;###tramp-autoload (defconst tramp-crypt-file-name-handler-alist '((access-file . tramp-crypt-handle-access-file) - ;; (add-name-to-file . tramp-crypt-handle-not-implemented) + (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) (copy-file . tramp-crypt-handle-copy-file) @@ -198,8 +198,8 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (load . tramp-handle-load) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-crypt-handle-make-directory) - ;; (make-directory-internal . tramp-crypt-handle-not-implemented) - ;; (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-directory-internal . ignore) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) (process-file . ignore) @@ -212,11 +212,11 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (shell-command . ignore) (start-file-process . ignore) ;; `substitute-in-file-name' performed by default handler. - ;; (temporary-file-directory . tramp-crypt-handle-temporary-file-directory) + (temporary-file-directory . tramp-handle-temporary-file-directory) ;; `tramp-get-remote-gid' performed by default handler. ;; `tramp-get-remote-uid' performed by default handler. (tramp-set-file-uid-gid . tramp-crypt-handle-set-file-uid-gid) - ;; (unhandled-file-name-directory . ignore) + (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-handle-write-region)) @@ -230,8 +230,8 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; if it is remote. So we check a possible second argument. (unless (tramp-crypt-file-name-p tfnfo) (setq tfnfo (apply - #'tramp-file-name-for-operation - operation (cons temporary-file-directory (cdr args))))) + #'tramp-file-name-for-operation operation + (cons (tramp-compat-temporary-file-directory) (cdr args))))) tfnfo)) (defun tramp-crypt-run-real-handler (operation args) @@ -413,7 +413,7 @@ Otherwise, return NAME." crypt-vec (if (eq op 'encrypt) "encode" "decode") (tramp-compat-temporary-file-directory) localname) (tramp-error - crypt-vec "%s of file name %s failed." + crypt-vec 'file-error "%s of file name %s failed." (if (eq op 'encrypt) "Encoding" "Decoding") name)) (with-current-buffer (tramp-get-connection-buffer crypt-vec) (goto-char (point-min)) @@ -448,7 +448,7 @@ Raise an error if this fails." (file-name-directory infile) (concat "/" (file-name-nondirectory infile))) (tramp-error - crypt-vec "%s of file %s failed." + crypt-vec 'file-error "%s of file %s failed." (if (eq op 'encrypt) "Encrypting" "Decrypting") infile)) (with-current-buffer (tramp-get-connection-buffer crypt-vec) (write-region nil nil outfile))))) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index f635d3cbb68..3701bfc22c9 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -459,7 +459,7 @@ file names." ;; to cache a nil result. (or (tramp-get-connection-property (tramp-get-connection-process vec) "mounted" nil) - (let* ((default-directory temporary-file-directory) + (let* ((default-directory (tramp-compat-temporary-file-directory)) (mount (shell-command-to-string "mount -t fuse.rclone"))) (tramp-message vec 6 "%s" "mount -t fuse.rclone") (tramp-message vec 6 "\n%s" mount) @@ -485,7 +485,8 @@ file names." ;; crash Emacs for some processes. So we use ;; "pidof", which might not work everywhere. (if (<= emacs-major-version 25) - (let ((default-directory temporary-file-directory)) + (let ((default-directory + (tramp-compat-temporary-file-directory))) (mapcar #'string-to-number (split-string diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 3a8a51fd4ad..7bb9e422a50 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2450,7 +2450,7 @@ Falls back to normal file name handler if no Tramp file name handler exists." "Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) (when tramp-mode - (let ((default-directory temporary-file-directory)) + (let ((default-directory (tramp-compat-temporary-file-directory))) (load "tramp" 'noerror 'nomessage))) (apply operation args))) From 75babd073a0e00a5bd1a08dc2059742c1a145ea9 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Thu, 18 Jun 2020 20:00:39 +0200 Subject: [PATCH 48/72] * etc/NEWS: Fix inconsistencies. Add `tramp-crypt-add-directory'. --- etc/NEWS | 39 ++++++++++++++++++++++----------------- 1 file changed, 22 insertions(+), 17 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 2ddb5fb089d..4c93e31346b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -140,6 +140,7 @@ displayed and which are kept hidden. ** Emacs Lisp mode *** The mode-line now indicates whether we're using lexical or dynamic scoping. + *** A space between an open paren and a symbol changes the indentation rule. The presence of a space between an open paren and a symbol now is taken as a statement by the programmer that this should be indented @@ -230,6 +231,12 @@ changes. *** New connection method "media", which allows accessing media devices like cell phones, tablets or cameras. ++++ +*** New command 'tramp-crypt-add-directory'. +This command marks a remote directory to contain only encrypted files. +See the "(tramp) Keeping files encrypted" node of the Tramp manual for +details. This feature is experimental. + ** Tempo --- @@ -420,9 +427,9 @@ information, see the related entry about 'shr-browse-url' above. all commands that prompt for a project directory. +++ -*** New commands 'project-dired', 'project-vc-dir', 'project-shell', 'project-eshell'. -These commands run Dired/VC-Dir and Shell/Eshell in a project's root directory, -respectively. +*** New commands 'project-dired', 'project-vc-dir', 'project-shell', +'project-eshell'. These commands run Dired/VC-Dir and Shell/Eshell in +a project's root directory, respectively. *** New command 'project-compile', which runs compilation. @@ -449,18 +456,6 @@ Previously 'xml-print' would produce invalid XML when given a string with characters that are not valid in XML (see https://www.w3.org/TR/xml/#charsets). Now it rejects such strings. -** The metamail.el library is now marked obsolete. - -** D-Bus - ---- -*** Some obsolete variable and function aliases have been removed. -In Emacs 24.3, the variable 'dbus-event-error-hooks' was renamed to -'dbus-event-error-functions' and the function -'dbus-call-method-non-blocking' was renamed to 'dbus-call-method'. -The old names, which were kept as obsolete aliases of the new names, -have now been removed. - ** Battery --- @@ -477,8 +472,8 @@ polling, respectively. *** A richer syntax can be used to format battery status information. The user options 'battery-mode-line-format' and 'battery-echo-area-format' now support the full formatting syntax of -the function 'format-spec' documented under '(elisp) Custom Format -Strings'. The new syntax includes specifiers for padding and +the function 'format-spec' documented under node "(elisp) Custom Format +Strings". The new syntax includes specifiers for padding and truncation, amongst other things. @@ -536,6 +531,16 @@ This is no longer supported, and setting this variable has no effect. ** The macro 'with-displayed-buffer-window' is now obsolete. Use macro 'with-current-buffer-window' with action alist entry 'body-function'. +** The metamail.el library is now marked obsolete. + +--- +** Some obsolete variable and function aliases in dbus.el have been removed. +In Emacs 24.3, the variable 'dbus-event-error-hooks' was renamed to +'dbus-event-error-functions' and the function +'dbus-call-method-non-blocking' was renamed to 'dbus-call-method'. +The old names, which were kept as obsolete aliases of the new names, +have now been removed. + --- ** Some libraries obsolete since Emacs 23 have been removed: 'ledit.el', 'lmenu.el', 'lucid.el and 'old-whitespace.el'. From ba450b6f462e278fcd3bc96c88f154fce219f5fc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Thu, 18 Jun 2020 21:16:42 +0200 Subject: [PATCH 49/72] Define the dark luminance limit as a named constant To make the meaning of the color-dark-p cutoff luminance clear, define it as a named constant. (We no longer use the somewhat obscure 0.6^2.2 definition since it doesn't really make sense to define the limit in gamma-compressed space.) * lisp/faces.el (color-luminance-dark-limit): New constant. (color-dark-p): Use color-luminance-dark-limit. --- lisp/faces.el | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/lisp/faces.el b/lisp/faces.el index f6b9593b9df..2480aaaf146 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1794,6 +1794,11 @@ on which one provides better contrast with COLOR." (color-values color))) "#ffffff" "black")) +(defconst color-luminance-dark-limit 0.325 + "The relative luminance below which a color is considered 'dark', +in the sense that white text is more readable than black with the +color as background. This value was determined experimentally.") + (defun color-dark-p (rgb) "Whether RGB is more readable against white than black. RGB is a 3-element list (R G B), each component in the range [0,1]. @@ -1814,7 +1819,7 @@ contrast colour with RGB as background and as foreground." (g (expt sg 2.2)) (b (expt sb 2.2)) (y (+ (* r 0.2126) (* g 0.7152) (* b 0.0722)))) - (< y (eval-when-compile (expt 0.6 2.2))))) + (< y color-luminance-dark-limit))) (declare-function xw-color-defined-p "xfns.c" (color &optional frame)) From b6c7780bb02465e3af2ccec332fc2d8b79fe7a2a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Thu, 18 Jun 2020 21:55:36 +0200 Subject: [PATCH 50/72] ; * lisp/faces.el (color-luminance-dark-limit): Better doc string. --- lisp/faces.el | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lisp/faces.el b/lisp/faces.el index 2480aaaf146..ba85973bf10 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1795,9 +1795,10 @@ on which one provides better contrast with COLOR." "#ffffff" "black")) (defconst color-luminance-dark-limit 0.325 - "The relative luminance below which a color is considered 'dark', -in the sense that white text is more readable than black with the -color as background. This value was determined experimentally.") + "The relative luminance below which a color is considered 'dark'. +A 'dark' color in this sense provides better contrast with white +than with black; see `color-dark-p'. +This value was determined experimentally.") (defun color-dark-p (rgb) "Whether RGB is more readable against white than black. From fbf40c1d903d18286ecd7d2c1d7b117c88a1d5dd Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Thu, 18 Jun 2020 14:01:56 -0700 Subject: [PATCH 51/72] Check AREF and aref_addr subscripts * src/lisp.h (gc_asize): Move before first use. (AREF, aref_addr): Check subscripts. Co-authored-by: Tino Calancha --- src/lisp.h | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/lisp.h b/src/lisp.h index 34426990882..7b4f484b9b7 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1671,6 +1671,13 @@ ASIZE (Lisp_Object array) return size; } +INLINE ptrdiff_t +gc_asize (Lisp_Object array) +{ + /* Like ASIZE, but also can be used in the garbage collector. */ + return XVECTOR (array)->header.size & ~ARRAY_MARK_FLAG; +} + INLINE ptrdiff_t PVSIZE (Lisp_Object pv) { @@ -1853,22 +1860,17 @@ bool_vector_set (Lisp_Object a, EMACS_INT i, bool b) INLINE Lisp_Object AREF (Lisp_Object array, ptrdiff_t idx) { + eassert (0 <= idx && idx < gc_asize (array)); return XVECTOR (array)->contents[idx]; } INLINE Lisp_Object * aref_addr (Lisp_Object array, ptrdiff_t idx) { + eassert (0 <= idx && idx <= gc_asize (array)); return & XVECTOR (array)->contents[idx]; } -INLINE ptrdiff_t -gc_asize (Lisp_Object array) -{ - /* Like ASIZE, but also can be used in the garbage collector. */ - return XVECTOR (array)->header.size & ~ARRAY_MARK_FLAG; -} - INLINE void ASET (Lisp_Object array, ptrdiff_t idx, Lisp_Object val) { From 6fe5c21c723c1ebf1d4df911761d14c47970262f Mon Sep 17 00:00:00 2001 From: Andrii Kolomoiets Date: Fri, 19 Jun 2020 02:21:55 +0300 Subject: [PATCH 52/72] project-switch-to-buffer: Use the "other buffer" as default * lisp/progmodes/project.el (project-switch-to-buffer): Pass the "other buffer" as DEF to read-buffer if it belongs to the current project (bug#41879). --- lisp/progmodes/project.el | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 7a41df614b9..89dcee97fa9 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -777,14 +777,24 @@ Arguments the same as in `compile'." (defun project-switch-to-buffer () "Switch to a buffer in the current project." (interactive) - (let ((root (project-root (project-current t)))) + (let* ((root (project-root (project-current t))) + (current-buffer (current-buffer)) + (other-buffer (other-buffer current-buffer)) + (other-name (buffer-name other-buffer)) + (predicate + (lambda (buffer) + ;; BUFFER is an entry (BUF-NAME . BUF-OBJ) of Vbuffer_alist. + (and (not (eq (cdr buffer) current-buffer)) + (when-let ((file (buffer-local-value 'default-directory + (cdr buffer)))) + (file-in-directory-p file root)))))) (switch-to-buffer (read-buffer - "Switch to buffer: " nil t - (lambda (buffer) - ;; BUFFER is an entry (BUF-NAME . BUF-OBJ) of Vbuffer_alist. - (when-let ((file (buffer-file-name (cdr buffer)))) - (file-in-directory-p file root))))))) + "Switch to buffer: " + (when (funcall predicate (cons other-name other-buffer)) + other-name) + t + predicate)))) (defcustom project-kill-buffers-skip-conditions '("\\*Help\\*") From 70ac80d75684819b633417b87bf13e1e4e15dd15 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Fri, 19 Jun 2020 09:24:27 +0200 Subject: [PATCH 53/72] Fix newly introduced errors in Tramp * lisp/net/tramp-gvfs.el (tramp-gvfs-unload-hook): Remove `tramp-gvfs-dbus-event-error' from `dbus-event-error-functions'. * lisp/net/tramp.el (tramp-autoload-file-name-handler): Revert patch. --- lisp/net/tramp-gvfs.el | 4 ++++ lisp/net/tramp.el | 4 +++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 36166ad1966..dce6edd19c4 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -951,6 +951,10 @@ is no information where to trace the message.") (tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err)))) (add-hook 'dbus-event-error-functions #'tramp-gvfs-dbus-event-error) +(add-hook 'tramp-gvfs-unload-hook + (lambda () + (remove-hook 'dbus-event-error-functions + #'tramp-gvfs-dbus-event-error))) ;; File name primitives. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 7bb9e422a50..9314c437d29 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2450,7 +2450,9 @@ Falls back to normal file name handler if no Tramp file name handler exists." "Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) (when tramp-mode - (let ((default-directory (tramp-compat-temporary-file-directory))) + ;; We cannot use `tramp-compat-temporary-file-directory' here due + ;; to autoload. + (let ((default-directory temporary-file-directory)) (load "tramp" 'noerror 'nomessage))) (apply operation args))) From 1e3b0f2d95a6b822e06586564bcb5204a1f78b15 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 19 Jun 2020 10:52:00 +0300 Subject: [PATCH 54/72] Improve doc strings of project.el * lisp/progmodes/project.el (project-dired, project-shell) (project-eshell, project-switch-to-buffer, project-kill-buffers) (project-list-file, project--read-project-list) (project--ensure-read-project-list, project--write-project-list) (project--add-to-project-list-front) (project--remove-from-project-list, project-prompt-project-dir) (project-switch-commands, project-switch-project): Fix wording and formatting of doc strings. --- lisp/progmodes/project.el | 45 ++++++++++++++++++++------------------- 1 file changed, 23 insertions(+), 22 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 89dcee97fa9..c0c07ab409e 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -703,19 +703,19 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in ;;;###autoload (defun project-dired () - "Open Dired in the current project." + "Start Dired in the current project's root." (interactive) (dired (project-root (project-current t)))) ;;;###autoload (defun project-vc-dir () - "Open VC-Dir in the current project." + "Run VC-Dir in the current project's root." (interactive) (vc-dir (project-root (project-current t)))) ;;;###autoload (defun project-shell () - "Open Shell in the current project." + "Start an inferior shell in the current project's root directory." (interactive) (let ((default-directory (project-root (project-current t)))) ;; Use ‘create-file-buffer’ to uniquify shell buffer names. @@ -723,7 +723,7 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in ;;;###autoload (defun project-eshell () - "Open Eshell in the current project." + "Start Eshell in the current project's root directory." (interactive) (let ((default-directory (project-root (project-current t)))) (eshell t))) @@ -775,7 +775,7 @@ Arguments the same as in `compile'." ;;;###autoload (defun project-switch-to-buffer () - "Switch to a buffer in the current project." + "Switch to another buffer that visits some file in the current project." (interactive) (let* ((root (project-root (project-current t))) (current-buffer (current-buffer)) @@ -820,8 +820,7 @@ any of the conditions will not be killed." ;;;###autoload (defun project-kill-buffers () "Kill all live buffers belonging to the current project. -Certain buffers may be ignored, depending on the value of -`project-kill-buffers-skip-conditions'." +Certain buffers may be \"spared\", see `project-kill-buffers-skip-conditions'." (interactive) (let ((pr (project-current t)) bufs) (dolist (buf (project--buffer-list pr)) @@ -841,7 +840,7 @@ Certain buffers may be ignored, depending on the value of ;;; Project list (defcustom project-list-file (locate-user-emacs-file "projects") - "File to save the list of known projects." + "File in which to save the list of known projects." :type 'file :version "28.1" :group 'project) @@ -850,7 +849,7 @@ Certain buffers may be ignored, depending on the value of "List of known project directories.") (defun project--read-project-list () - "Initialize `project--list' from the project list file." + "Initialize `project--list' using contents of `project-list-file'." (let ((filename project-list-file)) (setq project--list (when (file-exists-p filename) @@ -859,12 +858,12 @@ Certain buffers may be ignored, depending on the value of (read (current-buffer))))))) (defun project--ensure-read-project-list () - "Initialize `project--list' if it hasn't already been." + "Initialize `project--list' if it isn't already initialized." (when (eq project--list 'unset) (project--read-project-list))) (defun project--write-project-list () - "Persist `project--list' to the project list file." + "Save `project--list' in `project-list-file'." (let ((filename project-list-file)) (with-temp-buffer (insert ";;; -*- lisp-data -*-\n") @@ -873,7 +872,7 @@ Certain buffers may be ignored, depending on the value of (defun project--add-to-project-list-front (pr) "Add project PR to the front of the project list. -Save the result to disk if the project list was changed." +Save the result in `project-list-file' if the list of projects has changed." (project--ensure-read-project-list) (let ((dir (project-root pr))) (unless (equal (caar project--list) dir) @@ -882,9 +881,10 @@ Save the result to disk if the project list was changed." (project--write-project-list)))) (defun project--remove-from-project-list (pr-dir) - "Remove directory PR-DIR from the project list. + "Remove directory PR-DIR of a missing project from the project list. If the directory was in the list before the removal, save the -result to disk." +result in `project-list-file'. Announce the project's removal +from the list." (project--ensure-read-project-list) (when (assoc pr-dir project--list) (setq project--list (assoc-delete-all pr-dir project--list)) @@ -892,9 +892,10 @@ result to disk." (project--write-project-list))) (defun project-prompt-project-dir () - "Prompt the user for a directory from known project roots. -The project is chosen among projects known from the project list. -It's also possible to enter an arbitrary directory." + "Prompt the user for a directory that is one of the known project roots. +The project is chosen among projects known from the project list, +see `project-list-file'. +It's also possible to enter an arbitrary directory not in the list." (project--ensure-read-project-list) (let* ((dir-choice "... (choose a dir)") (choices @@ -921,9 +922,9 @@ It's also possible to enter an arbitrary directory." Used by `project-switch-project' to construct a dispatch menu of commands available upon \"switching\" to another project. -Each element looks like (KEY LABEL COMMAND), where COMMAND is the +Each element is of the form (KEY LABEL COMMAND), where COMMAND is the command to run when KEY is pressed. LABEL is used to distinguish -the choice in the dispatch menu.") +the menu entries in the dispatch menu.") (defun project--keymap-prompt () "Return a prompt for the project swithing dispatch menu." @@ -937,9 +938,9 @@ the choice in the dispatch menu.") ;;;###autoload (defun project-switch-project () - "\"Switch\" to another project by running a chosen command. -The available commands are picked from `project-switch-commands' -and presented in a dispatch menu." + "\"Switch\" to another project by running an Emacs command. +The available commands are presented as a dispatch menu +made from `project-switch-commands'." (interactive) (let ((dir (project-prompt-project-dir)) (choice nil)) From 3e7499c8389b8e8900320914fe496ae2780a453e Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Fri, 19 Jun 2020 15:12:31 +0200 Subject: [PATCH 55/72] Fix various problems in Tramp * lisp/net/tramp-compat.el (tramp-temp-name-prefix): Declare. (tramp-compat-make-temp-name): * lisp/net/tramp.el (tramp-make-tramp-temp-name): New defuns. * lisp/net/tramp.el (tramp-make-tramp-temp-file): * lisp/net/tramp-sh.el (tramp-find-inline-encoding) (tramp-maybe-open-connection, tramp-get-remote-touch) (tramp-get-remote-chmod-h): * lisp/net/tramp-smb.el (tramp-smb-handle-copy-directory): Use them. * lisp/net/tramp-sh.el (tramp-do-file-attributes-with-stat): Simplify shell command. Suppress errors (interpret as nil). (tramp-sh-handle-make-process): Do not visit with `insert-file-contents'. Delete tmp file only if exists. (tramp-send-command-and-read): Suppress `signal-hook-function' when reading expression. --- lisp/net/tramp-compat.el | 7 ++++++ lisp/net/tramp-sh.el | 50 +++++++++++++++------------------------- lisp/net/tramp-smb.el | 11 ++------- lisp/net/tramp.el | 11 +++++---- 4 files changed, 34 insertions(+), 45 deletions(-) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index f0131d59852..48670edcaa0 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -43,6 +43,7 @@ ;; `temporary-file-directory' as function is introduced with Emacs 26.1. (declare-function tramp-handle-temporary-file-directory "tramp") +(defvar tramp-temp-name-prefix) ;; For not existing functions, obsolete functions, or functions with a ;; changed argument list, there are compiler warnings. We want to @@ -61,6 +62,12 @@ It is the default value of `temporary-file-directory'." ;; into an infloop. (eval (car (get 'temporary-file-directory 'standard-value)))) +(defsubst tramp-compat-make-temp-name () + "Generate a local temporary file name (compat function)." + (make-temp-name + (expand-file-name + tramp-temp-name-prefix (tramp-compat-temporary-file-directory)))) + (defsubst tramp-compat-make-temp-file (f &optional dir-flag) "Create a local temporary file (compat function). Add the extension of F, if existing." diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index fad841a6ace..539d0486d27 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1336,13 +1336,8 @@ component is used as the target of the symlink." ;; add a space. Apostrophes in the stat output are masked as ;; `tramp-stat-marker', in order to make a proper shell escape ;; of them in file names. - "( (%s %s || %s -h %s) && (%s -c " - "'((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " - "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)")) - (tramp-get-file-exists-command vec) - (tramp-shell-quote-argument localname) - (tramp-get-test-command vec) - (tramp-shell-quote-argument localname) + "(%s -c '((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' %s |" + " sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g')")) (tramp-get-remote-stat vec) tramp-stat-marker tramp-stat-marker (if (eq id-format 'integer) @@ -1353,7 +1348,8 @@ component is used as the target of the symlink." (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker))) tramp-stat-marker tramp-stat-marker (tramp-shell-quote-argument localname) - tramp-stat-quoted-marker))) + tramp-stat-quoted-marker) + 'noerror)) (defun tramp-sh-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." @@ -2998,16 +2994,16 @@ STDERR can also be a file name." ;; the process is deleted. (when (bufferp stderr) (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr 'visit)) + (insert-file-contents-literally remote-tmpstderr)) ;; Delete tmpstderr file. (add-function :after (process-sentinel p) (lambda (_proc _msg) - (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr 'visit nil nil 'replace)) - (delete-file remote-tmpstderr)))) + (when (file-exists-p remote-tmpstderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr nil nil nil 'replace)) + (delete-file remote-tmpstderr))))) ;; Return process. p))) @@ -4610,11 +4606,7 @@ Goes through the list `tramp-local-coding-commands' and ?o (tramp-get-remote-od vec))) value (replace-regexp-in-string "%" "%%" value))) (when (string-match-p "\\(^\\|[^%]\\)%t" value) - (setq tmpfile - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-get-remote-tmpdir vec))) + (setq tmpfile (tramp-make-tramp-temp-name vec) value (format-spec value @@ -5053,10 +5045,7 @@ connection if a previous connection has died for some reason." (tmpfile (with-tramp-connection-property (tramp-get-process vec) "temp-file" - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory))))) + (tramp-compat-make-temp-name))) spec r-shell) ;; Add arguments for asynchronous processes. @@ -5276,7 +5265,10 @@ raises an error." command marker (buffer-string)))))) ;; Read the expression. (condition-case nil - (prog1 (read (current-buffer)) + (prog1 + (let ((signal-hook-function + (unless noerror signal-hook-function))) + (read (current-buffer))) ;; Error handling. (when (re-search-forward "\\S-" (point-at-eol) t) (error nil))) @@ -5684,10 +5676,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (tramp-message vec 5 "Finding a suitable `touch' command") (let ((result (tramp-find-executable vec "touch" (tramp-get-remote-path vec))) - (tmpfile - (make-temp-name - (expand-file-name - tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))))) + (tmpfile (tramp-make-tramp-temp-name vec))) ;; Busyboxes do support the "-t" option only when they have been ;; built with the DESKTOP config option. Let's check it. (when result @@ -5877,10 +5866,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." "Check whether remote `chmod' supports nofollow argument." (with-tramp-connection-property vec "chmod-h" (tramp-message vec 5 "Finding a suitable `chmod' command with nofollow") - (let ((tmpfile - (make-temp-name - (expand-file-name - tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))))) + (let ((tmpfile (tramp-make-tramp-temp-name vec))) (prog1 (tramp-send-command-and-check vec diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 3980add7c41..357e9a220ce 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -438,11 +438,7 @@ pass to the OPERATION." (cond ;; We must use a local temporary directory. ((and t1 t2) - (let ((tmpdir - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory))))) + (let ((tmpdir (tramp-compat-make-temp-name))) (unwind-protect (progn (make-directory tmpdir) @@ -470,10 +466,7 @@ pass to the OPERATION." (localname (file-name-as-directory (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v)))) - (tmpdir (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory)))) + (tmpdir (tramp-compat-make-temp-name)) (args (list (concat "//" host "/" share) "-E")) (options tramp-smb-options)) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 9314c437d29..1b50a6cf25b 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -4726,18 +4726,21 @@ This handles also chrooted environments, which are not regarded as local." (tramp-error vec 'file-error "Directory %s not accessible" dir)) dir))) +(defun tramp-make-tramp-temp-name (vec) + "Generate a temporary file name on the remote host identified by VEC." + (make-temp-name + (expand-file-name tramp-temp-name-prefix (tramp-get-remote-tmpdir vec)))) + (defun tramp-make-tramp-temp-file (vec) "Create a temporary file on the remote host identified by VEC. Return the local name of the temporary file." - (let ((prefix (expand-file-name - tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))) - result) + (let (result) (while (not result) ;; `make-temp-file' would be the natural choice for ;; implementation. But it calls `write-region' internally, ;; which also needs a temporary file - we would end in an ;; infinite loop. - (setq result (make-temp-name prefix)) + (setq result (tramp-make-tramp-temp-name vec)) (if (file-exists-p result) (setq result nil) ;; This creates the file by side effect. From 2eda8199bf3227f979edf532fae2d74892c27b5a Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 19 Jun 2020 21:50:30 +0300 Subject: [PATCH 56/72] Fix last change in doc strings of project.el * lisp/progmodes/project.el (project-switch-to-buffer): More accurate doc string. --- lisp/progmodes/project.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index c0c07ab409e..be1b801ca2b 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -775,7 +775,9 @@ Arguments the same as in `compile'." ;;;###autoload (defun project-switch-to-buffer () - "Switch to another buffer that visits some file in the current project." + "Switch to another buffer that is related to the current project. +A buffer is related to a project if its `default-directory' +is inside the directory hierarchy of the project's root." (interactive) (let* ((root (project-root (project-current t))) (current-buffer (current-buffer)) From be5d0c0f63081b5aee5efe2fbcc5c4ace6ca9a02 Mon Sep 17 00:00:00 2001 From: Theodor Thornhill Date: Sat, 20 Jun 2020 04:02:18 +0300 Subject: [PATCH 57/72] project-shell: Pop to an existing shell buffer by default * lisp/progmodes/project.el (project-shell): Pop to an existing shell buffer by default. If there's none, or if universal argument is used, open a subsequent shell buffer and jump to it. Prefix shell buffer name with the base name of project root directory. (Bug#41858) --- lisp/progmodes/project.el | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index be1b801ca2b..d35bdf6ce0c 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -715,11 +715,20 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in ;;;###autoload (defun project-shell () - "Start an inferior shell in the current project's root directory." + "Start an inferior shell in the current project's root directory. +With \\[universal-argument] prefix, create subsequent shell buffers +with uniquified names." (interactive) - (let ((default-directory (project-root (project-current t)))) - ;; Use ‘create-file-buffer’ to uniquify shell buffer names. - (shell (create-file-buffer "*shell*")))) + (let* ((default-directory (project-root (project-current t))) + (default-project-shell-name + (concat "*" (file-name-nondirectory + (directory-file-name + (file-name-directory default-directory))) + "-shell*")) + (shell-buffer (get-buffer default-project-shell-name))) + (if (and shell-buffer (not current-prefix-arg)) + (pop-to-buffer shell-buffer) + (shell (generate-new-buffer-name default-project-shell-name))))) ;;;###autoload (defun project-eshell () From 2fec4c733cfb078de24a9d2dea51b1ff0bc717ca Mon Sep 17 00:00:00 2001 From: Andrew Burgess Date: Sun, 7 Jun 2020 09:20:19 +0100 Subject: [PATCH 58/72] Fix bug with deactivation of mark in 'cua-cancel' * lisp/emulation/cua-base.el (cua-cancel): Use 'deactivate-mark' instead of setting 'mark-active' directly. Copyright-paperwork-exempt: yes --- lisp/emulation/cua-base.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el index 26a1a8955f4..c4dcb76446e 100644 --- a/lisp/emulation/cua-base.el +++ b/lisp/emulation/cua-base.el @@ -860,7 +860,7 @@ With numeric prefix arg, copy to register 0-9 instead." (defun cua-cancel () "Cancel the active region, rectangle, or global mark." (interactive) - (setq mark-active nil) + (deactivate-mark) (if (fboundp 'cua--cancel-rectangle) (cua--cancel-rectangle))) From ed08512978812220045ff12941d78b99ed32323f Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 20 Jun 2020 10:51:51 +0300 Subject: [PATCH 59/72] Revert "Don't mention non-GNU package archives." This reverts commit 5daa7a5fd4aced33a2ae016bde5bb37d1d95edf6. A proper fix will be committed to the emacs-27 branch, and will be later merged to master. --- doc/misc/efaq.texi | 29 +++++++++++++++++++---------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index 0290e797065..f5f01848f77 100644 --- a/doc/misc/efaq.texi +++ b/doc/misc/efaq.texi @@ -3463,16 +3463,25 @@ see @ref{Packages that do not come with Emacs}. @cindex Emacs Lisp List @cindex Emacs Lisp Archive -We distribute many packages that extend Emacs, in the -@uref{https://elpa.gnu.org, GNU ELPA} (``Emacs Lisp Package -Archive''). The command @kbd{M-x list-packages} contacts the GNU ELPA -server and fetches the list of packages that it distributes. These -GNU packages are designed for use with Emacs, but we distribute them -separately from Emacs itself, for reasons of space, and convenience of -development. You can browse the resulting @file{*Packages*} buffer to -see what is available, and then Emacs can automatically download and -install the packages that you select. @xref{Packages,,, emacs, The -GNU Emacs Manual}. +The easiest way to add more features to your Emacs is to use the +command @kbd{M-x list-packages}. This contacts the +@uref{https://elpa.gnu.org, GNU ELPA} (``Emacs Lisp Package Archive'') +server and fetches the list of additional packages that it offers. +These are GNU packages that are available for use with Emacs, but are +distributed separately from Emacs itself, for reasons of space, etc. +You can browse the resulting @file{*Packages*} buffer to see what is +available, and then Emacs can automatically download and install the +packages that you select. @xref{Packages,,, emacs, The GNU Emacs Manual}. + +There are other, non-GNU, Emacs Lisp package servers, including: +@uref{https://melpa.org, MELPA}; and +@uref{https://marmalade-repo.org, Marmalade}. To use additional +package servers, customize the @code{package-archives} variable. Be +aware that installing a package can run arbitrary code, so only add +sources that you trust. Also, packages hosted on non-GNU package +servers may encourage or require you to install and use non-free +software; for example, MELPA is known to host some packages that do +this. The @uref{https://lists.gnu.org/mailman/listinfo/gnu-emacs-sources, GNU Emacs sources mailing list}, which is gatewayed to the From 50f489b5dc59ba8eacd6dc5bdee98da690a61f2f Mon Sep 17 00:00:00 2001 From: Jan Beich Date: Sun, 14 Jun 2020 03:51:24 +0000 Subject: [PATCH 60/72] Add fallback for 24-bit terminal color via COLORTERM=truecolor * src/term.c (init_tty): When COLORTERM=truecolor is defined, override setaf/setab/colors terminfo capabilities with 24-bit color support. * doc/misc/efaq.texi (Colors on a TTY): Mention the possibility to enable 24-bit color via the COLORTERM environment variable. (Bug#41846) Copyright-paperwork-exempt: yes --- doc/misc/efaq.texi | 4 ++++ src/term.c | 9 +++++++++ 2 files changed, 13 insertions(+) diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index f5f01848f77..8f7ed715b52 100644 --- a/doc/misc/efaq.texi +++ b/doc/misc/efaq.texi @@ -1595,6 +1595,10 @@ xterm-direct2 xterm with direct-color indexing (old) xterm-direct xterm with direct-color indexing @end example +If Terminfo database is not available, but 24-bit direct color mode is +supported, it can still be enabled by defining the environment +variable @env{COLORTERM} to @samp{truecolor}. + Terminals with @samp{RGB} capability treat pixels #000001 - #000007 as indexed colors to maintain backward compatibility with applications that are unaware of direct color mode. Therefore the seven darkest diff --git a/src/term.c b/src/term.c index 94bf013f4a0..5cbb092ad17 100644 --- a/src/term.c +++ b/src/term.c @@ -4168,6 +4168,15 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ could return 32767. */ tty->TN_max_colors = 16777216; } + /* Fall back to xterm+direct (semicolon version) if requested + by the COLORTERM environment variable. */ + else if ((bg = getenv("COLORTERM")) != NULL + && strcasecmp(bg, "truecolor") == 0) + { + tty->TS_set_foreground = "\033[%?%p1%{8}%<%t3%p1%d%e38;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m"; + tty->TS_set_background = "\033[%?%p1%{8}%<%t4%p1%d%e48;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m"; + tty->TN_max_colors = 16777216; + } } #endif From 7a7090029437ae7981d3bba9722bdc8f4695fed3 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 20 Jun 2020 11:31:19 +0300 Subject: [PATCH 61/72] Documentation followup to the last change * doc/emacs/cmdargs.texi (General Variables): * etc/NEWS: Document the COLORTERM environment variable. (Bug#41846) --- doc/emacs/cmdargs.texi | 9 ++++++++- etc/NEWS | 6 ++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/doc/emacs/cmdargs.texi b/doc/emacs/cmdargs.texi index 2c131165244..3dd1fe9a308 100644 --- a/doc/emacs/cmdargs.texi +++ b/doc/emacs/cmdargs.texi @@ -495,7 +495,14 @@ variables to be set, but it uses their values if they are set. @item CDPATH @vindex CDPATH@r{, environment variable} Used by the @code{cd} command to search for the directory you specify, -when you specify a relative directory, +when you specify a relative directory. +@item COLORTERM +@vindex COLORTERM@r{, environment variable} +If this variable is set to the value @samp{truecolor}, it tells Emacs +to use 24-bit true color on text-mode displays even if the terminfo +database is not installed. Emacs will use built-in commands to +request true color by RGB values instead of the missing terminfo +information. @item DBUS_SESSION_BUS_ADDRESS @vindex DBUS_SESSION_BUS_ADDRESS@r{, environment variable} Used by D-Bus when Emacs is compiled with it. Usually, there is no diff --git a/etc/NEWS b/etc/NEWS index 4c93e31346b..5a46e7165e3 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -61,6 +61,12 @@ It was declared obsolete in Emacs 27.1. * Startup Changes in Emacs 28.1 +** Emacs can support 24-bit color TTY without terminfo database. +If your text-mode terminal supports 24-bit true color, but your system +lacks the terminfo database, you can instruct Emacs to support 24-bit +true color by setting COLORTERM=truecolor in the environment. This is +useful on systems such as FreeBSD which ships only with 'etc/termcap'. + * Changes in Emacs 28.1 From 3af631dcf28a5964d9e56c9be8ee7f2125d90d8a Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 20 Jun 2020 11:46:52 +0300 Subject: [PATCH 62/72] Fix last change for bug#41619 * lisp/progmodes/python.el (python-shell-virtualenv-root): Fix last change. (Bug#41619) --- lisp/progmodes/python.el | 1 - 1 file changed, 1 deletion(-) diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 0ce80db1993..22248f04402 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -2093,7 +2093,6 @@ This variable, when set to a string, makes the environment to be modified such that shells are started within the specified virtualenv." :type '(choice (const nil) directory) - :safe #'file-directory-p :group 'python) (defcustom python-shell-setup-codes nil From c59475ae1e34332501ea0f5758176a29b2797ba6 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sat, 20 Jun 2020 22:12:19 +0200 Subject: [PATCH 63/72] Fix a byte-compile warning. * lisp/gnus/gnus-cloud.el (gnus-cloud-download-data): Don't use 'mapcar' or effect. --- lisp/gnus/gnus-cloud.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index 7ea691e7220..5028da5e8df 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -479,7 +479,7 @@ Otherwise, returns the Gnus Cloud data chunks." (forward-line 1)))) (if update (progn - (mapcar #'gnus-cloud-update-all chunks) + (mapc #'gnus-cloud-update-all chunks) (setq gnus-cloud-sequence highest-sequence-seen)) chunks))) From c1056b0387fb6fda345da51e4e2ee9736c25a358 Mon Sep 17 00:00:00 2001 From: Theodor Thornhill Date: Sat, 20 Jun 2020 11:54:22 +0200 Subject: [PATCH 64/72] Pop to an existing Eshell buffer by default * lisp/progmodes/project.el (project-shell): Improve docstring to include information about an implementation detail. * list/progmodes/project.el (project-eshell): Modelled after 'project-shell', change default behavior such that we don't create too many eshell buffers by default. Use universal argument to create subsequent buffers. --- lisp/progmodes/project.el | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index d35bdf6ce0c..3a9e8bcee54 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -716,8 +716,9 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in ;;;###autoload (defun project-shell () "Start an inferior shell in the current project's root directory. -With \\[universal-argument] prefix, create subsequent shell buffers -with uniquified names." +With \\[universal-argument] prefix, create subsequent shell +buffers with uniquified names. If several Shell buffers exists, +this command jumps to the first created such buffer." (interactive) (let* ((default-directory (project-root (project-current t))) (default-project-shell-name @@ -732,10 +733,21 @@ with uniquified names." ;;;###autoload (defun project-eshell () - "Start Eshell in the current project's root directory." + "Start Eshell in the current project's root directory. +With \\[universal-argument] prefix, create subsequent shell +buffers with uniquified names. If several Eshell buffers exists, +this command jumps to the first created such buffer." (interactive) - (let ((default-directory (project-root (project-current t)))) - (eshell t))) + (let* ((default-directory (project-root (project-current t))) + (eshell-buffer-name + (concat "*" (file-name-nondirectory + (directory-file-name + (file-name-directory default-directory))) + "-eshell*")) + (eshell-buffer (get-buffer eshell-buffer-name))) + (if (and eshell-buffer (not current-prefix-arg)) + (pop-to-buffer eshell-buffer) + (eshell t)))) (declare-function fileloop-continue "fileloop" ()) From a1b487eac0ec10059eb2b8c5e7efc9eec1342148 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Sun, 21 Jun 2020 04:19:29 +0300 Subject: [PATCH 65/72] ; project-shell, project-eshell: Docstring tweaks --- lisp/progmodes/project.el | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 3a9e8bcee54..74495cf07a4 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -716,9 +716,10 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in ;;;###autoload (defun project-shell () "Start an inferior shell in the current project's root directory. -With \\[universal-argument] prefix, create subsequent shell -buffers with uniquified names. If several Shell buffers exists, -this command jumps to the first created such buffer." +If such buffer already exists (one or several), switch to the one +that was created first. +With \\[universal-argument] prefix, create a new inferior shell +buffer with uniquified name." (interactive) (let* ((default-directory (project-root (project-current t))) (default-project-shell-name @@ -734,9 +735,10 @@ this command jumps to the first created such buffer." ;;;###autoload (defun project-eshell () "Start Eshell in the current project's root directory. -With \\[universal-argument] prefix, create subsequent shell -buffers with uniquified names. If several Eshell buffers exists, -this command jumps to the first created such buffer." +If such buffer already exists (one or several), switch to the one +that was created first. +With \\[universal-argument] prefix, create a new Eshell buffer +with uniquified name." (interactive) (let* ((default-directory (project-root (project-current t))) (eshell-buffer-name From 4cc6854cd4b0857e223ed6bc1b1b1a051dd83480 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sun, 21 Jun 2020 12:50:34 +0100 Subject: [PATCH 66/72] Silence some warnings in tests * test/lisp/emacs-lisp/package-tests.el (package-test-suffix-matches): Evaluate lambda. (package-test-list-filter-marked): * test/lisp/vc/vc-tests.el (vc-test--run-maybe-unsupported-function): * test/src/undo-tests.el (undo-test-skip-invalidated-markers): Silence "unused local variable" warnings. * test/lisp/imenu-tests.el (imenu-simple-scan-deftest): Fix docstring. Don't shadow global major-mode. --- test/lisp/emacs-lisp/package-tests.el | 24 ++++++++++++------------ test/lisp/imenu-tests.el | 15 +++++++-------- test/lisp/vc/vc-tests.el | 9 ++++----- test/src/undo-tests.el | 2 +- 4 files changed, 24 insertions(+), 26 deletions(-) diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 90714af3061..fecabba40f5 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -176,7 +176,7 @@ (defun package-test-suffix-matches (base suffix-list) "Return file names matching BASE concatenated with each item in SUFFIX-LIST" (cl-mapcan - '(lambda (item) (file-expand-wildcards (concat base item))) + (lambda (item) (file-expand-wildcards (concat base item))) suffix-list)) (defvar tar-parse-info) @@ -419,17 +419,17 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-list-filter-marked () "Ensure package list is filtered correctly by non-empty mark." (with-package-test () - (let ((buf (package-list-packages))) - (revert-buffer) - (search-forward-regexp "^ +simple-single") - (package-menu-mark-install) - (package-menu-filter-marked) - (goto-char (point-min)) - (should (re-search-forward "^I +simple-single" nil t)) - (should (= (count-lines (point-min) (point-max)) 1)) - (package-menu-mark-unmark) - ;; No marked packages in default environment. - (should-error (package-menu-filter-marked))))) + (package-list-packages) + (revert-buffer) + (search-forward-regexp "^ +simple-single") + (package-menu-mark-install) + (package-menu-filter-marked) + (goto-char (point-min)) + (should (re-search-forward "^I +simple-single" nil t)) + (should (= (count-lines (point-min) (point-max)) 1)) + (package-menu-mark-unmark) + ;; No marked packages in default environment. + (should-error (package-menu-filter-marked)))) (ert-deftest package-test-list-filter-by-version () (with-package-menu-test diff --git a/test/lisp/imenu-tests.el b/test/lisp/imenu-tests.el index 5dbeb882e01..e5cdb9e65d1 100644 --- a/test/lisp/imenu-tests.el +++ b/test/lisp/imenu-tests.el @@ -50,24 +50,23 @@ (setq input (cdr input))))) result)) -(defmacro imenu-simple-scan-deftest (name doc major-mode content expected-items) +(defmacro imenu-simple-scan-deftest (name doc mode content expected-items) "Generate an ert test for mode-own imenu expression. Run `imenu-create-index-function' at the buffer which content is -CONTENT with MAJOR-MODE. A generated test runs `imenu-create-index-function' -at the buffer which content is CONTENT with MAJOR-MODE. Then it compares a list -of strings which are picked up from the result with EXPECTED-ITEMS." +CONTENT with major MODE. A generated test runs `imenu-create-index-function' +at the buffer which content is CONTENT with major MODE. Then it compares a +list of strings which are picked up from the result with EXPECTED-ITEMS." (let ((xname (intern (concat "imenu-simple-scan-deftest-" (symbol-name name))))) `(ert-deftest ,xname () - ,doc + ,doc (with-temp-buffer (insert ,content) - (funcall ',major-mode) + (funcall #',mode) (let ((result-items (sort (imenu-simple-scan-deftest-gather-strings-from-list (funcall imenu-create-index-function)) #'string-lessp)) (expected-items (sort (copy-sequence ,expected-items) #'string-lessp))) - (should (equal result-items expected-items)) - ))))) + (should (equal result-items expected-items))))))) (imenu-simple-scan-deftest sh "Test imenu expression for sh-mode." sh-mode "a() { diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el index ff85e2f904e..8e5cc95ec94 100644 --- a/test/lisp/vc/vc-tests.el +++ b/test/lisp/vc/vc-tests.el @@ -224,11 +224,10 @@ For backends which don't support it, `vc-not-supported' is signaled." (defmacro vc-test--run-maybe-unsupported-function (func &rest args) "Run FUNC with ARGS as arguments. Catch the `vc-not-supported' error." - `(let (err) - (condition-case err - (funcall ,func ,@args) - (vc-not-supported 'vc-not-supported) - (t (signal (car err) (cdr err)))))) + `(condition-case err + (funcall ,func ,@args) + (vc-not-supported 'vc-not-supported) + (t (signal (car err) (cdr err))))) (defun vc-test--register (backend) "Register and unregister a file. diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el index 13335a9bb10..b26a276c61b 100644 --- a/test/src/undo-tests.el +++ b/test/src/undo-tests.el @@ -452,7 +452,7 @@ Demonstrates bug 25599." (insert ";; aaaaaaaaa ;; bbbbbbbb") (let ((overlay-modified - (lambda (ov after-p _beg _end &optional length) + (lambda (ov after-p _beg _end &optional _length) (unless after-p (when (overlay-buffer ov) (delete-overlay ov)))))) From 1ecd350f38ee782cdebf4b08a59f2c1974ad44bd Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sun, 21 Jun 2020 13:42:14 +0100 Subject: [PATCH 67/72] Evaluate some unnecessarily quoted lambdas * lisp/cedet/semantic/complete.el (semantic-displayer-tooltip-max-tags): * lisp/emacs-lisp/benchmark.el (benchmark-run-compiled): * lisp/emacs-lisp/package.el (package--default-summary) (package-menu-filter-by-version): * lisp/eshell/em-pred.el (eshell-pred-file-time): * lisp/progmodes/verilog-mode.el (verilog-auto-lineup) (verilog-auto-reset-widths, verilog-auto-arg-format) (verilog-auto-inst-vector, verilog-auto-inst-template-numbers): * lisp/textmodes/bibtex.el (bibtex-dialect): * test/lisp/autoinsert-tests.el (autoinsert-tests-define-auto-insert-before) (autoinsert-tests-define-auto-insert-after): Remove some unnecessary quoting around anonymous functions. --- lisp/cedet/semantic/complete.el | 8 ++++---- lisp/emacs-lisp/benchmark.el | 2 +- lisp/emacs-lisp/package.el | 12 ++++++------ lisp/eshell/em-pred.el | 8 +++----- lisp/progmodes/verilog-mode.el | 10 +++++----- lisp/textmodes/bibtex.el | 10 +++++----- test/lisp/autoinsert-tests.el | 8 ++++---- 7 files changed, 28 insertions(+), 30 deletions(-) diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el index 7abc4360f64..b262ab710f6 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@ -1635,10 +1635,10 @@ This will not happen if you directly set this variable via `setq'." :group 'semantic :version "24.3" :type 'integer - :set '(lambda (sym var) - (set-default sym var) - (when (boundp 'x-max-tooltip-size) - (setcdr x-max-tooltip-size (max (1+ var) (cdr x-max-tooltip-size)))))) + :set (lambda (sym var) + (set-default sym var) + (when (boundp 'x-max-tooltip-size) + (setcdr x-max-tooltip-size (max (1+ var) (cdr x-max-tooltip-size)))))) (defclass semantic-displayer-tooltip (semantic-displayer-traditional) diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index a7fcc5cb8f2..984c62ddd54 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -81,7 +81,7 @@ result. The overhead of the `lambda's is accounted for." (gcs (make-symbol "gcs")) (gc (make-symbol "gc")) (code (byte-compile `(lambda () ,@forms))) - (lambda-code (byte-compile '(lambda ())))) + (lambda-code (byte-compile (lambda ())))) `(let ((,gc gc-elapsed) (,gcs gcs-done)) (list ,(if (or (symbolp repetitions) (> repetitions 1)) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 6fc80594125..e6f54d206d8 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -441,9 +441,9 @@ synchronously." &aux (name (intern name-string)) (version (version-to-list version-string)) - (reqs (mapcar #'(lambda (elt) - (list (car elt) - (version-to-list (cadr elt)))) + (reqs (mapcar (lambda (elt) + (list (car elt) + (version-to-list (cadr elt)))) (if (eq 'quote (car requirements)) (nth 1 requirements) requirements))) @@ -3871,9 +3871,9 @@ If VERSION is nil or the empty string, show all packages." (package-menu--generate t t) (package-menu--filter-by (let ((fun (pcase predicate - ('= 'version-list-=) - ('< 'version-list-<) - ('> '(lambda (a b) (not (version-list-<= a b)))) + ('= #'version-list-=) + ('< #'version-list-<) + ('> (lambda (a b) (not (version-list-<= a b)))) (_ (error "Unknown predicate: %s" predicate)))) (ver (version-to-list version))) (lambda (pkg-desc) diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index 7219af45f54..c26f654e278 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -451,11 +451,9 @@ resultant list of strings." `(lambda (file) (let ((attrs (file-attributes file))) (if attrs - (,(if (eq qual ?-) - 'time-less-p - (if (eq qual ?+) - '(lambda (a b) (time-less-p b a)) - 'time-equal-p)) + (,(cond ((eq qual ?-) #'time-less-p) + ((eq qual ?+) (lambda (a b) (time-less-p b a))) + (#'time-equal-p)) ,when (nth ,attr-index attrs))))))) (defun eshell-pred-file-type (type) diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index 87f901ae113..6400e1e6cd9 100644 --- a/lisp/progmodes/verilog-mode.el +++ b/lisp/progmodes/verilog-mode.el @@ -605,7 +605,7 @@ are lineup only when \\[verilog-pretty-declarations] is typed." (function :tag "Other")) :group 'verilog-mode-indent ) (put 'verilog-auto-lineup 'safe-local-variable - '(lambda (x) (memq x '(nil all assignments declarations)))) + (lambda (x) (memq x '(nil all assignments declarations)))) (defcustom verilog-indent-level 3 "Indentation of Verilog statements with respect to containing block." @@ -1118,7 +1118,7 @@ SystemVerilog designs." :type 'boolean :group 'verilog-mode-auto) (put 'verilog-auto-reset-widths 'safe-local-variable - '(lambda (x) (memq x '(nil t unbased)))) + (lambda (x) (memq x '(nil t unbased)))) (defcustom verilog-assignment-delay "" "Text used for delays in delayed assignments. Add a trailing space if set." @@ -1138,7 +1138,7 @@ line." (const :tag "Line up Assignment statements" single)) :group 'verilog-mode-auto) (put 'verilog-auto-arg-format 'safe-local-variable - '(lambda (x) (memq x '(packed single)))) + (lambda (x) (memq x '(packed single)))) (defcustom verilog-auto-arg-sort nil "Non-nil means AUTOARG signal names will be sorted, not in declaration order. @@ -1263,7 +1263,7 @@ otherwise no vectors if sizes match (like using nil)." :group 'verilog-mode-auto :type '(choice (const nil) (const t) (const unsigned))) (put 'verilog-auto-inst-vector 'safe-local-variable - '(lambda (x) (memq x '(nil t unsigned)))) + (lambda (x) (memq x '(nil t unsigned)))) (defcustom verilog-auto-inst-template-numbers nil "If true, when creating templated ports with AUTOINST, add a comment. @@ -1280,7 +1280,7 @@ won't merge conflict." :group 'verilog-mode-auto :type '(choice (const nil) (const t) (const lhs))) (put 'verilog-auto-inst-template-numbers 'safe-local-variable - '(lambda (x) (memq x '(nil t lhs)))) + (lambda (x) (memq x '(nil t lhs)))) (defcustom verilog-auto-inst-template-required nil "If non-nil, when creating a port with AUTOINST, require a template. diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index 4712f314080..0018b89d858 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -850,11 +850,11 @@ Predefined dialects include BibTeX and biblatex." To interactively change the dialect use the command `bibtex-set-dialect'." :group 'bibtex :version "24.1" - :set '(lambda (symbol value) - (set-default symbol value) - ;; `bibtex-set-dialect' is undefined during loading (no problem) - (if (fboundp 'bibtex-set-dialect) - (bibtex-set-dialect value))) + :set (lambda (symbol value) + (set-default symbol value) + ;; `bibtex-set-dialect' is undefined during loading (no problem). + (if (fboundp 'bibtex-set-dialect) + (bibtex-set-dialect value))) :type '(choice (const BibTeX) (const biblatex) (symbol :tag "Custom"))) diff --git a/test/lisp/autoinsert-tests.el b/test/lisp/autoinsert-tests.el index 574763c4b3d..eafa9c6c02c 100644 --- a/test/lisp/autoinsert-tests.el +++ b/test/lisp/autoinsert-tests.el @@ -79,10 +79,10 @@ (ert-deftest autoinsert-tests-define-auto-insert-before () (let ((auto-insert-alist - (list (cons 'text-mode '(lambda () (insert "foo"))))) + (list (cons 'text-mode (lambda () (insert "foo"))))) (auto-insert-query nil)) (define-auto-insert 'text-mode - '(lambda () (insert "bar"))) + (lambda () (insert "bar"))) (with-temp-buffer (text-mode) (auto-insert) @@ -90,10 +90,10 @@ (ert-deftest autoinsert-tests-define-auto-insert-after () (let ((auto-insert-alist - (list (cons 'text-mode '(lambda () (insert "foo"))))) + (list (cons 'text-mode (lambda () (insert "foo"))))) (auto-insert-query nil)) (define-auto-insert 'text-mode - '(lambda () (insert "bar")) + (lambda () (insert "bar")) t) (with-temp-buffer (text-mode) From f18b035763785ffa9d8e27f3ec2be183b741502e Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sun, 21 Jun 2020 15:19:51 +0200 Subject: [PATCH 68/72] Fix remaining problems with tramp-crypt.el * lisp/net/tramp-compat.el (tramp-compat-make-temp-file): Simplify implementation. * lisp/net/tramp-crypt.el (tramp-crypt-handle-delete-file) (tramp-crypt-handle-file-attributes, tramp-crypt-handle-file-system-info) (tramp-crypt-handle-make-directory): Let-bind `tramp-crypt-enabled' to nil. * lisp/net/tramp.el (tramp-file-name-for-operation): Fix for operations with two arguments. (tramp-handle-load): Suppress `signal-hook-function' when NOERROR is non-nil. * test/lisp/net/tramp-tests.el (tramp-test41-utf8) (tramp-test41-utf8-with-stat, tramp-test41-utf8-with-perl) (tramp-test41-utf8-with-ls): Skip if needed. --- lisp/net/tramp-compat.el | 10 ++++------ lisp/net/tramp-crypt.el | 20 ++++++++++---------- lisp/net/tramp-sh.el | 4 +--- lisp/net/tramp.el | 5 +++-- test/lisp/net/tramp-tests.el | 4 ++++ 5 files changed, 22 insertions(+), 21 deletions(-) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 48670edcaa0..218594b551c 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -71,12 +71,10 @@ It is the default value of `temporary-file-directory'." (defsubst tramp-compat-make-temp-file (f &optional dir-flag) "Create a local temporary file (compat function). Add the extension of F, if existing." - (let* (file-name-handler-alist - (prefix (expand-file-name - (symbol-value 'tramp-temp-name-prefix) - (tramp-compat-temporary-file-directory))) - (extension (file-name-extension f t))) - (make-temp-file prefix dir-flag extension))) + (make-temp-file + (expand-file-name + tramp-temp-name-prefix (tramp-compat-temporary-file-directory)) + dir-flag (file-name-extension f t))) ;; `temporary-file-directory' as function is introduced with Emacs 26.1. (defalias 'tramp-compat-temporary-file-directory-function diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index c859af83cd6..c9788fcff52 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -664,8 +664,8 @@ absolute file names." "Like `delete-file' for Tramp files." (with-parsed-tramp-file-name (expand-file-name filename) nil (tramp-flush-file-properties v localname) - (tramp-crypt-run-real-handler - #'delete-file (list (tramp-crypt-encrypt-file-name filename) trash)))) + (let (tramp-crypt-enabled) + (delete-file (tramp-crypt-encrypt-file-name filename) trash)))) (defun tramp-crypt-handle-directory-files (directory &optional full match nosort) "Like `directory-files' for Tramp files." @@ -700,8 +700,8 @@ absolute file names." (defun tramp-crypt-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." - (tramp-crypt-run-real-handler - #'file-attributes (list (tramp-crypt-encrypt-file-name filename) id-format))) + (let (tramp-crypt-enabled) + (file-attributes (tramp-crypt-encrypt-file-name filename) id-format))) (defun tramp-crypt-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." @@ -735,10 +735,10 @@ absolute file names." (defun tramp-crypt-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." - (tramp-crypt-run-real-handler - ;; `file-system-info' exists since Emacs 27.1. Then, we can use - ;; #'file-system-info. - 'file-system-info (list (tramp-crypt-encrypt-file-name filename)))) + (let (tramp-crypt-enabled) + ;; `file-system-info' exists since Emacs 27.1. + (tramp-compat-funcall + 'file-system-info (tramp-crypt-encrypt-file-name filename)))) (defun tramp-crypt-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." @@ -776,8 +776,8 @@ WILDCARD is not supported." (with-parsed-tramp-file-name (expand-file-name dir) nil (when (and (null parents) (file-exists-p dir)) (tramp-error v 'file-already-exists "Directory already exists %s" dir)) - (tramp-crypt-run-real-handler - #'make-directory (list (tramp-crypt-encrypt-file-name dir) parents)) + (let (tramp-crypt-enabled) + (make-directory (tramp-crypt-encrypt-file-name dir) parents)) ;; When PARENTS is non-nil, DIR could be a chain of non-existent ;; directories a/b/c/... Instead of checking, we simply flush the ;; whole cache. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 539d0486d27..89e5dc9e658 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1331,9 +1331,7 @@ component is used as the target of the symlink." (format (eval-when-compile (concat - ;; On Opsware, pdksh (which is the true name of ksh there) - ;; doesn't parse correctly the sequence "((". Therefore, we - ;; add a space. Apostrophes in the stat output are masked as + ;; Apostrophes in the stat output are masked as ;; `tramp-stat-marker', in order to make a proper shell escape ;; of them in file names. "(%s -c '((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' %s |" diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 1b50a6cf25b..1566162feaf 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2259,7 +2259,7 @@ Must be handled by the callers." file-newer-than-file-p rename-file)) (cond ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) - ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) + ((file-name-absolute-p (nth 1 args)) (nth 1 args)) (t default-directory))) ;; FILE DIRECTORY resp FILE1 FILE2. ((eq operation 'expand-file-name) @@ -3630,7 +3630,8 @@ User is always nil." v tramp-file-missing "Cannot load nonexistent file `%s'" file)) (if (not (file-exists-p file)) nil - (let ((inhibit-message nomessage)) + (let ((signal-hook-function (unless noerror signal-hook-function)) + (inhibit-message (or inhibit-message nomessage))) (with-tramp-progress-reporter v 0 (format "Loading %s" file) (let ((local-copy (file-local-copy file))) (unwind-protect diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index cb30a360225..43630c4debd 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -6042,6 +6042,7 @@ Use the `ls' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (tramp--test-utf8)) @@ -6056,6 +6057,7 @@ Use the `stat' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-stat v))) @@ -6077,6 +6079,7 @@ Use the `perl' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-perl v))) @@ -6101,6 +6104,7 @@ Use the `ls' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (let ((tramp-connection-properties (append From a4d3897d8f0caa54be1e1d081651ed6640b7f25e Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sun, 21 Jun 2020 14:31:16 +0100 Subject: [PATCH 69/72] Replace some uses of cl-mapcan with mapcan * lisp/progmodes/project.el (project-files, project-files): * lisp/progmodes/xref.el (xref-backend-references) (xref--convert-hits): * test/lisp/emacs-lisp/package-tests.el (package-test-strip-version): Replace cl-mapcan with equivalent calls to mapcan. --- lisp/progmodes/project.el | 4 ++-- lisp/progmodes/xref.el | 6 +++--- test/lisp/emacs-lisp/package-tests.el | 5 ++--- 3 files changed, 7 insertions(+), 8 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 74495cf07a4..8f6301c6020 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -195,7 +195,7 @@ subset of the project root and external roots. The default implementation uses `find-program'. PROJECT is used to find the list of ignores for each directory." - (cl-mapcan + (mapcan (lambda (dir) (project--files-in-directory dir (project--dir-ignores project dir))) @@ -351,7 +351,7 @@ backend implementation of `project-external-roots'.") (list (project-root project)))) (cl-defmethod project-files ((project (head vc)) &optional dirs) - (cl-mapcan + (mapcan (lambda (dir) (let (backend) (if (and (file-equal-p dir (cdr project)) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 5b5fb4bc47a..3e3a37f6da5 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -264,7 +264,7 @@ be found, return nil. The default implementation uses `semantic-symref-tool-alist' to find a search tool; by default, this uses \"find | grep\" in the `project-current' roots." - (cl-mapcan + (mapcan (lambda (dir) (xref-references-in-directory identifier dir)) (let ((pr (project-current t))) @@ -1383,8 +1383,8 @@ Such as the current syntax table and the applied syntax properties." (let (xref--last-file-buffer (tmp-buffer (generate-new-buffer " *xref-temp*"))) (unwind-protect - (cl-mapcan (lambda (hit) (xref--collect-matches hit regexp tmp-buffer)) - hits) + (mapcan (lambda (hit) (xref--collect-matches hit regexp tmp-buffer)) + hits) (kill-buffer tmp-buffer)))) (defun xref--collect-matches (hit regexp tmp-buffer) diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index fecabba40f5..cb06dd4cce3 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -175,9 +175,8 @@ (defun package-test-suffix-matches (base suffix-list) "Return file names matching BASE concatenated with each item in SUFFIX-LIST" - (cl-mapcan - (lambda (item) (file-expand-wildcards (concat base item))) - suffix-list)) + (mapcan (lambda (item) (file-expand-wildcards (concat base item))) + suffix-list)) (defvar tar-parse-info) (declare-function tar-header-name "tar-mode" (cl-x) t) ; defstruct From 8df2957df167bf34220fbf6a059752759ef41f4a Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 21 Jun 2020 19:20:37 +0300 Subject: [PATCH 70/72] Improve doc strings of 'project-shell' and 'project-eshell' * lisp/progmodes/project.el (project-shell, project-eshell): Doc fixes. --- lisp/progmodes/project.el | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 8f6301c6020..bfbe2362721 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -716,10 +716,10 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in ;;;###autoload (defun project-shell () "Start an inferior shell in the current project's root directory. -If such buffer already exists (one or several), switch to the one -that was created first. -With \\[universal-argument] prefix, create a new inferior shell -buffer with uniquified name." +If a buffer already exists for running a shell in the project's root, +switch to it. Otherwise, create a new shell buffer. +With \\[universal-argument] prefix arg, create a new inferior shell buffer even +if one already exist." (interactive) (let* ((default-directory (project-root (project-current t))) (default-project-shell-name @@ -735,10 +735,10 @@ buffer with uniquified name." ;;;###autoload (defun project-eshell () "Start Eshell in the current project's root directory. -If such buffer already exists (one or several), switch to the one -that was created first. -With \\[universal-argument] prefix, create a new Eshell buffer -with uniquified name." +If a buffer already exists for running Eshell in the project's root, +switch to it. Otherwise, create a new Eshell buffer. +With \\[universal-argument] prefix arg, create a new Eshell buffer even +if one already exist." (interactive) (let* ((default-directory (project-root (project-current t))) (eshell-buffer-name From 0792f8e4f0de2328c57d552a5845bdf77265a971 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sun, 21 Jun 2020 19:01:40 +0100 Subject: [PATCH 71/72] Revert last change in benchmark.el For discussion, see the following thread: https://lists.gnu.org/archive/html/emacs-devel/2020-06/msg00791.html * lisp/emacs-lisp/benchmark.el (benchmark-run-compiled): Revert to giving byte-compile a form rather than a closure. --- lisp/emacs-lisp/benchmark.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index 984c62ddd54..2fa5a878801 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -81,7 +81,7 @@ result. The overhead of the `lambda's is accounted for." (gcs (make-symbol "gcs")) (gc (make-symbol "gc")) (code (byte-compile `(lambda () ,@forms))) - (lambda-code (byte-compile (lambda ())))) + (lambda-code (byte-compile '(lambda ())))) `(let ((,gc gc-elapsed) (,gcs gcs-done)) (list ,(if (or (symbolp repetitions) (> repetitions 1)) From 9fe2bdb88a4ebd4b2286c1c2a2a2ba7411af01b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Fri, 12 Jun 2020 18:12:37 +0200 Subject: [PATCH 72/72] Consolidate #RGB string parsers Use a single parser of color strings in the #RGB, rgb:R/G/B and rgbi:R/G/B formats, replacing four existing ones. Previously, error-checking was spotty, handling of the rgbi: format not always present, and normalization of the result was sometimes incorrect. * src/dispextern.h: New prototype. * src/xfaces.c (parse_hex_color_comp, parse_float_color_comp) (parse_color_spec, Finternal-color_values_from_color_spec): New functions. * test/src/xfaces-tests.el (xfaces-internal-color-values-from-color-spec): New test. * lisp/term/tty-colors.el (tty-color-standard-values): Use internal-color-values-from-color-spec, replacing old parser. * src/nsterm.m (ns_get_color): * src/w32fns.c (x_to_w32_color): * src/xterm.c (x_parse_color): Use parse_color_spec, replacing old parsers. (HEX_COLOR_NAME_LENGTH): Remove #define. --- lisp/term/tty-colors.el | 58 +-------------- src/dispextern.h | 2 + src/nsterm.m | 63 +++++----------- src/w32fns.c | 157 ++------------------------------------- src/xfaces.c | 116 +++++++++++++++++++++++++++++ src/xterm.c | 51 ++++--------- test/src/xfaces-tests.el | 23 ++++++ 7 files changed, 182 insertions(+), 288 deletions(-) diff --git a/lisp/term/tty-colors.el b/lisp/term/tty-colors.el index 39ca2d36276..73e2431822e 100644 --- a/lisp/term/tty-colors.el +++ b/lisp/term/tty-colors.el @@ -923,62 +923,8 @@ The returned value reflects the standard Emacs definition of COLOR (see the info node `(emacs) Colors'), regardless of whether the terminal can display it, so the return value should be the same regardless of what display is being used." - (let ((len (length color))) - (cond ((and (>= len 4) ;; HTML/CSS/SVG-style "#XXYYZZ" color spec - (eq (aref color 0) ?#) - (member (aref color 1) - '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 - ?a ?b ?c ?d ?e ?f - ?A ?B ?C ?D ?E ?F))) - ;; Translate the string "#XXYYZZ" into a list of numbers - ;; (XX YY ZZ), scaling each to the {0..65535} range. This - ;; follows the HTML color convention, where both "#fff" and - ;; "#ffffff" represent the same color, white. - (let* ((ndig (/ (- len 1) 3)) - (maxval (1- (ash 1 (* 4 ndig)))) - (i1 1) - (i2 (+ i1 ndig)) - (i3 (+ i2 ndig)) - (i4 (+ i3 ndig))) - (list - (/ (* (string-to-number - (substring color i1 i2) 16) - 65535) - maxval) - (/ (* (string-to-number - (substring color i2 i3) 16) - 65535) - maxval) - (/ (* (string-to-number - (substring color i3 i4) 16) - 65535) - maxval)))) - ((and (>= len 9) ;; X-style rgb:xx/yy/zz color spec - (string= (substring color 0 4) "rgb:")) - ;; Translate the string "rgb:XX/YY/ZZ" into a list of - ;; numbers (XX YY ZZ), scaling each to the {0..65535} - ;; range. "rgb:F/F/F" is white. - (let* ((ndig (/ (- len 3) 3)) - (maxval (1- (ash 1 (* 4 (- ndig 1))))) - (i1 4) - (i2 (+ i1 ndig)) - (i3 (+ i2 ndig)) - (i4 (+ i3 ndig))) - (list - (/ (* (string-to-number - (substring color i1 (- i2 1)) 16) - 65535) - maxval) - (/ (* (string-to-number - (substring color i2 (- i3 1)) 16) - 65535) - maxval) - (/ (* (string-to-number - (substring color i3 (1- i4)) 16) - 65535) - maxval)))) - (t - (cdr (assoc color color-name-rgb-alist)))))) + (or (internal-color-values-from-color-spec color) + (cdr (assoc color color-name-rgb-alist)))) (defun tty-color-translate (color &optional frame) "Given a color COLOR, return the index of the corresponding TTY color. diff --git a/src/dispextern.h b/src/dispextern.h index 0b1f3d14aeb..e1d6eddc419 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -3514,6 +3514,8 @@ void update_face_from_frame_parameter (struct frame *, Lisp_Object, Lisp_Object); extern bool tty_defined_color (struct frame *, const char *, Emacs_Color *, bool, bool); +bool parse_color_spec (const char *, + unsigned short *, unsigned short *, unsigned short *); Lisp_Object tty_color_name (struct frame *, int); void clear_face_cache (bool); diff --git a/src/nsterm.m b/src/nsterm.m index 3dc7e1db7c9..0e405fc0175 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -2341,9 +2341,6 @@ so some key presses (TAB) are swallowed by the system. */ See https://lists.gnu.org/r/emacs-devel/2009-07/msg01203.html. */ { NSColor *new = nil; - static char hex[20]; - int scaling = 0; - float r = -1.0, g, b; NSString *nsname = [NSString stringWithUTF8String: name]; NSTRACE ("ns_get_color(%s, **)", name); @@ -2386,50 +2383,30 @@ so some key presses (TAB) are swallowed by the system. */ } /* First, check for some sort of numeric specification. */ - hex[0] = '\0'; - - if (name[0] == '0' || name[0] == '1' || name[0] == '.') /* RGB decimal */ + unsigned short r16, g16, b16; + if (parse_color_spec (name, &r16, &g16, &b16)) { - NSScanner *scanner = [NSScanner scannerWithString: nsname]; - [scanner scanFloat: &r]; - [scanner scanFloat: &g]; - [scanner scanFloat: &b]; - } - else if (!strncmp(name, "rgb:", 4)) /* A newer X11 format -- rgb:r/g/b */ - scaling = (snprintf (hex, sizeof hex, "%s", name + 4) - 2) / 3; - else if (name[0] == '#') /* An old X11 format; convert to newer */ - { - int len = 0; - while (isxdigit (name[len + 1])) - len++; - if (name[len + 1] == '\0' && len >= 1 && len <= 12 && len % 3 == 0) - { - scaling = len / 3; - for (int i = 0; i < 3; i++) - sprintf (hex + i * (scaling + 1), "%.*s/", scaling, - name + 1 + i * scaling); - hex[3 * (scaling + 1) - 1] = '\0'; - } - } - - if (hex[0]) - { - unsigned int rr, gg, bb; - float fscale = (1 << (scaling * 4)) - 1; - if (sscanf (hex, "%x/%x/%x", &rr, &gg, &bb)) - { - r = rr / fscale; - g = gg / fscale; - b = bb / fscale; - } - } - - if (r >= 0.0F) - { - *col = [NSColor colorForEmacsRed: r green: g blue: b alpha: 1.0]; + *col = [NSColor colorForEmacsRed: r16 / 65535.0 + green: g16 / 65535.0 + blue: b16 / 65535.0 + alpha: 1.0]; unblock_input (); return 0; } + else if (name[0] == '0' || name[0] == '1' || name[0] == '.') + { + /* RGB decimal */ + NSScanner *scanner = [NSScanner scannerWithString: nsname]; + float r, g, b; + if ( [scanner scanFloat: &r] && r >= 0 && r <= 1 + && [scanner scanFloat: &g] && g >= 0 && g <= 1 + && [scanner scanFloat: &b] && b >= 0 && b <= 1) + { + *col = [NSColor colorForEmacsRed: r green: g blue: b alpha: 1.0]; + unblock_input (); + return 0; + } + } /* Otherwise, color is expected to be from a list */ { diff --git a/src/w32fns.c b/src/w32fns.c index e595b0285a7..ab864332e78 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -864,161 +864,14 @@ x_to_w32_color (const char * colorname) block_input (); - if (colorname[0] == '#') + unsigned short r, g, b; + if (parse_color_spec (colorname, &r, &g, &b)) { - /* Could be an old-style RGB Device specification. */ - int size = strlen (colorname + 1); - char *color = alloca (size + 1); - - strcpy (color, colorname + 1); - if (size == 3 || size == 6 || size == 9 || size == 12) - { - UINT colorval; - int i, pos; - pos = 0; - size /= 3; - colorval = 0; - - for (i = 0; i < 3; i++) - { - char *end; - char t; - unsigned long value; - - /* The check for 'x' in the following conditional takes into - account the fact that strtol allows a "0x" in front of - our numbers, and we don't. */ - if (!isxdigit (color[0]) || color[1] == 'x') - break; - t = color[size]; - color[size] = '\0'; - value = strtoul (color, &end, 16); - color[size] = t; - if (errno == ERANGE || end - color != size) - break; - switch (size) - { - case 1: - value = value * 0x10; - break; - case 2: - break; - case 3: - value /= 0x10; - break; - case 4: - value /= 0x100; - break; - } - colorval |= (value << pos); - pos += 0x8; - if (i == 2) - { - unblock_input (); - XSETINT (ret, colorval); - return ret; - } - color = end; - } - } + unblock_input (); + /* Throw away the low 8 bits and return 0xBBGGRR. */ + return make_fixnum ((b & 0xff00) << 8 | (g & 0xff00) | r >> 8); } - else if (strnicmp (colorname, "rgb:", 4) == 0) - { - const char *color; - UINT colorval; - int i, pos; - pos = 0; - colorval = 0; - color = colorname + 4; - for (i = 0; i < 3; i++) - { - char *end; - unsigned long value; - - /* The check for 'x' in the following conditional takes into - account the fact that strtol allows a "0x" in front of - our numbers, and we don't. */ - if (!isxdigit (color[0]) || color[1] == 'x') - break; - value = strtoul (color, &end, 16); - if (errno == ERANGE) - break; - switch (end - color) - { - case 1: - value = value * 0x10 + value; - break; - case 2: - break; - case 3: - value /= 0x10; - break; - case 4: - value /= 0x100; - break; - default: - value = ULONG_MAX; - } - if (value == ULONG_MAX) - break; - colorval |= (value << pos); - pos += 0x8; - if (i == 2) - { - if (*end != '\0') - break; - unblock_input (); - XSETINT (ret, colorval); - return ret; - } - if (*end != '/') - break; - color = end + 1; - } - } - else if (strnicmp (colorname, "rgbi:", 5) == 0) - { - /* This is an RGB Intensity specification. */ - const char *color; - UINT colorval; - int i, pos; - pos = 0; - - colorval = 0; - color = colorname + 5; - for (i = 0; i < 3; i++) - { - char *end; - double value; - UINT val; - - value = strtod (color, &end); - if (errno == ERANGE) - break; - if (value < 0.0 || value > 1.0) - break; - val = (UINT)(0x100 * value); - /* We used 0x100 instead of 0xFF to give a continuous - range between 0.0 and 1.0 inclusive. The next statement - fixes the 1.0 case. */ - if (val == 0x100) - val = 0xFF; - colorval |= (val << pos); - pos += 0x8; - if (i == 2) - { - if (*end != '\0') - break; - unblock_input (); - XSETINT (ret, colorval); - return ret; - } - if (*end != '/') - break; - color = end + 1; - } - } /* I am not going to attempt to handle any of the CIE color schemes or TekHVC, since I don't know the algorithms for conversion to RGB. */ diff --git a/src/xfaces.c b/src/xfaces.c index cf155288bd1..308509a0267 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -220,6 +220,7 @@ along with GNU Emacs. If not, see . */ #include "sysstdio.h" #include #include +#include #include "lisp.h" #include "character.h" @@ -819,6 +820,120 @@ load_pixmap (struct frame *f, Lisp_Object name) Color Handling ***********************************************************************/ +/* Parse hex color component at S ending right before E. + Set *DST to the value normalized so that the maximum for the + number of digits given becomes 65535, and return true on success, + false otherwise. */ +static bool +parse_hex_color_comp (const char *s, const char *e, unsigned short *dst) +{ + int n = e - s; + if (n <= 0 || n > 4) + return false; + int val = 0; + for (; s < e; s++) + { + int digit; + if (*s >= '0' && *s <= '9') + digit = *s - '0'; + else if (*s >= 'A' && *s <= 'F') + digit = *s - 'A' + 10; + else if (*s >= 'a' && *s <= 'f') + digit = *s - 'a' + 10; + else + return false; + val = (val << 4) | digit; + } + int maxval = (1 << (n * 4)) - 1; + *dst = (unsigned)val * 65535 / maxval; + return true; +} + +/* Parse floating-point color component at S ending right before E. + Return the number if in the range [0,1]; otherwise -1. */ +static double +parse_float_color_comp (const char *s, const char *e) +{ + char *end; + double x = strtod (s, &end); + return (end == e && x >= 0 && x <= 1) ? x : -1; +} + +/* Parse S as a numeric color specification and set *R, *G and *B. + Return true on success, false on failure. + Recognized formats: + + "#RGB", with R, G and B hex strings of equal length, 1-4 digits each + "rgb:R/G/B", with R, G and B hex strings, 1-4 digits each + "rgbi:R/G/B", with R, G and B numbers in [0,1] + + The result is normalized to a maximum value of 65535 per component. */ +bool +parse_color_spec (const char *s, + unsigned short *r, unsigned short *g, unsigned short *b) +{ + int len = strlen (s); + if (s[0] == '#') + { + if ((len - 1) % 3 == 0) + { + int n = (len - 1) / 3; + return ( parse_hex_color_comp (s + 1 + 0 * n, s + 1 + 1 * n, r) + && parse_hex_color_comp (s + 1 + 1 * n, s + 1 + 2 * n, g) + && parse_hex_color_comp (s + 1 + 2 * n, s + 1 + 3 * n, b)); + } + } + else if (strncmp (s, "rgb:", 4) == 0) + { + char *sep1, *sep2; + return ((sep1 = strchr (s + 4, '/')) != NULL + && (sep2 = strchr (sep1 + 1, '/')) != NULL + && parse_hex_color_comp (s + 4, sep1, r) + && parse_hex_color_comp (sep1 + 1, sep2, g) + && parse_hex_color_comp (sep2 + 1, s + len, b)); + } + else if (strncmp (s, "rgbi:", 5) == 0) + { + char *sep1, *sep2; + double red, green, blue; + if ((sep1 = strchr (s + 5, '/')) != NULL + && (sep2 = strchr (sep1 + 1, '/')) != NULL + && (red = parse_float_color_comp (s + 5, sep1)) >= 0 + && (green = parse_float_color_comp (sep1 + 1, sep2)) >= 0 + && (blue = parse_float_color_comp (sep2 + 1, s + len)) >= 0) + { + *r = lrint (red * 65535); + *g = lrint (green * 65535); + *b = lrint (blue * 65535); + return true; + } + } + return false; +} + +DEFUN ("internal-color-values-from-color-spec", + Finternal_color_values_from_color_spec, + Sinternal_color_values_from_color_spec, + 1, 1, 0, + doc: /* Parse STRING as a numeric color and return (RED GREEN BLUE). +Recognised formats for STRING are: + + #RGB, where R, G and B are hex numbers of equal length, 1-4 digits each + rgb:R/G/B, where R, G, and B are hex numbers, 1-4 digits each + rgbi:R/G/B, where R, G and B are floating-point numbers in [0,1] + +The result is normalized to a maximum value of 65535 per component, +forming a list of three integers in [0,65535]. +If STRING is not in one of the above forms, return nil. */) + (Lisp_Object string) +{ + CHECK_STRING (string); + unsigned short r, g, b; + return (parse_color_spec (SSDATA (string), &r, &g, &b) + ? list3i (r, g, b) + : Qnil); +} + /* Parse RGB_LIST, and fill in the RGB fields of COLOR. RGB_LIST should contain (at least) 3 lisp integers. Return true iff RGB_LIST is OK. */ @@ -7018,4 +7133,5 @@ clear the face cache, see `clear-face-cache'. */); defsubr (&Sinternal_face_x_get_resource); defsubr (&Sx_family_fonts); #endif + defsubr (&Sinternal_color_values_from_color_spec); } diff --git a/src/xterm.c b/src/xterm.c index 7989cecec7f..6340700cb89 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -2376,8 +2376,6 @@ x_query_frame_background_color (struct frame *f, XColor *bgcolor) x_query_colors (f, bgcolor, 1); } -#define HEX_COLOR_NAME_LENGTH 32 - /* On frame F, translate the color name to RGB values. Use cached information, if possible. @@ -2389,44 +2387,23 @@ x_query_frame_background_color (struct frame *f, XColor *bgcolor) Status x_parse_color (struct frame *f, const char *color_name, XColor *color) { + /* Don't pass #RGB strings directly to XParseColor, because that + follows the X convention of zero-extending each channel + value: #f00 means #f00000. We want the convention of scaling + channel values, so #f00 means #ff0000, just as it does for + HTML, SVG, and CSS. */ + unsigned short r, g, b; + if (parse_color_spec (color_name, &r, &g, &b)) + { + color->red = r; + color->green = g; + color->blue = b; + return 1; + } + Display *dpy = FRAME_X_DISPLAY (f); Colormap cmap = FRAME_X_COLORMAP (f); struct color_name_cache_entry *cache_entry; - - if (color_name[0] == '#') - { - /* Don't pass #RGB strings directly to XParseColor, because that - follows the X convention of zero-extending each channel - value: #f00 means #f00000. We want the convention of scaling - channel values, so #f00 means #ff0000, just as it does for - HTML, SVG, and CSS. - - So we translate #f00 to rgb:f/0/0, which X handles - differently. */ - char rgb_color_name[HEX_COLOR_NAME_LENGTH]; - int len = strlen (color_name); - int digits_per_channel; - if (len == 4) - digits_per_channel = 1; - else if (len == 7) - digits_per_channel = 2; - else if (len == 10) - digits_per_channel = 3; - else if (len == 13) - digits_per_channel = 4; - else - return 0; - - snprintf (rgb_color_name, sizeof rgb_color_name, "rgb:%.*s/%.*s/%.*s", - digits_per_channel, color_name + 1, - digits_per_channel, color_name + digits_per_channel + 1, - digits_per_channel, color_name + 2 * digits_per_channel + 1); - - /* The rgb form is parsed directly by XParseColor without - talking to the X server. No need for caching. */ - return XParseColor (dpy, cmap, rgb_color_name, color); - } - for (cache_entry = FRAME_DISPLAY_INFO (f)->color_names; cache_entry; cache_entry = cache_entry->next) { diff --git a/test/src/xfaces-tests.el b/test/src/xfaces-tests.el index 5ed16c9e51d..34cda07e5b4 100644 --- a/test/src/xfaces-tests.el +++ b/test/src/xfaces-tests.el @@ -24,4 +24,27 @@ (should (equal (color-distance "#222222" "#ffffff") (color-distance "#ffffff" "#222222")))) +(ert-deftest xfaces-internal-color-values-from-color-spec () + (should (equal (internal-color-values-from-color-spec "#f05") + '(#xffff #x0000 #x5555))) + (should (equal (internal-color-values-from-color-spec "#1fb0C5") + '(#x1f1f #xb0b0 #xc5c5))) + (should (equal (internal-color-values-from-color-spec "#1f8b0AC5e") + '(#x1f81 #xb0aa #xc5eb))) + (should (equal (internal-color-values-from-color-spec "#1f83b0ADC5e2") + '(#x1f83 #xb0ad #xc5e2))) + (should (equal (internal-color-values-from-color-spec "#1f83b0ADC5e2g") nil)) + (should (equal (internal-color-values-from-color-spec "#1f83b0ADC5e20") nil)) + (should (equal (internal-color-values-from-color-spec "#12345") nil)) + (should (equal (internal-color-values-from-color-spec "rgb:f/23/28a") + '(#xffff #x2323 #x28a2))) + (should (equal (internal-color-values-from-color-spec "rgb:1234/5678/09ab") + '(#x1234 #x5678 #x09ab))) + (should (equal (internal-color-values-from-color-spec "rgb:0//0") nil)) + (should (equal (internal-color-values-from-color-spec "rgbi:0/0.5/0.1") + '(0 32768 6554))) + (should (equal (internal-color-values-from-color-spec "rgbi:1e-3/1.0e-2/1e0") + '(66 655 65535))) + (should (equal (internal-color-values-from-color-spec "rgbi:0/0.5/10") nil))) + (provide 'xfaces-tests)