|
14
|
1 ;;; url-file.el --- File retrieval code
|
|
|
2 ;; Author: wmperry
|
|
144
|
3 ;; Created: 1997/05/09 04:39:15
|
|
|
4 ;; Version: 1.19
|
|
14
|
5 ;; Keywords: comm, data, processes
|
|
|
6
|
|
|
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
8 ;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
|
|
82
|
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
|
|
14
|
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
|
|
98
|
47 ((file-exists-p fname)
|
|
|
48 (if (string-match "\\.\\(z\\|gz\\|Z\\)$" fname)
|
|
|
49 (case (intern (match-string 1 fname))
|
|
|
50 ((z gz)
|
|
|
51 (setq url-current-mime-headers (cons
|
|
|
52 (cons
|
|
|
53 "content-transfer-encoding"
|
|
|
54 "gzip")
|
|
|
55 url-current-mime-headers)))
|
|
|
56 (Z
|
|
|
57 (setq url-current-mime-headers (cons
|
|
|
58 (cons
|
|
|
59 "content-transfer-encoding"
|
|
|
60 "compress")
|
|
|
61 url-current-mime-headers))))
|
|
|
62 nil))
|
|
14
|
63 ((file-exists-p (concat fname ".Z"))
|
|
98
|
64 (setq fname (concat fname ".Z")
|
|
|
65 url-current-mime-headers (cons (cons
|
|
|
66 "content-transfer-encoding"
|
|
|
67 "compress")
|
|
|
68 url-current-mime-headers)))
|
|
14
|
69 ((file-exists-p (concat fname ".gz"))
|
|
98
|
70 (setq fname (concat fname ".gz")
|
|
|
71 url-current-mime-headers (cons (cons
|
|
|
72 "content-transfer-encoding"
|
|
|
73 "gzip")
|
|
|
74 url-current-mime-headers)))
|
|
14
|
75 ((file-exists-p (concat fname ".z"))
|
|
98
|
76 (setq fname (concat fname ".z")
|
|
|
77 url-current-mime-headers (cons (cons
|
|
|
78 "content-transfer-encoding"
|
|
|
79 "gzip")
|
|
|
80 url-current-mime-headers)))
|
|
14
|
81 (t
|
|
|
82 (error "File not found %s" fname))))
|
|
98
|
83 (apply 'insert-file-contents fname args)
|
|
|
84 (set-buffer-modified-p nil)))
|
|
|
85
|
|
|
86 (defvar url-dired-minor-mode-map
|
|
|
87 (let ((map (make-sparse-keymap)))
|
|
|
88 (define-key map "\C-m" 'url-dired-find-file)
|
|
|
89 (if url-running-xemacs
|
|
|
90 (define-key map [button2] 'url-dired-find-file-mouse)
|
|
|
91 (define-key map [mouse-2] 'url-dired-find-file-mouse))
|
|
|
92 map)
|
|
|
93 "Keymap used when browsing directories.")
|
|
|
94
|
|
|
95 (defvar url-dired-minor-mode nil
|
|
|
96 "Whether we are in url-dired-minor-mode")
|
|
|
97
|
|
|
98 (make-variable-buffer-local 'url-dired-minor-mode)
|
|
|
99
|
|
|
100 (defun url-dired-find-file ()
|
|
|
101 "In dired, visit the file or directory named on this line, using Emacs-W3."
|
|
|
102 (interactive)
|
|
|
103 (w3-open-local (dired-get-filename)))
|
|
|
104
|
|
|
105 (defun url-dired-find-file-mouse (event)
|
|
|
106 "In dired, visit the file or directory name you click on, using Emacs-W3."
|
|
|
107 (interactive "@e")
|
|
|
108 (if (event-point event)
|
|
|
109 (progn
|
|
|
110 (goto-char (event-point event))
|
|
|
111 (url-dired-find-file))))
|
|
|
112
|
|
|
113 (defun url-dired-minor-mode (&optional arg)
|
|
|
114 "Minor mode for directory browsing with Emacs-W3."
|
|
|
115 (interactive "P")
|
|
|
116 (cond
|
|
|
117 ((null arg)
|
|
|
118 (setq url-dired-minor-mode (not url-dired-minor-mode)))
|
|
|
119 ((equal 0 arg)
|
|
|
120 (setq url-dired-minor-mode nil))
|
|
|
121 (t
|
|
|
122 (setq url-dired-minor-mode t))))
|
|
|
123
|
|
|
124 (add-minor-mode 'url-dired-minor-mode " URL" url-dired-minor-mode-map)
|
|
14
|
125
|
|
|
126 (defun url-format-directory (dir)
|
|
|
127 ;; Format the files in DIR into hypertext
|
|
98
|
128 (if (and url-directory-index-file
|
|
|
129 (file-exists-p (expand-file-name url-directory-index-file dir))
|
|
|
130 (file-readable-p (expand-file-name url-directory-index-file dir)))
|
|
14
|
131 (save-excursion
|
|
|
132 (set-buffer url-working-buffer)
|
|
|
133 (erase-buffer)
|
|
120
|
134 (insert-file-contents
|
|
98
|
135 (expand-file-name url-directory-index-file dir)))
|
|
|
136 (kill-buffer (current-buffer))
|
|
|
137 (find-file dir)
|
|
|
138 (url-dired-minor-mode t)))
|
|
14
|
139
|
|
|
140 (defun url-host-is-local-p (host)
|
|
|
141 "Return t iff HOST references our local machine."
|
|
|
142 (let ((case-fold-search t))
|
|
|
143 (or
|
|
|
144 (null host)
|
|
|
145 (string= "" host)
|
|
|
146 (equal (downcase host) (downcase (system-name)))
|
|
|
147 (and (string-match "^localhost$" host) t)
|
|
|
148 (and (not (string-match (regexp-quote ".") host))
|
|
|
149 (equal (downcase host) (if (string-match (regexp-quote ".")
|
|
|
150 (system-name))
|
|
|
151 (substring (system-name) 0
|
|
|
152 (match-beginning 0))
|
|
|
153 (system-name)))))))
|
|
144
|
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
|
|
14
|
182 (defun url-file (url)
|
|
|
183 ;; Find a file
|
|
|
184 (let* ((urlobj (url-generic-parse-url url))
|
|
|
185 (user (url-user urlobj))
|
|
86
|
186 (pass (url-password urlobj))
|
|
14
|
187 (site (url-host urlobj))
|
|
|
188 (file (url-unhex-string (url-filename urlobj)))
|
|
|
189 (dest (url-target urlobj))
|
|
|
190 (filename (if (or user (not (url-host-is-local-p site)))
|
|
|
191 (concat "/" (or user "anonymous") "@" site ":" file)
|
|
|
192 file)))
|
|
|
193
|
|
|
194 (url-clear-tmp-buffer)
|
|
86
|
195 (and user pass
|
|
|
196 (cond
|
|
|
197 ((featurep 'ange-ftp)
|
|
|
198 (ange-ftp-set-passwd site user pass))
|
|
|
199 ((or (featurep 'efs) (featurep 'efs-auto))
|
|
|
200 (efs-set-passwd site user pass))
|
|
|
201 (t
|
|
|
202 nil)))
|
|
14
|
203 (cond
|
|
|
204 ((file-directory-p filename)
|
|
144
|
205 (if (not (string-match "/$" filename))
|
|
|
206 (setq filename (concat filename "/")))
|
|
|
207 (if (not (string-match "/$" file))
|
|
|
208 (setq file (concat file "/")))
|
|
98
|
209 (url-set-filename urlobj file)
|
|
|
210 (url-format-directory filename))
|
|
144
|
211 (url-be-asynchronous
|
|
14
|
212 (cond
|
|
|
213 ((file-exists-p filename) nil)
|
|
|
214 ((file-exists-p (concat filename ".Z"))
|
|
|
215 (setq filename (concat filename ".Z")))
|
|
|
216 ((file-exists-p (concat filename ".gz"))
|
|
|
217 (setq filename (concat filename ".gz")))
|
|
|
218 ((file-exists-p (concat filename ".z"))
|
|
|
219 (setq filename (concat filename ".z")))
|
|
144
|
220 (t nil))
|
|
|
221 (let ((new (mm-generate-unique-filename)))
|
|
|
222 (cond
|
|
|
223 ((url-host-is-local-p site)
|
|
|
224 (insert-file-contents-literally filename)
|
|
|
225 (if (featurep 'efs)
|
|
|
226 (url-file-asynch-callback nil nil nil nil nil
|
|
|
227 url-current-callback-func
|
|
|
228 url-current-callback-data)
|
|
|
229 (url-file-asynch-callback nil nil nil nil
|
|
|
230 url-current-callback-func
|
|
|
231 url-current-callback-data)))
|
|
|
232 ((featurep 'ange-ftp)
|
|
|
233 (ange-ftp-copy-file-internal filename (expand-file-name new) t
|
|
|
234 nil t
|
|
|
235 (url-file-build-continuation new)
|
|
|
236 t))
|
|
|
237 ((or (featurep 'efs) (featurep 'efs-auto))
|
|
14
|
238 (efs-copy-file-internal filename (efs-ftp-path filename)
|
|
|
239 new (efs-ftp-path new)
|
|
144
|
240 t nil 0
|
|
|
241 (url-file-build-continuation new)
|
|
|
242 0 nil)))))
|
|
14
|
243 (t
|
|
|
244 (let ((viewer (mm-mime-info
|
|
|
245 (mm-extension-to-mime (url-file-extension file))))
|
|
|
246 (errobj nil))
|
|
|
247 (if (or url-source ; Need it in a buffer
|
|
|
248 (and (symbolp viewer)
|
|
|
249 (not (eq viewer 'w3-default-local-file)))
|
|
|
250 (stringp viewer))
|
|
|
251 (condition-case errobj
|
|
|
252 (url-insert-possibly-compressed-file filename t)
|
|
|
253 (error
|
|
|
254 (url-save-error errobj)
|
|
|
255 (url-retrieve (concat "www://error/nofile/" file))))))))
|
|
102
|
256 (setq url-current-mime-type (mm-extension-to-mime
|
|
|
257 (url-file-extension file)))))
|
|
14
|
258
|
|
|
259 (fset 'url-ftp 'url-file)
|
|
|
260
|
|
|
261 (provide 'url-file)
|
