lisp/url/url-file.el

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