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

;;; 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
Commit	Line	Data
8c8b8430	1	;;; url-file.el --- File retrieval code
88c963ed	2
71ddfde5	3	;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
12dc447f	4	;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
88c963ed	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
8c0ee52a	12	;; the Free Software Foundation; either version 3, or (at your option)
88c963ed SM	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
4fc5845f LK	22	;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
4fc5845f LK	23	;; Boston, MA 02110-1301, USA.
88c963ed SM	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)
3ecd3a56	55	"Return t if HOST references our local machine."
8c8b8430 SM	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))))
175384d1	77	(with-current-buffer buff
8c8b8430 SM	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
40234eaf GM	89	(declare-function ange-ftp-set-passwd "ange-ftp" (host user passwd))
40234eaf GM	90	(declare-function ange-ftp-copy-file-internal "ange-ftp"
153ef845 DN	91	(filename newname ok-if-already-exists
153ef845 DN	92	keep-date &optional msg cont nowait))
e8ffb999	93	(declare-function url-generate-unique-filename "url-util" (&optional fmt))
153ef845	94
8c8b8430 SM	95	(defun url-file-build-filename (url)
	96	(if (not (vectorp url))
	97	(setq url (url-generic-parse-url url)))
	98	(let* ((user (url-user url))
	99	(pass (url-password url))
	100	(port (url-port url))
	101	(host (url-host url))
	102	(site (if (and port (/= port 21))
	103	(if (featurep 'ange-ftp)
	104	(format "%s %d" host port)
	105	;; This works in Emacs 21's ange-ftp too.
	106	(format "%s#%d" host port))
	107	host))
	108	(file (url-unhex-string (url-filename url)))
	109	(filename (if (or user (not (url-file-host-is-local-p host)))
	110	(concat "/" (or user "anonymous") "@" site ":" file)
	111	(if (and (memq system-type
	112	'(emx ms-dos windows-nt ms-windows))
	113	(string-match "^/[a-zA-Z]:/" file))
	114	(substring file 1)
	115	file)))
	116	pos-index)
	117
	118	(and user pass
	119	(cond
	120	((featurep 'ange-ftp)
	121	(ange-ftp-set-passwd host user pass))
132d5910 GM	122	((when (featurep 'xemacs)
	123	(or (featurep 'efs) (featurep 'efs-auto)
	124	(efs-set-passwd host user pass))))
8c8b8430 SM	125	(t
	126	nil)))
	127
	128	;; This makes sure that directories have a trailing directory
	129	;; separator on them so URL expansion works right.
	130	;;
	131	;; FIXME? What happens if the remote system doesn't use our local
	132	;; directory-sep-char as its separator? Would it be safer to just
	133	;; use '/' unconditionally and rely on the FTP server to
	134	;; straighten it out for us?
88c963ed SM	135	;; (if (and (file-directory-p filename)
88c963ed SM	136	;; (not (string-match (format "%c$" directory-sep-char) filename)))
d18ec89f SM	137	;; (setf (url-filename url)
d18ec89f SM	138	;; (format "%s%c" filename directory-sep-char)))
8c8b8430	139	(if (and (file-directory-p filename)
88c963ed	140	(not (string-match "/\\'" filename)))
d18ec89f	141	(setf (url-filename url) (format "%s/" filename)))
88c963ed	142
8c8b8430 SM	143
	144	;; If it is a directory, look for an index file first.
	145	(if (and (file-directory-p filename)
	146	url-directory-index-file
	147	(setq pos-index (expand-file-name url-directory-index-file filename))
	148	(file-exists-p pos-index)
	149	(file-readable-p pos-index))
	150	(setq filename pos-index))
	151
	152	;; Find the (possibly compressed) file
	153	(setq filename (url-file-find-possibly-compressed-file filename))
	154	filename))
	155
	156	;;;###autoload
	157	(defun url-file (url callback cbargs)
	158	"Handle file: and ftp: URLs."
	159	(let* ((buffer nil)
	160	(uncompressed-filename nil)
	161	(content-type nil)
	162	(content-encoding nil)
	163	(coding-system-for-read 'binary))
	164
	165	(setq filename (url-file-build-filename url))
	166
	167	(if (not filename)
	168	(error "File does not exist: %s" (url-recreate-url url)))
	169
	170	;; Need to figure out the content-type from the real extension,
	171	;; not the compressed one.
	172	(setq uncompressed-filename (if (string-match "\\.\\(gz\\\|Z\\\|z\\)$" filename)
	173	(substring filename 0 (match-beginning 0))
	174	filename))
	175	(setq content-type (mailcap-extension-to-mime
	176	(url-file-extension uncompressed-filename))
	177	content-encoding (case (intern (url-file-extension filename))
	178	((\.z \.gz) "gzip")
	179	(\.Z "compress")
	180	(\.uue "x-uuencoded")
	181	(\.hqx "x-hqx")
	182	(\.bz2 "x-bzip2")
	183	(otherwise nil)))
	184
	185	(if (file-directory-p filename)
	186	;; A directory is done the same whether we are local or remote
	187	(url-find-file-dired filename)
175384d1 SM	188	(with-current-buffer
175384d1 SM	189	(setq buffer (generate-new-buffer " url-file"))
8c8b8430 SM	190	(mm-disable-multibyte)
	191	(setq url-current-object url)
	192	(insert "Content-type: " (or content-type "application/octet-stream") "\n")
	193	(if content-encoding
	194	(insert "Content-transfer-encoding: " content-encoding "\n"))
	195	(if (url-file-host-is-local-p (url-host url))
	196	;; Local files are handled slightly oddly
	197	(if (featurep 'ange-ftp)
	198	(url-file-asynch-callback nil nil
	199	filename
	200	(current-buffer)
	201	callback cbargs)
	202	(url-file-asynch-callback nil nil nil
	203	filename
	204	(current-buffer)
	205	callback cbargs))
	206	;; FTP handling
	207	(let* ((extension (url-file-extension filename))
	208	(new (url-generate-unique-filename
	209	(and (> (length extension) 0)
	210	(concat "%s." extension)))))
	211	(if (featurep 'ange-ftp)
	212	(ange-ftp-copy-file-internal filename (expand-file-name new) t
	213	nil t
	214	(list 'url-file-asynch-callback
	215	new (current-buffer)
	216	callback cbargs)
	217	t)
132d5910 GM	218	(when (featurep 'xemacs)
	219	(autoload 'efs-copy-file-internal "efs")
	220	(efs-copy-file-internal filename (efs-ftp-path filename)
	221	new (efs-ftp-path new)
	222	t nil 0
	223	(list 'url-file-asynch-callback
	224	new (current-buffer)
	225	callback cbargs)
	226	0 nil)))))))
8c8b8430 SM	227	buffer))
	228
	229	(defmacro url-file-create-wrapper (method args)
ca000aff SM	230	`(defalias ',(intern (format "url-ftp-%s" method))
	231	(defun ,(intern (format "url-file-%s" method)) ,args
	232	,(format "FTP/FILE URL wrapper around `%s' call." method)
	233	(setq url (url-file-build-filename url))
	234	(and url (,method ,@(remove '&rest (remove '&optional args)))))))
8c8b8430 SM	235
8c8b8430 SM	236	(url-file-create-wrapper file-exists-p (url))
ca000aff	237	(url-file-create-wrapper file-attributes (url &optional id-format))
8c8b8430 SM	238	(url-file-create-wrapper file-symlink-p (url))
	239	(url-file-create-wrapper file-readable-p (url))
	240	(url-file-create-wrapper file-writable-p (url))
	241	(url-file-create-wrapper file-executable-p (url))
cc38a294 EZ	242	(url-file-create-wrapper directory-files (url &optional full match nosort))
cc38a294 EZ	243	(url-file-create-wrapper file-truename (url &optional counter prev-dirs))
8c8b8430 SM	244
8c8b8430 SM	245	(provide 'url-file)
e5566bd5	246
88c963ed SM	247	;; arch-tag: 010e914a-7313-494b-8a8c-6495a862157d
88c963ed SM	248	;;; url-file.el ends here