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

   1 ;;; url-handlers.el --- file-name-handler stuff for URL loading
   2 ;; Author: $Author: monnier $
   3 ;; Created: $Date: 2004/04/04 01:21:46 $
   4 ;; Version: $Revision: 1.1.1.1 $
   5 ;; Keywords: comm, data, processes, hypermedia
   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 (require 'url)
  30 (require 'url-parse)
  31 (require 'url-util)
  32 (require 'mm-decode)
  33 (require 'mailcap)
  34
  35 (eval-when-compile
  36   (require 'cl))
  37
  38 ;; Implementation status
  39 ;; ---------------------
  40 ;; Function                             Status
  41 ;; ------------------------------------------------------------
  42 ;; add-name-to-file                     Needs DAV Bindings
  43 ;; copy-file                            Broken (assumes 1st item is URL)
  44 ;; delete-directory                     Finished (DAV)
  45 ;; delete-file                          Finished (DAV)
  46 ;; diff-latest-backup-file
  47 ;; directory-file-name                  unnecessary (what about VMS)?
  48 ;; directory-files                      Finished (DAV)
  49 ;; dired-call-process
  50 ;; dired-compress-file
  51 ;; dired-uncache
  52 ;; expand-file-name                     Finished
  53 ;; file-accessible-directory-p
  54 ;; file-attributes                      Finished, better with DAV
  55 ;; file-directory-p                     Needs DAV, finished
  56 ;; file-executable-p                    Finished
  57 ;; file-exists-p                        Finished
  58 ;; file-local-copy
  59 ;; file-modes
  60 ;; file-name-all-completions            Finished (DAV)
  61 ;; file-name-as-directory
  62 ;; file-name-completion                 Finished (DAV)
  63 ;; file-name-directory
  64 ;; file-name-nondirectory
  65 ;; file-name-sans-versions              why?
  66 ;; file-newer-than-file-p
  67 ;; file-ownership-preserved-p           No way to know
  68 ;; file-readable-p                      Finished
  69 ;; file-regular-p                       !directory_p
  70 ;; file-symlink-p                       Needs DAV bindings
  71 ;; file-truename                        Needs DAV bindings
  72 ;; file-writable-p                      Check for LOCK?
  73 ;; find-backup-file-name                why?
  74 ;; get-file-buffer                      why?
  75 ;; insert-directory                     Use DAV
  76 ;; insert-file-contents                 Finished
  77 ;; load
  78 ;; make-directory                       Finished (DAV)
  79 ;; make-symbolic-link                   Needs DAV bindings
  80 ;; rename-file                          Finished (DAV)
  81 ;; set-file-modes                       Use mod_dav specific executable flag?
  82 ;; set-visited-file-modtime             Impossible?
  83 ;; shell-command                        Impossible?
  84 ;; unhandled-file-name-directory
  85 ;; vc-registered                        Finished (DAV)
  86 ;; verify-visited-file-modtime
  87 ;; write-region
  88
  89 (defvar url-handler-regexp
  90   "\\`\\(https?\\|ftp\\|file\\|nfs\\)://"
  91   "*A regular expression for matching  URLs handled by file-name-handler-alist.
  92 Some valid URL protocols just do not make sense to visit interactively
  93 \(about, data, info, irc, mailto, etc\).  This regular expression
  94 avoids conflicts with local files that look like URLs \(Gnus is
  95 particularly bad at this\).")
  96
  97 ;;;###autoload
  98 (defun url-setup-file-name-handlers ()
  99   "Setup file-name handlers."
 100   (cond
 101    ((not (boundp 'file-name-handler-alist))
 102     nil)                                ; Don't load if no alist
 103    ((rassq 'url-file-handler file-name-handler-alist)
 104     nil)                                ; Don't load twice
 105    (t
 106     (push (cons url-handler-regexp 'url-file-handler)
 107           file-name-handler-alist))))
 108
 109 (defun url-run-real-handler (operation args)
 110   (let ((inhibit-file-name-handlers (cons 'url-file-handler
 111                                           (if (eq operation inhibit-file-name-operation)
 112                                               inhibit-file-name-handlers)))
 113         (inhibit-file-name-operation operation))
 114     (apply operation args)))
 115
 116 (defun url-file-handler (operation &rest args)
 117   "Function called from the `file-name-handler-alist' routines.
 118 OPERATION is what needs to be done (`file-exists-p', etc).  ARGS are
 119 the arguments that would have been passed to OPERATION."
 120   (let ((fn (or (get operation 'url-file-handlers)
 121                 (intern-soft (format "url-%s" operation))))
 122         (val nil)
 123         (hooked nil))
 124     (if (and fn (fboundp fn))
 125         (setq hooked t
 126               val (apply fn args))
 127       (setq hooked nil
 128             val (url-run-real-handler operation args)))
 129     (url-debug 'handlers "%s %S%S => %S" (if hooked "Hooked" "Real")
 130                operation args val)
 131     val))
 132
 133 (defun url-file-handler-identity (&rest args)
 134   ;; Identity function
 135   (car args))
 136
 137 ;; These are operations that we can fully support
 138 (put 'file-readable-p 'url-file-handlers 'url-file-exists-p)
 139 (put 'substitute-in-file-name 'url-file-handlers 'url-file-handler-identity)
 140 (put 'file-name-absolute-p 'url-file-handlers (lambda (&rest ignored) t))
 141 (put 'expand-file-name 'url-file-handlers 'url-handler-expand-file-name)
 142
 143 ;; These are operations that we do not support yet (DAV!!!)
 144 (put 'file-writable-p 'url-file-handlers 'ignore)
 145 (put 'file-symlink-p 'url-file-handlers 'ignore)
 146
 147 (defun url-handler-expand-file-name (file &optional base)
 148   (if (file-name-absolute-p file)
 149       (expand-file-name file "/")
 150     (url-expand-file-name file base)))
 151
 152 ;; The actual implementation
 153 ;;;###autoload
 154 (defun url-copy-file (url newname &optional ok-if-already-exists keep-time)
 155   "Copy URL to NEWNAME.  Both args must be strings.
 156 Signals a `file-already-exists' error if file NEWNAME already exists,
 157 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
 158 A number as third arg means request confirmation if NEWNAME already exists.
 159 This is what happens in interactive use with M-x.
 160 Fourth arg KEEP-TIME non-nil means give the new file the same
 161 last-modified time as the old one.  (This works on only some systems.)
 162 A prefix arg makes KEEP-TIME non-nil."
 163   (if (and (file-exists-p newname)
 164            (not ok-if-already-exists))
 165       (error "Opening output file: File already exists, %s" newname))
 166   (let ((buffer (url-retrieve-synchronously url))
 167         (handle nil))
 168     (if (not buffer)
 169         (error "Opening input file: No such file or directory, %s" url))
 170     (save-excursion
 171       (set-buffer buffer)
 172       (setq handle (mm-dissect-buffer t)))
 173     (mm-save-part-to-file handle newname)
 174     (kill-buffer buffer)
 175     (mm-destroy-parts handle)))
 176
 177 ;;;###autoload
 178 (defun url-file-local-copy (url &rest ignored)
 179   "Copy URL into a temporary file on this machine.
 180 Returns the name of the local copy, or nil, if FILE is directly
 181 accessible."
 182   (let ((filename (make-temp-name "url")))
 183     (url-copy-file url filename)
 184     filename))
 185
 186 ;;;###autoload
 187 (defun url-insert-file-contents (url &optional visit beg end replace)
 188   (let ((buffer (url-retrieve-synchronously url))
 189         (handle nil)
 190         (data nil))
 191     (if (not buffer)
 192         (error "Opening input file: No such file or directory, %s" url))
 193     (if visit (setq buffer-file-name url))
 194     (save-excursion
 195       (set-buffer buffer)
 196       (setq handle (mm-dissect-buffer t))
 197       (set-buffer (mm-handle-buffer handle))
 198       (if beg
 199           (setq data (buffer-substring beg end))
 200         (setq data (buffer-string))))
 201     (kill-buffer buffer)
 202     (mm-destroy-parts handle)
 203     (if replace (delete-region (point-min) (point-max)))
 204     (save-excursion
 205       (insert data))
 206     (list url (length data))))
 207
 208 (defun url-file-name-completion (url directory)
 209   (error "Unimplemented"))
 210
 211 (defun url-file-name-all-completions (file directory)
 212   (error "Unimplemented"))
 213
 214 ;; All other handlers map onto their respective backends.
 215 (defmacro url-handlers-create-wrapper (method args)
 216   `(defun ,(intern (format "url-%s" method)) ,args
 217      ,(format "URL file-name-handler wrapper for `%s' call.\n---\n%s" method
 218               (or (documentation method t) "No original documentation."))
 219      (setq url (url-generic-parse-url url))
 220      (when (url-type url)
 221        (funcall (url-scheme-get-property (url-type url) (quote ,method))
 222                 ,@(remove '&rest (remove '&optional args))))))
 223
 224 (url-handlers-create-wrapper file-exists-p (url))
 225 (url-handlers-create-wrapper file-attributes (url))
 226 (url-handlers-create-wrapper file-symlink-p (url))
 227 (url-handlers-create-wrapper file-writable-p (url))
 228 (url-handlers-create-wrapper file-directory-p (url))
 229 (url-handlers-create-wrapper file-executable-p (url))
 230
 231 (if (featurep 'xemacs)
 232     (progn
 233       ;; XEmacs specific prototypes
 234       (url-handlers-create-wrapper
 235        directory-files (url &optional full match nosort files-only))
 236       (url-handlers-create-wrapper
 237        file-truename (url &optional default)))
 238   ;; Emacs specific prototypes
 239   (url-handlers-create-wrapper
 240    directory-files (url &optional full match nosort))
 241   (url-handlers-create-wrapper
 242    file-truename (url &optional counter prev-dirs)))
 243
 244 (add-hook 'find-file-hooks 'url-handlers-set-buffer-mode)
 245
 246 (defun url-handlers-set-buffer-mode ()
 247   "Set correct modes for the current buffer if visiting a remote file."
 248   (and (stringp buffer-file-name)
 249        (string-match url-handler-regexp buffer-file-name)
 250        (auto-save-mode 0)))
 251
 252 (provide 'url-handlers)
 253
 254 ;;; arch-tag: 7300b99c-cc83-42ff-9147-79b2723c62ac