[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 of the License, 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.  If not, see <http://www.gnu.org/licenses/>.

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