Commit | Line | Data |
---|---|---|
8c8b8430 | 1 | ;;; url-handlers.el --- file-name-handler stuff for URL loading |
f1300fba | 2 | |
ba318903 | 3 | ;; Copyright (C) 1996-1999, 2004-2014 Free Software Foundation, Inc. |
f1300fba | 4 | |
8c8b8430 SM |
5 | ;; Keywords: comm, data, processes, hypermedia |
6 | ||
f1300fba SM |
7 | ;; This file is part of GNU Emacs. |
8 | ;; | |
4936186e | 9 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
f1300fba | 10 | ;; it under the terms of the GNU General Public License as published by |
4936186e GM |
11 | ;; the Free Software Foundation, either version 3 of the License, or |
12 | ;; (at your option) any later version. | |
13 | ||
f1300fba SM |
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. | |
4936186e | 18 | |
f1300fba | 19 | ;; You should have received a copy of the GNU General Public License |
4936186e | 20 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
f1300fba SM |
21 | |
22 | ;;; Commentary: | |
23 | ||
24 | ;;; Code: | |
8c8b8430 | 25 | |
5007cdc9 | 26 | ;; (require 'url) |
29c7eba8 | 27 | (require 'url-parse) |
5007cdc9 SM |
28 | ;; (require 'url-util) |
29 | (eval-when-compile (require 'mm-decode)) | |
30 | ;; (require 'mailcap) | |
5007cdc9 SM |
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. | |
5007cdc9 SM |
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.") | |
8c8b8430 | 36 | |
af742248 GM |
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 | ||
8c8b8430 SM |
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 | |
a9f31e3d | 77 | ;; file-remote-p Finished |
8c8b8430 SM |
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 | ||
22c4001c JB |
97 | (defvar url-handler-regexp) ; defined below to avoid recursive load (revno:108572) |
98 | ||
f1a4e679 | 99 | ;;;###autoload |
47fc1d6b CY |
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 | ||
8def2875 | 114 | (defcustom url-handler-regexp "\\`\\(https?\\|ftp\\|file\\|nfs\\|ssh\\|scp\\|rsync\\|telnet\\)://" |
f1a4e679 CY |
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 | |
8def2875 | 125 | :version "24.5" |
f1a4e679 CY |
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))))) | |
8c8b8430 | 132 | |
8c8b8430 SM |
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 | ||
0f09bbfa MA |
140 | (defvar url-file-handler-load-in-progress nil |
141 | "Check for recursive load.") | |
142 | ||
80e4b01d | 143 | ;;;###autoload |
8c8b8430 SM |
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." | |
0f09bbfa MA |
148 | ;; Avoid recursive load. |
149 | (if (and load-in-progress url-file-handler-load-in-progress) | |
150 | (url-run-real-handler operation args) | |
bbbabffe GM |
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))))) | |
8c8b8430 SM |
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) | |
bdba217b | 185 | (put 'directory-file-name 'url-file-handlers 'url-handler-directory-file-name) |
ce4059ee | 186 | (put 'unhandled-file-name-directory 'url-file-handlers 'url-handler-unhandled-file-name-directory) |
a9f31e3d | 187 | (put 'file-remote-p 'url-file-handlers 'url-handler-file-remote-p) |
bdba217b | 188 | ;; (put 'file-name-as-directory 'url-file-handlers 'url-handler-file-name-as-directory) |
8c8b8430 SM |
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) | |
f1b58706 SM |
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) | |
8c8b8430 SM |
196 | |
197 | (defun url-handler-expand-file-name (file &optional base) | |
bdba217b SM |
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. | |
8c8b8430 SM |
203 | (if (file-name-absolute-p file) |
204 | (expand-file-name file "/") | |
205 | (url-expand-file-name file base))) | |
206 | ||
bdba217b SM |
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 | ||
ce4059ee | 219 | (defun url-handler-unhandled-file-name-directory (filename) |
791fe182 SM |
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))) | |
ce4059ee | 230 | |
a9f31e3d MA |
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 | ||
8c8b8430 SM |
250 | ;; The actual implementation |
251 | ;;;###autoload | |
120812a0 CY |
252 | (defun url-copy-file (url newname &optional ok-if-already-exists |
253 | keep-time preserve-uid-gid) | |
8c8b8430 SM |
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.) | |
120812a0 | 261 | Fifth arg PRESERVE-UID-GID is ignored. |
8c8b8430 SM |
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)) | |
d4fdad60 | 270 | (with-current-buffer buffer |
8c8b8430 SM |
271 | (setq handle (mm-dissect-buffer t))) |
272 | (mm-save-part-to-file handle newname) | |
273 | (kill-buffer buffer) | |
274 | (mm-destroy-parts handle))) | |
23855148 | 275 | (put 'copy-file 'url-file-handlers 'url-copy-file) |
8c8b8430 SM |
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." | |
bdba217b | 282 | (let ((filename (make-temp-file "url"))) |
d0f891a7 | 283 | (url-copy-file url filename 'ok-if-already-exists) |
8c8b8430 | 284 | filename)) |
23855148 | 285 | (put 'file-local-copy 'url-file-handlers 'url-file-local-copy) |
8c8b8430 | 286 | |
89a1fe77 SM |
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 | ||
cb6ce5ee | 310 | (defvar url-http-codes) |
1d8bea62 | 311 | |
8c8b8430 SM |
312 | ;;;###autoload |
313 | (defun url-insert-file-contents (url &optional visit beg end replace) | |
89a1fe77 | 314 | (let ((buffer (url-retrieve-synchronously url))) |
196716cf JB |
315 | (unless buffer (signal 'file-error (list url "No Data"))) |
316 | (with-current-buffer buffer | |
1d8bea62 LL |
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)))) | |
196716cf | 323 | (kill-buffer buffer) |
1d8bea62 | 324 | ;; Signal file-error per http://debbugs.gnu.org/16733. |
196716cf | 325 | (signal 'file-error (list url desc)))))) |
8c8b8430 | 326 | (if visit (setq buffer-file-name url)) |
8c8b8430 | 327 | (save-excursion |
89a1fe77 SM |
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)))))) | |
1d8bea62 | 339 | |
23855148 | 340 | (put 'insert-file-contents 'url-file-handlers 'url-insert-file-contents) |
8c8b8430 | 341 | |
a118b59b | 342 | (defun url-file-name-completion (url directory &optional predicate) |
42d43952 SM |
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) | |
23855148 | 347 | (put 'file-name-completion 'url-file-handlers 'url-file-name-completion) |
8c8b8430 SM |
348 | |
349 | (defun url-file-name-all-completions (file directory) | |
42d43952 SM |
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) | |
23855148 SM |
354 | (put 'file-name-all-completions |
355 | 'url-file-handlers 'url-file-name-all-completions) | |
8c8b8430 SM |
356 | |
357 | ;; All other handlers map onto their respective backends. | |
358 | (defmacro url-handlers-create-wrapper (method args) | |
23855148 SM |
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)))))) | |
8c8b8430 SM |
369 | |
370 | (url-handlers-create-wrapper file-exists-p (url)) | |
c7389b5d | 371 | (url-handlers-create-wrapper file-attributes (url &optional id-format)) |
8c8b8430 SM |
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)) | |
cc38a294 EZ |
376 | (url-handlers-create-wrapper directory-files (url &optional full match nosort)) |
377 | (url-handlers-create-wrapper file-truename (url &optional counter prev-dirs)) | |
8c8b8430 | 378 | |
c7389b5d | 379 | (add-hook 'find-file-hook 'url-handlers-set-buffer-mode) |
8c8b8430 SM |
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) | |
e5566bd5 | 388 | |
f1300fba | 389 | ;;; url-handlers.el ends here |