lisp/url/url-file.el

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