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