lisp/url/url-file.el

   1 ;;; url-file.el --- File retrieval code
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
   4 ;;   2005, 2006, 2007, 2008 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 3, 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'.
  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 if 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 (declare-function ange-ftp-set-passwd "ange-ftp" (host user passwd))
  90 (declare-function ange-ftp-copy-file-internal "ange-ftp"
  91                   (filename newname ok-if-already-exists
  92                             keep-date &optional msg cont nowait))
  93 (declare-function url-generate-unique-filename "url-util" (&optional fmt))
  94
  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))
 122           ((when (featurep 'xemacs)
 123              (or (featurep 'efs) (featurep 'efs-auto)
 124                  (efs-set-passwd host user pass))))
 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?
 135     ;; (if (and (file-directory-p filename)
 136     ;;          (not (string-match (format "%c$" directory-sep-char) filename)))
 137     ;;     (setf (url-filename url)
 138     ;;           (format "%s%c" filename directory-sep-char)))
 139     (if (and (file-directory-p filename)
 140              (not (string-match "/\\'" filename)))
 141         (setf (url-filename url) (format "%s/" filename)))
 142
 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)
 188       (with-current-buffer
 189           (setq buffer (generate-new-buffer " *url-file*"))
 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)
 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)))))))
 227     buffer))
 228
 229 (defmacro url-file-create-wrapper (method args)
 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)))))))
 235
 236 (url-file-create-wrapper file-exists-p (url))
 237 (url-file-create-wrapper file-attributes (url &optional id-format))
 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))
 242 (url-file-create-wrapper directory-files (url &optional full match nosort))
 243 (url-file-create-wrapper file-truename (url &optional counter prev-dirs))
 244
 245 (provide 'url-file)
 246
 247 ;; arch-tag: 010e914a-7313-494b-8a8c-6495a862157d
 248 ;;; url-file.el ends here