Mercurial > hg > xemacs-beta

comparison lisp/w3/url-file.el @ 144:318232e2a3f0 r20-2b6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-2b6
author cvs
date Mon, 13 Aug 2007 09:34:14 +0200
parents cca96a509cfe
children 5a88923fcbfe
comparison
equal deleted inserted replaced
143:50e7fedfe353 144:318232e2a3f0
1 ;;; url-file.el --- File retrieval code 1 ;;; url-file.el --- File retrieval code
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/04/04 16:19:42 3 ;; Created: 1997/05/09 04:39:15
4 ;; Version: 1.16 4 ;; Version: 1.19
5 ;; Keywords: comm, data, processes 5 ;; Keywords: comm, data, processes
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu) 8 ;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. 9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
149 (equal (downcase host) (if (string-match (regexp-quote ".") 149 (equal (downcase host) (if (string-match (regexp-quote ".")
150 (system-name)) 150 (system-name))
151 (substring (system-name) 0 151 (substring (system-name) 0
152 (match-beginning 0)) 152 (match-beginning 0))
153 (system-name))))))) 153 (system-name)))))))
154 154
155 (defun url-file-build-continuation (name)
156 (list 'url-file-asynch-callback
157 name (current-buffer)
158 url-current-callback-func url-current-callback-data))
159
160 (defun url-file-asynch-callback (x y name buff func args &optional efs)
161 (if (featurep 'efs)
162 ;; EFS passes us an extra argument
163 (setq name buff
164 buff func
165 func args
166 args efs))
167 (cond
168 ((not name) nil)
169 ((not (file-exists-p name)) nil)
170 (t
171 (if (not buff)
172 (setq buff (generate-new-buffer " *url-asynch-file*")))
173 (set-buffer buff)
174 (insert-file-contents-literally name)
175 (condition-case ()
176 (delete-file name)
177 (error nil))))
178 (if func
179 (apply func args)
180 (url-sentinel (current-buffer) nil)))
181
155 (defun url-file (url) 182 (defun url-file (url)
156 ;; Find a file 183 ;; Find a file
157 (let* ((urlobj (url-generic-parse-url url)) 184 (let* ((urlobj (url-generic-parse-url url))
158 (user (url-user urlobj)) 185 (user (url-user urlobj))
159 (pass (url-password urlobj)) 186 (pass (url-password urlobj))
173 (efs-set-passwd site user pass)) 200 (efs-set-passwd site user pass))
174 (t 201 (t
175 nil))) 202 nil)))
176 (cond 203 (cond
177 ((file-directory-p filename) 204 ((file-directory-p filename)
178 (if (string-match "/$" filename) 205 (if (not (string-match "/$" filename))
179 nil 206 (setq filename (concat filename "/")))
180 (setq filename (concat filename "/"))) 207 (if (not (string-match "/$" file))
181 (if (string-match "/$" file) 208 (setq file (concat file "/")))
182 nil
183 (setq file (concat file "/")))
184 (url-set-filename urlobj file) 209 (url-set-filename urlobj file)
185 (url-format-directory filename)) 210 (url-format-directory filename))
186 ((and (boundp 'w3-dump-to-disk) (symbol-value 'w3-dump-to-disk)) 211 (url-be-asynchronous
187 (cond 212 (cond
188 ((file-exists-p filename) nil) 213 ((file-exists-p filename) nil)
189 ((file-exists-p (concat filename ".Z")) 214 ((file-exists-p (concat filename ".Z"))
190 (setq filename (concat filename ".Z"))) 215 (setq filename (concat filename ".Z")))
191 ((file-exists-p (concat filename ".gz")) 216 ((file-exists-p (concat filename ".gz"))
192 (setq filename (concat filename ".gz"))) 217 (setq filename (concat filename ".gz")))
193 ((file-exists-p (concat filename ".z")) 218 ((file-exists-p (concat filename ".z"))
194 (setq filename (concat filename ".z"))) 219 (setq filename (concat filename ".z")))
195 (t 220 (t nil))
196 (error "File not found %s" filename))) 221 (let ((new (mm-generate-unique-filename)))
197 (cond 222 (cond
198 ((url-host-is-local-p site) 223 ((url-host-is-local-p site)
199 (copy-file 224 (insert-file-contents-literally filename)
200 filename 225 (if (featurep 'efs)
201 (read-file-name "Save to: " nil (url-basepath filename t)) t)) 226 (url-file-asynch-callback nil nil nil nil nil
202 ((featurep 'ange-ftp) 227 url-current-callback-func
203 (ange-ftp-copy-file-internal 228 url-current-callback-data)
204 filename 229 (url-file-asynch-callback nil nil nil nil
205 (expand-file-name 230 url-current-callback-func
206 (read-file-name "Save to: " nil (url-basepath filename t))) t 231 url-current-callback-data)))
207 nil t nil t)) 232 ((featurep 'ange-ftp)
208 ((or (featurep 'efs) (featurep 'efs-auto)) 233 (ange-ftp-copy-file-internal filename (expand-file-name new) t
209 (let ((new (expand-file-name 234 nil t
210 (read-file-name "Save to: " nil 235 (url-file-build-continuation new)
211 (url-basepath filename t))))) 236 t))
237 ((or (featurep 'efs) (featurep 'efs-auto))
212 (efs-copy-file-internal filename (efs-ftp-path filename) 238 (efs-copy-file-internal filename (efs-ftp-path filename)
213 new (efs-ftp-path new) 239 new (efs-ftp-path new)
214 t nil 0 nil 0 nil))) 240 t nil 0
215 (t (copy-file 241 (url-file-build-continuation new)
216 filename 242 0 nil)))))
217 (read-file-name "Save to: " nil (url-basepath filename t)) t)))
218 (if (get-buffer url-working-buffer)
219 (kill-buffer url-working-buffer)))
220 (t 243 (t
221 (let ((viewer (mm-mime-info 244 (let ((viewer (mm-mime-info
222 (mm-extension-to-mime (url-file-extension file)))) 245 (mm-extension-to-mime (url-file-extension file))))
223 (errobj nil)) 246 (errobj nil))
224 (if (or url-source ; Need it in a buffer 247 (if (or url-source ; Need it in a buffer