[bpt/emacs.git] / lisp / url / url-file.el

;;; url-file.el --- File retrieval code

;; Copyright (c) 1996 - 1999,2004  Free Software Foundation, Inc.
;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>

;; 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 2, 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., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, 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 iff 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))))
    (save-excursion
      (set-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))))

(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))
	  ((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)))
    ;;     (url-set-filename url (format "%s%c" filename directory-sep-char)))
    (if (and (file-directory-p filename)
	     (not (string-match "/\\'" filename)))
	(url-set-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)
      (save-excursion
	(setq buffer (generate-new-buffer " *url-file*"))
	(set-buffer buffer)
	(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)
	      (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 (quote (, (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))
(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))
(if (featurep 'xemacs)
    (progn
      (url-file-create-wrapper directory-files (url &optional full match nosort files-only))
      (url-file-create-wrapper file-truename (url &optional default)))
  (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
Commit	Line	Data
8c8b8430	1	;;; url-file.el --- File retrieval code
88c963ed SM	2
	3	;; Copyright (c) 1996 - 1999,2004 Free Software Foundation, Inc.
	4	;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
	5
8c8b8430 SM	6	;; Keywords: comm, data, processes
8c8b8430 SM	7
88c963ed SM	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., 59 Temple Place - Suite 330,
	23	;; Boston, MA 02111-1307, USA.
	24
	25	;;; Commentary:
	26
	27	;;; Code:
8c8b8430 SM	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'.
	41	This tries the common compression extensions, because things like
	42	ange-ftp and efs are not quite smart enough to realize when a server
	43	can 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
	45	to 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	(save-excursion
	78	(set-buffer buff)
	79	(goto-char (point-max))
	80	(if (/= -1 size)
	81	(insert (format "Content-length: %d\n" size)))
	82	(insert "\n")
	83	(insert-file-contents-literally name)
	84	(if (not (url-file-host-is-local-p (url-host url-current-object)))
	85	(condition-case ()
	86	(delete-file name)
	87	(error nil)))
	88	(apply func args))))
	89
	90	(defun url-file-build-filename (url)
	91	(if (not (vectorp url))
92	(setq url (url-generic-parse-url url)))
93	(let* ((user (url-user url))
94	(pass (url-password url))
95	(port (url-port url))
96	(host (url-host url))
97	(site (if (and port (/= port 21))
98	(if (featurep 'ange-ftp)
99	(format "%s %d" host port)
100	;; This works in Emacs 21's ange-ftp too.
101	(format "%s#%d" host port))
102	host))
103	(file (url-unhex-string (url-filename url)))
104	(filename (if (or user (not (url-file-host-is-local-p host)))
105	(concat "/" (or user "anonymous") "@" site ":" file)
106	(if (and (memq system-type
107	'(emx ms-dos windows-nt ms-windows))
108	(string-match "^/[a-zA-Z]:/" file))
109	(substring file 1)
110	file)))
111	pos-index)
112
113	(and user pass
114	(cond
115	((featurep 'ange-ftp)
116	(ange-ftp-set-passwd host user pass))
117	((or (featurep 'efs) (featurep 'efs-auto))
118	(efs-set-passwd host user pass))
119	(t
120	nil)))
121
122	;; This makes sure that directories have a trailing directory
123	;; separator on them so URL expansion works right.
124	;;
125	;; FIXME? What happens if the remote system doesn't use our local
126	;; directory-sep-char as its separator? Would it be safer to just
127	;; use '/' unconditionally and rely on the FTP server to
128	;; straighten it out for us?
88c963ed SM	129	;; (if (and (file-directory-p filename)
	130	;; (not (string-match (format "%c$" directory-sep-char) filename)))
	131	;; (url-set-filename url (format "%s%c" filename directory-sep-char)))
8c8b8430	132	(if (and (file-directory-p filename)
88c963ed SM	133	(not (string-match "/\\'" filename)))
	134	(url-set-filename url (format "%s/" filename)))
	135
8c8b8430 SM	136
	137	;; If it is a directory, look for an index file first.
	138	(if (and (file-directory-p filename)
	139	url-directory-index-file
	140	(setq pos-index (expand-file-name url-directory-index-file filename))
	141	(file-exists-p pos-index)
	142	(file-readable-p pos-index))
	143	(setq filename pos-index))
	144
	145	;; Find the (possibly compressed) file
	146	(setq filename (url-file-find-possibly-compressed-file filename))
	147	filename))
	148
	149	;;;###autoload
	150	(defun url-file (url callback cbargs)
	151	"Handle file: and ftp: URLs."
	152	(let* ((buffer nil)
	153	(uncompressed-filename nil)
	154	(content-type nil)
	155	(content-encoding nil)
	156	(coding-system-for-read 'binary))
	157
	158	(setq filename (url-file-build-filename url))
	159
	160	(if (not filename)
	161	(error "File does not exist: %s" (url-recreate-url url)))
	162
	163	;; Need to figure out the content-type from the real extension,
	164	;; not the compressed one.
	165	(setq uncompressed-filename (if (string-match "\\.\\(gz\\\|Z\\\|z\\)$" filename)
	166	(substring filename 0 (match-beginning 0))
	167	filename))
	168	(setq content-type (mailcap-extension-to-mime
	169	(url-file-extension uncompressed-filename))
	170	content-encoding (case (intern (url-file-extension filename))
	171	((\.z \.gz) "gzip")
	172	(\.Z "compress")
	173	(\.uue "x-uuencoded")
	174	(\.hqx "x-hqx")
	175	(\.bz2 "x-bzip2")
	176	(otherwise nil)))
	177
	178	(if (file-directory-p filename)
	179	;; A directory is done the same whether we are local or remote
	180	(url-find-file-dired filename)
	181	(save-excursion
	182	(setq buffer (generate-new-buffer " url-file"))
	183	(set-buffer buffer)
	184	(mm-disable-multibyte)
	185	(setq url-current-object url)
	186	(insert "Content-type: " (or content-type "application/octet-stream") "\n")
	187	(if content-encoding
	188	(insert "Content-transfer-encoding: " content-encoding "\n"))
	189	(if (url-file-host-is-local-p (url-host url))
	190	;; Local files are handled slightly oddly
	191	(if (featurep 'ange-ftp)
	192	(url-file-asynch-callback nil nil
	193	filename
	194	(current-buffer)
	195	callback cbargs)
	196	(url-file-asynch-callback nil nil nil
	197	filename
	198	(current-buffer)
	199	callback cbargs))
200	;; FTP handling
201	(let* ((extension (url-file-extension filename))
202	(new (url-generate-unique-filename
203	(and (> (length extension) 0)
204	(concat "%s." extension)))))
205	(if (featurep 'ange-ftp)
206	(ange-ftp-copy-file-internal filename (expand-file-name new) t
207	nil t
208	(list 'url-file-asynch-callback
209	new (current-buffer)
210	callback cbargs)
211	t)
212	(autoload 'efs-copy-file-internal "efs")
213	(efs-copy-file-internal filename (efs-ftp-path filename)
214	new (efs-ftp-path new)
215	t nil 0
216	(list 'url-file-asynch-callback
217	new (current-buffer)
218	callback cbargs)
219	0 nil))))))
220	buffer))
221
222	(defmacro url-file-create-wrapper (method args)
223	(` (defalias (quote (, (intern (format "url-ftp-%s" method))))
224	(defun (, (intern (format "url-file-%s" method))) (, args)
225	(, (format "FTP/FILE URL wrapper around `%s' call." method))
226	(setq url (url-file-build-filename url))
227	(and url ((, method) (,@ (remove '&rest (remove '&optional args)))))))))
228
229	(url-file-create-wrapper file-exists-p (url))
230	(url-file-create-wrapper file-attributes (url))
231	(url-file-create-wrapper file-symlink-p (url))
232	(url-file-create-wrapper file-readable-p (url))
233	(url-file-create-wrapper file-writable-p (url))
234	(url-file-create-wrapper file-executable-p (url))
235	(if (featurep 'xemacs)
236	(progn
237	(url-file-create-wrapper directory-files (url &optional full match nosort files-only))
238	(url-file-create-wrapper file-truename (url &optional default)))
239	(url-file-create-wrapper directory-files (url &optional full match nosort))
240	(url-file-create-wrapper file-truename (url &optional counter prev-dirs)))
241
242	(provide 'url-file)
e5566bd5	243
88c963ed SM	244	;; arch-tag: 010e914a-7313-494b-8a8c-6495a862157d
88c963ed SM	245	;;; url-file.el ends here