Commit | Line | Data |
---|---|---|
8c8b8430 | 1 | ;;; url-handlers.el --- file-name-handler stuff for URL loading |
8c8b8430 SM |
2 | ;; Keywords: comm, data, processes, hypermedia |
3 | ||
4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
5 | ;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu> | |
6 | ;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc. | |
7 | ;;; | |
8 | ;;; This file is part of GNU Emacs. | |
9 | ;;; | |
10 | ;;; GNU Emacs is free software; you can redistribute it and/or modify | |
11 | ;;; it under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 2, or (at your option) | |
13 | ;;; any later version. | |
14 | ;;; | |
15 | ;;; GNU Emacs is distributed in the hope that it will be useful, | |
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
19 | ;;; | |
20 | ;;; You should have received a copy of the GNU General Public License | |
21 | ;;; along with GNU Emacs; see the file COPYING. If not, write to the | |
22 | ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
23 | ;;; Boston, MA 02111-1307, USA. | |
24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
25 | ||
26 | (require 'url) | |
27 | (require 'url-parse) | |
28 | (require 'url-util) | |
29 | (require 'mm-decode) | |
30 | (require 'mailcap) | |
31 | ||
32 | (eval-when-compile | |
33 | (require 'cl)) | |
34 | ||
35 | ;; Implementation status | |
36 | ;; --------------------- | |
37 | ;; Function Status | |
38 | ;; ------------------------------------------------------------ | |
39 | ;; add-name-to-file Needs DAV Bindings | |
40 | ;; copy-file Broken (assumes 1st item is URL) | |
41 | ;; delete-directory Finished (DAV) | |
42 | ;; delete-file Finished (DAV) | |
43 | ;; diff-latest-backup-file | |
44 | ;; directory-file-name unnecessary (what about VMS)? | |
45 | ;; directory-files Finished (DAV) | |
46 | ;; dired-call-process | |
47 | ;; dired-compress-file | |
48 | ;; dired-uncache | |
49 | ;; expand-file-name Finished | |
50 | ;; file-accessible-directory-p | |
51 | ;; file-attributes Finished, better with DAV | |
52 | ;; file-directory-p Needs DAV, finished | |
53 | ;; file-executable-p Finished | |
54 | ;; file-exists-p Finished | |
55 | ;; file-local-copy | |
56 | ;; file-modes | |
57 | ;; file-name-all-completions Finished (DAV) | |
58 | ;; file-name-as-directory | |
59 | ;; file-name-completion Finished (DAV) | |
60 | ;; file-name-directory | |
61 | ;; file-name-nondirectory | |
62 | ;; file-name-sans-versions why? | |
63 | ;; file-newer-than-file-p | |
64 | ;; file-ownership-preserved-p No way to know | |
65 | ;; file-readable-p Finished | |
66 | ;; file-regular-p !directory_p | |
67 | ;; file-symlink-p Needs DAV bindings | |
68 | ;; file-truename Needs DAV bindings | |
69 | ;; file-writable-p Check for LOCK? | |
70 | ;; find-backup-file-name why? | |
71 | ;; get-file-buffer why? | |
72 | ;; insert-directory Use DAV | |
73 | ;; insert-file-contents Finished | |
74 | ;; load | |
75 | ;; make-directory Finished (DAV) | |
76 | ;; make-symbolic-link Needs DAV bindings | |
77 | ;; rename-file Finished (DAV) | |
78 | ;; set-file-modes Use mod_dav specific executable flag? | |
79 | ;; set-visited-file-modtime Impossible? | |
80 | ;; shell-command Impossible? | |
81 | ;; unhandled-file-name-directory | |
82 | ;; vc-registered Finished (DAV) | |
83 | ;; verify-visited-file-modtime | |
84 | ;; write-region | |
85 | ||
86 | (defvar url-handler-regexp | |
87 | "\\`\\(https?\\|ftp\\|file\\|nfs\\)://" | |
88 | "*A regular expression for matching URLs handled by file-name-handler-alist. | |
89 | Some valid URL protocols just do not make sense to visit interactively | |
90 | \(about, data, info, irc, mailto, etc\). This regular expression | |
91 | avoids conflicts with local files that look like URLs \(Gnus is | |
92 | particularly bad at this\).") | |
93 | ||
94 | ;;;###autoload | |
95 | (defun url-setup-file-name-handlers () | |
96 | "Setup file-name handlers." | |
97 | (cond | |
98 | ((not (boundp 'file-name-handler-alist)) | |
99 | nil) ; Don't load if no alist | |
100 | ((rassq 'url-file-handler file-name-handler-alist) | |
101 | nil) ; Don't load twice | |
102 | (t | |
103 | (push (cons url-handler-regexp 'url-file-handler) | |
104 | file-name-handler-alist)))) | |
105 | ||
106 | (defun url-run-real-handler (operation args) | |
107 | (let ((inhibit-file-name-handlers (cons 'url-file-handler | |
108 | (if (eq operation inhibit-file-name-operation) | |
109 | inhibit-file-name-handlers))) | |
110 | (inhibit-file-name-operation operation)) | |
111 | (apply operation args))) | |
112 | ||
113 | (defun url-file-handler (operation &rest args) | |
114 | "Function called from the `file-name-handler-alist' routines. | |
115 | OPERATION is what needs to be done (`file-exists-p', etc). ARGS are | |
116 | the arguments that would have been passed to OPERATION." | |
117 | (let ((fn (or (get operation 'url-file-handlers) | |
118 | (intern-soft (format "url-%s" operation)))) | |
119 | (val nil) | |
120 | (hooked nil)) | |
121 | (if (and fn (fboundp fn)) | |
122 | (setq hooked t | |
123 | val (apply fn args)) | |
124 | (setq hooked nil | |
125 | val (url-run-real-handler operation args))) | |
126 | (url-debug 'handlers "%s %S%S => %S" (if hooked "Hooked" "Real") | |
127 | operation args val) | |
128 | val)) | |
129 | ||
130 | (defun url-file-handler-identity (&rest args) | |
131 | ;; Identity function | |
132 | (car args)) | |
133 | ||
134 | ;; These are operations that we can fully support | |
135 | (put 'file-readable-p 'url-file-handlers 'url-file-exists-p) | |
136 | (put 'substitute-in-file-name 'url-file-handlers 'url-file-handler-identity) | |
137 | (put 'file-name-absolute-p 'url-file-handlers (lambda (&rest ignored) t)) | |
138 | (put 'expand-file-name 'url-file-handlers 'url-handler-expand-file-name) | |
139 | ||
140 | ;; These are operations that we do not support yet (DAV!!!) | |
141 | (put 'file-writable-p 'url-file-handlers 'ignore) | |
142 | (put 'file-symlink-p 'url-file-handlers 'ignore) | |
143 | ||
144 | (defun url-handler-expand-file-name (file &optional base) | |
145 | (if (file-name-absolute-p file) | |
146 | (expand-file-name file "/") | |
147 | (url-expand-file-name file base))) | |
148 | ||
149 | ;; The actual implementation | |
150 | ;;;###autoload | |
151 | (defun url-copy-file (url newname &optional ok-if-already-exists keep-time) | |
152 | "Copy URL to NEWNAME. Both args must be strings. | |
153 | Signals a `file-already-exists' error if file NEWNAME already exists, | |
154 | unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil. | |
155 | A number as third arg means request confirmation if NEWNAME already exists. | |
156 | This is what happens in interactive use with M-x. | |
157 | Fourth arg KEEP-TIME non-nil means give the new file the same | |
158 | last-modified time as the old one. (This works on only some systems.) | |
159 | A prefix arg makes KEEP-TIME non-nil." | |
160 | (if (and (file-exists-p newname) | |
161 | (not ok-if-already-exists)) | |
162 | (error "Opening output file: File already exists, %s" newname)) | |
163 | (let ((buffer (url-retrieve-synchronously url)) | |
164 | (handle nil)) | |
165 | (if (not buffer) | |
166 | (error "Opening input file: No such file or directory, %s" url)) | |
167 | (save-excursion | |
168 | (set-buffer buffer) | |
169 | (setq handle (mm-dissect-buffer t))) | |
170 | (mm-save-part-to-file handle newname) | |
171 | (kill-buffer buffer) | |
172 | (mm-destroy-parts handle))) | |
173 | ||
174 | ;;;###autoload | |
175 | (defun url-file-local-copy (url &rest ignored) | |
176 | "Copy URL into a temporary file on this machine. | |
177 | Returns the name of the local copy, or nil, if FILE is directly | |
178 | accessible." | |
179 | (let ((filename (make-temp-name "url"))) | |
180 | (url-copy-file url filename) | |
181 | filename)) | |
182 | ||
183 | ;;;###autoload | |
184 | (defun url-insert-file-contents (url &optional visit beg end replace) | |
185 | (let ((buffer (url-retrieve-synchronously url)) | |
186 | (handle nil) | |
187 | (data nil)) | |
188 | (if (not buffer) | |
189 | (error "Opening input file: No such file or directory, %s" url)) | |
190 | (if visit (setq buffer-file-name url)) | |
191 | (save-excursion | |
192 | (set-buffer buffer) | |
193 | (setq handle (mm-dissect-buffer t)) | |
194 | (set-buffer (mm-handle-buffer handle)) | |
195 | (if beg | |
196 | (setq data (buffer-substring beg end)) | |
197 | (setq data (buffer-string)))) | |
198 | (kill-buffer buffer) | |
199 | (mm-destroy-parts handle) | |
200 | (if replace (delete-region (point-min) (point-max))) | |
201 | (save-excursion | |
202 | (insert data)) | |
203 | (list url (length data)))) | |
204 | ||
205 | (defun url-file-name-completion (url directory) | |
206 | (error "Unimplemented")) | |
207 | ||
208 | (defun url-file-name-all-completions (file directory) | |
209 | (error "Unimplemented")) | |
210 | ||
211 | ;; All other handlers map onto their respective backends. | |
212 | (defmacro url-handlers-create-wrapper (method args) | |
213 | `(defun ,(intern (format "url-%s" method)) ,args | |
214 | ,(format "URL file-name-handler wrapper for `%s' call.\n---\n%s" method | |
215 | (or (documentation method t) "No original documentation.")) | |
216 | (setq url (url-generic-parse-url url)) | |
217 | (when (url-type url) | |
218 | (funcall (url-scheme-get-property (url-type url) (quote ,method)) | |
219 | ,@(remove '&rest (remove '&optional args)))))) | |
220 | ||
221 | (url-handlers-create-wrapper file-exists-p (url)) | |
222 | (url-handlers-create-wrapper file-attributes (url)) | |
223 | (url-handlers-create-wrapper file-symlink-p (url)) | |
224 | (url-handlers-create-wrapper file-writable-p (url)) | |
225 | (url-handlers-create-wrapper file-directory-p (url)) | |
226 | (url-handlers-create-wrapper file-executable-p (url)) | |
227 | ||
228 | (if (featurep 'xemacs) | |
229 | (progn | |
230 | ;; XEmacs specific prototypes | |
231 | (url-handlers-create-wrapper | |
232 | directory-files (url &optional full match nosort files-only)) | |
233 | (url-handlers-create-wrapper | |
234 | file-truename (url &optional default))) | |
235 | ;; Emacs specific prototypes | |
236 | (url-handlers-create-wrapper | |
237 | directory-files (url &optional full match nosort)) | |
238 | (url-handlers-create-wrapper | |
239 | file-truename (url &optional counter prev-dirs))) | |
240 | ||
241 | (add-hook 'find-file-hooks 'url-handlers-set-buffer-mode) | |
242 | ||
243 | (defun url-handlers-set-buffer-mode () | |
244 | "Set correct modes for the current buffer if visiting a remote file." | |
245 | (and (stringp buffer-file-name) | |
246 | (string-match url-handler-regexp buffer-file-name) | |
247 | (auto-save-mode 0))) | |
248 | ||
249 | (provide 'url-handlers) | |
e5566bd5 MB |
250 | |
251 | ;;; arch-tag: 7300b99c-cc83-42ff-9147-79b2723c62ac |