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