commit 14d8c6f7b13f3237aa5e54f5c16ef0a9189c0459 (HEAD, refs/remotes/origin/master) Merge: 948275b4d4 ba70d0f77c Author: Stefan Kangas Date: Mon Jul 25 06:30:18 2022 +0200 Merge from origin/emacs-28 ba70d0f77c Update to Org 9.5.4-17-g6e991f commit 948275b4d4e30d98c7ebd215d6b8cc14ce8a6019 Merge: 1a85545f2d f7fd7bf477 Author: Stefan Kangas Date: Mon Jul 25 06:30:18 2022 +0200 ; Merge from origin/emacs-28 The following commit was skipped: f7fd7bf477 Find libgccjit.dylib on Homebrew Macos commit 1a85545f2dcd5526f20d42a50995ebc328f969cd Author: Po Lu Date: Mon Jul 25 10:08:37 2022 +0800 Fix typo in x-dnd-tests.el * test/lisp/x-dnd-tests.el (x-begin-drag): Avoid extra leading / in file names. (bug#56712) diff --git a/test/lisp/x-dnd-tests.el b/test/lisp/x-dnd-tests.el index ef9c8aada2..55994e9b72 100644 --- a/test/lisp/x-dnd-tests.el +++ b/test/lisp/x-dnd-tests.el @@ -124,8 +124,8 @@ Return the result of the selection." (format "file://%s%s" (system-name) (expand-file-name x-dnd-tests-xds-property-value x-dnd-tests-xds-target-dir)) - (concat "file:///" (expand-file-name x-dnd-tests-xds-property-value - x-dnd-tests-xds-target-dir))))) + (concat "file://" (expand-file-name x-dnd-tests-xds-property-value + x-dnd-tests-xds-target-dir))))) (setq x-dnd-tests-xds-property-value (encode-coding-string (url-encode-url uri) 'raw-text))) commit 3c23ae13f044083c928df14ff441f841fcdc3b4f Author: Po Lu Date: Mon Jul 25 10:07:30 2022 +0800 Fix mouse face handling with tooltips * src/xterm.c (handle_one_xevent): Clear last_mouse_motion_frame and last_mouse_glyph_frame on LeaveNotify. Otherwise, mouse face will be restored by gui_redo_mouse_highlight and will not be restored if an EnterNotify is later sent on top of the same glyph. diff --git a/src/xterm.c b/src/xterm.c index da909f337f..e953f54d6d 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -18303,6 +18303,19 @@ handle_one_xevent (struct x_display_info *dpyinfo, #endif if (f) { + /* Now clear dpyinfo->last_mouse_motion_frame, or + gui_redo_mouse_highlight will end up highlighting the + last known poisition of the mouse if a tooltip frame is + later unmapped. */ + + if (f == dpyinfo->last_mouse_motion_frame) + dpyinfo->last_mouse_motion_frame = NULL; + + /* Something similar applies to + dpyinfo->last_mouse_glyph_frame. */ + if (f == dpyinfo->last_mouse_glyph_frame) + dpyinfo->last_mouse_glyph_frame = NULL; + if (f == hlinfo->mouse_face_mouse_frame) { /* If we move outside the frame, then we're @@ -19753,8 +19766,22 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (!f) f = x_top_window_to_frame (dpyinfo, leave->event); #endif + if (f) { + /* Now clear dpyinfo->last_mouse_motion_frame, or + gui_redo_mouse_highlight will end up highlighting + the last known poisition of the mouse if a + tooltip frame is later unmapped. */ + + if (f == dpyinfo->last_mouse_motion_frame) + dpyinfo->last_mouse_motion_frame = NULL; + + /* Something similar applies to + dpyinfo->last_mouse_glyph_frame. */ + if (f == dpyinfo->last_mouse_glyph_frame) + dpyinfo->last_mouse_glyph_frame = NULL; + if (f == hlinfo->mouse_face_mouse_frame) { /* If we move outside the frame, then we're commit b1f14e94ada90c266e3e6683d401e567397c4910 Author: Po Lu Date: Mon Jul 25 09:23:15 2022 +0800 ; Rename misnamed function in xterm.c * src/xterm.c (x_init_master_valuators): Rename to `x_cache_xi_devices'. Update comment accordingly. All callers changed. diff --git a/src/xterm.c b/src/xterm.c index 67a7de4213..da909f337f 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -5373,12 +5373,16 @@ xi_populate_device_from_info (struct xi_device_t *xi_device, #endif } -/* The code below handles the tracking of scroll valuators on XInput - 2, in order to support scroll wheels that report information more - granular than a screen line. +/* Populate our client-side record of all devices, which includes + basic information about the device and also touchscreen tracking + information and scroll valuators. - On X, when the XInput 2 extension is being utilized, the states of - the mouse wheels in each axis are stored as absolute values inside + Keeping track of scroll valuators is required in order to support + scroll wheels that report information in a fashion more detailed + than a single turn of a "step" in the wheel. + + When the input extension is being utilized, the states of the mouse + wheels on each axis are stored as absolute values inside "valuators" attached to each mouse device. To obtain the delta of the scroll wheel from a motion event (which is used to report that some valuator has changed), it is necessary to iterate over every @@ -5392,20 +5396,13 @@ xi_populate_device_from_info (struct xi_device_t *xi_device, This delta however is still intermediate, to make driver implementations easier. The XInput developers recommend (and most programs use) the following algorithm to convert from scroll unit - deltas to pixel deltas: + deltas to pixel deltas by which the display must actually be + scrolled: pixels_scrolled = pow (window_height, 2.0 / 3.0) * delta; */ -/* Setup valuator tracking for XI2 master devices on - DPYINFO->display. */ - -/* This function's name is a misnomer: these days, it keeps a - client-side record of all devices, which includes basic information - about the device and also touchscreen tracking information, instead - of just scroll valuators. */ - static void -x_init_master_valuators (struct x_display_info *dpyinfo) +x_cache_xi_devices (struct x_display_info *dpyinfo) { int ndevices, actual_devices; XIDeviceInfo *infos; @@ -19847,9 +19844,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, bar = NULL; - /* See the comment on top of - x_init_master_valuators for more details on how - scroll wheel movement is reported on XInput 2. */ + /* See the comment on top of x_cache_xi_devices + for more details on how scroll wheel movement + is reported on XInput 2. */ delta = x_get_scroll_valuator_delta (dpyinfo, device, i, *values, &val); values++; @@ -21711,7 +21708,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (!device) { /* An existing device might have been enabled. */ - x_init_master_valuators (dpyinfo); + x_cache_xi_devices (dpyinfo); /* Now try to find the device again, in case it was just enabled. */ @@ -27338,7 +27335,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) if (rc == Success) { dpyinfo->supports_xi2 = true; - x_init_master_valuators (dpyinfo); + x_cache_xi_devices (dpyinfo); } } commit ba70d0f77c52d471bceb2ad2cc7bc172db348abb (refs/remotes/origin/emacs-28) Author: Kyle Meyer Date: Sun Jul 24 16:24:24 2022 -0400 Update to Org 9.5.4-17-g6e991f diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index 23ef162a7f..04af84d2e4 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -480,7 +480,7 @@ value. The value can either be a string or a closure that evaluates to a string. The closure is evaluated when the source block is being evaluated (e.g. during execution or export), with point at the source block. It is not possible to use an -arbitrary function symbol (e.g. 'some-func), since org uses +arbitrary function symbol (e.g. `some-func'), since org uses lexical binding. To achieve the same functionality, call the function within a closure (e.g. (lambda () (some-func))). diff --git a/lisp/org/ob-julia.el b/lisp/org/ob-julia.el index abddca3613..50a44bcf44 100644 --- a/lisp/org/ob-julia.el +++ b/lisp/org/ob-julia.el @@ -250,8 +250,8 @@ end") (defun org-babel-julia-evaluate-external-process (body result-type result-params column-names-p) "Evaluate BODY in external julia process. -If RESULT-TYPE equals 'output then return standard output as a -string. If RESULT-TYPE equals 'value then return the value of the +If RESULT-TYPE equals `output' then return standard output as a +string. If RESULT-TYPE equals `value' then return the value of the last statement in BODY, as elisp." (cl-case result-type (value @@ -274,8 +274,8 @@ last statement in BODY, as elisp." (defun org-babel-julia-evaluate-session (session body result-type result-params column-names-p) "Evaluate BODY in SESSION. -If RESULT-TYPE equals 'output then return standard output as a -string. If RESULT-TYPE equals 'value then return the value of the +If RESULT-TYPE equals `output' then return standard output as a +string. If RESULT-TYPE equals `value' then return the value of the last statement in BODY, as elisp." (cl-case result-type (value diff --git a/lisp/org/ob-lua.el b/lisp/org/ob-lua.el index 48de0dbad0..b6e78fb7fd 100644 --- a/lisp/org/ob-lua.el +++ b/lisp/org/ob-lua.el @@ -395,7 +395,7 @@ fd:close()" (org-babel-lua-table-or-string results))))) (defun org-babel-lua-read-string (string) - "Strip 's from around Lua string." + "Strip \\=' characters from around Lua string." (org-unbracket-string "'" "'" string)) (provide 'ob-lua) diff --git a/lisp/org/ob-table.el b/lisp/org/ob-table.el index 2f092998d8..f6729e0ece 100644 --- a/lisp/org/ob-table.el +++ b/lisp/org/ob-table.el @@ -84,7 +84,7 @@ is the equivalent of the following source code block: #+end_src NOTE: The quotation marks around the function name, -'source-block', are optional. +`source-block', are optional. NOTE: By default, string variable names are interpreted as references to source-code blocks, to force interpretation of a diff --git a/lisp/org/ob-tangle.el b/lisp/org/ob-tangle.el index 566258eba4..525d27bc07 100644 --- a/lisp/org/ob-tangle.el +++ b/lisp/org/ob-tangle.el @@ -581,7 +581,10 @@ which enable the original code blocks to be found." (error "Not in tangled code")) (setq body (buffer-substring body-start end))) ;; Go to the beginning of the relative block in Org file. - (org-link-open-from-string link) + ;; Explicitly allow fuzzy search even if user customized + ;; otherwise. + (let (org-link-search-must-match-exact-headline) + (org-link-open-from-string link)) (setq target-buffer (current-buffer)) (if (string-match "[^ \t\n\r]:\\([[:digit:]]+\\)" block-name) (let ((n (string-to-number (match-string 1 block-name)))) diff --git a/lisp/org/oc-basic.el b/lisp/org/oc-basic.el index 9ed1b810fa..8c76e200e4 100644 --- a/lisp/org/oc-basic.el +++ b/lisp/org/oc-basic.el @@ -73,6 +73,7 @@ (require 'seq) (declare-function org-open-at-point "org" (&optional arg)) +(declare-function org-open-file "org" (path &optional in-emacs line search)) (declare-function org-element-interpret-data "org-element" (data)) (declare-function org-element-property "org-element" (property element)) diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el index 71aac271f7..a43b083d53 100644 --- a/lisp/org/org-agenda.el +++ b/lisp/org/org-agenda.el @@ -1615,7 +1615,7 @@ alpha-down Sort headlines alphabetically, reversed. The different possibilities will be tried in sequence, and testing stops if one comparison returns a \"not-equal\". For example, the default - '(time-up category-keep priority-down) + `(time-up category-keep priority-down)' means: Pull out all entries having a specified time of day and sort them, in order to make a time schedule for the current day the first thing in the agenda listing for the day. Of the entries without a time indication, keep @@ -4124,7 +4124,7 @@ dimming them." ;FIXME: The arg isn't used, actually! If the header at `org-hd-marker' is blocked according to `org-entry-blocked-p', then if `org-agenda-dim-blocked-tasks' is -'invisible and the header is not blocked by checkboxes, set the +`invisible' and the header is not blocked by checkboxes, set the text property `org-todo-blocked' to `invisible', otherwise set it to t." (when (get-text-property 0 'todo-state entry) @@ -7399,7 +7399,7 @@ Argument ARG is the prefix argument." When in a restricted subtree, remove it. The restriction will span over the entire file if TYPE is `file', -or if type is '(4), or if the cursor is before the first headline +or if type is \\='(4), or if the cursor is before the first headline in the file. Otherwise, only apply the restriction to the current subtree." (interactive "P") diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el index c26eb6f10a..da544a567d 100644 --- a/lisp/org/org-compat.el +++ b/lisp/org/org-compat.el @@ -113,6 +113,11 @@ the symbol of the calling function, for example." ;;; Emacs < 27.1 compatibility +(if (version< emacs-version "27.1") + (defsubst org-replace-buffer-contents (source &optional _max-secs _max-costs) + (replace-buffer-contents source)) + (defalias 'org-replace-buffer-contents #'replace-buffer-contents)) + (unless (fboundp 'proper-list-p) ;; `proper-list-p' was added in Emacs 27.1. The function below is ;; taken from Emacs subr.el 200195e824b^. diff --git a/lisp/org/org-plot.el b/lisp/org/org-plot.el index bf84c99e04..7958ffd58d 100644 --- a/lisp/org/org-plot.el +++ b/lisp/org/org-plot.el @@ -280,7 +280,7 @@ When NORMALISE is non-nil, the count is divided by the number of values." collect (cons n (/ (length m) normaliser))))) (defun org--plot/prime-factors (value) - "Return the prime decomposition of VALUE, e.g. for 12, '(3 2 2)." + "Return the prime decomposition of VALUE, e.g. for 12, \\='(3 2 2)." (let ((factors '(1)) (i 1)) (while (/= 1 value) (setq i (1+ i)) @@ -682,9 +682,10 @@ line directly before or after the table." (looking-at "[[:space:]]*#\\+")) (setf params (org-plot/collect-options params)))) ;; Dump table to datafile - (if-let ((dump-func (plist-get type :data-dump))) - (funcall dump-func table data-file num-cols params) - (org-plot/gnuplot-to-data table data-file params)) + (let ((dump-func (plist-get type :data-dump))) + (if dump-func + (funcall dump-func table data-file num-cols params) + (org-plot/gnuplot-to-data table data-file params))) ;; Check type of ind column (timestamp? text?) (when (plist-get params :check-ind-type) (let* ((ind (1- (plist-get params :ind))) diff --git a/lisp/org/org-src.el b/lisp/org/org-src.el index 54f901252f..89d0c28a43 100644 --- a/lisp/org/org-src.el +++ b/lisp/org/org-src.el @@ -1235,7 +1235,7 @@ Throw an error if there is no such buffer." (insert (with-current-buffer write-back-buf (buffer-string)))) (save-restriction (narrow-to-region beg end) - (replace-buffer-contents write-back-buf 0.1 nil) + (org-replace-buffer-contents write-back-buf 0.1 nil) (goto-char (point-max)))) (when (and expecting-bol (not (bolp))) (insert "\n"))) (kill-buffer write-back-buf) @@ -1283,7 +1283,7 @@ Throw an error if there is no such buffer." (buffer-string)))) (save-restriction (narrow-to-region beg end) - (replace-buffer-contents write-back-buf 0.1 nil) + (org-replace-buffer-contents write-back-buf 0.1 nil) (goto-char (point-max)))) (when (and expecting-bol (not (bolp))) (insert "\n"))))) (when write-back-buf (kill-buffer write-back-buf)) diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el index 860fd6e560..c301bc6af1 100644 --- a/lisp/org/org-table.el +++ b/lisp/org/org-table.el @@ -5465,7 +5465,7 @@ The table is taken from the parameter TXT, or from the buffer at point." (nreverse table))))) (defun org-table-collapse-header (table &optional separator max-header-lines) - "Collapse the lines before 'hline into a single header. + "Collapse the lines before `hline' into a single header. The given TABLE is a list of lists as returned by `org-table-to-lisp'. The leading lines before the first `hline' symbol are considered diff --git a/lisp/org/org-version.el b/lisp/org/org-version.el index 2a500fe510..915c3f63c7 100644 --- a/lisp/org/org-version.el +++ b/lisp/org/org-version.el @@ -11,7 +11,7 @@ Inserted by installing Org mode or when a release is made." (defun org-git-version () "The Git version of Org mode. Inserted by installing Org or when a release is made." - (let ((org-git-version "release_9.5.4-3-g6dc785")) + (let ((org-git-version "release_9.5.4-17-g6e991f")) org-git-version)) (provide 'org-version) diff --git a/lisp/org/org.el b/lisp/org/org.el index 06af12339e..a6155c1382 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -1694,7 +1694,7 @@ OK to kill that hidden subtree. When nil, kill without remorse." (const :tag "Never kill a hidden subtree with C-k" error))) (defcustom org-special-ctrl-o t - "Non-nil means, make `C-o' insert a row in tables." + "Non-nil means, make `open-line' (\\[open-line]) insert a row in tables." :group 'org-edit-structure :type 'boolean) @@ -3301,7 +3301,7 @@ Replace format-specifiers in the command as noted below and use %i: The LaTeX fragment to be converted. For example, this could be used with LaTeXML as -\"latexmlc 'literal:%i' --profile=math --preload=siunitx.sty 2>/dev/null\"." +\"latexmlc \\='literal:%i\\=' --profile=math --preload=siunitx.sty 2>/dev/null\"." :group 'org-latex :package-version '(Org . "9.4") :type '(choice diff --git a/lisp/org/ox-ascii.el b/lisp/org/ox-ascii.el index 38b2a5772c..76a1a71fab 100644 --- a/lisp/org/ox-ascii.el +++ b/lisp/org/ox-ascii.el @@ -948,12 +948,18 @@ channel." (when description (let ((dest (if (equal type "fuzzy") (org-export-resolve-fuzzy-link link info) - (org-export-resolve-id-link link info)))) - (concat - (org-ascii--fill-string - (format "[%s] %s" anchor (org-ascii--describe-datum dest info)) - width info) - "\n\n")))) + ;; Ignore broken links. On broken link, + ;; `org-export-resolve-id-link' will throw an + ;; error and we will return nil. + (condition-case nil + (org-export-resolve-id-link link info) + (org-link-broken nil))))) + (when dest + (concat + (org-ascii--fill-string + (format "[%s] %s" anchor (org-ascii--describe-datum dest info)) + width info) + "\n\n"))))) ;; Do not add a link that cannot be resolved and doesn't have ;; any description: destination is already visible in the ;; paragraph. diff --git a/lisp/org/ox-html.el b/lisp/org/ox-html.el index 81ef002a05..9cf9125aeb 100644 --- a/lisp/org/ox-html.el +++ b/lisp/org/ox-html.el @@ -2909,7 +2909,7 @@ Starred and \"displaymath\" environments are not numbered." (defun org-html--unlabel-latex-environment (latex-frag) "Change environment in LATEX-FRAG string to an unnumbered one. -For instance, change an 'equation' environment to 'equation*'." +For instance, change an `equation' environment to `equation*'." (replace-regexp-in-string "\\`[ \t]*\\\\begin{\\([^*]+?\\)}" "\\1*" diff --git a/lisp/org/ox-md.el b/lisp/org/ox-md.el index ad684d8033..3551e4184e 100644 --- a/lisp/org/ox-md.el +++ b/lisp/org/ox-md.el @@ -193,11 +193,11 @@ of contents can refer to headlines." ;; A link refers internally to HEADLINE. (org-element-map (plist-get info :parse-tree) 'link (lambda (link) - (eq headline - (pcase (org-element-property :type link) - ((or "custom-id" "id") (org-export-resolve-id-link link info)) - ("fuzzy" (org-export-resolve-fuzzy-link link info)) - (_ nil)))) + (equal headline + ;; Ignore broken links. + (condition-case nil + (org-export-resolve-id-link link info) + (org-link-broken nil)))) info t)))) (defun org-md--headline-title (style level title &optional anchor tags) diff --git a/lisp/org/ox-publish.el b/lisp/org/ox-publish.el index 636bd0d2ae..51e2352b4e 100644 --- a/lisp/org/ox-publish.el +++ b/lisp/org/ox-publish.el @@ -839,7 +839,7 @@ in `org-export-options-alist' or in export back-ends. In the latter case, optional argument BACKEND has to be set to the back-end where the option is defined, e.g., - (org-publish-find-property file :subtitle 'latex) + (org-publish-find-property file :subtitle \\='latex) Return value may be a string or a list, depending on the type of PROPERTY, i.e. \"behavior\" parameter from `org-export-options-alist'." diff --git a/lisp/org/ox.el b/lisp/org/ox.el index 2a3edaa500..a6209ee98f 100644 --- a/lisp/org/ox.el +++ b/lisp/org/ox.el @@ -1908,8 +1908,10 @@ Return a string." (org-element-property :archivedp data))) (let ((transcoder (org-export-transcoder data info))) (or (and (functionp transcoder) - (broken-link-handler - (funcall transcoder data nil info))) + (if (eq type 'link) + (broken-link-handler + (funcall transcoder data nil info)) + (funcall transcoder data nil info))) ;; Export snippets never return a nil value so ;; that white spaces following them are never ;; ignored. commit 2181495af8f47057a7a61e01c192416b9ca70988 Author: Mike Kupfer Date: Sun Jul 17 11:49:56 2022 -0700 Fix the prompt for mh-mime-save-parts (SF#500) * mh-mime.el (mh-mime-save-parts): Use the default argument to read-directory-name; don't use format-prompt. diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el index 5eada03ba4..865f817da5 100644 --- a/lisp/mh-e/mh-mime.el +++ b/lisp/mh-e/mh-mime.el @@ -379,10 +379,8 @@ do the work." ((and (or prompt (equal t mh-mime-save-parts-default-directory)) mh-mime-save-parts-directory) - (read-directory-name (format-prompt - "Store in directory" - mh-mime-save-parts-directory) - "" mh-mime-save-parts-directory t "")) + (read-directory-name "Store in directory: " + mh-mime-save-parts-directory nil t)) ((stringp mh-mime-save-parts-default-directory) mh-mime-save-parts-default-directory) (t commit bb0af6489a1ca0104636fe2d658916e8c5b54dfc Author: Mike Kupfer Date: Sun Jul 17 11:23:48 2022 -0700 * mh-mime.el (mh-mime-save-parts): Restore default-directory (SF#498) diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el index b93f7d8c41..5eada03ba4 100644 --- a/lisp/mh-e/mh-mime.el +++ b/lisp/mh-e/mh-mime.el @@ -394,18 +394,19 @@ do the work." (if (equal nil mh-mime-save-parts-default-directory) (setq mh-mime-save-parts-directory directory)) (with-current-buffer (get-buffer-create mh-log-buffer) - (cd directory) - (setq mh-mime-save-parts-directory directory) - (let ((initial-size (mh-truncate-log-buffer))) - (apply #'call-process - (expand-file-name command mh-progs) nil t nil - (mh-list-to-string (list folder msg "-auto" - (if (not (mh-variant-p 'nmh)) - "-store")))) - (if (> (buffer-size) initial-size) - (save-window-excursion - (switch-to-buffer-other-window mh-log-buffer) - (sit-for 3)))))))) + (let (default-directory) + (cd directory) + (setq mh-mime-save-parts-directory directory) + (let ((initial-size (mh-truncate-log-buffer))) + (apply #'call-process + (expand-file-name command mh-progs) nil t nil + (mh-list-to-string (list folder msg "-auto" + (if (not (mh-variant-p 'nmh)) + "-store")))) + (if (> (buffer-size) initial-size) + (save-window-excursion + (switch-to-buffer-other-window mh-log-buffer) + (sit-for 3))))))))) ;;;###mh-autoload (defun mh-toggle-mh-decode-mime-flag () commit 9ed5c39aad09571314097be91cb28e7504614421 Author: Michael Albinus Date: Sun Jul 24 16:02:10 2022 +0200 Refactor Tramp * lisp/net/tramp-adb.el (tramp-adb-file-name-handler-alist): Use `tramp-adb-handle-get-remote-gid' and `tramp-adb-handle-get-remote-uid'. (tramp-adb-handle-file-attributes): Use `tramp-convert-file-attributes'. (tramp-do-parse-file-attributes-with-ls): Remove ID-FORMAT. (tramp-adb-handle-directory-files-and-attributes): Use `tramp-skeleton-directory-files-and-attributes'. (tramp-adb-handle-file-local-copy): Use `tramp-skeleton-file-local-copy'. (tramp-adb-handle-copy-file, tramp-adb-handle-rename-file): Use `tramp-barf-if-file-missing'. (tramp-adb-handle-get-remote-uid) (tramp-adb-handle-get-remote-gid): New defuns. * lisp/net/tramp-archive.el (tramp-archive-file-name-handler-alist): Use `tramp-archive-handle-directory-files'. (tramp-archive-handle-directory-files): New defun. * lisp/net/tramp-cache.el (tramp-file-property-p): New defun. * lisp/net/tramp-compat.el (tramp-compat-take): New defalias. * lisp/net/tramp-crypt.el (tramp-crypt-do-copy-or-rename-file): Use `tramp-barf-if-file-missing'. (tramp-crypt-handle-directory-files): Use `tramp-skeleton-directory-files'. * lisp/net/tramp-fuse.el (tramp-fuse-handle-directory-files): Use `tramp-skeleton-directory-files'. * lisp/net/tramp-gvfs.el (tramp-gvfs-do-copy-or-rename-file): Use `tramp-barf-if-file-missing'. * lisp/net/tramp-rclone.el (tramp-rclone-do-copy-or-rename-file): Use `tramp-barf-if-file-missing'. * lisp/net/tramp-sh.el (tramp-readlink-file-truename) (tramp-stat-file-attributes) (tramp-stat-directory-files-and-attributes): New defconsts. (tramp-perl-file-attributes) (tramp-perl-directory-files-and-attributes): Adapt. (tramp-sh-handle-make-symbolic-link): Flush TARGET file properties. (tramp-sh-handle-file-truename): Use `tramp-readlink-file-truename' (tramp-sh-handle-file-exists-p) (tramp-sh-handle-file-executable-p) (tramp-sh-handle-file-readable-p) (tramp-sh-handle-file-directory-p) (tramp-sh-handle-file-writable-p): Adapt check of file properties. (tramp-sh-handle-file-attributes): Simplify. (tramp-do-file-attributes-with-ls): Remove ID-FORMAT. Combine two remote commands. Compute both versions of uid and gid together. (tramp-do-file-attributes-with-perl) (tramp-do-directory-files-and-attributes-with-perl): Remove ID-FORMAT. (tramp-do-file-attributes-with-stat): Remove ID-FORMAT. Use `tramp-stat-file-attributes'. (tramp-sh-handle-directory-files-and-attributes): Use `tramp-skeleton-directory-files-and-attributes'. (tramp-do-directory-files-and-attributes-with-stat): Remove ID-FORMAT. Use `tramp-stat-directory-files-and-attributes'. (tramp-sh-handle-copy-directory): Use `tramp-skeleton-copy-directory'. (tramp-do-copy-or-rename-file): Use `tramp-barf-if-file-missing'. (tramp-sh-handle-file-local-copy): Use `tramp-skeleton-file-local-copy'. (tramp-sh-handle-write-region): Combine two remote commands. (tramp-sh-gio-monitor-process-filter): Simplify `cond' call. (tramp-expand-script): Extend for ls, readling and stat. (tramp-open-connection-setup-interactive-shell): Do not set `tramp-end-of-output'. (tramp-open-connection-setup-interactive-shell): Do not send prompt formatting command, it's superfluous. (tramp-send-command-and-check): Rearrange in order to accept also heredoc scripts. (tramp-convert-file-attributes): Move function to tramp.el. (tramp-get-remote-id): Set connection property. (tramp-get-remote-uid-with-id): Use it. (tramp-get-remote-python): Don't check for python2 anymore. * lisp/net/tramp-smb.el (tramp-smb-file-name-handler-alist): Use `tramp-handle-directory-files'. (tramp-smb-handle-copy-directory): Use `tramp-skeleton-copy-directory'. (tramp-smb-handle-directory-files): Remove. (tramp-smb-handle-file-attributes): Use `tramp-convert-file-attributes'. (tramp-smb-do-file-attributes-with-stat): Remove ID-FORMAT. (tramp-smb-handle-file-local-copy): Use `tramp-skeleton-file-local-copy'. * lisp/net/tramp-sudoedit.el (tramp-sudoedit-do-copy-or-rename-file): Use `tramp-barf-if-file-missing'. (tramp-sudoedit-file-attributes): New defconst. (tramp-sudoedit-handle-file-attributes): Simplify code. * lisp/net/tramp.el (tramp-setup-debug-buffer): Set debug buffer as not modified. (tramp-barf-if-file-missing, tramp-skeleton-copy-directory) (tramp-skeleton-directory-files) (tramp-skeleton-directory-files-and-attributes) (tramp-skeleton-file-local-copy): New macros. (tramp-handle-copy-directory): Use `tramp-skeleton-copy-directory'. (tramp-handle-directory-files): Use `tramp-skeleton-directory-files'. (tramp-handle-file-local-copy): Use `tramp-skeleton-file-local-copy'. (tramp-handle-insert-file-contents): Use `tramp-barf-if-file-missing'. (tramp-get-process-attributes, tramp-action-out-of-band): Simplify `cond' call. (tramp-check-cached-permissions): Simplify. (tramp-make-tramp-temp-file): Reimplement. * test/lisp/net/tramp-archive-tests.el (tramp-copy-size-limit): Don't set. * test/lisp/net/tramp-tests.el (tramp--test-enabled): Remove superfluous test files. (tramp-test21-file-links): Protect file name deletion. diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index de55856830..3e780aa1a1 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -182,8 +182,8 @@ It is used for TCP/IP devices." (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) (tramp-get-home-directory . ignore) - (tramp-get-remote-gid . ignore) - (tramp-get-remote-uid . ignore) + (tramp-get-remote-gid . tramp-adb-handle-get-remote-gid) + (tramp-get-remote-uid . tramp-adb-handle-get-remote-uid) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (unlock-file . tramp-handle-unlock-file) @@ -252,21 +252,19 @@ arguments to pass to the OPERATION." (defun tramp-adb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." - (unless id-format (setq id-format 'integer)) - (ignore-errors - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property - v localname (format "file-attributes-%s" id-format) - (and - (tramp-adb-send-command-and-check - v (format "%s -d -l %s" - (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument localname))) - (with-current-buffer (tramp-get-buffer v) - (tramp-adb-sh-fix-ls-output) - (cdar (tramp-do-parse-file-attributes-with-ls v id-format)))))))) - -(defun tramp-do-parse-file-attributes-with-ls (vec &optional id-format) + ;; The result is cached in `tramp-convert-file-attributes'. + (with-parsed-tramp-file-name filename nil + (tramp-convert-file-attributes v localname id-format + (and + (tramp-adb-send-command-and-check + v (format "%s -d -l %s" + (tramp-adb-get-ls-command v) + (tramp-shell-quote-argument localname))) + (with-current-buffer (tramp-get-buffer v) + (tramp-adb-sh-fix-ls-output) + (cdar (tramp-do-parse-file-attributes-with-ls v))))))) + +(defun tramp-do-parse-file-attributes-with-ls (vec) "Parse `file-attributes' for Tramp files using the ls(1) command." (with-current-buffer (tramp-get-buffer vec) (goto-char (point-min)) @@ -290,8 +288,8 @@ arguments to pass to the OPERATION." (or is-dir symlink-target) 1 ;link-count ;; no way to handle numeric ids in Androids ash - (if (eq id-format 'integer) 0 uid) - (if (eq id-format 'integer) 0 gid) + (cons uid tramp-unknown-id-integer) + (cons gid tramp-unknown-id-integer) tramp-time-dont-know ; atime ;; `date-to-time' checks `iso8601-parse', which might fail. (let (signal-hook-function) @@ -308,54 +306,28 @@ arguments to pass to the OPERATION." (defun tramp-adb-handle-directory-files-and-attributes (directory &optional full match nosort id-format count) "Like `directory-files-and-attributes' for Tramp files." - (unless (file-exists-p directory) - (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) - (when (file-directory-p directory) - (with-parsed-tramp-file-name (expand-file-name directory) nil - (copy-tree - (with-tramp-file-property - v localname (format "directory-files-and-attributes-%s-%s-%s-%s-%s" - full match id-format nosort count) - (with-current-buffer (tramp-get-buffer v) - (when (tramp-adb-send-command-and-check - v (format "%s -a -l %s" - (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument localname))) - ;; We insert also filename/. and filename/.., because "ls" doesn't. - ;; Looks like it does include them in toybox, since Android 6. - (unless (re-search-backward "\\.$" nil t) - (narrow-to-region (point-max) (point-max)) - (tramp-adb-send-command - v (format "%s -d -a -l %s %s" - (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument - (tramp-compat-file-name-concat localname ".")) - (tramp-shell-quote-argument - (tramp-compat-file-name-concat localname "..")))) - (widen))) - (tramp-adb-sh-fix-ls-output) - (let ((result (tramp-do-parse-file-attributes-with-ls - v (or id-format 'integer)))) - (when full - (setq result - (mapcar - (lambda (x) - (cons (expand-file-name (car x) directory) (cdr x))) - result))) - (unless nosort - (setq result - (sort result (lambda (x y) (string< (car x) (car y)))))) - - (setq result (delq nil - (mapcar - (lambda (x) (if (or (not match) - (string-match-p - match (car x))) - x)) - result))) - (when (and (natnump count) (> count 0)) - (setq result (tramp-compat-ntake count result))) - result))))))) + (tramp-skeleton-directory-files-and-attributes + directory full match nosort id-format count + (with-current-buffer (tramp-get-buffer v) + (when (tramp-adb-send-command-and-check + v (format "%s -a -l %s" + (tramp-adb-get-ls-command v) + (tramp-shell-quote-argument localname))) + ;; We insert also filename/. and filename/.., because "ls" + ;; doesn't. Looks like it does include them in toybox, since + ;; Android 6. + (unless (re-search-backward "\\.$" nil t) + (narrow-to-region (point-max) (point-max)) + (tramp-adb-send-command + v (format "%s -d -a -l %s %s" + (tramp-adb-get-ls-command v) + (tramp-shell-quote-argument + (tramp-compat-file-name-concat localname ".")) + (tramp-shell-quote-argument + (tramp-compat-file-name-concat localname "..")))) + (widen))) + (tramp-adb-sh-fix-ls-output) + (tramp-do-parse-file-attributes-with-ls v)))) (defun tramp-adb-get-ls-command (vec) "Determine `ls' command and its arguments." @@ -502,22 +474,18 @@ Emacs dired can't find files." (defun tramp-adb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." - (with-parsed-tramp-file-name filename nil - (unless (file-exists-p (file-truename filename)) - (tramp-error v 'file-missing filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (with-tramp-progress-reporter - v 3 (format "Fetching %s to tmp file %s" filename tmpfile) - ;; "adb pull ..." does not always return an error code. - (unless - (and (tramp-adb-execute-adb-command - v "pull" (tramp-compat-file-name-unquote localname) tmpfile) - (file-exists-p tmpfile)) - (ignore-errors (delete-file tmpfile)) - (tramp-error - v 'file-error "Cannot make local copy of file `%s'" filename)) - (set-file-modes tmpfile (logior (or (file-modes filename) 0) #o0400))) - tmpfile))) + (tramp-skeleton-file-local-copy filename + (with-tramp-progress-reporter + v 3 (format "Fetching %s to tmp file %s" filename tmpfile) + ;; "adb pull ..." does not always return an error code. + (unless + (and (tramp-adb-execute-adb-command + v "pull" (tramp-compat-file-name-unquote localname) tmpfile) + (file-exists-p tmpfile)) + (ignore-errors (delete-file tmpfile)) + (tramp-error + v 'file-error "Cannot make local copy of file `%s'" filename)) + (set-file-modes tmpfile (logior (or (file-modes filename) 0) #o0400))))) (defun tramp-adb-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." @@ -617,62 +585,61 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; let-bind `jka-compr-inhibit' to t. (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil - (unless (file-exists-p filename) - (tramp-error v 'file-missing filename)) - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - (with-tramp-progress-reporter - v 0 (format "Copying %s to %s" filename newname) - (if (and t1 t2 (tramp-equal-remote filename newname)) - (let ((l1 (tramp-file-local-name filename)) - (l2 (tramp-file-local-name newname))) - ;; We must also flush the cache of the directory, - ;; because `file-attributes' reads the values from - ;; there. - (tramp-flush-file-properties v l2) - ;; Short track. - (tramp-adb-barf-unless-okay - v (format - "cp -f %s %s" - (tramp-shell-quote-argument l1) - (tramp-shell-quote-argument l2)) - "Error copying %s to %s" filename newname)) - - (if-let ((tmpfile (file-local-copy filename))) - ;; Remote filename. - (condition-case err - (rename-file tmpfile newname ok-if-already-exists) - ((error quit) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Remote newname. - (when (and (file-directory-p newname) - (directory-name-p newname)) - (setq newname - (expand-file-name - (file-name-nondirectory filename) newname))) - - (with-parsed-tramp-file-name newname nil - (when (and (not ok-if-already-exists) - (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - - ;; We must also flush the cache of the directory, - ;; because `file-attributes' reads the values from - ;; there. - (tramp-flush-file-properties v localname) - (unless (tramp-adb-execute-adb-command - v "push" - (tramp-compat-file-name-unquote filename) - (tramp-compat-file-name-unquote localname)) - (tramp-error - v 'file-error - "Cannot copy `%s' `%s'" filename newname)))))))) + (tramp-barf-if-file-missing v filename + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (with-tramp-progress-reporter + v 0 (format "Copying %s to %s" filename newname) + (if (and t1 t2 (tramp-equal-remote filename newname)) + (let ((l1 (tramp-file-local-name filename)) + (l2 (tramp-file-local-name newname))) + ;; We must also flush the cache of the directory, + ;; because `file-attributes' reads the values from + ;; there. + (tramp-flush-file-properties v l2) + ;; Short track. + (tramp-adb-barf-unless-okay + v (format + "cp -f %s %s" + (tramp-shell-quote-argument l1) + (tramp-shell-quote-argument l2)) + "Error copying %s to %s" filename newname)) + + (if-let ((tmpfile (file-local-copy filename))) + ;; Remote filename. + (condition-case err + (rename-file tmpfile newname ok-if-already-exists) + ((error quit) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + ;; Remote newname. + (when (and (file-directory-p newname) + (directory-name-p newname)) + (setq newname + (expand-file-name + (file-name-nondirectory filename) newname))) + + (with-parsed-tramp-file-name newname nil + (when (and (not ok-if-already-exists) + (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + + ;; We must also flush the cache of the directory, + ;; because `file-attributes' reads the values from + ;; there. + (tramp-flush-file-properties v localname) + (unless (tramp-adb-execute-adb-command + v "push" + (tramp-compat-file-name-unquote filename) + (tramp-compat-file-name-unquote localname)) + (tramp-error + v 'file-error + "Cannot copy `%s' `%s'" filename newname))))))))) ;; KEEP-DATE handling. (when keep-date @@ -698,37 +665,38 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; let-bind `jka-compr-inhibit' to t. (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil - (unless (file-exists-p filename) - (tramp-error v 'file-missing filename)) - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - (with-tramp-progress-reporter - v 0 (format "Renaming %s to %s" filename newname) - (if (and t1 t2 - (tramp-equal-remote filename newname) - (not (file-directory-p filename))) - (let ((l1 (tramp-file-local-name filename)) - (l2 (tramp-file-local-name newname))) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v l1) - (tramp-flush-file-properties v l2) - ;; Short track. - (tramp-adb-barf-unless-okay - v (format - "mv -f %s %s" - (tramp-shell-quote-argument l1) - (tramp-shell-quote-argument l2)) - "Error renaming %s to %s" filename newname)) - - ;; Rename by copy. - (copy-file - filename newname ok-if-already-exists 'keep-time 'preserve-uid-gid) - (delete-file filename))))))) + (tramp-barf-if-file-missing v filename + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (with-tramp-progress-reporter + v 0 (format "Renaming %s to %s" filename newname) + (if (and t1 t2 + (tramp-equal-remote filename newname) + (not (file-directory-p filename))) + (let ((l1 (tramp-file-local-name filename)) + (l2 (tramp-file-local-name newname))) + ;; We must also flush the cache of the directory, + ;; because `file-attributes' reads the values from + ;; there. + (tramp-flush-file-properties v l1) + (tramp-flush-file-properties v l2) + ;; Short track. + (tramp-adb-barf-unless-okay + v (format + "mv -f %s %s" + (tramp-shell-quote-argument l1) + (tramp-shell-quote-argument l2)) + "Error renaming %s to %s" filename newname)) + + ;; Rename by copy. + (copy-file + filename newname ok-if-already-exists + 'keep-time 'preserve-uid-gid) + (delete-file filename)))))))) (defun tramp-adb-get-signal-strings (vec) "Strings to return by `process-file' in case of signals." @@ -1067,6 +1035,36 @@ implementation will be used." ;; The equivalent to `exec-directory'. `(,(tramp-file-local-name (expand-file-name default-directory))))) +(defun tramp-adb-handle-get-remote-uid (vec id-format) + "Like `tramp-get-remote-uid' for Tramp files. + ID-FORMAT valid values are `string' and `integer'." + ;; The result is cached in `tramp-get-remote-uid'. + (tramp-adb-send-command + vec + (format "id -u%s %s" + (if (equal id-format 'integer) "" "n") + (if (equal id-format 'integer) + "" "| sed -e s/^/\\\"/ -e s/\\$/\\\"/"))) + (with-current-buffer (tramp-get-connection-buffer vec) + ;; Read the expression. + (goto-char (point-min)) + (read (current-buffer)))) + +(defun tramp-adb-handle-get-remote-gid (vec id-format) + "Like `tramp-get-remote-gid' for Tramp files. +ID-FORMAT valid values are `string' and `integer'." + ;; The result is cached in `tramp-get-remote-gid'. + (tramp-adb-send-command + vec + (format "id -g%s %s" + (if (equal id-format 'integer) "" "n") + (if (equal id-format 'integer) + "" "| sed -e s/^/\\\"/ -e s/\\$/\\\"/"))) + (with-current-buffer (tramp-get-connection-buffer vec) + ;; Read the expression. + (goto-char (point-min)) + (read (current-buffer)))) + (defun tramp-adb-get-device (vec) "Return full host name from VEC to be used in shell execution. E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 47f14861e3..4f106a6b59 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -227,7 +227,7 @@ It must be supported by libarchive(3).") (delete-file . tramp-archive-handle-not-implemented) ;; `diff-latest-backup-file' performed by default handler. (directory-file-name . tramp-archive-handle-directory-file-name) - (directory-files . tramp-handle-directory-files) + (directory-files . tramp-archive-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) (dired-compress-file . tramp-archive-handle-not-implemented) @@ -612,6 +612,27 @@ offered." ;; example. So we return `directory'. directory))) +(defun tramp-archive-handle-directory-files + (directory &optional full match nosort count) + "Like `directory-files' for Tramp files." + (unless (file-exists-p directory) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) + (when (file-directory-p directory) + (setq directory (file-name-as-directory (expand-file-name directory))) + (let ((temp (nreverse (file-name-all-completions "" directory))) + result item) + + (while temp + (setq item (directory-file-name (pop temp))) + (when (or (null match) (string-match-p match item)) + (push (if full (concat directory item) item) + result))) + (unless nosort + (setq result (sort result #'string<))) + (when (and (natnump count) (> count 0)) + (setq result (tramp-compat-ntake count result))) + result))) + (defun tramp-archive-handle-dired-uncache (dir) "Like `dired-uncache' for file archives." (dired-uncache (tramp-archive-gvfs-file-name dir))) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index dbebcad1a8..68f4fda475 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -204,6 +204,12 @@ Return VALUE." (dolist (var (all-completions "tramp-cache-set-count-" obarray)) (unintern var obarray)))) +;;;###tramp-autoload +(defun tramp-file-property-p (key file property) + "Check whether PROPERTY of FILE is defined in the cache context of KEY." + (not (eq (tramp-get-file-property key file property tramp-cache-undefined) + tramp-cache-undefined))) + ;;;###tramp-autoload (defun tramp-flush-file-property (key file property) "Remove PROPERTY of FILE in the cache context of KEY." diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 1286255c89..ef5b1f7ec9 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -294,6 +294,15 @@ CONDITION can also be a list of error conditions." (setq secret (funcall secret))) secret)))) +;; Function `take' is new in Emacs 29.1. +(defalias 'tramp-compat-take + (if (fboundp 'take) + #'take + (lambda (n list) + (when (and (natnump n) (> n 0)) + (if (>= n (length list)) + list (butlast list (- (length list) n))))))) + ;; Function `ntake' is new in Emacs 29.1. (defalias 'tramp-compat-ntake (if (fboundp 'ntake) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 804d6e5bd1..4fcd132ab0 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -600,62 +600,61 @@ absolute file names." (delete-directory filename 'recursive))) (with-parsed-tramp-file-name (if t1 filename newname) nil - (unless (file-exists-p filename) - (tramp-error v 'file-missing filename)) - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - (with-tramp-progress-reporter - v 0 (format "%s %s to %s" msg-operation filename newname) - (if (and t1 t2 (string-equal t1 t2)) - ;; Both files are on the same encrypted remote directory. - (let (tramp-crypt-enabled) - (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))) - - (let* ((tmpdir (tramp-compat-make-temp-file filename 'dir)) - (tmpfile1 - (expand-file-name - (file-name-nondirectory encrypt-filename) tmpdir)) - (tmpfile2 - (expand-file-name - (file-name-nondirectory encrypt-newname) tmpdir)) - tramp-crypt-enabled) - (cond - ;; Source and target file are on an encrypted 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 an encrypted remote directory. - (t1 - (if (eq op 'copy) - (copy-file - encrypt-filename tmpfile1 t keep-date preserve-uid-gid - preserve-extended-attributes) - (rename-file encrypt-filename tmpfile1 t)) - (tramp-crypt-decrypt-file t1 tmpfile1 tmpfile2) - (rename-file tmpfile2 newname ok-if-already-exists)) - ;; Target file is on an encrypted remote directory. - (t2 - (if (eq op 'copy) - (copy-file - filename tmpfile1 t keep-date preserve-uid-gid - preserve-extended-attributes) - (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)))))) + (tramp-barf-if-file-missing v filename + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (if (and t1 t2 (string-equal t1 t2)) + ;; Both files are on the same encrypted remote directory. + (let (tramp-crypt-enabled) + (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))) + + (let* ((tmpdir (tramp-compat-make-temp-file filename 'dir)) + (tmpfile1 + (expand-file-name + (file-name-nondirectory encrypt-filename) tmpdir)) + (tmpfile2 + (expand-file-name + (file-name-nondirectory encrypt-newname) tmpdir)) + tramp-crypt-enabled) + (cond + ;; Source and target file are on an encrypted 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 an encrypted remote directory. + (t1 + (if (eq op 'copy) + (copy-file + encrypt-filename tmpfile1 t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file encrypt-filename tmpfile1 t)) + (tramp-crypt-decrypt-file t1 tmpfile1 tmpfile2) + (rename-file tmpfile2 newname ok-if-already-exists)) + ;; Target file is on an encrypted remote directory. + (t2 + (if (eq op 'copy) + (copy-file + filename tmpfile1 t keep-date preserve-uid-gid + preserve-extended-attributes) + (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))))))) (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename v1 @@ -702,36 +701,14 @@ absolute file names." (defun tramp-crypt-handle-directory-files (directory &optional full match nosort count) "Like `directory-files' for Tramp files." - (unless (file-exists-p directory) - (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) - (when (file-directory-p directory) - (setq directory (file-name-as-directory (expand-file-name directory))) - (let* (tramp-crypt-enabled - (result - (directory-files (tramp-crypt-encrypt-file-name directory) 'full))) - (setq result - (mapcar (lambda (x) (tramp-crypt-decrypt-file-name x)) result)) - (when match - (setq result - (delq - nil - (mapcar - (lambda (x) - (when (string-match-p match (substring x (length directory))) - x)) - result)))) - (unless full - (setq result - (mapcar - (lambda (x) - (replace-regexp-in-string - (concat "^" (regexp-quote directory)) "" x)) - result))) - (unless nosort - (setq result (sort result #'string<))) - (when (and (natnump count) (> count 0)) - (setq result (tramp-compat-ntake count result))) - result))) + (tramp-skeleton-directory-files directory full match nosort count + (let (tramp-crypt-enabled) + (mapcar + (lambda (x) + (replace-regexp-in-string + (concat "^" (regexp-quote directory)) "" + (tramp-crypt-decrypt-file-name x))) + (directory-files (tramp-crypt-encrypt-file-name directory) 'full))))) (defun tramp-crypt-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index 2ff106d602..486a3cc57b 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -58,36 +58,30 @@ (defun tramp-fuse-handle-directory-files (directory &optional full match nosort count) "Like `directory-files' for Tramp files." - (unless (file-exists-p directory) - (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) - (when (file-directory-p directory) - (setq directory (file-name-as-directory (expand-file-name directory))) - (with-parsed-tramp-file-name directory nil - (let ((result - (tramp-compat-directory-files - (tramp-fuse-local-file-name directory) full match nosort count))) + (let ((result + (tramp-skeleton-directory-files directory full match nosort count + ;; Some storage systems do not return "." and "..". + (delete-dups + (append + '("." "..") + (tramp-fuse-remove-hidden-files + (tramp-compat-directory-files + (tramp-fuse-local-file-name directory)))))))) + (if full ;; Massage the result. - (when full - (let ((local (concat "^" (regexp-quote (tramp-fuse-mount-point v)))) - (remote (directory-file-name - (funcall - (if (tramp-compat-file-name-quoted-p directory) - #'tramp-compat-file-name-quote #'identity) - (file-remote-p directory))))) - (setq result - (mapcar - (lambda (x) (replace-regexp-in-string local remote x)) - result)))) - ;; Some storage systems do not return "." and "..". - (dolist (item '(".." ".")) - (when (and (string-match-p (or match (regexp-quote item)) item) - (not - (member (if full (setq item (concat directory item)) item) - result))) - (setq result (cons item result)))) - ;; Return result. - (tramp-fuse-remove-hidden-files - (if nosort result (sort result #'string<))))))) + (let ((local (concat + "^" (regexp-quote + (tramp-fuse-mount-point + (tramp-dissect-file-name directory))))) + (remote (directory-file-name + (funcall + (if (tramp-compat-file-name-quoted-p directory) + #'tramp-compat-file-name-quote #'identity) + (file-remote-p directory))))) + (mapcar + (lambda (x) (replace-regexp-in-string local remote x)) + result)) + result))) (defun tramp-fuse-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 03a6a46e80..d9afcf93c1 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1002,84 +1002,83 @@ file names." (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) (with-parsed-tramp-file-name (if t1 filename newname) nil - (unless (file-exists-p filename) - (tramp-error v 'file-missing filename)) - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - (cond - ;; We cannot rename volatile files, as used by Google-drive. - ((and (not equal-remote) volatile) - (prog1 (copy-file - filename newname ok-if-already-exists keep-date - preserve-uid-gid preserve-extended-attributes) - (delete-file filename))) - - ;; We cannot copy or rename directly. - ((or (and equal-remote - (tramp-get-connection-property v "direct-copy-failed")) - (and t1 (not (tramp-gvfs-file-name-p filename))) - (and t2 (not (tramp-gvfs-file-name-p newname)))) - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (if (eq op 'copy) - (copy-file - filename tmpfile t keep-date preserve-uid-gid - preserve-extended-attributes) - (rename-file filename tmpfile t)) - (rename-file tmpfile newname ok-if-already-exists))) - - ;; Direct action. - (t (with-tramp-progress-reporter - v 0 (format "%s %s to %s" msg-operation filename newname) - (unless - (and (apply - #'tramp-gvfs-send-command v gvfs-operation - (append - (and (eq op 'copy) (or keep-date preserve-uid-gid) - '("--preserve")) - (list - (tramp-gvfs-url-file-name filename) - (tramp-gvfs-url-file-name newname)))) - ;; Some backends do not return a proper error - ;; code in case of direct copy/move. Apply - ;; sanity checks. - (or (not equal-remote) - (tramp-gvfs-send-command - v "gvfs-info" (tramp-gvfs-url-file-name newname)) - (eq op 'copy) - (not (tramp-gvfs-send-command - v "gvfs-info" - (tramp-gvfs-url-file-name filename))))) - - (if (or (not equal-remote) - (and equal-remote - (tramp-get-connection-property - v "direct-copy-failed"))) - ;; Propagate the error. - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (tramp-error-with-buffer - nil v 'file-error - "%s failed, see buffer `%s' for details." - msg-operation (buffer-name))) - - ;; Some WebDAV server, like the one from QNAP, do - ;; not support direct copy/move. Try a fallback. - (tramp-set-connection-property v "direct-copy-failed" t) - (tramp-gvfs-do-copy-or-rename-file - op filename newname ok-if-already-exists keep-date - preserve-uid-gid preserve-extended-attributes)))) - - (when (and t1 (eq op 'rename)) - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname))) - - (when t2 - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-properties v localname))))))))) + (tramp-barf-if-file-missing v filename + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (cond + ;; We cannot rename volatile files, as used by Google-drive. + ((and (not equal-remote) volatile) + (prog1 (copy-file + filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + (delete-file filename))) + + ;; We cannot copy or rename directly. + ((or (and equal-remote + (tramp-get-connection-property v "direct-copy-failed")) + (and t1 (not (tramp-gvfs-file-name-p filename))) + (and t2 (not (tramp-gvfs-file-name-p newname)))) + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (if (eq op 'copy) + (copy-file + filename tmpfile t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file filename tmpfile t)) + (rename-file tmpfile newname ok-if-already-exists))) + + ;; Direct action. + (t (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (unless + (and (apply + #'tramp-gvfs-send-command v gvfs-operation + (append + (and (eq op 'copy) (or keep-date preserve-uid-gid) + '("--preserve")) + (list + (tramp-gvfs-url-file-name filename) + (tramp-gvfs-url-file-name newname)))) + ;; Some backends do not return a proper error + ;; code in case of direct copy/move. Apply + ;; sanity checks. + (or (not equal-remote) + (tramp-gvfs-send-command + v "gvfs-info" (tramp-gvfs-url-file-name newname)) + (eq op 'copy) + (not (tramp-gvfs-send-command + v "gvfs-info" + (tramp-gvfs-url-file-name filename))))) + + (if (or (not equal-remote) + (and equal-remote + (tramp-get-connection-property + v "direct-copy-failed"))) + ;; Propagate the error. + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (tramp-error-with-buffer + nil v 'file-error + "%s failed, see buffer `%s' for details." + msg-operation (buffer-name))) + + ;; Some WebDAV server, like the one from QNAP, do + ;; not support direct copy/move. Try a fallback. + (tramp-set-connection-property v "direct-copy-failed" t) + (tramp-gvfs-do-copy-or-rename-file + op filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes)))) + + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname))) + + (when t2 + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-properties v localname)))))))))) (defun tramp-gvfs-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -1626,6 +1625,7 @@ VEC or USER, or if there is no home directory, return nil." (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'." + ;; The result is cached in `tramp-get-remote-uid'. (if (equal id-format 'string) (tramp-file-name-user vec) (when-let ((localname @@ -1636,6 +1636,7 @@ ID-FORMAT valid values are `string' and `integer'." (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'." + ;; The result is cached in `tramp-get-remote-gid'. (when-let ((localname (tramp-get-connection-property (tramp-get-process vec) "share"))) (file-attribute-group-id @@ -1795,7 +1796,8 @@ a downcased host name only." (progn (message "%s" message) 0) - (with-tramp-connection-property (tramp-get-process v) message + (with-tramp-connection-property + (tramp-get-process v) message ;; In theory, there can be several choices. ;; Until now, there is only the question ;; whether to accept an unknown host diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index bbc7685131..5bee5641bb 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -225,46 +225,45 @@ file names." (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) (with-parsed-tramp-file-name (if t1 filename newname) nil - (unless (file-exists-p filename) - (tramp-error v 'file-missing filename)) - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - (if (or (and t1 (not (tramp-rclone-file-name-p filename))) - (and t2 (not (tramp-rclone-file-name-p newname)))) - - ;; We cannot copy or rename directly. - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (if (eq op 'copy) - (copy-file - filename tmpfile t keep-date preserve-uid-gid - preserve-extended-attributes) - (rename-file filename tmpfile t)) - (rename-file tmpfile newname ok-if-already-exists)) - - ;; Direct action. - (with-tramp-progress-reporter - v 0 (format "%s %s to %s" msg-operation filename newname) - (unless (zerop - (tramp-rclone-send-command - v rclone-operation - (tramp-rclone-remote-file-name filename) - (tramp-rclone-remote-file-name newname))) - (tramp-error - v 'file-error - "Error %s `%s' `%s'" msg-operation filename newname))) - - (when (and t1 (eq op 'rename)) - (while (file-exists-p filename) - (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)))))))) + (tramp-barf-if-file-missing v filename + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (if (or (and t1 (not (tramp-rclone-file-name-p filename))) + (and t2 (not (tramp-rclone-file-name-p newname)))) + + ;; We cannot copy or rename directly. + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (if (eq op 'copy) + (copy-file + filename tmpfile t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file filename tmpfile t)) + (rename-file tmpfile newname ok-if-already-exists)) + + ;; Direct action. + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (unless (zerop + (tramp-rclone-send-command + v rclone-operation + (tramp-rclone-remote-file-name filename) + (tramp-rclone-remote-file-name newname))) + (tramp-error + v 'file-error + "Error %s `%s' `%s'" msg-operation filename newname))) + + (when (and t1 (eq op 'rename)) + (while (file-exists-p filename) + (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))))))))) (defun tramp-rclone-handle-copy-file (filename newname &optional ok-if-already-exists keep-date diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index e772af9e0a..6d32622742 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -620,6 +620,21 @@ on the remote file system. Format specifiers are replaced by `tramp-expand-script', percent characters need to be doubled.") +(defconst tramp-readlink-file-truename + (format + (concat + "(echo -n %s &&" + " %%r --no-newline --canonicalize-missing \"$1\" &&" + " echo %s) |" + " sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'") + tramp-stat-marker + tramp-stat-marker + tramp-stat-quoted-marker) + "Shell function to produce output suitable for use with `file-truename' +on the remote file system. +Format specifiers are replaced by `tramp-expand-script', percent +characters need to be doubled.") + (defconst tramp-perl-file-name-all-completions "%p -e ' opendir(d, $ARGV[0]) || die(\"$ARGV[0]: $!\\nfail\\n\"); @@ -666,14 +681,14 @@ else { $type = \"nil\" }; -$uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; -$gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; printf( - \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t %%u -1)\\n\", + \"(%%s %%u (%%s . %%u) (%%s . %%u) (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t %%u -1)\\n\", $type, $stat[3], - $uid, - $gid, + \"\\\"\" . getpwuid($stat[4]) . \"\\\"\", + $stat[4], + \"\\\"\" . getgrgid($stat[5]) . \"\\\"\", + $stat[5], $stat[8] >> 16 & 0xffff, $stat[8] & 0xffff, $stat[9] >> 16 & 0xffff, @@ -683,12 +698,29 @@ printf( $stat[7], $stat[2], $stat[1] -);' \"$1\" \"$2\" %n" +);' \"$1\" %n" "Perl script to produce output suitable for use with `file-attributes' on the remote file system. Format specifiers are replaced by `tramp-expand-script', percent characters need to be doubled.") +(defconst tramp-stat-file-attributes + (format + (concat + "(%%s -c" + " '((%s%%%%N%s) %%%%h (%s%%%%U%s . %%%%u) (%s%%%%G%s . %%%%g)" + " %%%%X %%%%Y %%%%Z %%%%s %s%%%%A%s t %%%%i -1)' \"$1\" %%n || echo nil) |" + " sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'") + tramp-stat-marker tramp-stat-marker ; %%N + tramp-stat-marker tramp-stat-marker ; %%U + tramp-stat-marker tramp-stat-marker ; %%G + tramp-stat-marker tramp-stat-marker ; %%A + tramp-stat-quoted-marker) + "Shell function to produce output suitable for use with `file-attributes' +on the remote file system. +Format specifiers are replaced by `tramp-expand-script', percent +characters need to be doubled.") + (defconst tramp-perl-directory-files-and-attributes "%p -e ' chdir($ARGV[0]) or printf(\"\\\"Cannot change to $ARGV[0]: $''!''\\\"\\n\"), exit(); @@ -715,16 +747,16 @@ for($i = 0; $i < $n; $i++) { $type = \"nil\" }; - $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; - $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; $filename =~ s/\"/\\\\\"/g; printf( - \"(\\\"%%s\\\" %%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t %%u -1)\\n\", + \"(\\\"%%s\\\" %%s %%u (%%s . %%u) (%%s . %%u) (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t %%u -1)\\n\", $filename, $type, $stat[3], - $uid, - $gid, + \"\\\"\" . getpwuid($stat[4]) . \"\\\"\", + $stat[4], + \"\\\"\" . getgrgid($stat[5]) . \"\\\"\", + $stat[5], $stat[8] >> 16 & 0xffff, $stat[8] & 0xffff, $stat[9] >> 16 & 0xffff, @@ -735,12 +767,38 @@ for($i = 0; $i < $n; $i++) $stat[2], $stat[1]); } -printf(\")\\n\");' \"$1\" \"$2\" %n" +printf(\")\\n\");' \"$1\" %n" "Perl script implementing `directory-files-and-attributes' as Lisp `read'able output. Format specifiers are replaced by `tramp-expand-script', percent characters need to be doubled.") +(defconst tramp-stat-directory-files-and-attributes + (format + (concat + ;; We must care about file names with spaces, or starting with + ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, + ;; but it does not work on all remote systems. Therefore, we use + ;; \000 as file separator. `tramp-sh--quoting-style-options' do + ;; not work for file names with spaces piped to "xargs". + ;; Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape of + ;; them in file names. + "cd \"$1\" && echo \"(\"; (%%l -a | tr '\\n\\r' '\\000\\000' |" + " xargs -0 %%s -c" + " '(%s%%%%n%s (%s%%%%N%s) %%%%h (%s%%%%U%s . %%%%u) (%s%%%%G%s . %%%%g) %%%%X %%%%Y %%%%Z %%%%s %s%%%%A%s t %%%%i -1)'" + " -- %%n | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"") + tramp-stat-marker tramp-stat-marker ; %n + tramp-stat-marker tramp-stat-marker ; %N + tramp-stat-marker tramp-stat-marker ; %U + tramp-stat-marker tramp-stat-marker ; %G + tramp-stat-marker tramp-stat-marker ; %A + tramp-stat-quoted-marker) + "Shell function implementing `directory-files-and-attributes' as Lisp +`read'able output. +Format specifiers are replaced by `tramp-expand-script', percent +characters need to be doubled.") + ;; These two use base64 encoding. (defconst tramp-perl-encode-with-module "%p -MMIME::Base64 -0777 -ne 'print encode_base64($_)' %n" @@ -1068,7 +1126,9 @@ component is used as the target of the symlink." (let ((non-essential t)) (when (and (tramp-tramp-file-p target) (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target (tramp-file-local-name (expand-file-name target))))) + (setq target (tramp-file-local-name (expand-file-name target)))) + ;; There could be a cyclic link. + (tramp-flush-file-properties v target)) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -1130,36 +1190,31 @@ component is used as the target of the symlink." (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) - (cond - ;; Use GNU readlink --canonicalize-missing where available. - ((tramp-get-remote-readlink v) - (tramp-send-command-and-check - v - (format "%s --canonicalize-missing %s" - (tramp-get-remote-readlink v) - (tramp-shell-quote-argument localname))) - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (setq result (buffer-substring (point-min) (point-at-eol))))) - - ;; Use Perl implementation. - ((and (tramp-get-remote-perl v) - (tramp-get-connection-property v "perl-file-spec") - (tramp-get-connection-property v "perl-cwd-realpath")) - (tramp-maybe-send-script - v tramp-perl-file-truename "tramp_perl_file_truename") - (setq result - (tramp-send-command-and-read - v - (format "tramp_perl_file_truename %s" - (tramp-shell-quote-argument localname))))) - - ;; Do it yourself. - (t (setq - result - (tramp-file-local-name (tramp-handle-file-truename filename))))) + (tramp-message v 4 "Finding true name for `%s'" filename) + (let ((result + (cond + ;; Use GNU readlink --canonicalize-missing where + ;; available. + ((tramp-get-remote-readlink v) + (tramp-maybe-send-script + v tramp-readlink-file-truename "tramp_readlink_file_truename") + (tramp-send-command-and-read + v (format "tramp_readlink_file_truename %s" + (tramp-shell-quote-argument localname)))) + + ;; Use Perl implementation. + ((and (tramp-get-remote-perl v) + (tramp-get-connection-property v "perl-file-spec") + (tramp-get-connection-property v "perl-cwd-realpath")) + (tramp-maybe-send-script + v tramp-perl-file-truename "tramp_perl_file_truename") + (tramp-send-command-and-read + v (format "tramp_perl_file_truename %s" + (tramp-shell-quote-argument localname)))) + + ;; Do it yourself. + (t (tramp-file-local-name + (tramp-handle-file-truename filename)))))) ;; Detect cycle. (when (and (file-symlink-p filename) @@ -1184,37 +1239,28 @@ component is used as the target of the symlink." (when (tramp-connectable-p filename) (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-exists-p" - (or (not (null (tramp-get-file-property - v localname "file-attributes-integer"))) - (not (null (tramp-get-file-property - v localname "file-attributes-string"))) - (tramp-send-command-and-check - v - (format - "%s %s" - (tramp-get-file-exists-command v) - (tramp-shell-quote-argument localname)))))))) + (if (tramp-file-property-p v localname "file-attributes") + (not (null (tramp-get-file-property v localname "file-attributes"))) + (tramp-send-command-and-check + v + (format + "%s %s" + (tramp-get-file-exists-command v) + (tramp-shell-quote-argument localname)))))))) (defun tramp-sh-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." - (unless id-format (setq id-format 'integer)) - (ignore-errors - ;; Don't modify `last-coding-system-used' by accident. - (let ((last-coding-system-used last-coding-system-used)) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property - v localname (format "file-attributes-%s" id-format) - (tramp-convert-file-attributes - v - (or - (cond - ((tramp-get-remote-stat v) - (tramp-do-file-attributes-with-stat v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-file-attributes-with-perl v localname id-format)) - (t nil)) - ;; The scripts could fail, for example with huge file size. - (tramp-do-file-attributes-with-ls v localname id-format)))))))) + ;; The result is cached in `tramp-convert-file-attributes'. + ;; Don't modify `last-coding-system-used' by accident. + (let ((last-coding-system-used last-coding-system-used)) + (with-parsed-tramp-file-name (expand-file-name filename) nil + (tramp-convert-file-attributes v localname id-format + (cond + ((tramp-get-remote-stat v) + (tramp-do-file-attributes-with-stat v localname)) + ((tramp-get-remote-perl v) + (tramp-do-file-attributes-with-perl v localname)) + (t (tramp-do-file-attributes-with-ls v localname))))))) (defconst tramp-sunos-unames (regexp-opt '("SunOS 5.10" "SunOS 5.11")) "Regexp to determine remote SunOS.") @@ -1230,29 +1276,40 @@ component is used as the target of the symlink." (tramp-get-ls-command-with vec "-w")) "")) -(defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) +(defun tramp-do-file-attributes-with-ls (vec localname) "Implement `file-attributes' for Tramp files using the ls(1) command." (let (symlinkp dirp res-inode res-filemodes res-numlinks - res-uid res-gid res-size res-symlink-target) + res-uid-string res-gid-string res-uid-integer res-gid-integer + res-size res-symlink-target) (tramp-message vec 5 "file attributes with ls: %s" localname) ;; We cannot send all three commands combined, it could exceed ;; NAME_MAX or PATH_MAX. Happened on macOS, for example. - (when (or (tramp-send-command-and-check - vec - (format "%s %s" - (tramp-get-file-exists-command vec) - (tramp-shell-quote-argument localname))) - (tramp-send-command-and-check - vec - (format "%s -h %s" - (tramp-get-test-command vec) - (tramp-shell-quote-argument localname)))) + (when (tramp-send-command-and-check + vec + (format "cd %s && (%s %s || %s -h %s)" + (tramp-shell-quote-argument + (tramp-run-real-handler + #'file-name-directory (list localname))) + (tramp-get-file-exists-command vec) + (if (string-empty-p (file-name-nondirectory localname)) + "." + (tramp-shell-quote-argument + (file-name-nondirectory localname))) + (tramp-get-test-command vec) + (if (string-empty-p (file-name-nondirectory localname)) + "." + (tramp-shell-quote-argument + (file-name-nondirectory localname))))) (tramp-send-command vec - (format "%s %s %s %s" + (format "%s -ild %s %s; %s -lnd %s %s" + (tramp-get-ls-command vec) + ;; On systems which have no quoting style, file names + ;; with special characters could fail. + (tramp-sh--quoting-style-options vec) + (tramp-shell-quote-argument localname) (tramp-get-ls-command vec) - (if (eq id-format 'integer) "-ildn" "-ild") ;; On systems which have no quoting style, file names ;; with special characters could fail. (tramp-sh--quoting-style-options vec) @@ -1268,17 +1325,12 @@ component is used as the target of the symlink." ;; ... number links (setq res-numlinks (read (current-buffer))) ;; ... uid and gid - (setq res-uid (read (current-buffer))) - (setq res-gid (read (current-buffer))) - (if (eq id-format 'integer) - (progn - (unless (numberp res-uid) - (setq res-uid tramp-unknown-id-integer)) - (unless (numberp res-gid) - (setq res-gid tramp-unknown-id-integer))) - (progn - (unless (stringp res-uid) (setq res-uid (symbol-name res-uid))) - (unless (stringp res-gid) (setq res-gid (symbol-name res-gid))))) + (setq res-uid-string (read (current-buffer))) + (setq res-gid-string (read (current-buffer))) + (unless (stringp res-uid-string) + (setq res-uid-string (symbol-name res-uid-string))) + (unless (stringp res-gid-string) + (setq res-gid-string (symbol-name res-gid-string))) ;; ... size (setq res-size (read (current-buffer))) ;; From the file modes, figure out other stuff. @@ -1291,7 +1343,20 @@ component is used as the target of the symlink." (if (looking-at-p "\"") (read (current-buffer)) (buffer-substring (point) (point-at-eol))))) - ;; Return data gathered. + (forward-line) + ;; ... file mode flags + (read (current-buffer)) + ;; ... number links + (read (current-buffer)) + ;; ... uid and gid + (setq res-uid-integer (read (current-buffer))) + (setq res-gid-integer (read (current-buffer))) + (unless (numberp res-uid-integer) + (setq res-uid-integer tramp-unknown-id-integer)) + (unless (numberp res-gid-integer) + (setq res-gid-integer tramp-unknown-id-integer)) + + ;; Return data gathered. (list ;; 0. t for directory, string (name linked to) for symbolic ;; link, or nil. @@ -1299,9 +1364,9 @@ component is used as the target of the symlink." ;; 1. Number of links to file. res-numlinks ;; 2. File uid. - res-uid + (cons res-uid-string res-uid-integer) ;; 3. File gid. - res-gid + (cons res-gid-string res-gid-integer) ;; 4. Last access time. ;; 5. Last modification time. ;; 6. Last status change time. @@ -1318,42 +1383,23 @@ component is used as the target of the symlink." ;; 11. Device number. Will be replaced by a virtual device number. -1)))))) -(defun tramp-do-file-attributes-with-perl - (vec localname &optional id-format) +(defun tramp-do-file-attributes-with-perl (vec localname) "Implement `file-attributes' for Tramp files using a Perl script." (tramp-message vec 5 "file attributes with perl: %s" localname) (tramp-maybe-send-script vec tramp-perl-file-attributes "tramp_perl_file_attributes") (tramp-send-command-and-read - vec - (format "tramp_perl_file_attributes %s %s" - (tramp-shell-quote-argument localname) id-format))) + vec (format "tramp_perl_file_attributes %s" + (tramp-shell-quote-argument localname)))) -(defun tramp-do-file-attributes-with-stat - (vec localname &optional id-format) +(defun tramp-do-file-attributes-with-stat (vec localname) "Implement `file-attributes' for Tramp files using stat(1) command." (tramp-message vec 5 "file attributes with stat: %s" localname) + (tramp-maybe-send-script + vec tramp-stat-file-attributes "tramp_stat_file_attributes") (tramp-send-command-and-read - vec - (format - (concat - ;; 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 |" - " sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g')") - (tramp-get-remote-stat vec) - tramp-stat-marker tramp-stat-marker - (if (eq id-format 'integer) - "%u" - (eval-when-compile (concat tramp-stat-marker "%U" tramp-stat-marker))) - (if (eq id-format 'integer) - "%g" - (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) - 'noerror)) + vec (format "tramp_stat_file_attributes %s" + (tramp-shell-quote-argument localname)))) (defun tramp-sh-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." @@ -1486,6 +1532,7 @@ VEC or USER, or if there is no home directory, return nil." (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'." + ;; The result is cached in `tramp-get-remote-uid'. (ignore-errors (cond ((tramp-get-remote-id vec) (tramp-get-remote-uid-with-id vec id-format)) @@ -1496,6 +1543,7 @@ ID-FORMAT valid values are `string' and `integer'." (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'." + ;; The result is cached in `tramp-get-remote-gid'. (ignore-errors (cond ((tramp-get-remote-id vec) (tramp-get-remote-gid-with-id vec id-format)) @@ -1620,16 +1668,18 @@ ID-FORMAT valid values are `string' and `integer'." (with-tramp-file-property v localname "file-executable-p" ;; Examine `file-attributes' cache to see if request can be ;; satisfied without remote operation. - (or (tramp-check-cached-permissions v ?x) - (tramp-check-cached-permissions v ?s) - (tramp-run-test "-x" filename))))) + (if (tramp-file-property-p v localname "file-attributes") + (or (tramp-check-cached-permissions v ?x) + (tramp-check-cached-permissions v ?s)) + (tramp-run-test "-x" filename))))) (defun tramp-sh-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-readable-p" - (or (tramp-handle-file-readable-p filename) - (tramp-run-test "-r" filename))))) + (if (tramp-file-property-p v localname "file-attributes") + (tramp-handle-file-readable-p filename) + (tramp-run-test "-r" filename))))) ;; Functions implemented using the basic functions above. @@ -1642,19 +1692,28 @@ ID-FORMAT valid values are `string' and `integer'." ;; be expected that this is always a directory. (or (zerop (length localname)) (with-tramp-file-property v localname "file-directory-p" - (tramp-run-test "-d" filename))))) + (if-let + ((truename (tramp-get-file-property v localname "file-truename")) + (attr-p (tramp-file-property-p + v (tramp-file-local-name truename) "file-attributes"))) + (eq (file-attribute-type + (tramp-get-file-property + v (tramp-file-local-name truename) "file-attributes")) + t) + (tramp-run-test "-d" filename)))))) (defun tramp-sh-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-writable-p" (if (file-exists-p filename) - ;; Examine `file-attributes' cache to see if request can be - ;; satisfied without remote operation. - (or (tramp-check-cached-permissions v ?w) - (tramp-run-test "-w" filename)) + (if (tramp-file-property-p v localname "file-attributes") + ;; Examine `file-attributes' cache to see if request can + ;; be satisfied without remote operation. + (tramp-check-cached-permissions v ?w) + (tramp-run-test "-w" filename)) ;; If file doesn't exist, check if directory is writable. - (and (tramp-run-test "-d" (file-name-directory filename)) + (and (file-exists-p (file-name-directory filename)) (tramp-run-test "-w" (file-name-directory filename))))))) (defun tramp-sh-handle-file-ownership-preserved-p (filename &optional group) @@ -1683,51 +1742,18 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sh-handle-directory-files-and-attributes (directory &optional full match nosort id-format count) "Like `directory-files-and-attributes' for Tramp files." - (unless id-format (setq id-format 'integer)) - (unless (file-exists-p directory) - (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) - (when (file-directory-p directory) - (setq directory (expand-file-name directory)) - (let* ((temp - (copy-tree - (with-parsed-tramp-file-name directory nil - (with-tramp-file-property - v localname - (format "directory-files-and-attributes-%s" id-format) - (mapcar - (lambda (x) - (cons (car x) (tramp-convert-file-attributes v (cdr x)))) - (cond - ((tramp-get-remote-stat v) - (tramp-do-directory-files-and-attributes-with-stat - v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-directory-files-and-attributes-with-perl - v localname id-format)) - (t nil))))))) - result item) - - (while temp - (setq item (pop temp)) - (when (or (null match) (string-match-p match (car item))) - (when full - (setcar item (expand-file-name (car item) directory))) - (push item result))) - - (unless nosort - (setq result (sort result (lambda (x y) (string< (car x) (car y)))))) - - (when (and (natnump count) (> count 0)) - (setq result (tramp-compat-ntake count result))) - - (or result - ;; The scripts could fail, for example with huge file size. - (tramp-handle-directory-files-and-attributes - directory full match nosort id-format count))))) + (tramp-skeleton-directory-files-and-attributes + directory full match nosort id-format count + (cond + ((tramp-get-remote-stat v) + (tramp-do-directory-files-and-attributes-with-stat + v localname)) + ((tramp-get-remote-perl v) + (tramp-do-directory-files-and-attributes-with-perl + v localname))))) ;; FIXME: Fix function to work with count parameter. -(defun tramp-do-directory-files-and-attributes-with-perl - (vec localname &optional id-format) +(defun tramp-do-directory-files-and-attributes-with-perl (vec localname) "Implement `directory-files-and-attributes' for Tramp files using a Perl script." (tramp-message vec 5 "directory-files-and-attributes with perl: %s" localname) (tramp-maybe-send-script @@ -1735,50 +1761,21 @@ ID-FORMAT valid values are `string' and `integer'." "tramp_perl_directory_files_and_attributes") (let ((object (tramp-send-command-and-read - vec - (format "tramp_perl_directory_files_and_attributes %s %s" - (tramp-shell-quote-argument localname) id-format)))) + vec (format "tramp_perl_directory_files_and_attributes %s" + (tramp-shell-quote-argument localname))))) (when (stringp object) (tramp-error vec 'file-error object)) object)) ;; FIXME: Fix function to work with count parameter. -(defun tramp-do-directory-files-and-attributes-with-stat - (vec localname &optional id-format) +(defun tramp-do-directory-files-and-attributes-with-stat (vec localname) "Implement `directory-files-and-attributes' for Tramp files with stat(1) command." (tramp-message vec 5 "directory-files-and-attributes with stat: %s" localname) + (tramp-maybe-send-script + vec tramp-stat-directory-files-and-attributes + "tramp_stat_directory_files_and_attributes") (tramp-send-command-and-read - vec - (format - (concat - ;; We must care about file names with spaces, or starting with - ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, - ;; but it does not work on all remote systems. Therefore, we use - ;; \000 as file separator. `tramp-sh--quoting-style-options' do - ;; not work for file names with spaces piped to "xargs". - ;; Apostrophes in the stat output are masked as - ;; `tramp-stat-marker', in order to make a proper shell escape of - ;; them in file names. - "cd %s && echo \"(\"; (%s %s -a | tr '\\n\\r' '\\000\\000' | " - "xargs -0 %s -c " - "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " - "-- 2>%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"") - (tramp-shell-quote-argument localname) - (tramp-get-ls-command vec) - ;; On systems which have no quoting style, file names with special - ;; characters could fail. - (tramp-sh--quoting-style-options vec) - (tramp-get-remote-stat vec) - tramp-stat-marker tramp-stat-marker - tramp-stat-marker tramp-stat-marker - (if (eq id-format 'integer) - "%u" - (eval-when-compile (concat tramp-stat-marker "%U" tramp-stat-marker))) - (if (eq id-format 'integer) - "%g" - (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker))) - tramp-stat-marker tramp-stat-marker - (tramp-get-remote-null-device vec) - tramp-stat-quoted-marker))) + vec (format "tramp_stat_directory_files_and_attributes %s" + (tramp-shell-quote-argument localname)))) ;; This function should return "foo/" for directories and "bar" for ;; files. @@ -1900,59 +1897,62 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sh-handle-copy-directory (dirname newname &optional keep-date parents copy-contents) "Like `copy-directory' for Tramp files." - (let ((t1 (tramp-tramp-file-p dirname)) - (t2 (tramp-tramp-file-p newname)) - target) - (with-parsed-tramp-file-name (if t1 dirname newname) nil - (unless (file-exists-p dirname) - (tramp-error v 'file-missing dirname)) - - ;; `copy-directory-create-symlink' exists since Emacs 28.1. - (if (and (bound-and-true-p copy-directory-create-symlink) - (setq target (file-symlink-p dirname)) - (tramp-equal-remote dirname newname)) - (make-symbolic-link - target - (if (directory-name-p newname) - (concat newname (file-name-nondirectory dirname)) newname) - t) - - (if (and (not copy-contents) - (tramp-get-method-parameter v 'tramp-copy-recursive) - ;; When DIRNAME and NEWNAME are remote, they must - ;; have the same method. - (or (null t1) (null t2) - (string-equal - (tramp-file-name-method (tramp-dissect-file-name dirname)) - (tramp-file-name-method - (tramp-dissect-file-name newname))))) - ;; scp or rsync DTRT. - (progn - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-already-exists newname)) - (setq dirname (directory-file-name (expand-file-name dirname)) - newname (directory-file-name (expand-file-name newname))) - (when (and (file-directory-p newname) - (not (string-equal (file-name-nondirectory dirname) - (file-name-nondirectory newname)))) - (setq newname - (expand-file-name - (file-name-nondirectory dirname) newname))) - (unless (file-directory-p (file-name-directory newname)) - (make-directory (file-name-directory newname) parents)) - (tramp-do-copy-or-rename-file-out-of-band - 'copy dirname newname 'ok-if-already-exists keep-date)) - - ;; We must do it file-wise. - (tramp-run-real-handler - #'copy-directory - (list dirname newname keep-date parents copy-contents)))) - - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-properties v localname)))))) + (tramp-skeleton-copy-directory + dirname newname keep-date parents copy-contents + (let ((t1 (tramp-tramp-file-p dirname)) + (t2 (tramp-tramp-file-p newname)) + target) + (with-parsed-tramp-file-name (if t1 dirname newname) nil + (unless (file-exists-p dirname) + (tramp-error v 'file-missing dirname)) + + ;; `copy-directory-create-symlink' exists since Emacs 28.1. + (if (and (bound-and-true-p copy-directory-create-symlink) + (setq target (file-symlink-p dirname)) + (tramp-equal-remote dirname newname)) + (make-symbolic-link + target + (if (directory-name-p newname) + (concat newname (file-name-nondirectory dirname)) newname) + t) + + (if (and (not copy-contents) + (tramp-get-method-parameter v 'tramp-copy-recursive) + ;; When DIRNAME and NEWNAME are remote, they must + ;; have the same method. + (or (null t1) (null t2) + (string-equal + (tramp-file-name-method + (tramp-dissect-file-name dirname)) + (tramp-file-name-method + (tramp-dissect-file-name newname))))) + ;; scp or rsync DTRT. + (progn + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-already-exists newname)) + (setq dirname (directory-file-name (expand-file-name dirname)) + newname (directory-file-name (expand-file-name newname))) + (when (and (file-directory-p newname) + (not (string-equal (file-name-nondirectory dirname) + (file-name-nondirectory newname)))) + (setq newname + (expand-file-name + (file-name-nondirectory dirname) newname))) + (unless (file-directory-p (file-name-directory newname)) + (make-directory (file-name-directory newname) parents)) + (tramp-do-copy-or-rename-file-out-of-band + 'copy dirname newname 'ok-if-already-exists keep-date)) + + ;; We must do it file-wise. + (tramp-run-real-handler + #'copy-directory + (list dirname newname keep-date parents copy-contents)))) + + ;; When newname did exist, we have wrong cached values. + (when t2 + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-properties v localname))))))) (defun tramp-sh-handle-rename-file (filename newname &optional ok-if-already-exists) @@ -1997,98 +1997,101 @@ file names." (copy-directory filename newname keep-date t) (when (eq op 'rename) (delete-directory filename 'recursive))) + ;; FIXME: This should be optimized. Computing `file-attributes' + ;; checks already, whether the file exists. (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) (length (file-attribute-size (file-attributes (file-truename filename)))) - (attributes (and preserve-extended-attributes - (file-extended-attributes filename))) (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) (with-parsed-tramp-file-name (if t1 filename newname) nil - (unless (file-exists-p filename) + (unless length (tramp-error v 'file-missing filename)) - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) + (tramp-barf-if-file-missing v filename + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) - (with-tramp-progress-reporter - v 0 (format "%s %s to %s" msg-operation filename newname) + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) - (cond - ;; Both are Tramp files. - ((and t1 t2) - (with-parsed-tramp-file-name filename v1 - (with-parsed-tramp-file-name newname v2 - (cond - ;; Shortcut: if method, host, user are the same for - ;; both files, we invoke `cp' or `mv' on the remote - ;; host directly. - ((tramp-equal-remote filename newname) - (tramp-do-copy-or-rename-file-directly - op filename newname - ok-if-already-exists keep-date preserve-uid-gid)) - - ;; Try out-of-band operation. - ((and - (tramp-method-out-of-band-p v1 length) - (tramp-method-out-of-band-p v2 length)) - (tramp-do-copy-or-rename-file-out-of-band - op filename newname ok-if-already-exists keep-date)) - - ;; No shortcut was possible. So we copy the file - ;; first. If the operation was `rename', we go back - ;; and delete the original file (if the copy was - ;; successful). The approach is simple-minded: we - ;; create a new buffer, insert the contents of the - ;; source file into it, then write out the buffer to - ;; the target file. The advantage is that it doesn't - ;; matter which file name handlers are used for the - ;; source and target file. - (t - (tramp-do-copy-or-rename-file-via-buffer - op filename newname ok-if-already-exists keep-date)))))) - - ;; One file is a Tramp file, the other one is local. - ((or t1 t2) (cond - ;; Fast track on local machine. - ((tramp-local-host-p v) - (tramp-do-copy-or-rename-file-directly - op filename newname - ok-if-already-exists keep-date preserve-uid-gid)) - - ;; If the Tramp file has an out-of-band method, the - ;; corresponding copy-program can be invoked. - ((tramp-method-out-of-band-p v length) - (tramp-do-copy-or-rename-file-out-of-band - op filename newname ok-if-already-exists keep-date)) - - ;; Use the inline method via a Tramp buffer. - (t (tramp-do-copy-or-rename-file-via-buffer - op filename newname ok-if-already-exists keep-date)))) - - (t - ;; One of them must be a Tramp file. - (error "Tramp implementation says this cannot happen"))) - - ;; Handle `preserve-extended-attributes'. We ignore possible - ;; errors, because ACL strings could be incompatible. - (when attributes - (ignore-errors - (set-file-extended-attributes newname attributes))) - - ;; In case of `rename', we must flush the cache of the source file. - (when (and t1 (eq op 'rename)) - (with-parsed-tramp-file-name filename v1 - (tramp-flush-file-properties v1 v1-localname))) - - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname v2 - (tramp-flush-file-properties v2 v2-localname)))))))) + ;; Both are Tramp files. + ((and t1 t2) + (with-parsed-tramp-file-name filename v1 + (with-parsed-tramp-file-name newname v2 + (cond + ;; Shortcut: if method, host, user are the same for + ;; both files, we invoke `cp' or `mv' on the remote + ;; host directly. + ((tramp-equal-remote filename newname) + (tramp-do-copy-or-rename-file-directly + op filename newname + ok-if-already-exists keep-date preserve-uid-gid)) + + ;; Try out-of-band operation. + ((and + (tramp-method-out-of-band-p v1 length) + (tramp-method-out-of-band-p v2 length)) + (tramp-do-copy-or-rename-file-out-of-band + op filename newname ok-if-already-exists keep-date)) + + ;; No shortcut was possible. So we copy the file + ;; first. If the operation was `rename', we go + ;; back and delete the original file (if the copy + ;; was successful). The approach is simple-minded: + ;; we create a new buffer, insert the contents of + ;; the source file into it, then write out the + ;; buffer to the target file. The advantage is + ;; that it doesn't matter which file name handlers + ;; are used for the source and target file. + (t + (tramp-do-copy-or-rename-file-via-buffer + op filename newname ok-if-already-exists keep-date)))))) + + ;; One file is a Tramp file, the other one is local. + ((or t1 t2) + (cond + ;; Fast track on local machine. + ((tramp-local-host-p v) + (tramp-do-copy-or-rename-file-directly + op filename newname + ok-if-already-exists keep-date preserve-uid-gid)) + + ;; If the Tramp file has an out-of-band method, the + ;; corresponding copy-program can be invoked. + ((tramp-method-out-of-band-p v length) + (tramp-do-copy-or-rename-file-out-of-band + op filename newname ok-if-already-exists keep-date)) + + ;; Use the inline method via a Tramp buffer. + (t (tramp-do-copy-or-rename-file-via-buffer + op filename newname ok-if-already-exists keep-date)))) + + (t + ;; One of them must be a Tramp file. + (error "Tramp implementation says this cannot happen"))) + + ;; Handle `preserve-extended-attributes'. We ignore + ;; possible errors, because ACL strings could be + ;; incompatible. + (when-let ((attributes (and preserve-extended-attributes + (file-extended-attributes filename)))) + (ignore-errors + (set-file-extended-attributes newname attributes))) + + ;; In case of `rename', we must flush the cache of the source file. + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-properties v1 v1-localname))) + + ;; When newname did exist, we have wrong cached values. + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-properties v2 v2-localname))))))))) (defun tramp-do-copy-or-rename-file-via-buffer (op filename newname ok-if-already-exists keep-date) @@ -3269,15 +3272,10 @@ implementation will be used." (defun tramp-sh-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." - (with-parsed-tramp-file-name filename nil - (unless (file-exists-p (file-truename filename)) - (tramp-error v 'file-missing filename)) - - (let* ((size (file-attribute-size - (file-attributes (file-truename filename)))) - (rem-enc (tramp-get-inline-coding v "remote-encoding" size)) - (loc-dec (tramp-get-inline-coding v "local-decoding" size)) - (tmpfile (tramp-compat-make-temp-file filename))) + (tramp-skeleton-file-local-copy filename + (if-let ((size (file-attribute-size (file-attributes filename))) + (rem-enc (tramp-get-inline-coding v "remote-encoding" size)) + (loc-dec (tramp-get-inline-coding v "local-decoding" size))) (condition-case err (cond @@ -3308,7 +3306,7 @@ implementation will be used." (let (file-name-handler-alist (coding-system-for-write 'binary) (default-directory - tramp-compat-temporary-file-directory)) + tramp-compat-temporary-file-directory)) (with-temp-file tmpfile (set-buffer-multibyte nil) (insert-buffer-substring (tramp-get-buffer v)) @@ -3343,8 +3341,8 @@ implementation will be used." (delete-file tmpfile) (signal (car err) (cdr err)))) - (run-hooks 'tramp-handle-file-local-copy-hook) - tmpfile))) + ;; Impossible to copy. Trigger `file-missing' error. + (setq tmpfile nil)))) (defun tramp-sh-handle-write-region (start end filename &optional append visit lockname mustbenew) @@ -3490,16 +3488,14 @@ implementation will be used." filename rem-dec) (goto-char (point-max)) (unless (bolp) (newline)) - (tramp-send-command + (tramp-barf-unless-okay v (format (concat rem-dec " <<'%s'\n%s%s") (tramp-shell-quote-argument localname) tramp-end-of-heredoc (buffer-string) - tramp-end-of-heredoc)) - (tramp-barf-unless-okay - v nil + tramp-end-of-heredoc) "Couldn't write region to `%s', decode using `%s' failed" filename rem-dec) ;; When `file-precious-flag' is set, the region is @@ -3814,8 +3810,7 @@ Fall back to normal file name handler if no Tramp handler exists." (setq pos (match-end 0)) (cond ((getenv "EMACS_EMBA_CI") 'GInotifyFileMonitor) - ((eq system-type 'cygwin) 'GPollFileMonitor) - (t nil))) + ((eq system-type 'cygwin) 'GPollFileMonitor))) ;; TODO: What happens, if several monitor names are reported? ((string-match "\ Supported arguments for GIO_USE_FILE_MONITOR environment variable: @@ -3927,14 +3922,14 @@ Supported arguments for GIO_USE_FILE_MONITOR environment variable: (defun tramp-expand-script (vec script) "Expand SCRIPT with remote files or commands. -\"%a\", \"%h\", \"%o\" and \"%p\" format specifiers are replaced -by the respective `awk', `hexdump', `od' and `perl' commands. -\"%n\" is replaced by \"2>/dev/null\", and \"%t\" is replaced by -a temporary file name. -If VEC is nil, the respective local commands are used. -If there is a format specifier which cannot be expanded, this +\"%a\", \"%h\", \"%l\", \"%o\", \"%p\", \"%r\" and \"%s\" format +specifiers are replaced by the respective `awk', `hexdump', `ls', +`od', `perl', `readlink' and `stat' commands. \"%n\" is replaced +by \"2>/dev/null\", and \"%t\" is replaced by a temporary file +name. If VEC is nil, the respective local commands are used. If +there is a format specifier which cannot be expanded, this function returns nil." - (if (not (string-match-p "\\(^\\|[^%]\\)%[ahnopt]" script)) + (if (not (string-match-p "\\(^\\|[^%]\\)%[ahlnoprst]" script)) script (catch 'wont-work (let ((awk (when (string-match-p "\\(^\\|[^%]\\)%a" script) @@ -3952,6 +3947,11 @@ function returns nil." (if (eq system-type 'windows-nt) "" (concat "2>" null-device))) (throw 'wont-work nil)))) + (ls (when (string-match-p "\\(^\\|[^%]\\)%l" script) + (format "%s %s" + (or (tramp-get-ls-command vec) + (throw 'wont-work nil)) + (tramp-sh--quoting-style-options vec)))) (od (when (string-match-p "\\(^\\|[^%]\\)%o" script) (or (if vec (tramp-get-remote-od vec) (executable-find "od")) (throw 'wont-work nil)))) @@ -3960,6 +3960,17 @@ function returns nil." (if vec (tramp-get-remote-perl vec) (executable-find "perl")) (throw 'wont-work nil)))) + (readlink (when (string-match-p "\\(^\\|[^%]\\)%r" script) + (or + (if vec + (tramp-get-remote-readlink vec) + (executable-find "readlink")) + (throw 'wont-work nil)))) + (stat (when (string-match-p "\\(^\\|[^%]\\)%s" script) + (or + (if vec + (tramp-get-remote-stat vec) (executable-find "stat")) + (throw 'wont-work nil)))) (tmp (when (string-match-p "\\(^\\|[^%]\\)%t" script) (or (if vec @@ -3968,7 +3979,9 @@ function returns nil." (throw 'wont-work nil))))) (format-spec script - (format-spec-make ?a awk ?h hdmp ?n dev ?o od ?p perl ?t tmp)))))) + (format-spec-make + ?a awk ?h hdmp ?l ls ?n dev ?o od ?p perl + ?r readlink ?s stat ?t tmp)))))) (defun tramp-maybe-send-script (vec script name) "Define in remote shell function NAME implemented as SCRIPT. @@ -4284,8 +4297,7 @@ seconds. If not, it produces an error message with the given ERROR-ARGS." "Set up an interactive shell. Mainly sets the prompt and the echo correctly. PROC is the shell process to set up. VEC specifies the connection." - (let ((tramp-end-of-output tramp-initial-end-of-output) - (case-fold-search t)) + (let ((case-fold-search t)) (tramp-open-shell vec (tramp-get-method-parameter vec 'tramp-remote-shell)) (tramp-message vec 5 "Setting up remote shell environment") @@ -4312,12 +4324,6 @@ process to set up. VEC specifies the connection." ;; width magic interferes with them. (tramp-send-command vec "stty icanon erase ^H cols 32767" t)))) - (tramp-message vec 5 "Setting shell prompt") - (tramp-send-command - vec (format "PS1=%s PS2='' PS3='' PROMPT_COMMAND=''" - (tramp-shell-quote-argument tramp-end-of-output)) - t) - ;; Check whether the output of "uname -sr" has been changed. If ;; yes, this is a strong indication that we must expire all ;; connection properties. We start again with @@ -5264,16 +5270,23 @@ executed in a subshell, ie surrounded by parentheses. If DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to \"/dev/null\". Optional argument EXIT-STATUS, if non-nil, triggers the return of the exit status." - (tramp-send-command - vec - (concat (if subshell "( " "") - command - (if command - (if dont-suppress-err - "; " (format " 2>%s; " (tramp-get-remote-null-device vec))) - "") - "echo tramp_exit_status $?" - (if subshell " )" ""))) + (let (cmd data) + (if (and (stringp command) + (string-match (format ".*<<'%s'.*" tramp-end-of-heredoc) command)) + (setq cmd (match-string 0 command) + data (substring command (match-end 0))) + (setq cmd command)) + (tramp-send-command + vec + (concat (if subshell "( " "") + cmd + (if cmd + (if dont-suppress-err + "; " (format " 2>%s; " (tramp-get-remote-null-device vec))) + "") + "echo tramp_exit_status $?" + (if subshell " )" "") + data))) (with-current-buffer (tramp-get-connection-buffer vec) (unless (tramp-search-regexp "tramp_exit_status [[:digit:]]+") (tramp-error @@ -5328,94 +5341,6 @@ raises an error." "`%s' does not return a valid Lisp expression: `%s'" command (buffer-string)))))))) -;; FIXME: Move to tramp.el? -;;;###tramp-autoload -(defun tramp-convert-file-attributes (vec attr) - "Convert `file-attributes' ATTR generated by perl script, stat or ls. -Convert file mode bits to string and set virtual device number. -Return ATTR." - (when attr - (save-match-data - ;; Remove color escape sequences from symlink. - (when (stringp (car attr)) - (while (string-match tramp-display-escape-sequence-regexp (car attr)) - (setcar attr (replace-match "" nil nil (car attr))))) - ;; Convert uid and gid. Use `tramp-unknown-id-integer' as - ;; indication of unusable value. - (when (and (numberp (nth 2 attr)) (< (nth 2 attr) 0)) - (setcar (nthcdr 2 attr) tramp-unknown-id-integer)) - (when (and (floatp (nth 2 attr)) - (<= (nth 2 attr) most-positive-fixnum)) - (setcar (nthcdr 2 attr) (round (nth 2 attr)))) - (when (and (numberp (nth 3 attr)) (< (nth 3 attr) 0)) - (setcar (nthcdr 3 attr) tramp-unknown-id-integer)) - (when (and (floatp (nth 3 attr)) - (<= (nth 3 attr) most-positive-fixnum)) - (setcar (nthcdr 3 attr) (round (nth 3 attr)))) - ;; Convert last access time. - (unless (listp (nth 4 attr)) - (setcar (nthcdr 4 attr) (seconds-to-time (nth 4 attr)))) - ;; Convert last modification time. - (unless (listp (nth 5 attr)) - (setcar (nthcdr 5 attr) (seconds-to-time (nth 5 attr)))) - ;; Convert last status change time. - (unless (listp (nth 6 attr)) - (setcar (nthcdr 6 attr) (seconds-to-time (nth 6 attr)))) - ;; Convert file size. - (when (< (nth 7 attr) 0) - (setcar (nthcdr 7 attr) -1)) - (when (and (floatp (nth 7 attr)) - (<= (nth 7 attr) most-positive-fixnum)) - (setcar (nthcdr 7 attr) (round (nth 7 attr)))) - ;; Convert file mode bits to string. - (unless (stringp (nth 8 attr)) - (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr))) - (when (stringp (car attr)) - (aset (nth 8 attr) 0 ?l))) - ;; Convert directory indication bit. - (when (string-prefix-p "d" (nth 8 attr)) - (setcar attr t)) - ;; Convert symlink from `tramp-do-file-attributes-with-stat'. - ;; Decode also multibyte string. - (when (consp (car attr)) - (setcar attr - (and (stringp (caar attr)) - (string-match ".+ -> .\\(.+\\)." (caar attr)) - (decode-coding-string - (match-string 1 (caar attr)) 'utf-8)))) - ;; Set file's gid change bit. - (setcar (nthcdr 9 attr) - (if (numberp (nth 3 attr)) - (not (= (nth 3 attr) - (tramp-get-remote-gid vec 'integer))) - (not (string-equal - (nth 3 attr) - (tramp-get-remote-gid vec 'string))))) - ;; Convert inode. - (when (floatp (nth 10 attr)) - (setcar (nthcdr 10 attr) - (condition-case nil - (let ((high (nth 10 attr)) - middle low) - (if (<= high most-positive-fixnum) - (floor high) - ;; The low 16 bits. - (setq low (mod high #x10000) - high (/ high #x10000)) - (if (<= high most-positive-fixnum) - (cons (floor high) (floor low)) - ;; The middle 24 bits. - (setq middle (mod high #x1000000) - high (/ high #x1000000)) - (cons (floor high) - (cons (floor middle) (floor low)))))) - ;; Inodes can be incredible huge. We must hide this. - (error (tramp-get-inode vec))))) - ;; Set virtual device number. - (setcar (nthcdr 11 attr) - (tramp-get-device vec))) - attr)) - (defun tramp-shell-case-fold (string) "Convert STRING to shell glob pattern which ignores case." (mapconcat @@ -5797,18 +5722,25 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (while (and dl (setq result (tramp-find-executable vec cmd dl t t))) ;; Check POSIX parameter. (when (tramp-send-command-and-check vec (format "%s -u" result)) + (tramp-set-connection-property + vec "uid-integer" + (with-current-buffer (tramp-get-connection-buffer vec) + (goto-char (point-min)) + (read (current-buffer)))) (throw 'id-found result)) (setq dl (cdr dl)))))))) (defun tramp-get-remote-uid-with-id (vec id-format) "Implement `tramp-get-remote-uid' for Tramp files using `id'." - (tramp-send-command-and-read - vec - (format "%s -u%s %s" - (tramp-get-remote-id vec) - (if (equal id-format 'integer) "" "n") - (if (equal id-format 'integer) - "" "| sed -e s/^/\\\"/ -e s/\\$/\\\"/")))) + ;; `tramp-get-remote-id' sets already connection property "uid-integer". + (with-tramp-connection-property vec (format "uid-%s" id-format) + (tramp-send-command-and-read + vec + (format "%s -u%s %s" + (tramp-get-remote-id vec) + (if (equal id-format 'integer) "" "n") + (if (equal id-format 'integer) + "" "| sed -e s/^/\\\"/ -e s/\\$/\\\"/"))))) (defun tramp-get-remote-uid-with-perl (vec id-format) "Implement `tramp-get-remote-uid' for Tramp files using a Perl script." @@ -5825,7 +5757,6 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (with-tramp-connection-property vec "python" (tramp-message vec 5 "Finding a suitable `python' command") (or (tramp-find-executable vec "python" (tramp-get-remote-path vec)) - (tramp-find-executable vec "python2" (tramp-get-remote-path vec)) (tramp-find-executable vec "python3" (tramp-get-remote-path vec))))) (defun tramp-get-remote-uid-with-python (vec id-format) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 5789b8f947..29abdb575d 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -232,7 +232,7 @@ See `tramp-actions-before-shell' for more info.") (delete-file . tramp-smb-handle-delete-file) ;; `diff-latest-backup-file' performed by default handler. (directory-file-name . tramp-handle-directory-file-name) - (directory-files . tramp-smb-handle-directory-files) + (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) (dired-compress-file . ignore) @@ -416,175 +416,181 @@ arguments to pass to the OPERATION." (defun tramp-smb-handle-copy-directory (dirname newname &optional keep-date parents copy-contents) "Like `copy-directory' for Tramp files." - (let ((t1 (tramp-tramp-file-p dirname)) - (t2 (tramp-tramp-file-p newname)) - target) - (with-parsed-tramp-file-name (if t1 dirname newname) nil - (unless (file-exists-p dirname) - (tramp-error v 'file-missing dirname)) - - ;; `copy-directory-create-symlink' exists since Emacs 28.1. - (if (and (bound-and-true-p copy-directory-create-symlink) - (setq target (file-symlink-p dirname)) - (tramp-equal-remote dirname newname)) - (make-symbolic-link - target - (if (directory-name-p newname) - (concat newname (file-name-nondirectory dirname)) newname) - t) - - (if copy-contents - ;; We must do it file-wise. - (tramp-run-real-handler - #'copy-directory - (list dirname newname keep-date parents copy-contents)) - - (setq dirname (expand-file-name dirname) - newname (expand-file-name newname)) - (with-tramp-progress-reporter - v 0 (format "Copying %s to %s" dirname newname) - (unless (file-exists-p dirname) - (tramp-error v 'file-missing dirname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-already-exists newname)) - (cond - ;; We must use a local temporary directory. - ((and t1 t2) - (let ((tmpdir (tramp-compat-make-temp-name))) - (unwind-protect - (progn - (make-directory tmpdir) - (copy-directory - dirname (file-name-as-directory tmpdir) - keep-date 'parents) - (copy-directory - (expand-file-name (file-name-nondirectory dirname) tmpdir) - newname keep-date parents)) - (delete-directory tmpdir 'recursive)))) - - ;; We can copy recursively. - ;; TODO: Does not work reliably. - (nil ;(and (or t1 t2) (tramp-smb-get-cifs-capabilities v)) + (tramp-skeleton-copy-directory + dirname newname keep-date parents copy-contents + (let ((t1 (tramp-tramp-file-p dirname)) + (t2 (tramp-tramp-file-p newname)) + target) + (with-parsed-tramp-file-name (if t1 dirname newname) nil + (unless (file-exists-p dirname) + (tramp-error v 'file-missing dirname)) + + ;; `copy-directory-create-symlink' exists since Emacs 28.1. + (if (and (bound-and-true-p copy-directory-create-symlink) + (setq target (file-symlink-p dirname)) + (tramp-equal-remote dirname newname)) + (make-symbolic-link + target + (if (directory-name-p newname) + (concat newname (file-name-nondirectory dirname)) newname) + t) + + (if copy-contents + ;; We must do it file-wise. + (tramp-run-real-handler + #'copy-directory + (list dirname newname keep-date parents copy-contents)) + + (setq dirname (expand-file-name dirname) + newname (expand-file-name newname)) + (with-tramp-progress-reporter + v 0 (format "Copying %s to %s" dirname newname) (when (and (file-directory-p newname) - (not (string-equal (file-name-nondirectory dirname) - (file-name-nondirectory newname)))) - (setq newname - (expand-file-name - (file-name-nondirectory dirname) newname)) - (if t2 (setq v (tramp-dissect-file-name newname)))) - (if (not (file-directory-p newname)) - (make-directory newname parents)) - - (let* ((share (tramp-smb-get-share v)) - (localname (file-name-as-directory - (tramp-compat-string-replace - "\\" "/" (tramp-smb-get-localname v)))) - (tmpdir (tramp-compat-make-temp-name)) - (args (list (concat "//" host "/" share) "-E")) - (options tramp-smb-options)) - - (if (not (zerop (length user))) - (setq args (append args (list "-U" user))) - (setq args (append args (list "-N")))) - - (when domain (setq args (append args (list "-W" domain)))) - (when port (setq args (append args (list "-p" port)))) - (when tramp-smb-conf - (setq args (append args (list "-s" tramp-smb-conf)))) - (while options - (setq args - (append args `("--option" ,(format "%s" (car options)))) - options (cdr options))) - (setq args - (if t1 - ;; Source is remote. + (not (directory-name-p newname))) + (tramp-error v 'file-already-exists newname)) + (cond + ;; We must use a local temporary directory. + ((and t1 t2) + (let ((tmpdir (tramp-compat-make-temp-name))) + (unwind-protect + (progn + (make-directory tmpdir) + (copy-directory + dirname (file-name-as-directory tmpdir) + keep-date 'parents) + (copy-directory + (expand-file-name + (file-name-nondirectory dirname) tmpdir) + newname keep-date parents)) + (delete-directory tmpdir 'recursive)))) + + ;; We can copy recursively. + ;; FIXME: Does not work reliably. + (nil ;(and (or t1 t2) (tramp-smb-get-cifs-capabilities v)) + (when (and (file-directory-p newname) + (not (string-equal (file-name-nondirectory dirname) + (file-name-nondirectory newname)))) + (setq newname + (expand-file-name + (file-name-nondirectory dirname) newname)) + (if t2 (setq v (tramp-dissect-file-name newname)))) + (if (not (file-directory-p newname)) + (make-directory newname parents)) + + (let* ((share (tramp-smb-get-share v)) + (localname (file-name-as-directory + (tramp-compat-string-replace + "\\" "/" (tramp-smb-get-localname v)))) + (tmpdir (tramp-compat-make-temp-name)) + (args (list (concat "//" host "/" share) "-E")) + (options tramp-smb-options)) + + (if (not (zerop (length user))) + (setq args (append args (list "-U" user))) + (setq args (append args (list "-N")))) + + (when domain (setq args (append args (list "-W" domain)))) + (when port (setq args (append args (list "-p" port)))) + (when tramp-smb-conf + (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args (append args + `("--option" ,(format "%s" (car options)))) + options (cdr options))) + (setq args + (if t1 + ;; Source is remote. + (append args + (list "-D" + (tramp-unquote-shell-quote-argument + localname) + "-c" + (tramp-unquote-shell-quote-argument + "tar qc - *") + "|" "tar" "xfC" "-" + (tramp-unquote-shell-quote-argument + tmpdir))) + ;; Target is remote. + (append (list + "tar" "cfC" "-" + (tramp-unquote-shell-quote-argument dirname) + "." "|") + args (list "-D" (tramp-unquote-shell-quote-argument localname) "-c" (tramp-unquote-shell-quote-argument - "tar qc - *") - "|" "tar" "xfC" "-" - (tramp-unquote-shell-quote-argument - tmpdir))) - ;; Target is remote. - (append (list - "tar" "cfC" "-" - (tramp-unquote-shell-quote-argument dirname) - "." "|") - args - (list "-D" (tramp-unquote-shell-quote-argument - localname) - "-c" (tramp-unquote-shell-quote-argument - "tar qx -"))))) - - (unwind-protect - (with-tramp-saved-connection-property v "process-name" - (with-tramp-saved-connection-property v "process-buffer" - (with-temp-buffer - ;; Set the transfer process properties. - (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) - (tramp-set-connection-property - v "process-buffer" (current-buffer)) - - (when t1 - ;; The smbclient tar command creates - ;; always complete paths. We must emulate - ;; the directory structure, and symlink to - ;; the real target. - (make-directory - (expand-file-name - ".." (concat tmpdir localname)) - 'parents) - (make-symbolic-link - newname - (directory-file-name (concat tmpdir localname)))) - - ;; Use an asynchronous processes. By this, - ;; password can be handled. - (let* ((default-directory tmpdir) - (p (apply - #'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - tramp-smb-program args))) - - (tramp-message - v 6 "%s" (string-join (process-command p) " ")) - (process-put p 'vector v) - (process-put p 'adjust-window-size-function #'ignore) - (set-process-query-on-exit-flag p nil) - (tramp-process-actions - p v nil tramp-smb-actions-with-tar) - - (while (process-live-p p) - (sleep-for 0.1)) - (tramp-message v 6 "\n%s" (buffer-string)))))) - - ;; Save exit. - (when t1 (delete-directory tmpdir 'recursive)))) - - ;; Handle KEEP-DATE argument. - (when keep-date - (tramp-compat-set-file-times - newname - (file-attribute-modification-time (file-attributes dirname)) - (unless ok-if-already-exists 'nofollow))) - - ;; Set the mode. - (unless keep-date - (set-file-modes newname (tramp-default-file-modes dirname))) - - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-properties v localname)))) - - ;; We must do it file-wise. - (t - (tramp-run-real-handler - #'copy-directory (list dirname newname keep-date parents)))))))))) + "tar qx -"))))) + + (unwind-protect + (with-tramp-saved-connection-property v "process-name" + (with-tramp-saved-connection-property v "process-buffer" + (with-temp-buffer + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + + (when t1 + ;; The smbclient tar command creates + ;; always complete paths. We must + ;; emulate the directory structure, and + ;; symlink to the real target. + (make-directory + (expand-file-name + ".." (concat tmpdir localname)) + 'parents) + (make-symbolic-link + newname + (directory-file-name (concat tmpdir localname)))) + + ;; Use an asynchronous processes. By + ;; this, password can be handled. + (let* ((default-directory tmpdir) + (p (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-program args))) + + (tramp-message + v 6 "%s" (string-join (process-command p) " ")) + (process-put p 'vector v) + (process-put + p 'adjust-window-size-function #'ignore) + (set-process-query-on-exit-flag p nil) + (tramp-process-actions + p v nil tramp-smb-actions-with-tar) + + (while (process-live-p p) + (sleep-for 0.1)) + (tramp-message v 6 "\n%s" (buffer-string)))))) + + ;; Save exit. + (when t1 (delete-directory tmpdir 'recursive)))) + + ;; Handle KEEP-DATE argument. + (when keep-date + (tramp-compat-set-file-times + newname + (file-attribute-modification-time (file-attributes dirname)) + (unless ok-if-already-exists 'nofollow))) + + ;; Set the mode. + (unless keep-date + (set-file-modes newname (tramp-default-file-modes dirname))) + + ;; When newname did exist, we have wrong cached values. + (when t2 + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-properties v localname)))) + + ;; We must do it file-wise. + (t + (tramp-run-real-handler + #'copy-directory + (list dirname newname keep-date parents))))))))))) (defun tramp-smb-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -706,37 +712,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (search-forward-regexp tramp-smb-errors nil t) (tramp-error v 'file-error "%s `%s'" (match-string 0) filename))))))) -(defun tramp-smb-handle-directory-files - (directory &optional full match nosort count) - "Like `directory-files' for Tramp files." - (unless (file-exists-p directory) - (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) - (let ((result (mapcar #'directory-file-name - (file-name-all-completions "" directory)))) - ;; Discriminate with regexp. - (when match - (setq result - (delete nil - (mapcar (lambda (x) (when (string-match-p match x) x)) - result)))) - - ;; Sort them if necessary. - (unless nosort - (setq result (sort result #'string-lessp))) - - ;; Return count number of results. - (when (and (natnump count) (> count 0)) - (setq result (tramp-compat-ntake count result))) - - ;; Prepend directory. - (when full - (setq result - (mapcar - (lambda (x) (format "%s/%s" (directory-file-name directory) x)) - result))) - - result)) - (defun tramp-smb-handle-expand-file-name (name &optional dir) "Like `expand-file-name' for Tramp files." ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". @@ -852,24 +827,21 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-smb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." - (unless id-format (setq id-format 'integer)) - (ignore-errors - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property - v localname (format "file-attributes-%s" id-format) + ;; The result is cached in `tramp-convert-file-attributes'. + (with-parsed-tramp-file-name filename nil + (tramp-convert-file-attributes v localname id-format + (ignore-errors (if (tramp-smb-get-stat-capability v) - (tramp-smb-do-file-attributes-with-stat v id-format) - ;; Reading just the filename entry via "dir localname" is not - ;; possible, because when filename is a directory, some - ;; smbclient versions return the content of the directory, and - ;; other versions don't. Therefore, the whole content of the - ;; upper directory is retrieved, and the entry of the filename - ;; is extracted from. + (tramp-smb-do-file-attributes-with-stat v) + ;; Reading just the filename entry via "dir localname" is + ;; not possible, because when filename is a directory, some + ;; smbclient versions return the content of the directory, + ;; and other versions don't. Therefore, the whole content + ;; of the upper directory is retrieved, and the entry of the + ;; filename is extracted from. (let* ((entries (tramp-smb-get-file-entries (file-name-directory filename))) (entry (assoc (file-name-nondirectory filename) entries)) - (uid (if (equal id-format 'string) "nobody" -1)) - (gid (if (equal id-format 'string) "nogroup" -1)) (inode (tramp-get-inode v)) (device (tramp-get-device v))) @@ -877,19 +849,21 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when entry (list (and (tramp-compat-string-search "d" (nth 1 entry)) t) ;0 file type - -1 ;1 link count - uid ;2 uid - gid ;3 gid + -1 ;1 link count + (cons + tramp-unknown-id-string tramp-unknown-id-integer) ;2 uid + (cons + tramp-unknown-id-string tramp-unknown-id-integer) ;3 gid tramp-time-dont-know ;4 atime (nth 3 entry) ;5 mtime tramp-time-dont-know ;6 ctime (nth 2 entry) ;7 size (nth 1 entry) ;8 mode - nil ;9 gid weird - inode ;10 inode number + nil ;9 gid weird + inode ;10 inode number device)))))))) ;11 file system number -(defun tramp-smb-do-file-attributes-with-stat (vec &optional id-format) +(defun tramp-smb-do-file-attributes-with-stat (vec) "Implement `file-attributes' for Tramp files using `stat' command." (tramp-message vec 5 "file attributes with stat: %s" (tramp-file-name-localname vec)) @@ -920,10 +894,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Uid:\\s-+\\([[:digit:]]+\\)\\s-+" "Gid:\\s-+\\([[:digit:]]+\\)")) (setq mode (match-string 1) - uid (if (equal id-format 'string) (match-string 2) - (string-to-number (match-string 2))) - gid (if (equal id-format 'string) (match-string 3) - (string-to-number (match-string 3))))) + uid (match-string 2) + gid (match-string 3))) ((looking-at (concat "Access:\\s-+" @@ -977,26 +949,23 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Return the result. (when (or id link uid gid atime mtime ctime size mode inode) - (list id link uid gid atime mtime ctime size mode nil inode - (tramp-get-device vec)))))))) + (list id link (cons uid (string-to-number uid)) + (cons gid (string-to-number gid)) gid atime mtime ctime size + mode nil inode (tramp-get-device vec)))))))) (defun tramp-smb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." - (with-parsed-tramp-file-name (file-truename filename) nil - (unless (file-exists-p (file-truename filename)) - (tramp-error v 'file-missing filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (with-tramp-progress-reporter - v 3 (format "Fetching %s to tmp file %s" filename tmpfile) - (unless (tramp-smb-send-command - v (format "get %s %s" - (tramp-smb-shell-quote-localname v) - (tramp-smb-shell-quote-argument tmpfile))) - ;; Oops, an error. We shall cleanup. - (delete-file tmpfile) - (tramp-error - v 'file-error "Cannot make local copy of file `%s'" filename))) - tmpfile))) + (tramp-skeleton-file-local-copy filename + (with-tramp-progress-reporter + v 3 (format "Fetching %s to tmp file %s" filename tmpfile) + (unless (tramp-smb-send-command + v (format "get %s %s" + (tramp-smb-shell-quote-localname v) + (tramp-smb-shell-quote-argument tmpfile))) + ;; Oops, an error. We shall cleanup. + (delete-file tmpfile) + (tramp-error + v 'file-error "Cannot make local copy of file `%s'" filename))))) ;; This function should return "foo/" for directories and "bar" for ;; files. @@ -2060,24 +2029,6 @@ If ARGUMENT is non-nil, use it as argument for tramp-smb-actions-with-share tramp-smb-actions-without-share)) - ;; Check server version. - ;; FIXME: With recent smbclient versions, this - ;; information isn't printed anymore. - ;; (unless argument - ;; (with-current-buffer (tramp-get-connection-buffer vec) - ;; (goto-char (point-min)) - ;; (search-forward-regexp tramp-smb-server-version nil t) - ;; (let ((smbserver-version (match-string 0))) - ;; (unless - ;; (string-equal - ;; smbserver-version - ;; (tramp-get-connection-property - ;; vec "smbserver-version" smbserver-version)) - ;; (tramp-flush-directory-properties vec "") - ;; (tramp-flush-connection-properties vec)) - ;; (tramp-set-connection-property - ;; vec "smbserver-version" smbserver-version)))) - ;; Set chunksize to 1. smbclient reads its input ;; character by character; if we send the string ;; at once, it is read painfully slow. diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 420a593644..5ec68e904e 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -241,6 +241,8 @@ absolute file names." (copy-directory filename newname keep-date t) (when (eq op 'rename) (delete-directory filename 'recursive))) + ;; FIXME: This should be optimized. Computing `file-attributes' + ;; checks already, whether the file exists. (let ((t1 (tramp-sudoedit-file-name-p filename)) (t2 (tramp-sudoedit-file-name-p newname)) (file-times (file-attribute-modification-time @@ -256,62 +258,61 @@ absolute file names." (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) (with-parsed-tramp-file-name (if t1 filename newname) nil - (unless (file-exists-p filename) - (tramp-error v 'file-missing filename)) - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - (if (or (and (file-remote-p filename) (not t1)) - (and (file-remote-p newname) (not t2))) - ;; We cannot copy or rename directly. - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (if (eq op 'copy) - (copy-file filename tmpfile t) - (rename-file filename tmpfile t)) - (rename-file tmpfile newname ok-if-already-exists)) - - ;; Direct action. - (with-tramp-progress-reporter - v 0 (format "%s %s to %s" msg-operation filename newname) - (unless (tramp-sudoedit-send-command - v sudoedit-operation - (tramp-unquote-file-local-name filename) - (tramp-unquote-file-local-name newname)) - (tramp-error - v 'file-error - "Error %s `%s' `%s'" msg-operation filename newname)))) - - ;; When `newname' is local, we must change the ownership to - ;; the local user. - (unless (file-remote-p newname) - (tramp-set-file-uid-gid - (concat (file-remote-p filename) newname) - (tramp-get-local-uid 'integer) - (tramp-get-local-gid 'integer))) - - ;; Set the time and mode. Mask possible errors. - (when keep-date - (ignore-errors - (tramp-compat-set-file-times - newname file-times (unless ok-if-already-exists 'nofollow)) - (set-file-modes newname file-modes))) - - ;; Handle `preserve-extended-attributes'. We ignore possible - ;; errors, because ACL strings could be incompatible. - (when attributes - (ignore-errors - (set-file-extended-attributes newname attributes))) - - (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))))))) + (tramp-barf-if-file-missing v filename + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (if (or (and (file-remote-p filename) (not t1)) + (and (file-remote-p newname) (not t2))) + ;; We cannot copy or rename directly. + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (if (eq op 'copy) + (copy-file filename tmpfile t) + (rename-file filename tmpfile t)) + (rename-file tmpfile newname ok-if-already-exists)) + + ;; Direct action. + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (unless (tramp-sudoedit-send-command + v sudoedit-operation + (tramp-unquote-file-local-name filename) + (tramp-unquote-file-local-name newname)) + (tramp-error + v 'file-error + "Error %s `%s' `%s'" msg-operation filename newname)))) + + ;; When `newname' is local, we must change the ownership to + ;; the local user. + (unless (file-remote-p newname) + (tramp-set-file-uid-gid + (concat (file-remote-p filename) newname) + (tramp-get-local-uid 'integer) + (tramp-get-local-gid 'integer))) + + ;; Set the time and mode. Mask possible errors. + (when keep-date + (ignore-errors + (tramp-compat-set-file-times + newname file-times (unless ok-if-already-exists 'nofollow)) + (set-file-modes newname file-modes))) + + ;; Handle `preserve-extended-attributes'. We ignore possible + ;; errors, because ACL strings could be incompatible. + (when attributes + (ignore-errors + (set-file-extended-attributes newname attributes))) + + (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)))))))) (defun tramp-sudoedit-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -407,34 +408,30 @@ the result will be a local, non-Tramp, file name." ;; provided by `tramp-sudoedit-send-command-string'. Add it. (and (stringp result) (concat result "\n")))))) +(defconst tramp-sudoedit-file-attributes + (format + ;; Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape of + ;; them in file names. They are replaced in + ;; `tramp-sudoedit-send-command-and-read'. + (concat "((%s%%N%s) %%h (%s%%U%s . %%u) (%s%%G%s . %%g)" + " %%X %%Y %%Z %%s %s%%A%s t %%i -1)") + tramp-stat-marker tramp-stat-marker ; %%N + tramp-stat-marker tramp-stat-marker ; %%U + tramp-stat-marker tramp-stat-marker ; %%G + tramp-stat-marker tramp-stat-marker) ; %%A + "stat format string to produce output suitable for use with +`file-attributes' on the remote file system.") + (defun tramp-sudoedit-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." - (unless id-format (setq id-format 'integer)) + ;; The result is cached in `tramp-convert-file-attributes'. (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property - v localname (format "file-attributes-%s" id-format) - (tramp-message v 5 "file attributes: %s" localname) - (ignore-errors - (tramp-convert-file-attributes - v - (tramp-sudoedit-send-command-and-read - v "env" "QUOTING_STYLE=locale" "stat" "-c" - (format - ;; 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%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)" - tramp-stat-marker tramp-stat-marker - (if (eq id-format 'integer) - "%u" - (eval-when-compile - (concat tramp-stat-marker "%U" tramp-stat-marker))) - (if (eq id-format 'integer) - "%g" - (eval-when-compile - (concat tramp-stat-marker "%G" tramp-stat-marker))) - tramp-stat-marker tramp-stat-marker) - (tramp-compat-file-name-unquote localname))))))) + (tramp-convert-file-attributes v localname id-format + (tramp-sudoedit-send-command-and-read + v "env" "QUOTING_STYLE=locale" "stat" "-c" + tramp-sudoedit-file-attributes + (tramp-compat-file-name-unquote localname))))) (defun tramp-sudoedit-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." @@ -718,6 +715,7 @@ VEC or USER, or if there is no home directory, return nil." (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'." + ;; The result is cached in `tramp-get-remote-uid'. (if (equal id-format 'integer) (tramp-sudoedit-send-command-and-read vec "id" "-u") (tramp-sudoedit-send-command-string vec "id" "-un"))) @@ -725,6 +723,7 @@ ID-FORMAT valid values are `string' and `integer'." (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'." + ;; The result is cached in `tramp-get-remote-gid'. (if (equal id-format 'integer) (tramp-sudoedit-send-command-and-read vec "id" "-g") (tramp-sudoedit-send-command-string vec "id" "-gn"))) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index b11fd293cc..3f78c8d658 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1957,7 +1957,8 @@ The outline level is equal to the verbosity of the Tramp message." They are completed by \"M-x TAB\" only in Tramp debug buffers." (with-current-buffer buffer (string-equal - (buffer-substring (point-min) (min (+ (point-min) 10) (point-max))) ";; Emacs:"))) + (buffer-substring (point-min) (min (+ (point-min) 10) (point-max))) + ";; Emacs:"))) (put #'tramp-debug-buffer-command-completion-p 'tramp-suppress-trace t) @@ -1984,6 +1985,7 @@ They are completed by \"M-x TAB\" only in Tramp debug buffers." ,(eval tramp-debug-font-lock-keywords t))) ;; Do not edit the debug buffer. (use-local-map special-mode-map) + (set-buffer-modified-p nil) ;; For debugging purposes. (local-set-key "\M-n" 'clone-buffer) (add-hook 'clone-buffer-hook #'tramp-setup-debug-buffer nil 'local)) @@ -2272,6 +2274,24 @@ the resulting error message." (put #'tramp-with-demoted-errors 'tramp-suppress-trace t) +;; This macro shall optimize the cases where an `file-exists-p' call +;; is invoked first. Often, the file exists, so the remote command is +;; superfluous. +(defmacro tramp-barf-if-file-missing (vec filename &rest body) + "Execute BODY and return the result. +In case if an error, raise a `file-missing' error if FILENAME +does not exist, otherwise propagate the error." + (declare (indent 2) (debug (symbolp form body))) + (let ((err (make-symbol "err"))) + `(condition-case ,err + (progn ,@body) + (error + (if (not (file-exists-p ,filename)) + (tramp-error ,vec 'file-missing ,filename) + (signal (car ,err) (cdr ,err))))))) + +(put #'tramp-barf-if-file-missing 'tramp-suppress-trace t) + (defun tramp-test-message (fmt-string &rest arguments) "Emit a Tramp message according `default-directory'." (cond @@ -3375,6 +3395,22 @@ User is always nil." ;;; Skeleton macros for file name handler functions. +(defmacro tramp-skeleton-copy-directory + (directory _newname &optional _keep-date _parents _copy-contents &rest body) + "Skeleton for `tramp-*-handle-copy-directory'. +BODY is the backend specific code." + (declare (indent 5) (debug t)) + ;; `copy-directory' creates NEWNAME before running this check. So + ;; we do it ourselves. Therefore, we cannot also run + ;; `tramp-barf-if-file-missing'. + `(progn + (unless (file-exists-p ,directory) + (tramp-error + (tramp-dissect-file-name ,directory) 'file-missing ,directory)) + ,@body)) + +(put #'tramp-skeleton-copy-directory 'tramp-suppress-trace t) + (defmacro tramp-skeleton-delete-directory (directory recursive trash &rest body) "Skeleton for `tramp-*-handle-delete-directory'. BODY is the backend specific code." @@ -3392,6 +3428,106 @@ BODY is the backend specific code." (put #'tramp-skeleton-delete-directory 'tramp-suppress-trace t) +(defmacro tramp-skeleton-directory-files + (directory &optional full match nosort count &rest body) + "Skeleton for `tramp-*-handle-directory-files'. +BODY is the backend specific code." + (declare (indent 5) (debug t)) + `(or + (with-parsed-tramp-file-name ,directory nil + (tramp-barf-if-file-missing v ,directory + (when (file-directory-p ,directory) + (setq ,directory + (file-name-as-directory (expand-file-name ,directory))) + (let ((temp + (with-tramp-file-property v localname "directory-files" ,@body)) + result item) + (while temp + (setq item (directory-file-name (pop temp))) + (when (or (null ,match) (string-match-p ,match item)) + (push (if ,full (concat ,directory item) item) + result))) + (unless ,nosort + (setq result (sort result #'string<))) + (when (and (natnump ,count) (> ,count 0)) + (setq result (tramp-compat-ntake ,count result))) + result)))) + + ;; Error handling. + (if (not (file-exists-p ,directory)) + (tramp-error + (tramp-dissect-file-name ,directory) 'file-missing ,directory) + nil))) + +(put #'tramp-skeleton-directory-files 'tramp-suppress-trace t) + +(defmacro tramp-skeleton-directory-files-and-attributes + (directory &optional full match nosort id-format count &rest body) + "Skeleton for `tramp-*-handle-directory-files-and-attributes'. +BODY is the backend specific code." + (declare (indent 6) (debug t)) + `(or + (with-parsed-tramp-file-name ,directory nil + (tramp-barf-if-file-missing v ,directory + (when (file-directory-p ,directory) + (setq ,directory (expand-file-name ,directory)) + (let ((temp + (copy-tree + (mapcar + (lambda (x) + (cons + (car x) + (tramp-convert-file-attributes + v (car x) ,id-format (cdr x)))) + (with-tramp-file-property + v localname ",directory-files-and-attributes" + ,@body)))) + result item) + + (while temp + (setq item (pop temp)) + (when (or (null ,match) (string-match-p ,match (car item))) + (when ,full + (setcar item (expand-file-name (car item) ,directory))) + (push item result))) + + (unless ,nosort + (setq result + (sort result (lambda (x y) (string< (car x) (car y)))))) + + (when (and (natnump ,count) (> ,count 0)) + (setq result (tramp-compat-ntake ,count result))) + + (or result + ;; The scripts could fail, for example with huge file size. + (tramp-handle-directory-files-and-attributes + ,directory ,full ,match ,nosort ,id-format ,count)))))) + + ;; Error handling. + (if (not (file-exists-p ,directory)) + (tramp-error + (tramp-dissect-file-name ,directory) 'file-missing ,directory) + nil))) + +(put #'tramp-skeleton-directory-files-and-attributes 'tramp-suppress-trace t) + +(defmacro tramp-skeleton-file-local-copy (filename &rest body) + "Skeleton for `tramp-*-handle-file-local-copy-files'. +BODY is the backend specific code." + (declare (indent 1) (debug t)) + `(with-parsed-tramp-file-name (file-truename ,filename) nil + (tramp-barf-if-file-missing v ,filename + (or + (let ((tmpfile (tramp-compat-make-temp-file ,filename))) + ,@body + (run-hooks 'tramp-handle-file-local-copy-hook) + tmpfile) + + ;; Trigger the `file-missing' error. + (signal 'error nil))))) + +(put #'tramp-skeleton-file-local-copy 'tramp-suppress-trace t) + (defmacro tramp-skeleton-write-region (start end filename append visit lockname mustbenew &rest body) "Skeleton for `tramp-*-handle-write-region'. @@ -3585,14 +3721,12 @@ Let-bind it when necessary.") (defun tramp-handle-copy-directory (directory newname &optional keep-date parents copy-contents) "Like `copy-directory' for Tramp files." - ;; `copy-directory' creates NEWNAME before running this check. So - ;; we do it ourselves. - (unless (file-exists-p directory) - (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) - ;; We must do it file-wise. - (tramp-run-real-handler - #'copy-directory - (list directory newname keep-date parents copy-contents))) + (tramp-skeleton-copy-directory + directory newname keep-date parents copy-contents + ;; We must do it file-wise. + (tramp-run-real-handler + #'copy-directory + (list directory newname keep-date parents copy-contents)))) (defun tramp-handle-directory-file-name (directory) "Like `directory-file-name' for Tramp files." @@ -3608,23 +3742,8 @@ Let-bind it when necessary.") (defun tramp-handle-directory-files (directory &optional full match nosort count) "Like `directory-files' for Tramp files." - (unless (file-exists-p directory) - (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) - (when (file-directory-p directory) - (setq directory (file-name-as-directory (expand-file-name directory))) - (let ((temp (nreverse (file-name-all-completions "" directory))) - result item) - - (while temp - (setq item (directory-file-name (pop temp))) - (when (or (null match) (string-match-p match item)) - (push (if full (concat directory item) item) - result))) - (unless nosort - (setq result (sort result #'string<))) - (when (and (natnump count) (> count 0)) - (setq result (tramp-compat-ntake count result))) - result))) + (tramp-skeleton-directory-files directory full match nosort count + (nreverse (file-name-all-completions "" directory)))) (defun tramp-handle-directory-files-and-attributes (directory &optional full match nosort id-format count) @@ -3722,12 +3841,8 @@ Let-bind it when necessary.") (defun tramp-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." - (with-parsed-tramp-file-name filename nil - (unless (file-exists-p filename) - (tramp-error v 'file-missing filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) - tmpfile))) + (tramp-skeleton-file-local-copy filename + (copy-file filename tmpfile 'ok-if-already-exists 'keep-time))) (defun tramp-handle-file-modes (filename &optional flag) "Like `file-modes' for Tramp files." @@ -4048,13 +4163,10 @@ Let-bind it when necessary.") (let (result local-copy remote-copy) (with-parsed-tramp-file-name filename nil (unwind-protect - (if (not (file-exists-p filename)) - (let ((tramp-verbose (if visit 0 tramp-verbose))) - (tramp-error v 'file-missing filename)) - - (with-tramp-progress-reporter - v 3 (format-message "Inserting `%s'" filename) - (condition-case err + (condition-case err + (tramp-barf-if-file-missing v filename + (with-tramp-progress-reporter + v 3 (format-message "Inserting `%s'" filename) (if (and (tramp-local-host-p v) (let (file-name-handler-alist) (file-readable-p localname))) @@ -4067,7 +4179,7 @@ Let-bind it when necessary.") ;; When we shall insert only a part of the file, we ;; copy this part. This works only for the shell file - ;; name handlers. It doesn't work for encrypted files. + ;; name handlers. It doesn't work for encrypted files. (when (and (or beg end) (tramp-sh-file-name-handler-p v) (null tramp-crypt-enabled)) @@ -4131,12 +4243,16 @@ Let-bind it when necessary.") filename local-copy))) (setq result (insert-file-contents - local-copy visit beg end replace)))) - (error - (add-hook 'find-file-not-found-functions - `(lambda () (signal ',(car err) ',(cdr err))) - nil t) - (signal (car err) (cdr err)))))) + local-copy visit beg end replace)))))) + + (file-error + (let ((tramp-verbose (if visit 0 tramp-verbose))) + (tramp-error v 'file-missing filename))) + (error + (add-hook 'find-file-not-found-functions + `(lambda () (signal ',(car err) ',(cdr err))) + nil t) + (signal (car err) (cdr err)))) ;; Save exit. (when visit @@ -4288,8 +4404,7 @@ It is not guaranteed, that all process attributes as described in (funcall (cdr elt))) ((null (cdr elt)) (search-forward-regexp "\\s-+") - (buffer-substring (point) (line-end-position))) - (t nil))) + (buffer-substring (point) (line-end-position))))) res)) ;; `nice' could be `-'. (setq res (rassq-delete-all '- res)) @@ -5199,8 +5314,7 @@ Wait, until the connection buffer changes." (tramp-message vec 3 "Process has finished.") (throw 'tramp-action 'ok)) (tramp-message vec 3 "Process has died.") - (throw 'tramp-action 'out-of-band-failed)))) - (t nil))) + (throw 'tramp-action 'out-of-band-failed)))))) ;;; Functions for processing the actions: @@ -5711,51 +5825,140 @@ VEC is used for tracing." "Check `file-attributes' caches for VEC. Return t if according to the cache access type ACCESS is known to be granted." - (let (result - (offset (cond - ((eq ?r access) 1) - ((eq ?w access) 2) - ((eq ?x access) 3) - ((eq ?s access) 3)))) - (dolist (suffix '("string" "integer") result) - (setq - result - (or - result - (let ((file-attr - (or - (tramp-get-file-property - vec (tramp-file-name-localname vec) - (concat "file-attributes-" suffix) nil) - (file-attributes - (tramp-make-tramp-file-name vec) (intern suffix)))) - (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))) - (and - file-attr - (or - ;; Not a symlink. - (eq t (file-attribute-type file-attr)) - (null (file-attribute-type file-attr))) - (or - ;; World accessible. - (eq access (aref (file-attribute-modes file-attr) (+ offset 6))) - ;; User accessible and owned by user. - (and - (eq access (aref (file-attribute-modes file-attr) offset)) - (or (equal remote-uid unknown-id) - (equal remote-uid (file-attribute-user-id file-attr)) - (equal unknown-id (file-attribute-user-id file-attr)))) - ;; Group accessible and owned by user's principal group. - (and - (eq access - (aref (file-attribute-modes file-attr) (+ offset 3))) - (or (equal remote-gid unknown-id) - (equal remote-gid (file-attribute-group-id file-attr)) - (equal unknown-id (file-attribute-group-id file-attr)))))))))))) + (when-let ((offset (cond + ((eq ?r access) 1) + ((eq ?w access) 2) + ((eq ?x access) 3) + ((eq ?s access) 3))) + (file-attr (file-attributes (tramp-make-tramp-file-name vec))) + (remote-uid (tramp-get-remote-uid vec 'integer)) + (remote-gid (tramp-get-remote-gid vec 'integer))) + (or + ;; Not a symlink. + (eq t (file-attribute-type file-attr)) + (null (file-attribute-type file-attr))) + (or + ;; World accessible. + (eq access (aref (file-attribute-modes file-attr) (+ offset 6))) + ;; User accessible and owned by user. + (and + (eq access (aref (file-attribute-modes file-attr) offset)) + (or (equal remote-uid tramp-unknown-id-integer) + (equal remote-uid (file-attribute-user-id file-attr)) + (equal tramp-unknown-id-integer (file-attribute-user-id file-attr)))) + ;; Group accessible and owned by user's principal group. + (and + (eq access + (aref (file-attribute-modes file-attr) (+ offset 3))) + (or (equal remote-gid tramp-unknown-id-integer) + (equal remote-gid (file-attribute-group-id file-attr)) + (equal tramp-unknown-id-integer + (file-attribute-group-id file-attr))))))) + +(defmacro tramp-convert-file-attributes (vec localname id-format attr) + "Convert `file-attributes' ATTR generated Tramp backend functions. +Convert file mode bits to string and set virtual device number. +Set file uid and gid according to ID-FORMAT. LOCALNAME is used +to cache the result. Return the modified ATTR." + (declare (indent 3) (debug t)) + `(with-tramp-file-property + ,vec ,localname (format "file-attributes-%s" (or ,id-format 'integer)) + (when-let + ((result + (with-tramp-file-property ,vec ,localname "file-attributes" + (when-let ((attr ,attr)) + (save-match-data + ;; Remove color escape sequences from symlink. + (when (stringp (car attr)) + (while (string-match + tramp-display-escape-sequence-regexp (car attr)) + (setcar attr (replace-match "" nil nil (car attr))))) + ;; Convert uid and gid. Use `tramp-unknown-id-integer' + ;; as indication of unusable value. + (when (consp (nth 2 attr)) + (when (and (numberp (cdr (nth 2 attr))) + (< (cdr (nth 2 attr)) 0)) + (setcdr (car (nthcdr 2 attr)) tramp-unknown-id-integer)) + (when (and (floatp (cdr (nth 2 attr))) + (<= (cdr (nth 2 attr)) most-positive-fixnum)) + (setcdr (car (nthcdr 2 attr)) (round (cdr (nth 2 attr)))))) + (when (consp (nth 3 attr)) + (when (and (numberp (cdr (nth 3 attr))) + (< (cdr (nth 3 attr)) 0)) + (setcdr (car (nthcdr 3 attr)) tramp-unknown-id-integer)) + (when (and (floatp (cdr (nth 3 attr))) + (<= (cdr (nth 3 attr)) most-positive-fixnum)) + (setcdr (car (nthcdr 3 attr)) (round (cdr (nth 3 attr)))))) + ;; Convert last access time. + (unless (listp (nth 4 attr)) + (setcar (nthcdr 4 attr) (seconds-to-time (nth 4 attr)))) + ;; Convert last modification time. + (unless (listp (nth 5 attr)) + (setcar (nthcdr 5 attr) (seconds-to-time (nth 5 attr)))) + ;; Convert last status change time. + (unless (listp (nth 6 attr)) + (setcar (nthcdr 6 attr) (seconds-to-time (nth 6 attr)))) + ;; Convert file size. + (when (< (nth 7 attr) 0) + (setcar (nthcdr 7 attr) -1)) + (when (and (floatp (nth 7 attr)) + (<= (nth 7 attr) most-positive-fixnum)) + (setcar (nthcdr 7 attr) (round (nth 7 attr)))) + ;; Convert file mode bits to string. + (unless (stringp (nth 8 attr)) + (setcar (nthcdr 8 attr) + (tramp-file-mode-from-int (nth 8 attr))) + (when (stringp (car attr)) + (aset (nth 8 attr) 0 ?l))) + ;; Convert directory indication bit. + (when (string-prefix-p "d" (nth 8 attr)) + (setcar attr t)) + ;; Convert symlink from `tramp-do-file-attributes-with-stat'. + ;; Decode also multibyte string. + (when (consp (car attr)) + (setcar attr + (and (stringp (caar attr)) + (string-match ".+ -> .\\(.+\\)." (caar attr)) + (decode-coding-string + (match-string 1 (caar attr)) 'utf-8)))) + ;; Set file's gid change bit. + (setcar + (nthcdr 9 attr) + (not (= (cdr (nth 3 attr)) + (or (tramp-get-remote-gid ,vec 'integer) + tramp-unknown-id-integer)))) + ;; Convert inode. + (when (floatp (nth 10 attr)) + (setcar (nthcdr 10 attr) + (condition-case nil + (let ((high (nth 10 attr)) + middle low) + (if (<= high most-positive-fixnum) + (floor high) + ;; The low 16 bits. + (setq low (mod high #x10000) + high (/ high #x10000)) + (if (<= high most-positive-fixnum) + (cons (floor high) (floor low)) + ;; The middle 24 bits. + (setq middle (mod high #x1000000) + high (/ high #x1000000)) + (cons (floor high) + (cons (floor middle) (floor low)))))) + ;; Inodes can be incredible huge. We + ;; must hide this. + (error (tramp-get-inode ,vec))))) + ;; Set virtual device number. + (setcar (nthcdr 11 attr) + (tramp-get-device ,vec)) + attr))))) + + ;; Return normalized result. + (append (tramp-compat-take 2 result) + (if (eq ,id-format 'string) + (list (car (nth 2 result)) (car (nth 3 result))) + (list (cdr (nth 2 result)) (cdr (nth 3 result)))) + (nthcdr 4 result))))) (defun tramp-get-home-directory (vec &optional user) "The remote home directory for connection VEC as local file name. @@ -5828,21 +6031,15 @@ This handles also chrooted environments, which are not regarded as local." (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 (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 (tramp-make-tramp-temp-name vec)) - (if (file-exists-p result) - (setq result nil) - ;; This creates the file by side effect. - (set-file-times result) - (set-file-modes result #o0700))) - - ;; Return the local part. - (tramp-file-local-name result))) + (let (create-lockfiles) + (cl-letf (((symbol-function 'tramp-remote-acl-p) #'ignore) + ((symbol-function 'tramp-remote-selinux-p) #'ignore) + ((symbol-function 'tramp-sudoedit-remote-acl-p) #'ignore) + ((symbol-function 'tramp-sudoedit-remote-selinux-p) #'ignore)) + (tramp-file-local-name + (make-temp-file + (expand-file-name + tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))))))) (defun tramp-delete-temp-file-function () "Remove temporary files related to current buffer." diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 54d1ecf365..f51037aabb 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -31,7 +31,6 @@ (require 'ert) (require 'ert-x) (require 'tramp-archive) -(defvar tramp-copy-size-limit) (defvar tramp-persistency-file-name) ;; `ert-resource-file' was introduced in Emacs 28.1. @@ -96,7 +95,6 @@ Do not hexlify \"/\". This hexlified string is used in `file:///' URLs." (setq password-cache-expiry nil tramp-cache-read-persistent-data t ;; For auth-sources. - tramp-copy-size-limit nil tramp-persistency-file-name nil tramp-verbose 0) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 55a6feba9b..e2abb77591 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -201,6 +201,14 @@ being the result.") (file-writable-p ert-remote-temporary-file-directory)))))) (when (cdr tramp--test-enabled-checked) + ;; Remove old test files. + (dolist (dir `(,temporary-file-directory + ,ert-remote-temporary-file-directory)) + (dolist (file (directory-files dir 'full "^\\(.#\\)?tramp-test")) + (ignore-errors + (if (file-directory-p file) + (delete-directory file 'recursive) + (delete-file file))))) ;; Cleanup connection. (ignore-errors (tramp-cleanup-connection tramp-test-vec nil 'keep-password))) @@ -4078,10 +4086,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (setq tmp-name3 (concat (file-remote-p tmp-name3) tmp-name2))))) ;; Cleanup. - (ignore-errors - (delete-file tmp-name2) - (delete-file tmp-name3) - (delete-directory tmp-name1 'recursive))) + (ignore-errors (delete-file tmp-name2)) + (ignore-errors (delete-file tmp-name3)) + (ignore-errors (delete-directory tmp-name1 'recursive))) ;; Detect cyclic symbolic links. (unwind-protect commit 295efb60257d6eefa5d570009f4de3f6088af25e Author: Po Lu Date: Sun Jul 24 21:32:42 2022 +0800 Throw errors in XDS handler directly * lisp/x-dnd.el (x-dnd-xds-testing): New defvar. (x-dnd-handle-direct-save): Signal errors directly if it is true. * test/lisp/x-dnd-tests.el (x-dnd-xds-testing): New defvar. (x-dnd-tests-do-direct-save-internal): Bind it to t around x-begin-drag. (bug#56712) diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index a61905cfac..10fd9e5dac 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -1442,6 +1442,11 @@ ACTION is the action given to `x-begin-drag'." (defvar x-dnd-disable-motif-protocol) (defvar x-dnd-use-unsupported-drop) +(defvar x-dnd-xds-testing nil + "Whether or not XDS is being tested from ERT. +When non-nil, throw errors from the `XdndDirectSave0' converters +instead of returning \"E\".") + (defun x-dnd-handle-direct-save (_selection _type _value) "Handle a selection request for `XdndDirectSave'." (setq x-dnd-xds-performed t) @@ -1456,15 +1461,24 @@ ACTION is the action given to `x-begin-drag'." (dnd-get-local-file-name local-file-uri)))) (if (not local-name) '(STRING . "F") - (condition-case nil - (progn + ;; We want errors to be signalled immediately during ERT + ;; testing, instead of being silently handled. (bug#56712) + (if x-dnd-xds-testing + (prog1 '(STRING . "S") (copy-file x-dnd-xds-current-file local-name t) (when (equal x-dnd-xds-current-file dnd-last-dragged-remote-file) (dnd-remove-last-dragged-remote-file))) - (:success '(STRING . "S")) - (error '(STRING . "E")))))) + (condition-case nil + (progn + (copy-file x-dnd-xds-current-file + local-name t) + (when (equal x-dnd-xds-current-file + dnd-last-dragged-remote-file) + (dnd-remove-last-dragged-remote-file))) + (:success '(STRING . "S")) + (error '(STRING . "E"))))))) (defun x-dnd-handle-octet-stream (_selection _type _value) "Handle a selecton request for `application/octet-stream'. diff --git a/test/lisp/x-dnd-tests.el b/test/lisp/x-dnd-tests.el index 8856be79eb..ef9c8aada2 100644 --- a/test/lisp/x-dnd-tests.el +++ b/test/lisp/x-dnd-tests.el @@ -90,6 +90,8 @@ AgAABQMAAAYDAAATGwAAGhsAAA==") ;;; XDS tests. +(defvar x-dnd-xds-testing) + (defvar x-dnd-tests-xds-target-dir nil "The name of the target directory where the file will be saved.") @@ -162,7 +164,8 @@ hostname in the target URI." (original-file (expand-file-name (make-temp-name "x-dnd-test") temporary-file-directory)) - (x-dnd-tests-xds-name (make-temp-name "x-dnd-test-target"))) + (x-dnd-tests-xds-name (make-temp-name "x-dnd-test-target")) + (x-dnd-xds-testing t)) ;; The call to `gui-set-selection' is only used for providing the ;; conventional `text/uri-list' target and can be ignored. (cl-flet ((gui-set-selection #'ignore)) commit f7fd7bf477acfc65701065ec70c32dacb17e275a Author: Eugene Ha Date: Thu Apr 28 23:48:38 2022 +0200 Find libgccjit.dylib on Homebrew Macos * configure.ac: Also find libggcjit on Homebrew (bug#55173). Copyright-paperwork-exempt: yes (cherry picked from commit faa29fa2c9e9d5a5d7544a1a39b2a89cf57a8439) diff --git a/configure.ac b/configure.ac index 741a1a31df..03eb9783a9 100644 --- a/configure.ac +++ b/configure.ac @@ -3844,7 +3844,7 @@ if test "${with_native_compilation}" != "no"; then MAC_CFLAGS="-I$(dirname $($BREW ls -v libgccjit | \ grep libgccjit.h))" MAC_LIBS="-L$(dirname $($BREW ls -v libgccjit| \ - grep libgccjit.so\$))" + grep -E 'libgccjit\.(so|dylib)$'))" fi fi commit 2024136d31e85f5935e1dd1a494ecb3ea715ef80 Author: Paul Pogonyshev Date: Sun Jul 24 11:06:19 2022 +0200 Don't exclude current dir in `package--reload-previously-loaded' * lisp/emacs-lisp/package.el (package--reload-previously-loaded): Don't exclude the current directory (bug#56614). diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 00beee811b..5ea0c819e9 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -785,10 +785,14 @@ byte-compilation of the new package to fail." (with-demoted-errors "Error in package--load-files-for-activation: %s" (let* (result (dir (package-desc-dir pkg-desc)) - (load-path-sans-dir - (cl-remove-if (apply-partially #'string= dir) - (or (bound-and-true-p find-function-source-path) - load-path))) + ;; A previous implementation would skip `dir' itself. + ;; However, in normal use reloading from the same directory + ;; never happens anyway, while in certain cases external to + ;; Emacs a package in the same directory not necessary + ;; stays byte-identical, e.g. during development. Just + ;; don't special-case `dir'. + (effective-path (or (bound-and-true-p find-library-source-path) + load-path)) (files (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")) (history (mapcar #'file-truename (cl-remove-if-not #'stringp @@ -796,8 +800,19 @@ byte-compilation of the new package to fail." (dolist (file files) (when-let ((library (package--library-stem (file-relative-name file dir))) - (canonical (locate-library library nil load-path-sans-dir)) - (found (member (file-truename canonical) history)) + (canonical (locate-library library nil effective-path)) + (truename (file-truename canonical)) + ;; Normally, all files in a package are compiled by + ;; now, but don't assume that. E.g. different + ;; versions can add or remove `no-byte-compile'. + (altname (if (string-suffix-p ".el" truename) + (replace-regexp-in-string + "\\.el\\'" ".elc" truename t) + (replace-regexp-in-string + "\\.elc\\'" ".el" truename t))) + (found (or (member truename history) + (and (not (string= altname truename)) + (member altname history)))) (recent-index (length found))) (unless (equal (file-name-base library) (format "%s-autoloads" (package-desc-name pkg-desc))) commit 2c980815f5c88c14cf7567aa12eb23fc1d41d5d1 Author: YugaEgo Date: Sun Jul 24 11:01:50 2022 +0200 Add new user option 'diff-whitespace-style' * lisp/vc/diff-mode.el (diff-whitespace-style): New user option. (diff-setup-whitespace): Use it (Bug#56679). (top level): require 'whitespace. (whitespace-style, whitespace-trailing-regexp): Remove defvars. diff --git a/etc/NEWS b/etc/NEWS index 27046894ad..1d0e45fdcc 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1190,6 +1190,13 @@ the run/continue command. This is bound to 'H' and toggles whether to hide or show the widget contents. +** Diff mode + +--- +*** New user option 'diff-whitespace-style'. +This option determines buffer-local 'whitespace-style' value. + + ** Ispell --- diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 30ba4153a9..8d9caf35a3 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -56,6 +56,7 @@ (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'subr-x)) (require 'easy-mmode) +(require 'whitespace) (autoload 'vc-find-revision "vc") (autoload 'vc-find-revision-no-save "vc") @@ -147,6 +148,11 @@ and hunk-based syntax highlighting otherwise as a fallback." (const :tag "Highlight syntax" t) (const :tag "Allow hunk-based fallback" hunk-also))) +(defcustom diff-whitespace-style '(face trailing) + "Specify `whitespace-style' variable for the current Diff mode buffer." + :type (get 'whitespace-style 'custom-type) + :version "29.1") + (defvar diff-vc-backend nil "The VC backend that created the current Diff buffer, if any.") @@ -1476,9 +1482,6 @@ See `after-change-functions' for the meaning of BEG, END and LEN." ;; Added when diff--font-lock-prettify is non-nil! (cl-pushnew 'display font-lock-extra-managed-props))) -(defvar whitespace-style) -(defvar whitespace-trailing-regexp) - (defvar-local diff-mode-read-only nil "Non-nil when read-only diff buffer uses short keys.") @@ -1572,7 +1575,7 @@ a diff with \\[diff-reverse-direction]. This sets `whitespace-style' and `whitespace-trailing-regexp' so that Whitespace mode shows trailing whitespace problems on the modified lines of the diff." - (setq-local whitespace-style '(face trailing)) + (setq-local whitespace-style diff-whitespace-style) (let ((style (save-excursion (goto-char (point-min)) ;; FIXME: For buffers filled from async processes, this search commit a463dccdd0b33fd329419601eecddb109057233e Merge: 279eb4e6ab b4067394dc Author: Stefan Kangas Date: Sun Jul 24 09:55:01 2022 +0200 Merge from origin/emacs-28 b4067394dc Set `default-directory' of Tramp archive connection buffer 2529e82002 ; * doc/lispref/functions.texi (Declare Form): Fix typo. 54c4ceb009 Update the documentation of 'declare' forms 7263631dca Fix bookmark support for Help functions in native-compilat... # Conflicts: # lisp/help.el commit 279eb4e6ab0fb99cacdb504d37953d9630fae8b4 Merge: 928ea0fbf1 ba7a75e052 Author: Stefan Kangas Date: Sun Jul 24 09:53:17 2022 +0200 ; Merge from origin/emacs-28 The following commit was skipped: ba7a75e052 Fix mode line mouse-1 binding when showing only column num... commit b4067394dcf33d64e0372bf553cec5b6f9c4af1c Author: Michael Albinus Date: Sat Jul 23 19:45:24 2022 +0200 Set `default-directory' of Tramp archive connection buffer * lisp/net/tramp-archive.el (tramp-archive-file-name-handler): Set `default-directory' of Tramp connection buffer. (Bug#56628) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 4b649edaab..33348ca21e 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -339,6 +339,13 @@ arguments to pass to the OPERATION." (tramp-archive-run-real-handler #'file-directory-p (list archive))) (tramp-archive-run-real-handler operation args) + ;; The default directory of the Tramp connection buffer + ;; cannot be accessed. (Bug#56628) + ;; FIXME: It is superfluous to set it every single loop. + ;; But there is no place to set it when creating the buffer. + (with-current-buffer + (tramp-get-buffer (tramp-archive-dissect-file-name filename)) + (setq default-directory (file-name-as-directory archive))) ;; Now run the handler. (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods)) (tramp-gvfs-methods tramp-archive-all-gvfs-methods) commit 2529e8200232aa8ce252084634d81a2809fb26fa Author: Eli Zaretskii Date: Sat Jul 23 12:56:00 2022 +0300 ; * doc/lispref/functions.texi (Declare Form): Fix typo. diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index 2889387506..a70364c3cb 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -2348,7 +2348,7 @@ symbol, @pxref{Standard Properties}. @item (speed @var{n}) Specify the value of @code{native-comp-speed} in effect for native compilation of this function (@pxref{Native-Compilation Variables}). -This allows function-level control on the optimization level used for +This allows function-level control of the optimization level used for native code emitted for the function. In particular, if @var{n} is @minus{}1, native compilation of the function will emit bytecode instead of native code for the function. commit 54c4ceb0091e0d3190755afbd7875864cd91b730 Author: Eli Zaretskii Date: Sat Jul 23 12:54:07 2022 +0300 Update the documentation of 'declare' forms * doc/lispref/compile.texi (Native-Compilation Variables): Mention the 'declare' alternative for 'native-comp-speed'. * doc/lispref/functions.texi (Declare Form): Document 'declare' forms that were previously undocumented. diff --git a/doc/lispref/compile.texi b/doc/lispref/compile.texi index 335200469b..f336753a6c 100644 --- a/doc/lispref/compile.texi +++ b/doc/lispref/compile.texi @@ -985,7 +985,9 @@ corresponding compiler @option{-O0}, @option{-O1}, etc.@: command-line options of the compiler. The value @minus{}1 means disable native-compilation: functions and files will be only byte-compiled; however, the @file{*.eln} files will still be produced, they will just -contain the compiled code in bytecode form. +contain the compiled code in bytecode form. (This can be achieved at +function granularity by using the @w{@code{(declare (speed -1))}} +form, @pxref{Declare Form}.) The default value is 2. @end defopt diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index 06d5031179..2889387506 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -2333,6 +2333,30 @@ the current buffer. @item (modes @var{modes}) Specify that this command is meant to be applicable for @var{modes} only. + +@item (pure @var{val}) +If @var{val} is non-@code{nil}, this function is @dfn{pure} +(@pxref{What Is a Function}). This is the same as the @code{pure} +property of the function's symbol (@pxref{Standard Properties}). + +@item (side-effect-free @var{val}) +If @var{val} is non-@code{nil}, this function is free of side effects, +so the byte compiler can ignore calls whose value is ignored. This is +the same as the @code{side-effect-free} property of the function's +symbol, @pxref{Standard Properties}. + +@item (speed @var{n}) +Specify the value of @code{native-comp-speed} in effect for native +compilation of this function (@pxref{Native-Compilation Variables}). +This allows function-level control on the optimization level used for +native code emitted for the function. In particular, if @var{n} is +@minus{}1, native compilation of the function will emit bytecode +instead of native code for the function. + +@item no-font-lock-keyword +This is valid for macros only. Macros with this declaration are +highlighted by font-lock (@pxref{Font Lock Mode}) as normal functions, +not specially as macros. @end table @end defmac commit 7263631dca6145354e994d84c9ff3e09c450739b Author: Eli Zaretskii Date: Sat Jul 23 11:11:47 2022 +0300 Fix bookmark support for Help functions in native-compilation builds * lisp/help.el (describe-key--helper, describe-function--helper): New helper functions. (describe-key): Call 'describe-key--helper' instead of a lambda-function. * lisp/help-fns.el (describe-function): Call 'describe-function--helper' instead of a lambda-function. (Bug#56643) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 6a7951d160..656e7b7da2 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -251,13 +251,9 @@ handling of autoloaded functions." (or describe-function-orig-buffer (current-buffer)))) - (help-setup-xref - (list (lambda (function buffer) - (let ((describe-function-orig-buffer - (if (buffer-live-p buffer) buffer))) - (describe-function function))) - function describe-function-orig-buffer) - (called-interactively-p 'interactive)) + (help-setup-xref (list #'describe-function--helper + function describe-function-orig-buffer) + (called-interactively-p 'interactive)) (save-excursion (with-help-window (help-buffer) diff --git a/lisp/help.el b/lisp/help.el index fd331ac0d4..0701bf178a 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -881,6 +881,19 @@ Describe the following key, mouse click, or menu item: " (setq yank-menu (copy-sequence saved-yank-menu)) (fset 'yank-menu (cons 'keymap yank-menu)))))) +;; These two are named functions because lambda-functions cannot be +;; serialized in a native-compilation build, which breaks bookmark +;; support in help-mode.el. +(defun describe-key--helper (key-list buf) + (describe-key key-list + (if (buffer-live-p buf) buf))) + +(defvar describe-function-orig-buffer) +(defun describe-function--helper (func buf) + (let ((describe-function-orig-buffer + (if (buffer-live-p buf) buf))) + (describe-function func))) + (defun describe-key (&optional key-list buffer up-event) "Display documentation of the function invoked by KEY-LIST. KEY-LIST can be any kind of a key sequence; it can include keyboard events, @@ -926,10 +939,7 @@ current buffer." `(,seq ,brief-desc ,defn ,locus))) key-list)) 2))) - (help-setup-xref (list (lambda (key-list buf) - (describe-key key-list - (if (buffer-live-p buf) buf))) - key-list buf) + (help-setup-xref (list #'describe-key--helper key-list buf) (called-interactively-p 'interactive)) (if (and (<= (length info-list) 1) (help--binding-undefined-p (nth 2 (car info-list)))) commit ba7a75e052bfd24e99b79bbb161b2b0a99e7cce2 Author: Miha Rihtarsic Date: Sat Jul 23 10:32:50 2022 +0300 Fix mode line mouse-1 binding when showing only column numbers * lisp/bindings.el (mode-line-position): Fix the mouse-1 binding when showing only column numbers (bug#56694). Do not merge to master. diff --git a/lisp/bindings.el b/lisp/bindings.el index 56f742a270..5eb8e62912 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -516,7 +516,7 @@ mouse-1: Display Line and Column Mode Menu") 'help-echo "Size indication mode\n\ mouse-1: Display Line and Column Mode Menu"))) (line-number-mode - ((column-number-mode + (column-number-mode (column-number-indicator-zero-based (10 (:propertize @@ -530,13 +530,13 @@ mouse-1: Display Line and Column Mode Menu"))) (6 (:propertize mode-line-position-line-format - ,@mode-line-position--column-line-properties)))) + ,@mode-line-position--column-line-properties))) (column-number-mode (column-number-indicator-zero-based (6 (:propertize mode-line-position-column-format - (,@mode-line-position--column-line-properties))) + ,@mode-line-position--column-line-properties)) (6 (:propertize (:eval (string-replace