[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] Changes to emacs/lisp/url/url-handlers.el [emacs-unicode-2
From: |
Miles Bader |
Subject: |
[Emacs-diffs] Changes to emacs/lisp/url/url-handlers.el [emacs-unicode-2] |
Date: |
Mon, 28 Jun 2004 04:34:13 -0400 |
Index: emacs/lisp/url/url-handlers.el
diff -c /dev/null emacs/lisp/url/url-handlers.el:1.4.2.1
*** /dev/null Mon Jun 28 07:39:47 2004
--- emacs/lisp/url/url-handlers.el Mon Jun 28 07:30:01 2004
***************
*** 0 ****
--- 1,258 ----
+ ;;; url-handlers.el --- file-name-handler stuff for URL loading
+
+ ;; Copyright (c) 1996,97,98,1999,2004 Free Software Foundation, Inc.
+ ;; Copyright (c) 1993 - 1996 by William M. Perry <address@hidden>
+
+ ;; Keywords: comm, data, processes, hypermedia
+
+ ;; This file is part of GNU Emacs.
+ ;;
+ ;; GNU Emacs is free software; you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation; either version 2, or (at your option)
+ ;; any later version.
+ ;;
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+ ;;
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs; see the file COPYING. If not, write to the
+ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ ;; Boston, MA 02111-1307, USA.
+
+ ;;; Commentary:
+
+ ;;; Code:
+
+ (require 'url)
+ (require 'url-parse)
+ (require 'url-util)
+ (require 'mm-decode)
+ (require 'mailcap)
+
+ (eval-when-compile
+ (require 'cl))
+
+ ;; Implementation status
+ ;; ---------------------
+ ;; Function Status
+ ;; ------------------------------------------------------------
+ ;; add-name-to-file Needs DAV Bindings
+ ;; copy-file Broken (assumes 1st item is URL)
+ ;; delete-directory Finished (DAV)
+ ;; delete-file Finished (DAV)
+ ;; diff-latest-backup-file
+ ;; directory-file-name unnecessary (what about VMS)?
+ ;; directory-files Finished (DAV)
+ ;; dired-call-process
+ ;; dired-compress-file
+ ;; dired-uncache
+ ;; expand-file-name Finished
+ ;; file-accessible-directory-p
+ ;; file-attributes Finished, better with DAV
+ ;; file-directory-p Needs DAV, finished
+ ;; file-executable-p Finished
+ ;; file-exists-p Finished
+ ;; file-local-copy
+ ;; file-modes
+ ;; file-name-all-completions Finished (DAV)
+ ;; file-name-as-directory
+ ;; file-name-completion Finished (DAV)
+ ;; file-name-directory
+ ;; file-name-nondirectory
+ ;; file-name-sans-versions why?
+ ;; file-newer-than-file-p
+ ;; file-ownership-preserved-p No way to know
+ ;; file-readable-p Finished
+ ;; file-regular-p !directory_p
+ ;; file-symlink-p Needs DAV bindings
+ ;; file-truename Needs DAV bindings
+ ;; file-writable-p Check for LOCK?
+ ;; find-backup-file-name why?
+ ;; get-file-buffer why?
+ ;; insert-directory Use DAV
+ ;; insert-file-contents Finished
+ ;; load
+ ;; make-directory Finished (DAV)
+ ;; make-symbolic-link Needs DAV bindings
+ ;; rename-file Finished (DAV)
+ ;; set-file-modes Use mod_dav specific executable flag?
+ ;; set-visited-file-modtime Impossible?
+ ;; shell-command Impossible?
+ ;; unhandled-file-name-directory
+ ;; vc-registered Finished (DAV)
+ ;; verify-visited-file-modtime
+ ;; write-region
+
+ (defvar url-handler-regexp
+ "\\`\\(https?\\|ftp\\|file\\|nfs\\)://"
+ "*A regular expression for matching URLs handled by
file-name-handler-alist.
+ Some valid URL protocols just do not make sense to visit interactively
+ \(about, data, info, irc, mailto, etc\). This regular expression
+ avoids conflicts with local files that look like URLs \(Gnus is
+ particularly bad at this\).")
+
+ ;;;###autoload
+ (define-minor-mode url-handler-mode
+ "Use URL to handle URL-like file names."
+ :global t
+ (if (not (boundp 'file-name-handler-alist))
+ ;; Can't be turned ON anyway.
+ (setq url-handler-mode nil)
+ ;; Remove old entry, if any.
+ (setq file-name-handler-alist
+ (delq (rassq 'url-file-handler file-name-handler-alist)
+ file-name-handler-alist))
+ (if url-handler-mode
+ (push (cons url-handler-regexp 'url-file-handler)
+ file-name-handler-alist))))
+
+ (defun url-run-real-handler (operation args)
+ (let ((inhibit-file-name-handlers (cons 'url-file-handler
+ (if (eq operation
inhibit-file-name-operation)
+ inhibit-file-name-handlers)))
+ (inhibit-file-name-operation operation))
+ (apply operation args)))
+
+ (defun url-file-handler (operation &rest args)
+ "Function called from the `file-name-handler-alist' routines.
+ OPERATION is what needs to be done (`file-exists-p', etc). ARGS are
+ the arguments that would have been passed to OPERATION."
+ (let ((fn (or (get operation 'url-file-handlers)
+ (intern-soft (format "url-%s" operation))))
+ (val nil)
+ (hooked nil))
+ (if (and fn (fboundp fn))
+ (setq hooked t
+ val (apply fn args))
+ (setq hooked nil
+ val (url-run-real-handler operation args)))
+ (url-debug 'handlers "%s %S%S => %S" (if hooked "Hooked" "Real")
+ operation args val)
+ val))
+
+ (defun url-file-handler-identity (&rest args)
+ ;; Identity function
+ (car args))
+
+ ;; These are operations that we can fully support
+ (put 'file-readable-p 'url-file-handlers 'url-file-exists-p)
+ (put 'substitute-in-file-name 'url-file-handlers 'url-file-handler-identity)
+ (put 'file-name-absolute-p 'url-file-handlers (lambda (&rest ignored) t))
+ (put 'expand-file-name 'url-file-handlers 'url-handler-expand-file-name)
+
+ ;; These are operations that we do not support yet (DAV!!!)
+ (put 'file-writable-p 'url-file-handlers 'ignore)
+ (put 'file-symlink-p 'url-file-handlers 'ignore)
+
+ (defun url-handler-expand-file-name (file &optional base)
+ (if (file-name-absolute-p file)
+ (expand-file-name file "/")
+ (url-expand-file-name file base)))
+
+ ;; The actual implementation
+ ;;;###autoload
+ (defun url-copy-file (url newname &optional ok-if-already-exists keep-time)
+ "Copy URL to NEWNAME. Both args must be strings.
+ Signals a `file-already-exists' error if file NEWNAME already exists,
+ unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
+ A number as third arg means request confirmation if NEWNAME already exists.
+ This is what happens in interactive use with M-x.
+ Fourth arg KEEP-TIME non-nil means give the new file the same
+ last-modified time as the old one. (This works on only some systems.)
+ A prefix arg makes KEEP-TIME non-nil."
+ (if (and (file-exists-p newname)
+ (not ok-if-already-exists))
+ (error "Opening output file: File already exists, %s" newname))
+ (let ((buffer (url-retrieve-synchronously url))
+ (handle nil))
+ (if (not buffer)
+ (error "Opening input file: No such file or directory, %s" url))
+ (save-excursion
+ (set-buffer buffer)
+ (setq handle (mm-dissect-buffer t)))
+ (mm-save-part-to-file handle newname)
+ (kill-buffer buffer)
+ (mm-destroy-parts handle)))
+
+ ;;;###autoload
+ (defun url-file-local-copy (url &rest ignored)
+ "Copy URL into a temporary file on this machine.
+ Returns the name of the local copy, or nil, if FILE is directly
+ accessible."
+ (let ((filename (make-temp-name "url")))
+ (url-copy-file url filename)
+ filename))
+
+ ;;;###autoload
+ (defun url-insert-file-contents (url &optional visit beg end replace)
+ (let ((buffer (url-retrieve-synchronously url))
+ (handle nil)
+ (data nil))
+ (if (not buffer)
+ (error "Opening input file: No such file or directory, %s" url))
+ (if visit (setq buffer-file-name url))
+ (save-excursion
+ (set-buffer buffer)
+ (setq handle (mm-dissect-buffer t))
+ (set-buffer (mm-handle-buffer handle))
+ (if beg
+ (setq data (buffer-substring beg end))
+ (setq data (buffer-string))))
+ (kill-buffer buffer)
+ (mm-destroy-parts handle)
+ (if replace (delete-region (point-min) (point-max)))
+ (save-excursion
+ (insert data))
+ (list url (length data))))
+
+ (defun url-file-name-completion (url directory)
+ (error "Unimplemented"))
+
+ (defun url-file-name-all-completions (file directory)
+ (error "Unimplemented"))
+
+ ;; All other handlers map onto their respective backends.
+ (defmacro url-handlers-create-wrapper (method args)
+ `(defun ,(intern (format "url-%s" method)) ,args
+ ,(format "URL file-name-handler wrapper for `%s' call.\n---\n%s" method
+ (or (documentation method t) "No original documentation."))
+ (setq url (url-generic-parse-url url))
+ (when (url-type url)
+ (funcall (url-scheme-get-property (url-type url) (quote ,method))
+ ,@(remove '&rest (remove '&optional args))))))
+
+ (url-handlers-create-wrapper file-exists-p (url))
+ (url-handlers-create-wrapper file-attributes (url &optional id-format))
+ (url-handlers-create-wrapper file-symlink-p (url))
+ (url-handlers-create-wrapper file-writable-p (url))
+ (url-handlers-create-wrapper file-directory-p (url))
+ (url-handlers-create-wrapper file-executable-p (url))
+
+ (if (featurep 'xemacs)
+ (progn
+ ;; XEmacs specific prototypes
+ (url-handlers-create-wrapper
+ directory-files (url &optional full match nosort files-only))
+ (url-handlers-create-wrapper
+ file-truename (url &optional default)))
+ ;; Emacs specific prototypes
+ (url-handlers-create-wrapper
+ directory-files (url &optional full match nosort))
+ (url-handlers-create-wrapper
+ file-truename (url &optional counter prev-dirs)))
+
+ (add-hook 'find-file-hook 'url-handlers-set-buffer-mode)
+
+ (defun url-handlers-set-buffer-mode ()
+ "Set correct modes for the current buffer if visiting a remote file."
+ (and (stringp buffer-file-name)
+ (string-match url-handler-regexp buffer-file-name)
+ (auto-save-mode 0)))
+
+ (provide 'url-handlers)
+
+ ;; arch-tag: 7300b99c-cc83-42ff-9147-79b2723c62ac
+ ;;; url-handlers.el ends here
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] Changes to emacs/lisp/url/url-handlers.el [emacs-unicode-2],
Miles Bader <=