|
70
|
1 ;;; url-file.el,v --- File retrieval code
|
|
|
2 ;; Author: wmperry
|
|
|
3 ;; Created: 1996/05/28 02:46:51
|
|
|
4 ;; Version: 1.12
|
|
|
5 ;; Keywords: comm, data, processes
|
|
|
6
|
|
|
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
8 ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
|
|
|
9 ;;;
|
|
|
10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
|
|
|
11 ;;;
|
|
|
12 ;;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
13 ;;; it under the terms of the GNU General Public License as published by
|
|
|
14 ;;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
15 ;;; any later version.
|
|
|
16 ;;;
|
|
|
17 ;;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
20 ;;; GNU General Public License for more details.
|
|
|
21 ;;;
|
|
|
22 ;;; You should have received a copy of the GNU General Public License
|
|
|
23 ;;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
|
24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
26
|
|
|
27 (require 'url-vars)
|
|
|
28 (require 'url-parse)
|
|
|
29
|
|
|
30 (defun url-insert-possibly-compressed-file (fname &rest args)
|
|
|
31 ;; Insert a file into a buffer, checking for compressed versions.
|
|
|
32 (let ((compressed nil)
|
|
|
33 ;;
|
|
|
34 ;; F*** *U** **C* ***K!!!
|
|
|
35 ;; We cannot just use insert-file-contents-literally here, because
|
|
|
36 ;; then we would lose big time with ange-ftp. *sigh*
|
|
|
37 (crypt-encoding-alist nil)
|
|
|
38 (jka-compr-compression-info-list nil)
|
|
|
39 (jam-zcat-filename-list nil)
|
|
|
40 (file-coding-system-for-read
|
|
|
41 (if (featurep 'mule)
|
|
|
42 *noconv*)))
|
|
|
43 (setq compressed
|
|
|
44 (cond
|
|
|
45 ((file-exists-p fname) nil)
|
|
|
46 ((file-exists-p (concat fname ".Z"))
|
|
|
47 (setq fname (concat fname ".Z")))
|
|
|
48 ((file-exists-p (concat fname ".gz"))
|
|
|
49 (setq fname (concat fname ".gz")))
|
|
|
50 ((file-exists-p (concat fname ".z"))
|
|
|
51 (setq fname (concat fname ".z")))
|
|
|
52 (t
|
|
|
53 (error "File not found %s" fname))))
|
|
|
54 (if (or (not compressed) url-inhibit-uncompression)
|
|
|
55 (apply 'insert-file-contents fname args)
|
|
|
56 (let* ((extn (url-file-extension fname))
|
|
|
57 (code (cdr-safe (assoc extn url-uncompressor-alist)))
|
|
|
58 (decoder (cdr-safe (assoc code mm-content-transfer-encodings))))
|
|
|
59 (cond
|
|
|
60 ((null decoder)
|
|
|
61 (apply 'insert-file-contents fname args))
|
|
|
62 ((stringp decoder)
|
|
|
63 (apply 'insert-file-contents fname args)
|
|
|
64 (message "Decoding...")
|
|
|
65 (call-process-region (point-min) (point-max) decoder t t nil)
|
|
|
66 (message "Decoding... done."))
|
|
|
67 ((listp decoder)
|
|
|
68 (apply 'call-process-region (point-min) (point-max)
|
|
|
69 (car decoder) t t t (cdr decoder)))
|
|
|
70 ((and (symbolp decoder) (fboundp decoder))
|
|
|
71 (apply 'insert-file-contents fname args)
|
|
|
72 (message "Decoding...")
|
|
|
73 (funcall decoder (point-min) (point-max))
|
|
|
74 (message "Decoding... done."))
|
|
|
75 (t
|
|
|
76 (error "Malformed entry for %s in `mm-content-transfer-encodings'"
|
|
|
77 code))))))
|
|
|
78 (set-buffer-modified-p nil))
|
|
|
79
|
|
|
80 (defun url-format-directory (dir)
|
|
|
81 ;; Format the files in DIR into hypertext
|
|
|
82 (let ((files (directory-files dir nil)) file
|
|
|
83 div attr mod-time size typ title)
|
|
|
84 (if (and url-directory-index-file
|
|
|
85 (file-exists-p (expand-file-name url-directory-index-file dir))
|
|
|
86 (file-readable-p (expand-file-name url-directory-index-file dir)))
|
|
|
87 (save-excursion
|
|
|
88 (set-buffer url-working-buffer)
|
|
|
89 (erase-buffer)
|
|
|
90 (insert-file-contents-literally
|
|
|
91 (expand-file-name url-directory-index-file dir)))
|
|
|
92 (save-excursion
|
|
|
93 (if (string-match "/\\([^/]+\\)/$" dir)
|
|
|
94 (setq title (concat ".../" (url-match dir 1) "/"))
|
|
|
95 (setq title "/"))
|
|
|
96 (setq div (1- (length files)))
|
|
|
97 (set-buffer url-working-buffer)
|
|
|
98 (erase-buffer)
|
|
|
99 (insert "<html>\n"
|
|
|
100 " <head>\n"
|
|
|
101 " <title>" title "</title>\n"
|
|
|
102 " </head>\n"
|
|
|
103 " <body>\n"
|
|
|
104 " <div>\n"
|
|
|
105 " <h1 align=center> Index of " title "</h1>\n"
|
|
|
106 (if url-forms-based-ftp
|
|
|
107 " <form method=mget enctype=application/batch-fetch>\n"
|
|
|
108 "")
|
|
|
109 " <pre>\n"
|
|
|
110 " Name Last modified Size\n</pre>"
|
|
|
111 "<hr>\n <pre>\n")
|
|
|
112 (while files
|
|
|
113 (url-lazy-message "Building directory list... (%d%%)"
|
|
|
114 (/ (* 100 (- div (length files))) div))
|
|
|
115 (setq file (expand-file-name (car files) dir)
|
|
|
116 attr (file-attributes file)
|
|
|
117 file (car files)
|
|
|
118 mod-time (nth 5 attr)
|
|
|
119 size (nth 7 attr)
|
|
|
120 typ (or (mm-extension-to-mime (url-file-extension file)) ""))
|
|
|
121 (setq file (url-hexify-string file))
|
|
|
122 (if (equal '(0 0) mod-time) ; Set to null if unknown or
|
|
|
123 (setq mod-time "Unknown ")
|
|
|
124 (setq mod-time (current-time-string mod-time)))
|
|
|
125 (if (or (equal size 0) (equal size -1) (null size))
|
|
|
126 (setq size " -")
|
|
|
127 (setq size
|
|
|
128 (cond
|
|
|
129 ((< size 1024) (concat " " "1K"))
|
|
|
130 ((< size 1048576) (concat " "
|
|
|
131 (int-to-string
|
|
|
132 (max 1 (/ size 1024))) "K"))
|
|
|
133 (t
|
|
|
134 (let* ((megs (max 1 (/ size 1048576)))
|
|
|
135 (kilo (/ (- size (* megs 1048576)) 1024)))
|
|
|
136 (concat " " (int-to-string megs)
|
|
|
137 (if (> kilo 0)
|
|
|
138 (concat "." (int-to-string kilo))
|
|
|
139 "") "M"))))))
|
|
|
140 (cond
|
|
|
141 ((or (equal "." (car files))
|
|
|
142 (equal "/.." (car files)))
|
|
|
143 nil)
|
|
|
144 ((equal ".." (car files))
|
|
|
145 (if (not (= ?/ (aref file (1- (length file)))))
|
|
|
146 (setq file (concat file "/")))
|
|
|
147 (insert (if url-forms-based-ftp " " "")
|
|
|
148 "[DIR] <a href=\"" file "\">Parent directory</a>\n"))
|
|
|
149 ((stringp (nth 0 attr)) ; Symbolic link handling
|
|
|
150 (insert (if url-forms-based-ftp " " "")
|
|
|
151 "[LNK] <a href=\"./" file "\">" (car files) "</a>"
|
|
|
152 (make-string (max 0 (- 25 (length (car files)))) ? )
|
|
|
153 mod-time size "\n"))
|
|
|
154 ((nth 0 attr) ; Directory handling
|
|
|
155 (insert (if url-forms-based-ftp " " "")
|
|
|
156 "[DIR] <a href=\"./" file "/\">" (car files) "</a>"
|
|
|
157 (make-string (max 0 (- 25 (length (car files)))) ? )
|
|
|
158 mod-time size "\n"))
|
|
|
159 ((string-match "image" typ)
|
|
|
160 (insert (if url-forms-based-ftp
|
|
|
161 (concat "<input type=checkbox name=file value=\""
|
|
|
162 (car files) "\">")
|
|
|
163 "")
|
|
|
164 "[IMG] <a href=\"./" file "\">" (car files) "</a>"
|
|
|
165 (make-string (max 0 (- 25 (length (car files)))) ? )
|
|
|
166 mod-time size "\n"))
|
|
|
167 ((string-match "application" typ)
|
|
|
168 (insert (if url-forms-based-ftp
|
|
|
169 (concat "<input type=checkbox name=file value=\""
|
|
|
170 (car files) "\">")
|
|
|
171 "")
|
|
|
172 "[APP] <a href=\"./" file "\">" (car files) "</a>"
|
|
|
173 (make-string (max 0 (- 25 (length (car files)))) ? )
|
|
|
174 mod-time size "\n"))
|
|
|
175 ((string-match "text" typ)
|
|
|
176 (insert (if url-forms-based-ftp
|
|
|
177 (concat "<input type=checkbox name=file value=\""
|
|
|
178 (car files) "\">")
|
|
|
179 "")
|
|
|
180 "[TXT] <a href=\"./" file "\">" (car files) "</a>"
|
|
|
181 (make-string (max 0 (- 25 (length (car files)))) ? )
|
|
|
182 mod-time size "\n"))
|
|
|
183 (t
|
|
|
184 (insert (if url-forms-based-ftp
|
|
|
185 (concat "<input type=checkbox name=file value=\""
|
|
|
186 (car files) "\">")
|
|
|
187 "")
|
|
|
188 "[UNK] <a href=\"./" file "\">" (car files) "</a>"
|
|
|
189 (make-string (max 0 (- 25 (length (car files)))) ? )
|
|
|
190 mod-time size "\n")))
|
|
|
191 (setq files (cdr files)))
|
|
|
192 (insert " </pre>\n"
|
|
|
193 (if url-forms-based-ftp
|
|
|
194 (concat " <input type=submit value=\"Copy files\">\n"
|
|
|
195 " </form>\n")
|
|
|
196 "")
|
|
|
197 " </div>\n"
|
|
|
198 " </body>\n"
|
|
|
199 "</html>\n"
|
|
|
200 "<!-- Automatically generated by URL v" url-version
|
|
|
201 " -->\n")))))
|
|
|
202
|
|
|
203 (defun url-host-is-local-p (host)
|
|
|
204 "Return t iff HOST references our local machine."
|
|
|
205 (let ((case-fold-search t))
|
|
|
206 (or
|
|
|
207 (null host)
|
|
|
208 (string= "" host)
|
|
|
209 (equal (downcase host) (downcase (system-name)))
|
|
|
210 (and (string-match "^localhost$" host) t)
|
|
|
211 (and (not (string-match (regexp-quote ".") host))
|
|
|
212 (equal (downcase host) (if (string-match (regexp-quote ".")
|
|
|
213 (system-name))
|
|
|
214 (substring (system-name) 0
|
|
|
215 (match-beginning 0))
|
|
|
216 (system-name)))))))
|
|
|
217
|
|
|
218 (defun url-file (url)
|
|
|
219 ;; Find a file
|
|
|
220 (let* ((urlobj (url-generic-parse-url url))
|
|
|
221 (user (url-user urlobj))
|
|
|
222 (site (url-host urlobj))
|
|
|
223 (file (url-unhex-string (url-filename urlobj)))
|
|
|
224 (dest (url-target urlobj))
|
|
|
225 (filename (if (or user (not (url-host-is-local-p site)))
|
|
|
226 (concat "/" (or user "anonymous") "@" site ":" file)
|
|
|
227 file)))
|
|
|
228
|
|
|
229 (if (and file (url-host-is-local-p site)
|
|
|
230 (memq system-type '(ms-windows ms-dos windows-nt os2)))
|
|
|
231 (let ((x (1- (length file)))
|
|
|
232 (y 0))
|
|
|
233 (while (<= y x)
|
|
|
234 (if (= (aref file y) ?\\ )
|
|
|
235 (aset file y ?/))
|
|
|
236 (setq y (1+ y)))))
|
|
|
237
|
|
|
238 (url-clear-tmp-buffer)
|
|
|
239 (cond
|
|
|
240 ((file-directory-p filename)
|
|
|
241 (if url-use-hypertext-dired
|
|
|
242 (progn
|
|
|
243 (if (string-match "/$" filename)
|
|
|
244 nil
|
|
|
245 (setq filename (concat filename "/")))
|
|
|
246 (if (string-match "/$" file)
|
|
|
247 nil
|
|
|
248 (setq file (concat file "/")))
|
|
|
249 (url-set-filename urlobj file)
|
|
|
250 (url-format-directory filename))
|
|
|
251 (progn
|
|
|
252 (if (get-buffer url-working-buffer)
|
|
|
253 (kill-buffer url-working-buffer))
|
|
|
254 (find-file filename))))
|
|
|
255 ((and (boundp 'w3-dump-to-disk) (symbol-value 'w3-dump-to-disk))
|
|
|
256 (cond
|
|
|
257 ((file-exists-p filename) nil)
|
|
|
258 ((file-exists-p (concat filename ".Z"))
|
|
|
259 (setq filename (concat filename ".Z")))
|
|
|
260 ((file-exists-p (concat filename ".gz"))
|
|
|
261 (setq filename (concat filename ".gz")))
|
|
|
262 ((file-exists-p (concat filename ".z"))
|
|
|
263 (setq filename (concat filename ".z")))
|
|
|
264 (t
|
|
|
265 (error "File not found %s" filename)))
|
|
|
266 (cond
|
|
|
267 ((url-host-is-local-p site)
|
|
|
268 (copy-file
|
|
|
269 filename
|
|
|
270 (read-file-name "Save to: " nil (url-basepath filename t)) t))
|
|
|
271 ((featurep 'ange-ftp)
|
|
|
272 (ange-ftp-copy-file-internal
|
|
|
273 filename
|
|
|
274 (expand-file-name
|
|
|
275 (read-file-name "Save to: " nil (url-basepath filename t))) t
|
|
|
276 nil t nil t))
|
|
|
277 ((or (featurep 'efs) (featurep 'efs-auto))
|
|
|
278 (let ((new (expand-file-name
|
|
|
279 (read-file-name "Save to: " nil
|
|
|
280 (url-basepath filename t)))))
|
|
|
281 (efs-copy-file-internal filename (efs-ftp-path filename)
|
|
|
282 new (efs-ftp-path new)
|
|
|
283 t nil 0 nil 0 nil)))
|
|
|
284 (t (copy-file
|
|
|
285 filename
|
|
|
286 (read-file-name "Save to: " nil (url-basepath filename t)) t)))
|
|
|
287 (if (get-buffer url-working-buffer)
|
|
|
288 (kill-buffer url-working-buffer)))
|
|
|
289 (t
|
|
|
290 (let ((viewer (mm-mime-info
|
|
|
291 (mm-extension-to-mime (url-file-extension file))))
|
|
|
292 (errobj nil))
|
|
|
293 (if (or url-source ; Need it in a buffer
|
|
|
294 (and (symbolp viewer)
|
|
|
295 (not (eq viewer 'w3-default-local-file)))
|
|
|
296 (stringp viewer))
|
|
|
297 (condition-case errobj
|
|
|
298 (url-insert-possibly-compressed-file filename t)
|
|
|
299 (error
|
|
|
300 (url-save-error errobj)
|
|
|
301 (url-retrieve (concat "www://error/nofile/" file))))))))
|
|
|
302 (setq url-current-type (if site "ftp" "file")
|
|
|
303 url-current-object urlobj
|
|
|
304 url-find-this-link dest
|
|
|
305 url-current-user user
|
|
|
306 url-current-server site
|
|
|
307 url-current-mime-type (mm-extension-to-mime
|
|
|
308 (url-file-extension file))
|
|
|
309 url-current-file file)))
|
|
|
310
|
|
|
311 (fset 'url-ftp 'url-file)
|
|
|
312
|
|
|
313 (provide 'url-file)
|
