1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
|
;;; url-file.el --- File retrieval code
;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
;; This file is part of GNU Emacs.
;;
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
(eval-when-compile (require 'cl))
(require 'mailcap)
(require 'url-vars)
(require 'url-parse)
(require 'url-dired)
(defconst url-file-default-port 21 "Default FTP port.")
(defconst url-file-asynchronous-p t "FTP transfers are asynchronous.")
(defalias 'url-file-expand-file-name 'url-default-expander)
(defun url-file-find-possibly-compressed-file (fname &rest args)
"Find the exact file referenced by `fname'.
This tries the common compression extensions, because things like
ange-ftp and efs are not quite smart enough to realize when a server
can do automatic decompression for them, and won't find 'foo' if
'foo.gz' exists, even though the ftp server would happily serve it up
to them."
(let ((scratch nil)
(compressed-extensions '("" ".gz" ".z" ".Z" ".bz2"))
(found nil))
(while (and compressed-extensions (not found))
(if (file-exists-p (setq scratch (concat fname (pop compressed-extensions))))
(setq found scratch)))
found))
(defun url-file-host-is-local-p (host)
"Return t if HOST references our local machine."
(let ((case-fold-search t))
(or
(null host)
(string= "" host)
(equal (downcase host) (downcase (system-name)))
(and (string-match "^localhost$" host) t)
(and (not (string-match (regexp-quote ".") host))
(equal (downcase host) (if (string-match (regexp-quote ".")
(system-name))
(substring (system-name) 0
(match-beginning 0))
(system-name)))))))
(defun url-file-asynch-callback (x y name buff func args &optional efs)
(if (not (featurep 'ange-ftp))
;; EFS passes us an extra argument
(setq name buff
buff func
func args
args efs))
(let ((size (nth 7 (file-attributes name))))
(with-current-buffer buff
(goto-char (point-max))
(if (/= -1 size)
(insert (format "Content-length: %d\n" size)))
(insert "\n")
(insert-file-contents-literally name)
(if (not (url-file-host-is-local-p (url-host url-current-object)))
(condition-case ()
(delete-file name)
(error nil)))
(apply func args))))
(declare-function ange-ftp-set-passwd "ange-ftp" (host user passwd))
(declare-function ange-ftp-copy-file-internal "ange-ftp"
(filename newname ok-if-already-exists
keep-date &optional msg cont nowait))
(declare-function url-generate-unique-filename "url-util" (&optional fmt))
(defun url-file-build-filename (url)
(if (not (vectorp url))
(setq url (url-generic-parse-url url)))
(let* ((user (url-user url))
(pass (url-password url))
(port (url-port url))
(host (url-host url))
(site (if (and port (/= port 21))
(if (featurep 'ange-ftp)
(format "%s %d" host port)
;; This works in Emacs 21's ange-ftp too.
(format "%s#%d" host port))
host))
(file (url-unhex-string (url-filename url)))
(filename (if (or user (not (url-file-host-is-local-p host)))
(concat "/" (or user "anonymous") "@" site ":" file)
(if (and (memq system-type
'(emx ms-dos windows-nt ms-windows))
(string-match "^/[a-zA-Z]:/" file))
(substring file 1)
file)))
pos-index)
(and user pass
(cond
((featurep 'ange-ftp)
(ange-ftp-set-passwd host user pass))
((when (featurep 'xemacs)
(or (featurep 'efs) (featurep 'efs-auto)
(efs-set-passwd host user pass))))
(t
nil)))
;; This makes sure that directories have a trailing directory
;; separator on them so URL expansion works right.
;;
;; FIXME? What happens if the remote system doesn't use our local
;; directory-sep-char as its separator? Would it be safer to just
;; use '/' unconditionally and rely on the FTP server to
;; straighten it out for us?
;; (if (and (file-directory-p filename)
;; (not (string-match (format "%c$" directory-sep-char) filename)))
;; (setf (url-filename url)
;; (format "%s%c" filename directory-sep-char)))
(if (and (file-directory-p filename)
(not (string-match "/\\'" filename)))
(setf (url-filename url) (format "%s/" filename)))
;; If it is a directory, look for an index file first.
(if (and (file-directory-p filename)
url-directory-index-file
(setq pos-index (expand-file-name url-directory-index-file filename))
(file-exists-p pos-index)
(file-readable-p pos-index))
(setq filename pos-index))
;; Find the (possibly compressed) file
(setq filename (url-file-find-possibly-compressed-file filename))
filename))
;;;###autoload
(defun url-file (url callback cbargs)
"Handle file: and ftp: URLs."
(let* ((buffer nil)
(uncompressed-filename nil)
(content-type nil)
(content-encoding nil)
(coding-system-for-read 'binary))
(setq filename (url-file-build-filename url))
(if (not filename)
(error "File does not exist: %s" (url-recreate-url url)))
;; Need to figure out the content-type from the real extension,
;; not the compressed one.
(setq uncompressed-filename (if (string-match "\\.\\(gz\\|Z\\|z\\)$" filename)
(substring filename 0 (match-beginning 0))
filename))
(setq content-type (mailcap-extension-to-mime
(url-file-extension uncompressed-filename))
content-encoding (case (intern (url-file-extension filename))
((\.z \.gz) "gzip")
(\.Z "compress")
(\.uue "x-uuencoded")
(\.hqx "x-hqx")
(\.bz2 "x-bzip2")
(otherwise nil)))
(if (file-directory-p filename)
;; A directory is done the same whether we are local or remote
(url-find-file-dired filename)
(with-current-buffer
(setq buffer (generate-new-buffer " *url-file*"))
(mm-disable-multibyte)
(setq url-current-object url)
(insert "Content-type: " (or content-type "application/octet-stream") "\n")
(if content-encoding
(insert "Content-transfer-encoding: " content-encoding "\n"))
(if (url-file-host-is-local-p (url-host url))
;; Local files are handled slightly oddly
(if (featurep 'ange-ftp)
(url-file-asynch-callback nil nil
filename
(current-buffer)
callback cbargs)
(url-file-asynch-callback nil nil nil
filename
(current-buffer)
callback cbargs))
;; FTP handling
(let* ((extension (url-file-extension filename))
(new (url-generate-unique-filename
(and (> (length extension) 0)
(concat "%s." extension)))))
(if (featurep 'ange-ftp)
(ange-ftp-copy-file-internal filename (expand-file-name new) t
nil t
(list 'url-file-asynch-callback
new (current-buffer)
callback cbargs)
t)
(when (featurep 'xemacs)
(autoload 'efs-copy-file-internal "efs")
(efs-copy-file-internal filename (efs-ftp-path filename)
new (efs-ftp-path new)
t nil 0
(list 'url-file-asynch-callback
new (current-buffer)
callback cbargs)
0 nil)))))))
buffer))
(defmacro url-file-create-wrapper (method args)
`(defalias ',(intern (format "url-ftp-%s" method))
(defun ,(intern (format "url-file-%s" method)) ,args
,(format "FTP/FILE URL wrapper around `%s' call." method)
(setq url (url-file-build-filename url))
(and url (,method ,@(remove '&rest (remove '&optional args)))))))
(url-file-create-wrapper file-exists-p (url))
(url-file-create-wrapper file-attributes (url &optional id-format))
(url-file-create-wrapper file-symlink-p (url))
(url-file-create-wrapper file-readable-p (url))
(url-file-create-wrapper file-writable-p (url))
(url-file-create-wrapper file-executable-p (url))
(url-file-create-wrapper directory-files (url &optional full match nosort))
(url-file-create-wrapper file-truename (url &optional counter prev-dirs))
(provide 'url-file)
;; arch-tag: 010e914a-7313-494b-8a8c-6495a862157d
;;; url-file.el ends here
|
