lisp/url/url-file.el

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