Fix url-copy-file argument handling
For discussion, see the following thread: https://lists.gnu.org/archive/html/emacs-devel/2019-05/msg00500.html * lisp/url/url-handlers.el: Update autoloaded docstrings. Quote function symbols as such. (url-handler-regexp): Make grouping construct shy. (url-file-handler, url-insert-buffer-contents) (url-handlers-create-wrapper, url-handlers-set-buffer-mode): Simplify. (url-file-handler-identity): Clarify calling convention. (file-name-absolute-p, url-file-local-copy): Mark ignored arguments as such. (url-handler-directory-file-name): Prefer string comparison over regexp match where either will do. (url-copy-file): Handle integer as third argument as per copy-file.
This commit is contained in:
Basil L. Contovounesios
parent
7083974021
commit
72047556fa
1 changed files with 77 additions and 82 deletions
|
|
@ -23,17 +23,17 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
;; (require 'url)
|
||||
(require 'url-parse)
|
||||
;; (require 'url-util)
|
||||
(eval-when-compile (require 'mm-decode))
|
||||
;; (require 'mailcap)
|
||||
(eval-when-compile (require 'subr-x))
|
||||
;; The following are autoloaded instead of `require'd to avoid eagerly
|
||||
;; loading all of URL when turning on url-handler-mode in the .emacs.
|
||||
(autoload 'url-expand-file-name "url-expand" "Convert url to a fully specified url, and canonicalize it.")
|
||||
(autoload 'mm-dissect-buffer "mm-decode" "Dissect the current buffer and return a list of MIME handles.")
|
||||
(autoload 'url-scheme-get-property "url-methods" "Get property of a URL SCHEME.")
|
||||
(autoload 'url-expand-file-name "url-expand"
|
||||
"Convert URL to a fully specified URL, and canonicalize it.")
|
||||
(autoload 'mm-dissect-buffer "mm-decode"
|
||||
"Dissect the current buffer and return a list of MIME handles.")
|
||||
(autoload 'url-scheme-get-property "url-methods"
|
||||
"Get PROPERTY of a URL SCHEME.")
|
||||
|
||||
;; Always used after mm-dissect-buffer and defined in the same file.
|
||||
(declare-function mm-save-part-to-file "mm-decode" (handle file))
|
||||
|
|
@ -112,15 +112,16 @@
|
|||
(push (cons url-handler-regexp 'url-file-handler)
|
||||
file-name-handler-alist)))
|
||||
|
||||
(defcustom url-handler-regexp "\\`\\(https?\\|ftp\\|file\\|nfs\\|ssh\\|scp\\|rsync\\|telnet\\)://"
|
||||
(defcustom url-handler-regexp
|
||||
"\\`\\(?:https?\\|ftp\\|file\\|nfs\\|ssh\\|scp\\|rsync\\|telnet\\)://"
|
||||
"Regular expression for URLs handled by `url-handler-mode'.
|
||||
When URL Handler mode is enabled, this regular expression is
|
||||
added to `file-name-handler-alist'.
|
||||
|
||||
Some valid URL protocols just do not make sense to visit
|
||||
interactively \(about, data, info, irc, mailto, etc.). This
|
||||
interactively (about, data, info, irc, mailto, etc.). This
|
||||
regular expression avoids conflicts with local files that look
|
||||
like URLs \(Gnus is particularly bad at this)."
|
||||
like URLs (Gnus is particularly bad at this)."
|
||||
:group 'url
|
||||
:type 'regexp
|
||||
:version "25.1"
|
||||
|
|
@ -144,8 +145,8 @@ like URLs \(Gnus is particularly bad at this)."
|
|||
;;;###autoload
|
||||
(defun url-file-handler (operation &rest args)
|
||||
"Function called from the `file-name-handler-alist' routines.
|
||||
OPERATION is what needs to be done (`file-exists-p', etc). ARGS are
|
||||
the arguments that would have been passed to OPERATION."
|
||||
OPERATION is what needs to be done (`file-exists-p', etc.).
|
||||
ARGS are the arguments that would have been passed to OPERATION."
|
||||
;; Avoid recursive load.
|
||||
(if (and load-in-progress url-file-handler-load-in-progress)
|
||||
(url-run-real-handler operation args)
|
||||
|
|
@ -153,48 +154,46 @@ the arguments that would have been passed to OPERATION."
|
|||
;; Check, whether there are arguments we want pass to Tramp.
|
||||
(if (catch :do
|
||||
(dolist (url (cons default-directory args))
|
||||
(and (member
|
||||
(url-type (url-generic-parse-url (and (stringp url) url)))
|
||||
url-tramp-protocols)
|
||||
(and (stringp url)
|
||||
(member (url-type (url-generic-parse-url url))
|
||||
url-tramp-protocols)
|
||||
(throw :do t))))
|
||||
(apply 'url-tramp-file-handler operation args)
|
||||
(apply #'url-tramp-file-handler operation args)
|
||||
;; Otherwise, let's do the job.
|
||||
(let ((fn (get operation 'url-file-handlers))
|
||||
(val nil)
|
||||
(hooked nil))
|
||||
(if (and (not fn) (intern-soft (format "url-%s" operation))
|
||||
val)
|
||||
(if (and (not fn)
|
||||
(fboundp (intern-soft (format "url-%s" operation))))
|
||||
(error "Missing URL handler mapping for %s" operation))
|
||||
(if fn
|
||||
(setq hooked t
|
||||
val (save-match-data (apply fn args)))
|
||||
(setq hooked nil
|
||||
val (url-run-real-handler operation args)))
|
||||
(url-debug 'handlers "%s %S%S => %S" (if hooked "Hooked" "Real")
|
||||
(setq val (if fn (save-match-data (apply fn args))
|
||||
(url-run-real-handler operation args)))
|
||||
(url-debug 'handlers "%s %S%S => %S" (if fn "Hooked" "Real")
|
||||
operation args val)
|
||||
val)))))
|
||||
|
||||
(defun url-file-handler-identity (&rest args)
|
||||
;; Identity function
|
||||
(car args))
|
||||
(defun url-file-handler-identity (arg &rest _ignored)
|
||||
;; Identity function.
|
||||
arg)
|
||||
|
||||
;; These are operations that we can fully support
|
||||
(put 'file-readable-p 'url-file-handlers 'url-file-exists-p)
|
||||
(put 'substitute-in-file-name 'url-file-handlers 'url-file-handler-identity)
|
||||
(put 'file-name-absolute-p 'url-file-handlers (lambda (&rest ignored) t))
|
||||
(put 'expand-file-name 'url-file-handlers 'url-handler-expand-file-name)
|
||||
(put 'directory-file-name 'url-file-handlers 'url-handler-directory-file-name)
|
||||
(put 'file-name-directory 'url-file-handlers 'url-handler-file-name-directory)
|
||||
(put 'unhandled-file-name-directory 'url-file-handlers 'url-handler-unhandled-file-name-directory)
|
||||
(put 'file-remote-p 'url-file-handlers 'url-handler-file-remote-p)
|
||||
;; (put 'file-name-as-directory 'url-file-handlers 'url-handler-file-name-as-directory)
|
||||
;; These are operations that we can fully support.
|
||||
(put 'file-readable-p 'url-file-handlers #'url-file-exists-p)
|
||||
(put 'substitute-in-file-name 'url-file-handlers #'url-file-handler-identity)
|
||||
(put 'file-name-absolute-p 'url-file-handlers (lambda (&rest _ignored) t))
|
||||
(put 'expand-file-name 'url-file-handlers #'url-handler-expand-file-name)
|
||||
(put 'directory-file-name 'url-file-handlers #'url-handler-directory-file-name)
|
||||
(put 'file-name-directory 'url-file-handlers #'url-handler-file-name-directory)
|
||||
(put 'unhandled-file-name-directory 'url-file-handlers
|
||||
#'url-handler-unhandled-file-name-directory)
|
||||
(put 'file-remote-p 'url-file-handlers #'url-handler-file-remote-p)
|
||||
;; (put 'file-name-as-directory 'url-file-handlers
|
||||
;; #'url-handler-file-name-as-directory)
|
||||
|
||||
;; These are operations that we do not support yet (DAV!!!)
|
||||
(put 'file-writable-p 'url-file-handlers 'ignore)
|
||||
(put 'file-symlink-p 'url-file-handlers 'ignore)
|
||||
(put 'file-writable-p 'url-file-handlers #'ignore)
|
||||
(put 'file-symlink-p 'url-file-handlers #'ignore)
|
||||
;; Just like for ange-ftp: let's not waste time trying to look for RCS/foo,v
|
||||
;; files and such since we can't do anything clever with them anyway.
|
||||
(put 'vc-registered 'url-file-handlers 'ignore)
|
||||
(put 'vc-registered 'url-file-handlers #'ignore)
|
||||
|
||||
(defun url-handler-expand-file-name (file &optional base)
|
||||
;; When we see "/foo/bar" in a file whose working dir is "http://bla/bla",
|
||||
|
|
@ -215,7 +214,7 @@ the arguments that would have been passed to OPERATION."
|
|||
;; reversible: (f-n-a-d (d-f-n (f-n-a-d X))) == (f-n-a-d X)
|
||||
(defun url-handler-directory-file-name (dir)
|
||||
;; When there's more than a single /, just don't touch the slashes at all.
|
||||
(if (string-match "//\\'" dir) dir
|
||||
(if (string-suffix-p "//" dir) dir
|
||||
(url-run-real-handler 'directory-file-name (list dir))))
|
||||
|
||||
(defun url-handler-unhandled-file-name-directory (filename)
|
||||
|
|
@ -257,44 +256,42 @@ the arguments that would have been passed to OPERATION."
|
|||
;; `url-handler-unhandled-file-name-directory'.
|
||||
nil)))
|
||||
|
||||
;; The actual implementation
|
||||
;; The actual implementation.
|
||||
;;;###autoload
|
||||
(defun url-copy-file (url newname &optional ok-if-already-exists
|
||||
_keep-time _preserve-uid-gid _preserve-permissions)
|
||||
"Copy URL to NEWNAME. Both args must be strings.
|
||||
Signal a `file-already-exists' error if file NEWNAME already exists,
|
||||
unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
|
||||
A number as third arg means request confirmation if NEWNAME already exists.
|
||||
This is what happens in interactive use with M-x.
|
||||
Fourth arg KEEP-TIME non-nil means give the new file the same
|
||||
last-modified time as the old one. (This works on only some systems.)
|
||||
Args PRESERVE-UID-GID and PRESERVE-PERMISSIONS are ignored.
|
||||
A prefix arg makes KEEP-TIME non-nil."
|
||||
(if (and (file-exists-p newname)
|
||||
(not ok-if-already-exists))
|
||||
(signal 'file-already-exists (list "File exists" newname)))
|
||||
(let ((buffer (url-retrieve-synchronously url))
|
||||
(handle nil))
|
||||
(if (not buffer)
|
||||
(signal 'file-missing (list "Opening URL" "No such file or directory"
|
||||
url)))
|
||||
(with-current-buffer buffer
|
||||
(setq handle (mm-dissect-buffer t)))
|
||||
(defun url-copy-file (url newname &optional ok-if-already-exists &rest _ignored)
|
||||
"Copy URL to NEWNAME. Both arguments must be strings.
|
||||
Signal a `file-already-exists' error if file NEWNAME already
|
||||
exists, unless a third argument OK-IF-ALREADY-EXISTS is supplied
|
||||
and non-nil. An integer as third argument means request
|
||||
confirmation if NEWNAME already exists."
|
||||
(and (file-exists-p newname)
|
||||
(or (not ok-if-already-exists)
|
||||
(and (integerp ok-if-already-exists)
|
||||
(not (yes-or-no-p
|
||||
(format "File %s already exists; copy to it anyway? "
|
||||
newname)))))
|
||||
(signal 'file-already-exists (list "File already exists" newname)))
|
||||
(let* ((buffer (or (url-retrieve-synchronously url)
|
||||
(signal 'file-missing
|
||||
(list "Opening URL"
|
||||
"No such file or directory" url))))
|
||||
(handle (with-current-buffer buffer
|
||||
(mm-dissect-buffer t))))
|
||||
(let ((mm-attachment-file-modes (default-file-modes)))
|
||||
(mm-save-part-to-file handle newname))
|
||||
(kill-buffer buffer)
|
||||
(mm-destroy-parts handle)))
|
||||
(put 'copy-file 'url-file-handlers 'url-copy-file)
|
||||
(put 'copy-file 'url-file-handlers #'url-copy-file)
|
||||
|
||||
;;;###autoload
|
||||
(defun url-file-local-copy (url &rest ignored)
|
||||
(defun url-file-local-copy (url &rest _ignored)
|
||||
"Copy URL into a temporary file on this machine.
|
||||
Returns the name of the local copy, or nil, if FILE is directly
|
||||
accessible."
|
||||
(let ((filename (make-temp-file "url")))
|
||||
(url-copy-file url filename 'ok-if-already-exists)
|
||||
filename))
|
||||
(put 'file-local-copy 'url-file-handlers 'url-file-local-copy)
|
||||
(put 'file-local-copy 'url-file-handlers #'url-file-local-copy)
|
||||
|
||||
(defun url-insert (buffer &optional beg end)
|
||||
"Insert the body of a URL object.
|
||||
|
|
@ -330,8 +327,8 @@ This is like `url-insert', but also decodes the current buffer as
|
|||
if it had been inserted from a file named URL."
|
||||
(if visit (setq buffer-file-name url))
|
||||
(save-excursion
|
||||
(let* ((start (point))
|
||||
(size-and-charset (url-insert buffer beg end)))
|
||||
(let ((start (point))
|
||||
(size-and-charset (url-insert buffer beg end)))
|
||||
(kill-buffer buffer)
|
||||
(when replace
|
||||
(delete-region (point-min) start)
|
||||
|
|
@ -342,10 +339,9 @@ if it had been inserted from a file named URL."
|
|||
(decode-coding-inserted-region (point-min) (point) url
|
||||
visit beg end replace))
|
||||
(let ((inserted (car size-and-charset)))
|
||||
(when (fboundp 'after-insert-file-set-coding)
|
||||
(let ((insval (after-insert-file-set-coding inserted visit)))
|
||||
(if insval (setq inserted insval))))
|
||||
(list url inserted)))))
|
||||
(list url (or (and (fboundp 'after-insert-file-set-coding)
|
||||
(after-insert-file-set-coding inserted visit))
|
||||
inserted))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun url-insert-file-contents (url &optional visit beg end replace)
|
||||
|
|
@ -356,15 +352,14 @@ if it had been inserted from a file named URL."
|
|||
;; instead. See bug#17549.
|
||||
(url-http--insert-file-helper buffer url visit))
|
||||
(url-insert-buffer-contents buffer url visit beg end replace)))
|
||||
|
||||
(put 'insert-file-contents 'url-file-handlers 'url-insert-file-contents)
|
||||
(put 'insert-file-contents 'url-file-handlers #'url-insert-file-contents)
|
||||
|
||||
(defun url-file-name-completion (url _directory &optional _predicate)
|
||||
;; Even if it's not implemented, it's not an error to ask for completion,
|
||||
;; in case it's available (bug#14806).
|
||||
;; (error "Unimplemented")
|
||||
url)
|
||||
(put 'file-name-completion 'url-file-handlers 'url-file-name-completion)
|
||||
(put 'file-name-completion 'url-file-handlers #'url-file-name-completion)
|
||||
|
||||
(defun url-file-name-all-completions (_file _directory)
|
||||
;; Even if it's not implemented, it's not an error to ask for completion,
|
||||
|
|
@ -372,7 +367,7 @@ if it had been inserted from a file named URL."
|
|||
;; (error "Unimplemented")
|
||||
nil)
|
||||
(put 'file-name-all-completions
|
||||
'url-file-handlers 'url-file-name-all-completions)
|
||||
'url-file-handlers #'url-file-name-all-completions)
|
||||
|
||||
;; All other handlers map onto their respective backends.
|
||||
(defmacro url-handlers-create-wrapper (method args)
|
||||
|
|
@ -382,10 +377,10 @@ if it had been inserted from a file named URL."
|
|||
(or (documentation method t) "No original documentation."))
|
||||
(setq url (url-generic-parse-url url))
|
||||
(when (url-type url)
|
||||
(funcall (url-scheme-get-property (url-type url) (quote ,method))
|
||||
,@(remove '&rest (remove '&optional args)))))
|
||||
(funcall (url-scheme-get-property (url-type url) ',method)
|
||||
,@(remq '&rest (remq '&optional args)))))
|
||||
(unless (get ',method 'url-file-handlers)
|
||||
(put ',method 'url-file-handlers ',(intern (format "url-%s" method))))))
|
||||
(put ',method 'url-file-handlers #',(intern (format "url-%s" method))))))
|
||||
|
||||
(url-handlers-create-wrapper file-exists-p (url))
|
||||
(url-handlers-create-wrapper file-attributes (url &optional id-format))
|
||||
|
|
@ -396,12 +391,12 @@ if it had been inserted from a file named URL."
|
|||
(url-handlers-create-wrapper directory-files (url &optional full match nosort))
|
||||
(url-handlers-create-wrapper file-truename (url &optional counter prev-dirs))
|
||||
|
||||
(add-hook 'find-file-hook 'url-handlers-set-buffer-mode)
|
||||
(add-hook 'find-file-hook #'url-handlers-set-buffer-mode)
|
||||
|
||||
(defun url-handlers-set-buffer-mode ()
|
||||
"Set correct modes for the current buffer if visiting a remote file."
|
||||
(and (stringp buffer-file-name)
|
||||
(string-match url-handler-regexp buffer-file-name)
|
||||
(and buffer-file-name
|
||||
(string-match-p url-handler-regexp buffer-file-name)
|
||||
(auto-save-mode 0)))
|
||||
|
||||
(provide 'url-handlers)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue