Mercurial > hg > xemacs-beta

comparison lisp/w3/url-file.el @ 14:9ee227acff29 r19-15b90

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