code.delx.au - gnu-emacs/blob - lisp/url/url-file.el

   1 ;;; url-file.el --- File retrieval code
   2 ;; Author: $Author: fx $
   3 ;; Created: $Date: 2002/04/22 09:14:24 $
   4 ;; Version: $Revision: 1.11 $
   5 ;; Keywords: comm, data, processes
   6
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
   9 ;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
  10 ;;;
  11 ;;; This file is part of GNU Emacs.
  12 ;;;
  13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;;; it under the terms of the GNU General Public License as published by
  15 ;;; the Free Software Foundation; either version 2, or (at your option)
  16 ;;; any later version.
  17 ;;;
  18 ;;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;;; GNU General Public License for more details.
  22 ;;;
  23 ;;; You should have received a copy of the GNU General Public License
  24 ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;;; Boston, MA 02111-1307, USA.
  27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  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 iff 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     (save-excursion
  78       (set-buffer buff)
  79       (goto-char (point-max))
  80       (if (/= -1 size)
  81           (insert (format "Content-length: %d\n" size)))
  82       (insert "\n")
  83       (insert-file-contents-literally name)
  84       (if (not (url-file-host-is-local-p (url-host url-current-object)))
  85           (condition-case ()
  86               (delete-file name)
  87             (error nil)))
  88       (apply func args))))
  89
  90 (defun url-file-build-filename (url)
  91   (if (not (vectorp url))
  92       (setq url (url-generic-parse-url url)))
  93   (let* ((user (url-user url))
  94          (pass (url-password url))
  95          (port (url-port url))
  96          (host (url-host url))
  97          (site (if (and port (/= port 21))
  98                    (if (featurep 'ange-ftp)
  99                        (format "%s %d" host port)
 100                      ;; This works in Emacs 21's ange-ftp too.
 101                      (format "%s#%d" host port))
 102                  host))
 103          (file (url-unhex-string (url-filename url)))
 104          (filename (if (or user (not (url-file-host-is-local-p host)))
 105                        (concat "/" (or user "anonymous") "@" site ":" file)
 106                      (if (and (memq system-type
 107                                     '(emx ms-dos windows-nt ms-windows))
 108                               (string-match "^/[a-zA-Z]:/" file))
 109                          (substring file 1)
 110                        file)))
 111          pos-index)
 112
 113     (and user pass
 114          (cond
 115           ((featurep 'ange-ftp)
 116            (ange-ftp-set-passwd host user pass))
 117           ((or (featurep 'efs) (featurep 'efs-auto))
 118            (efs-set-passwd host user pass))
 119           (t
 120            nil)))
 121
 122     ;; This makes sure that directories have a trailing directory
 123     ;; separator on them so URL expansion works right.
 124     ;;
 125     ;; FIXME?  What happens if the remote system doesn't use our local
 126     ;; directory-sep-char as its separator?  Would it be safer to just
 127     ;; use '/' unconditionally and rely on the FTP server to
 128     ;; straighten it out for us?
 129     (if (and (file-directory-p filename)
 130              (not (string-match (format "%c$" directory-sep-char) filename)))
 131         (url-set-filename url
 132                           (format "%s%c" filename directory-sep-char)))
 133
 134     ;; If it is a directory, look for an index file first.
 135     (if (and (file-directory-p filename)
 136              url-directory-index-file
 137              (setq pos-index (expand-file-name url-directory-index-file filename))
 138              (file-exists-p pos-index)
 139              (file-readable-p pos-index))
 140         (setq filename pos-index))
 141
 142     ;; Find the (possibly compressed) file
 143     (setq filename (url-file-find-possibly-compressed-file filename))
 144     filename))
 145
 146 ;;;###autoload
 147 (defun url-file (url callback cbargs)
 148   "Handle file: and ftp: URLs."
 149   (let* ((buffer nil)
 150          (uncompressed-filename nil)
 151          (content-type nil)
 152          (content-encoding nil)
 153          (coding-system-for-read 'binary))
 154
 155     (setq filename (url-file-build-filename url))
 156
 157     (if (not filename)
 158         (error "File does not exist: %s" (url-recreate-url url)))
 159
 160     ;; Need to figure out the content-type from the real extension,
 161     ;; not the compressed one.
 162     (setq uncompressed-filename (if (string-match "\\.\\(gz\\|Z\\|z\\)$" filename)
 163                                     (substring filename 0 (match-beginning 0))
 164                                   filename))
 165     (setq content-type (mailcap-extension-to-mime
 166                         (url-file-extension uncompressed-filename))
 167           content-encoding (case (intern (url-file-extension filename))
 168                              ((\.z \.gz) "gzip")
 169                              (\.Z "compress")
 170                              (\.uue "x-uuencoded")
 171                              (\.hqx "x-hqx")
 172                              (\.bz2 "x-bzip2")
 173                              (otherwise nil)))
 174
 175     (if (file-directory-p filename)
 176         ;; A directory is done the same whether we are local or remote
 177         (url-find-file-dired filename)
 178       (save-excursion
 179         (setq buffer (generate-new-buffer " *url-file*"))
 180         (set-buffer buffer)
 181         (mm-disable-multibyte)
 182         (setq url-current-object url)
 183         (insert "Content-type: " (or content-type "application/octet-stream") "\n")
 184         (if content-encoding
 185             (insert "Content-transfer-encoding: " content-encoding "\n"))
 186         (if (url-file-host-is-local-p (url-host url))
 187               ;; Local files are handled slightly oddly
 188             (if (featurep 'ange-ftp)
 189                 (url-file-asynch-callback nil nil
 190                                           filename
 191                                           (current-buffer)
 192                                           callback cbargs)
 193               (url-file-asynch-callback nil nil nil
 194                                         filename
 195                                         (current-buffer)
 196                                         callback cbargs))
 197           ;; FTP handling
 198           (let* ((extension (url-file-extension filename))
 199                  (new (url-generate-unique-filename
 200                        (and (> (length extension) 0)
 201                             (concat "%s." extension)))))
 202             (if (featurep 'ange-ftp)
 203                 (ange-ftp-copy-file-internal filename (expand-file-name new) t
 204                                              nil t
 205                                              (list 'url-file-asynch-callback
 206                                                    new (current-buffer)
 207                                                    callback cbargs)
 208                                              t)
 209               (autoload 'efs-copy-file-internal "efs")
 210               (efs-copy-file-internal filename (efs-ftp-path filename)
 211                                       new (efs-ftp-path new)
 212                                       t nil 0
 213                                       (list 'url-file-asynch-callback
 214                                             new (current-buffer)
 215                                             callback cbargs)
 216                                       0 nil))))))
 217     buffer))
 218
 219 (defmacro url-file-create-wrapper (method args)
 220   (` (defalias (quote (, (intern (format "url-ftp-%s" method))))
 221        (defun (, (intern (format "url-file-%s" method))) (, args)
 222          (, (format "FTP/FILE URL wrapper around `%s' call." method))
 223          (setq url (url-file-build-filename url))
 224          (and url ((, method) (,@ (remove '&rest (remove '&optional args)))))))))
 225
 226 (url-file-create-wrapper file-exists-p (url))
 227 (url-file-create-wrapper file-attributes (url))
 228 (url-file-create-wrapper file-symlink-p (url))
 229 (url-file-create-wrapper file-readable-p (url))
 230 (url-file-create-wrapper file-writable-p (url))
 231 (url-file-create-wrapper file-executable-p (url))
 232 (if (featurep 'xemacs)
 233     (progn
 234       (url-file-create-wrapper directory-files (url &optional full match nosort files-only))
 235       (url-file-create-wrapper file-truename (url &optional default)))
 236   (url-file-create-wrapper directory-files (url &optional full match nosort))
 237   (url-file-create-wrapper file-truename (url &optional counter prev-dirs)))
 238
 239 (provide 'url-file)