Mercurial > hg > xemacs-beta

comparison lisp/url/url-file.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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 (if (equal '(0 0) mod-time) ; Set to null if unknown or
122 (setq mod-time "Unknown ")
123 (setq mod-time (current-time-string mod-time)))
124 (if (or (equal size 0) (equal size -1) (null size))
125 (setq size " -")
126 (setq size
127 (cond
128 ((< size 1024) (concat " " "1K"))
129 ((< size 1048576) (concat " "
130 (int-to-string
131 (max 1 (/ size 1024))) "K"))
132 (t
133 (let* ((megs (max 1 (/ size 1048576)))
134 (kilo (/ (- size (* megs 1048576)) 1024)))
135 (concat " " (int-to-string megs)
136 (if (> kilo 0)
137 (concat "." (int-to-string kilo))
138 "") "M"))))))
139 (cond
140 ((or (equal "." (car files))
141 (equal "/.." (car files)))
142 nil)
143 ((equal ".." (car files))
144 (if (not (= ?/ (aref file (1- (length file)))))
145 (setq file (concat file "/")))
146 (insert (if url-forms-based-ftp " " "")
147 "[DIR] <a href=\"" file "\">Parent directory</a>\n"))
148 ((stringp (nth 0 attr)) ; Symbolic link handling
149 (insert (if url-forms-based-ftp " " "")
150 "[LNK] <a href=\"./" file "\">" (car files) "</a>"
151 (make-string (max 0 (- 25 (length (car files)))) ? )
152 mod-time size "\n"))
153 ((nth 0 attr) ; Directory handling
154 (insert (if url-forms-based-ftp " " "")
155 "[DIR] <a href=\"./" file "/\">" (car files) "</a>"
156 (make-string (max 0 (- 25 (length (car files)))) ? )
157 mod-time size "\n"))
158 ((string-match "image" typ)
159 (insert (if url-forms-based-ftp
160 (concat "<input type=checkbox name=file value=\""
161 (car files) "\">")
162 "")
163 "[IMG] <a href=\"./" file "\">" (car files) "</a>"
164 (make-string (max 0 (- 25 (length (car files)))) ? )
165 mod-time size "\n"))
166 ((string-match "application" typ)
167 (insert (if url-forms-based-ftp
168 (concat "<input type=checkbox name=file value=\""
169 (car files) "\">")
170 "")
171 "[APP] <a href=\"./" file "\">" (car files) "</a>"
172 (make-string (max 0 (- 25 (length (car files)))) ? )
173 mod-time size "\n"))
174 ((string-match "text" typ)
175 (insert (if url-forms-based-ftp
176 (concat "<input type=checkbox name=file value=\""
177 (car files) "\">")
178 "")
179 "[TXT] <a href=\"./" file "\">" (car files) "</a>"
180 (make-string (max 0 (- 25 (length (car files)))) ? )
181 mod-time size "\n"))
182 (t
183 (insert (if url-forms-based-ftp
184 (concat "<input type=checkbox name=file value=\""
185 (car files) "\">")
186 "")
187 "[UNK] <a href=\"./" file "\">" (car files) "</a>"
188 (make-string (max 0 (- 25 (length (car files)))) ? )
189 mod-time size "\n")))
190 (setq files (cdr files)))
191 (insert " </pre>\n"
192 (if url-forms-based-ftp
193 (concat " <input type=submit value=\"Copy files\">\n"
194 " </form>\n")
195 "")
196 " </div>\n"
197 " </body>\n"
198 "</html>\n"
199 "<!-- Automatically generated by URL v" url-version
200 " -->\n")))))
201
202 (defun url-host-is-local-p (host)
203 "Return t iff HOST references our local machine."
204 (let ((case-fold-search t))
205 (or
206 (null host)
207 (string= "" host)
208 (equal (downcase host) (downcase (system-name)))
209 (and (string-match "^localhost$" host) t)
210 (and (not (string-match (regexp-quote ".") host))
211 (equal (downcase host) (if (string-match (regexp-quote ".")
212 (system-name))
213 (substring (system-name) 0
214 (match-beginning 0))
215 (system-name)))))))
216
217 (defun url-file (url)
218 ;; Find a file
219 (let* ((urlobj (url-generic-parse-url url))
220 (user (url-user urlobj))
221 (site (url-host urlobj))
222 (file (url-unhex-string (url-filename urlobj)))
223 (dest (url-target urlobj))
224 (filename (if (or user (not (url-host-is-local-p site)))
225 (concat "/" (or user "anonymous") "@" site ":" file)
226 file)))
227
228 (if (and file (url-host-is-local-p site)
229 (memq system-type '(ms-windows ms-dos windows-nt os2)))
230 (let ((x (1- (length file)))
231 (y 0))
232 (while (<= y x)
233 (if (= (aref file y) ?\\ )
234 (aset file y ?/))
235 (setq y (1+ y)))))
236
237 (url-clear-tmp-buffer)
238 (cond
239 ((file-directory-p filename)
240 (if url-use-hypertext-dired
241 (progn
242 (if (string-match "/$" filename)
243 nil
244 (setq filename (concat filename "/")))
245 (if (string-match "/$" file)
246 nil
247 (setq file (concat file "/")))
248 (url-set-filename urlobj file)
249 (url-format-directory filename))
250 (progn
251 (if (get-buffer url-working-buffer)
252 (kill-buffer url-working-buffer))
253 (find-file filename))))
254 ((and (boundp 'w3-dump-to-disk) (symbol-value 'w3-dump-to-disk))
255 (cond
256 ((file-exists-p filename) nil)
257 ((file-exists-p (concat filename ".Z"))
258 (setq filename (concat filename ".Z")))
259 ((file-exists-p (concat filename ".gz"))
260 (setq filename (concat filename ".gz")))
261 ((file-exists-p (concat filename ".z"))
262 (setq filename (concat filename ".z")))
263 (t
264 (error "File not found %s" filename)))
265 (cond
266 ((url-host-is-local-p site)
267 (copy-file
268 filename
269 (read-file-name "Save to: " nil (url-basepath filename t)) t))
270 ((featurep 'ange-ftp)
271 (ange-ftp-copy-file-internal
272 filename
273 (expand-file-name
274 (read-file-name "Save to: " nil (url-basepath filename t))) t
275 nil t nil t))
276 ((or (featurep 'efs) (featurep 'efs-auto))
277 (let ((new (expand-file-name
278 (read-file-name "Save to: " nil
279 (url-basepath filename t)))))
280 (efs-copy-file-internal filename (efs-ftp-path filename)
281 new (efs-ftp-path new)
282 t nil 0 nil 0 nil)))
283 (t (copy-file
284 filename
285 (read-file-name "Save to: " nil (url-basepath filename t)) t)))
286 (if (get-buffer url-working-buffer)
287 (kill-buffer url-working-buffer)))
288 (t
289 (let ((viewer (mm-mime-info
290 (mm-extension-to-mime (url-file-extension file))))
291 (errobj nil))
292 (if (or url-source ; Need it in a buffer
293 (and (symbolp viewer)
294 (not (eq viewer 'w3-default-local-file)))
295 (stringp viewer))
296 (condition-case errobj
297 (url-insert-possibly-compressed-file filename t)
298 (error
299 (url-save-error errobj)
300 (url-retrieve (concat "www://error/nofile/" file))))))))
301 (setq url-current-type (if site "ftp" "file")
302 url-current-object urlobj
303 url-find-this-link dest
304 url-current-user user
305 url-current-server site
306 url-current-mime-type (mm-extension-to-mime
307 (url-file-extension file))
308 url-current-file file)))
309
310 (fset 'url-ftp 'url-file)
311
312 (provide 'url-file)