lisp/url/url-handlers.el

   1 ;;; url-handlers.el --- file-name-handler stuff for URL loading  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 1996-1999, 2004-2018 Free Software Foundation, Inc.
   4
   5 ;; Keywords: comm, data, processes, hypermedia
   6
   7 ;; This file is part of GNU Emacs.
   8 ;;
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 ;; (require 'url)
  27 (require 'url-parse)
  28 ;; (require 'url-util)
  29 (eval-when-compile (require 'mm-decode))
  30 ;; (require 'mailcap)
  31 (eval-when-compile (require 'subr-x))
  32 ;; The following are autoloaded instead of `require'd to avoid eagerly
  33 ;; loading all of URL when turning on url-handler-mode in the .emacs.
  34 (autoload 'url-expand-file-name "url-expand" "Convert url to a fully specified url, and canonicalize it.")
  35 (autoload 'mm-dissect-buffer "mm-decode" "Dissect the current buffer and return a list of MIME handles.")
  36 (autoload 'url-scheme-get-property "url-methods" "Get property of a URL SCHEME.")
  37
  38 ;; Always used after mm-dissect-buffer and defined in the same file.
  39 (declare-function mm-save-part-to-file "mm-decode" (handle file))
  40 (declare-function mm-destroy-parts "mm-decode" (handles))
  41 ;; mm-decode loads mm-bodies.
  42 (declare-function mm-decode-string "mm-bodies" (string charset))
  43 ;; mm-decode loads mail-parse.
  44 (declare-function mail-content-type-get "mail-parse" (ct attribute))
  45 ;; mm-decode loads mm-bodies, which loads mm-util.
  46 (declare-function mm-charset-to-coding-system "mm-util"
  47                  (charset &optional lbt allow-override silent))
  48
  49 ;; Implementation status
  50 ;; ---------------------
  51 ;; Function                             Status
  52 ;; ------------------------------------------------------------
  53 ;; add-name-to-file                     Needs DAV Bindings
  54 ;; copy-file                            Broken (assumes 1st item is URL)
  55 ;; delete-directory                     Finished (DAV)
  56 ;; delete-file                          Finished (DAV)
  57 ;; diff-latest-backup-file
  58 ;; directory-file-name                  unnecessary
  59 ;; directory-files                      Finished (DAV)
  60 ;; dired-call-process
  61 ;; dired-compress-file
  62 ;; dired-uncache
  63 ;; expand-file-name                     Finished
  64 ;; file-accessible-directory-p
  65 ;; file-attributes                      Finished, better with DAV
  66 ;; file-directory-p                     Needs DAV, finished
  67 ;; file-executable-p                    Finished
  68 ;; file-exists-p                        Finished
  69 ;; file-local-copy
  70 ;; file-modes
  71 ;; file-name-all-completions            Finished (DAV)
  72 ;; file-name-as-directory
  73 ;; file-name-completion                 Finished (DAV)
  74 ;; file-name-directory
  75 ;; file-name-nondirectory
  76 ;; file-name-sans-versions              why?
  77 ;; file-newer-than-file-p
  78 ;; file-ownership-preserved-p           No way to know
  79 ;; file-readable-p                      Finished
  80 ;; file-regular-p                       !directory_p
  81 ;; file-remote-p                        Finished
  82 ;; file-symlink-p                       Needs DAV bindings
  83 ;; file-truename                        Needs DAV bindings
  84 ;; file-writable-p                      Check for LOCK?
  85 ;; find-backup-file-name                why?
  86 ;; get-file-buffer                      why?
  87 ;; insert-directory                     Use DAV
  88 ;; insert-file-contents                 Finished
  89 ;; load
  90 ;; make-directory                       Finished (DAV)
  91 ;; make-symbolic-link                   Needs DAV bindings
  92 ;; rename-file                          Finished (DAV)
  93 ;; set-file-modes                       Use mod_dav specific executable flag?
  94 ;; set-visited-file-modtime             Impossible?
  95 ;; shell-command                        Impossible?
  96 ;; unhandled-file-name-directory
  97 ;; vc-registered                        Finished (DAV)
  98 ;; verify-visited-file-modtime
  99 ;; write-region
 100
 101 (defvar url-handler-regexp) ; defined below to avoid recursive load (revno:108572)
 102
 103 ;;;###autoload
 104 (define-minor-mode url-handler-mode
 105   "Toggle using `url' library for URL filenames (URL Handler mode).
 106 With a prefix argument ARG, enable URL Handler mode if ARG is
 107 positive, and disable it otherwise.  If called from Lisp, enable
 108 the mode if ARG is omitted or nil."
 109   :global t :group 'url
 110   ;; Remove old entry, if any.
 111   (setq file-name-handler-alist
 112         (delq (rassq 'url-file-handler file-name-handler-alist)
 113               file-name-handler-alist))
 114   (if url-handler-mode
 115       (push (cons url-handler-regexp 'url-file-handler)
 116             file-name-handler-alist)))
 117
 118 (defcustom url-handler-regexp "\\`\\(https?\\|ftp\\|file\\|nfs\\|ssh\\|scp\\|rsync\\|telnet\\)://"
 119   "Regular expression for URLs handled by `url-handler-mode'.
 120 When URL Handler mode is enabled, this regular expression is
 121 added to `file-name-handler-alist'.
 122
 123 Some valid URL protocols just do not make sense to visit
 124 interactively \(about, data, info, irc, mailto, etc.).  This
 125 regular expression avoids conflicts with local files that look
 126 like URLs \(Gnus is particularly bad at this)."
 127   :group 'url
 128   :type 'regexp
 129   :version "25.1"
 130   :set (lambda (symbol value)
 131          (let ((enable url-handler-mode))
 132            (url-handler-mode 0)
 133            (set-default symbol value)
 134            (if enable
 135                (url-handler-mode)))))
 136
 137 (defun url-run-real-handler (operation args)
 138   (let ((inhibit-file-name-handlers (cons 'url-file-handler
 139                                           (if (eq operation inhibit-file-name-operation)
 140                                               inhibit-file-name-handlers)))
 141         (inhibit-file-name-operation operation))
 142     (apply operation args)))
 143
 144 (defvar url-file-handler-load-in-progress nil
 145   "Check for recursive load.")
 146
 147 ;;;###autoload
 148 (defun url-file-handler (operation &rest args)
 149   "Function called from the `file-name-handler-alist' routines.
 150 OPERATION is what needs to be done (`file-exists-p', etc).  ARGS are
 151 the arguments that would have been passed to OPERATION."
 152   ;; Avoid recursive load.
 153   (if (and load-in-progress url-file-handler-load-in-progress)
 154       (url-run-real-handler operation args)
 155     (let ((url-file-handler-load-in-progress load-in-progress))
 156       ;; Check, whether there are arguments we want pass to Tramp.
 157       (if (catch :do
 158             (dolist (url (cons default-directory args))
 159               (and (member
 160                     (url-type (url-generic-parse-url (and (stringp url) url)))
 161                     url-tramp-protocols)
 162                    (throw :do t))))
 163           (apply 'url-tramp-file-handler operation args)
 164         ;; Otherwise, let's do the job.
 165         (let ((fn (get operation 'url-file-handlers))
 166               (val nil)
 167               (hooked nil))
 168           (if (and (not fn) (intern-soft (format "url-%s" operation))
 169                    (fboundp (intern-soft (format "url-%s" operation))))
 170               (error "Missing URL handler mapping for %s" operation))
 171           (if fn
 172               (setq hooked t
 173                     val (save-match-data (apply fn args)))
 174             (setq hooked nil
 175                   val (url-run-real-handler operation args)))
 176           (url-debug 'handlers "%s %S%S => %S" (if hooked "Hooked" "Real")
 177                      operation args val)
 178           val)))))
 179
 180 (defun url-file-handler-identity (&rest args)
 181   ;; Identity function
 182   (car args))
 183
 184 ;; These are operations that we can fully support
 185 (put 'file-readable-p 'url-file-handlers 'url-file-exists-p)
 186 (put 'substitute-in-file-name 'url-file-handlers 'url-file-handler-identity)
 187 (put 'file-name-absolute-p 'url-file-handlers (lambda (&rest ignored) t))
 188 (put 'expand-file-name 'url-file-handlers 'url-handler-expand-file-name)
 189 (put 'directory-file-name 'url-file-handlers 'url-handler-directory-file-name)
 190 (put 'file-name-directory 'url-file-handlers 'url-handler-file-name-directory)
 191 (put 'unhandled-file-name-directory 'url-file-handlers 'url-handler-unhandled-file-name-directory)
 192 (put 'file-remote-p 'url-file-handlers 'url-handler-file-remote-p)
 193 ;; (put 'file-name-as-directory 'url-file-handlers 'url-handler-file-name-as-directory)
 194
 195 ;; These are operations that we do not support yet (DAV!!!)
 196 (put 'file-writable-p 'url-file-handlers 'ignore)
 197 (put 'file-symlink-p 'url-file-handlers 'ignore)
 198 ;; Just like for ange-ftp: let's not waste time trying to look for RCS/foo,v
 199 ;; files and such since we can't do anything clever with them anyway.
 200 (put 'vc-registered 'url-file-handlers 'ignore)
 201
 202 (defun url-handler-expand-file-name (file &optional base)
 203   ;; When we see "/foo/bar" in a file whose working dir is "http://bla/bla",
 204   ;; there are two interpretations possible: either it's a local "/foo/bar"
 205   ;; or it's "http:/bla/foo/bar".  When working with URLs, the second
 206   ;; interpretation is the right one, but when working with Emacs file
 207   ;; names, the first is preferred.
 208   (if (file-name-absolute-p file)
 209       (expand-file-name file "/")
 210     (url-expand-file-name file base)))
 211
 212 ;; directory-file-name and file-name-as-directory are kind of hard to
 213 ;; implement really right for URLs since URLs can have repeated / chars.
 214 ;; We'd want the following behavior:
 215 ;; idempotence: (d-f-n (d-f-n X) == (d-f-n X)
 216 ;; idempotence: (f-n-a-d (f-n-a-d X) == (f-n-a-d X)
 217 ;; reversible:  (d-f-n (f-n-a-d (d-f-n X))) == (d-f-n X)
 218 ;; reversible:  (f-n-a-d (d-f-n (f-n-a-d X))) == (f-n-a-d X)
 219 (defun url-handler-directory-file-name (dir)
 220   ;; When there's more than a single /, just don't touch the slashes at all.
 221   (if (string-match "//\\'" dir) dir
 222     (url-run-real-handler 'directory-file-name (list dir))))
 223
 224 (defun url-handler-unhandled-file-name-directory (filename)
 225   (let ((url (url-generic-parse-url filename)))
 226     (if (equal (url-type url) "file")
 227         ;; `file' URLs are actually local.  The filename part may be ""
 228         ;; which really stands for "/".
 229         ;; FIXME: maybe we should check that the host part is "" or "localhost"
 230         ;; or some name that represents the local host?
 231         (or (file-name-as-directory (url-filename url)) "/")
 232       ;; All other URLs are not expected to be directly accessible from
 233       ;; a local process.
 234       nil)))
 235
 236 (defun url-handler-file-name-directory (dir)
 237   (let ((url (url-generic-parse-url dir)))
 238     ;; Do not attempt to handle `file' URLs which are local.
 239     (if (and (not (equal (url-type url) "file"))
 240              (string-empty-p (url-filename url)))
 241         (url-handler-file-name-directory (concat dir "/"))
 242       (url-run-real-handler 'file-name-directory (list dir)))))
 243
 244 (defun url-handler-file-remote-p (filename &optional identification _connected)
 245   (let ((url (url-generic-parse-url filename)))
 246     (if (and (url-type url) (not (equal (url-type url) "file")))
 247         ;; Maybe we can find a suitable check for CONNECTED.  For now,
 248         ;; we ignore it.
 249         (cond
 250          ((eq identification 'method) (url-type url))
 251          ((eq identification 'user) (url-user url))
 252          ((eq identification 'host) (url-host url))
 253          ((eq identification 'localname) (url-filename url))
 254          (t (url-recreate-url
 255              (url-parse-make-urlobj (url-type url) (url-user url) nil
 256                                     (url-host url) (url-port url)))))
 257       ;; If there is no URL type, or it is a "file://" URL, the
 258       ;; filename is expected to be non remote.  A more subtle check
 259       ;; for "file://" URLs could be applied, as said in
 260       ;; `url-handler-unhandled-file-name-directory'.
 261       nil)))
 262
 263 ;; The actual implementation
 264 ;;;###autoload
 265 (defun url-copy-file (url newname &optional ok-if-already-exists
 266                           _keep-time _preserve-uid-gid)
 267   "Copy URL to NEWNAME.  Both args must be strings.
 268 Signals a `file-already-exists' error if file NEWNAME already exists,
 269 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
 270 A number as third arg means request confirmation if NEWNAME already exists.
 271 This is what happens in interactive use with M-x.
 272 Fourth arg KEEP-TIME non-nil means give the new file the same
 273 last-modified time as the old one.  (This works on only some systems.)
 274 Fifth arg PRESERVE-UID-GID is ignored.
 275 A prefix arg makes KEEP-TIME non-nil."
 276   (if (and (file-exists-p newname)
 277            (not ok-if-already-exists))
 278       (signal 'file-already-exists (list "File exists" newname)))
 279   (let ((buffer (url-retrieve-synchronously url))
 280         (handle nil))
 281     (if (not buffer)
 282         (signal 'file-missing (list "Opening URL" "No such file or directory"
 283                                     url)))
 284     (with-current-buffer buffer
 285       (setq handle (mm-dissect-buffer t)))
 286     (let ((mm-attachment-file-modes (default-file-modes)))
 287       (mm-save-part-to-file handle newname))
 288     (kill-buffer buffer)
 289     (mm-destroy-parts handle)))
 290 (put 'copy-file 'url-file-handlers 'url-copy-file)
 291
 292 ;;;###autoload
 293 (defun url-file-local-copy (url &rest ignored)
 294   "Copy URL into a temporary file on this machine.
 295 Returns the name of the local copy, or nil, if FILE is directly
 296 accessible."
 297   (let ((filename (make-temp-file "url")))
 298     (url-copy-file url filename 'ok-if-already-exists)
 299     filename))
 300 (put 'file-local-copy 'url-file-handlers 'url-file-local-copy)
 301
 302 (defun url-insert (buffer &optional beg end)
 303   "Insert the body of a URL object.
 304 BUFFER should be a complete URL buffer as returned by `url-retrieve'.
 305 If the headers specify a coding-system, it is applied to the body before it is inserted.
 306 Returns a list of the form (SIZE CHARSET), where SIZE is the size in bytes
 307 of the inserted text and CHARSET is the charset that was specified in the header,
 308 or nil if none was found.
 309 BEG and END can be used to only insert a subpart of the body.
 310 They count bytes from the beginning of the body."
 311   (let* ((handle (with-current-buffer buffer (mm-dissect-buffer t)))
 312          (data (with-current-buffer (mm-handle-buffer handle)
 313                  (if beg
 314                      (buffer-substring (+ (point-min) beg)
 315                                        (if end (+ (point-min) end) (point-max)))
 316                    (buffer-string))))
 317          (charset (mail-content-type-get (mm-handle-type handle)
 318                                           'charset)))
 319     (mm-destroy-parts handle)
 320     (if charset
 321         (insert (mm-decode-string data (mm-charset-to-coding-system charset)))
 322       (insert data))
 323     (list (length data) charset)))
 324
 325 (defvar url-http-codes)
 326
 327 ;;;###autoload
 328 (defun url-insert-buffer-contents (buffer url &optional visit beg end replace)
 329   "Insert the contents of BUFFER into current buffer.
 330 This is like `url-insert', but also decodes the current buffer as
 331 if it had been inserted from a file named URL."
 332   (if visit (setq buffer-file-name url))
 333   (save-excursion
 334     (let* ((start (point))
 335            (size-and-charset (url-insert buffer beg end)))
 336       (kill-buffer buffer)
 337       (when replace
 338         (delete-region (point-min) start)
 339         (delete-region (point) (point-max)))
 340       (unless (cadr size-and-charset)
 341         ;; If the headers don't specify any particular charset, use the
 342         ;; usual heuristic/rules that we apply to files.
 343         (decode-coding-inserted-region (point-min) (point) url
 344                                        visit beg end replace))
 345       (let ((inserted (car size-and-charset)))
 346         (when (fboundp 'after-insert-file-set-coding)
 347           (let ((insval (after-insert-file-set-coding inserted visit)))
 348             (if insval (setq inserted insval))))
 349         (list url inserted)))))
 350
 351 ;;;###autoload
 352 (defun url-insert-file-contents (url &optional visit beg end replace)
 353   (let ((buffer (url-retrieve-synchronously url)))
 354     (unless buffer (signal 'file-error (list url "No Data")))
 355     (with-current-buffer buffer
 356       ;; XXX: This is HTTP/S specific and should be moved to url-http
 357       ;; instead.  See https://debbugs.gnu.org/17549.
 358       (when (bound-and-true-p url-http-response-status)
 359         ;; Don't signal an error if VISIT is non-nil, because
 360         ;; 'insert-file-contents' doesn't.  This is required to
 361         ;; support, e.g., 'browse-url-emacs', which is a fancy way of
 362         ;; visiting the HTML source of a URL: in that case, we want to
 363         ;; display a file buffer even if the URL does not exist and
 364         ;; 'url-retrieve-synchronously' returns 404 or whatever.
 365         (unless (or visit
 366                     (and (>= url-http-response-status 200)
 367                          (< url-http-response-status 300)))
 368           (let ((desc (nth 2 (assq url-http-response-status url-http-codes))))
 369             (kill-buffer buffer)
 370             ;; Signal file-error per https://debbugs.gnu.org/16733.
 371             (signal 'file-error (list url desc))))))
 372     (url-insert-buffer-contents buffer url visit beg end replace)))
 373
 374 (put 'insert-file-contents 'url-file-handlers 'url-insert-file-contents)
 375
 376 (defun url-file-name-completion (url _directory &optional _predicate)
 377   ;; Even if it's not implemented, it's not an error to ask for completion,
 378   ;; in case it's available (bug#14806).
 379   ;; (error "Unimplemented")
 380   url)
 381 (put 'file-name-completion 'url-file-handlers 'url-file-name-completion)
 382
 383 (defun url-file-name-all-completions (_file _directory)
 384   ;; Even if it's not implemented, it's not an error to ask for completion,
 385   ;; in case it's available (bug#14806).
 386   ;; (error "Unimplemented")
 387   nil)
 388 (put 'file-name-all-completions
 389      'url-file-handlers 'url-file-name-all-completions)
 390
 391 ;; All other handlers map onto their respective backends.
 392 (defmacro url-handlers-create-wrapper (method args)
 393   `(progn
 394      (defun ,(intern (format "url-%s" method)) ,args
 395        ,(format "URL file-name-handler wrapper for `%s' call.\n---\n%s" method
 396                 (or (documentation method t) "No original documentation."))
 397        (setq url (url-generic-parse-url url))
 398        (when (url-type url)
 399          (funcall (url-scheme-get-property (url-type url) (quote ,method))
 400                   ,@(remove '&rest (remove '&optional args)))))
 401      (unless (get ',method 'url-file-handlers)
 402        (put ',method 'url-file-handlers ',(intern (format "url-%s" method))))))
 403
 404 (url-handlers-create-wrapper file-exists-p (url))
 405 (url-handlers-create-wrapper file-attributes (url &optional id-format))
 406 (url-handlers-create-wrapper file-symlink-p (url))
 407 (url-handlers-create-wrapper file-writable-p (url))
 408 (url-handlers-create-wrapper file-directory-p (url))
 409 (url-handlers-create-wrapper file-executable-p (url))
 410 (url-handlers-create-wrapper directory-files (url &optional full match nosort))
 411 (url-handlers-create-wrapper file-truename (url &optional counter prev-dirs))
 412
 413 (add-hook 'find-file-hook 'url-handlers-set-buffer-mode)
 414
 415 (defun url-handlers-set-buffer-mode ()
 416   "Set correct modes for the current buffer if visiting a remote file."
 417   (and (stringp buffer-file-name)
 418        (string-match url-handler-regexp buffer-file-name)
 419        (auto-save-mode 0)))
 420
 421 (provide 'url-handlers)
 422
 423 ;;; url-handlers.el ends here