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

   1 ;;; url.el --- Uniform Resource Locator retrieval tool
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004,
   4 ;;   2005 Free Software Foundation, Inc.
   5
   6 ;; Author: Bill Perry <wmperry@gnu.org>
   7 ;; Keywords: comm, data, processes, hypermedia
   8
   9 ;; This file is part of GNU Emacs.
  10 ;;
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; Registered URI schemes: http://www.iana.org/assignments/uri-schemes
  29
  30 ;;; Code:
  31
  32 (eval-when-compile (require 'cl))
  33 ;; Don't require CL at runtime if we can avoid it (Emacs 21).
  34 ;; Otherwise we need it for hashing functions.  `puthash' was never
  35 ;; defined in the Emacs 20 cl.el for some reason.
  36 (if (fboundp 'puthash)
  37     nil                                 ; internal or CL is loaded
  38   (defalias 'puthash 'cl-puthash)
  39   (autoload 'cl-puthash "cl")
  40   (autoload 'gethash "cl")
  41   (autoload 'maphash "cl")
  42   (autoload 'make-hash-table "cl"))
  43
  44 (eval-when-compile
  45   (require 'mm-decode)
  46   (require 'mm-view))
  47
  48 (require 'mailcap)
  49 (require 'url-vars)
  50 (require 'url-cookie)
  51 (require 'url-history)
  52 (require 'url-expand)
  53 (require 'url-privacy)
  54 (require 'url-methods)
  55 (require 'url-proxy)
  56 (require 'url-parse)
  57 (require 'url-util)
  58
  59 ;; Fixme: customize? convert-standard-filename?
  60 ;;;###autoload
  61 (defvar url-configuration-directory "~/.url")
  62
  63 (defun url-do-setup ()
  64   "Setup the url package.
  65 This is to avoid conflict with user settings if URL is dumped with
  66 Emacs."
  67   (unless url-setup-done
  68
  69     ;; Make OS/2 happy
  70     ;;(push '("http" "80") tcp-binary-process-input-services)
  71
  72     (mailcap-parse-mailcaps)
  73     (mailcap-parse-mimetypes)
  74
  75     ;; Register all the authentication schemes we can handle
  76     (url-register-auth-scheme "basic" nil 4)
  77     (url-register-auth-scheme "digest" nil 7)
  78
  79     (setq url-cookie-file
  80           (or url-cookie-file
  81               (expand-file-name "cookies" url-configuration-directory)))
  82
  83     (setq url-history-file
  84           (or url-history-file
  85               (expand-file-name "history" url-configuration-directory)))
  86
  87     ;; Parse the global history file if it exists, so that it can be used
  88     ;; for URL completion, etc.
  89     (url-history-parse-history)
  90     (url-history-setup-save-timer)
  91
  92     ;; Ditto for cookies
  93     (url-cookie-setup-save-timer)
  94     (url-cookie-parse-file url-cookie-file)
  95
  96     ;; Read in proxy gateways
  97     (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services))
  98                         (or (getenv "NO_PROXY")
  99                             (getenv "no_PROXY")
 100                             (getenv "no_proxy")))))
 101       (if noproxy
 102           (setq url-proxy-services
 103                 (cons (cons "no_proxy"
 104                             (concat "\\("
 105                                     (mapconcat
 106                                      (lambda (x)
 107                                        (cond
 108                                         ((= x ?,) "\\|")
 109                                         ((= x ? ) "")
 110                                         ((= x ?.) (regexp-quote "."))
 111                                         ((= x ?*) ".*")
 112                                         ((= x ??) ".")
 113                                         (t (char-to-string x))))
 114                                      noproxy "") "\\)"))
 115                       url-proxy-services))))
 116
 117     (url-setup-privacy-info)
 118     (run-hooks 'url-load-hook)
 119     (setq url-setup-done t)))
 120
 121 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 122 ;;; Retrieval functions
 123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 124 (defun url-retrieve (url callback &optional cbargs)
 125   "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
 126 URL is either a string or a parsed URL.
 127
 128 CALLBACK is called when the object has been completely retrieved, with
 129 the current buffer containing the object, and any MIME headers associated
 130 with it.  Normally it gets the arguments in the list CBARGS.
 131 However, if what we find is a redirect, CALLBACK is given
 132 two additional args, `:redirect' and the redirected URL,
 133 followed by CBARGS.
 134
 135 Return the buffer URL will load into, or nil if the process has
 136 already completed."
 137   (url-do-setup)
 138   (url-gc-dead-buffers)
 139   (if (stringp url)
 140        (set-text-properties 0 (length url) nil url))
 141   (if (not (vectorp url))
 142       (setq url (url-generic-parse-url url)))
 143   (if (not (functionp callback))
 144       (error "Must provide a callback function to url-retrieve"))
 145   (unless (url-type url)
 146     (error "Bad url: %s" (url-recreate-url url)))
 147   (let ((loader (url-scheme-get-property (url-type url) 'loader))
 148         (url-using-proxy (if (url-host url)
 149                              (url-find-proxy-for-url url (url-host url))))
 150         (buffer nil)
 151         (asynch (url-scheme-get-property (url-type url) 'asynchronous-p)))
 152     (if url-using-proxy
 153         (setq asynch t
 154               loader 'url-proxy))
 155     (if asynch
 156         (setq buffer (funcall loader url callback cbargs))
 157       (setq buffer (funcall loader url))
 158       (if buffer
 159           (with-current-buffer buffer
 160             (apply callback cbargs))))
 161     (url-history-update-url url (current-time))
 162     buffer))
 163
 164 (defun url-retrieve-synchronously (url)
 165   "Retrieve URL synchronously.
 166 Return the buffer containing the data, or nil if there are no data
 167 associated with it (the case for dired, info, or mailto URLs that need
 168 no further processing).  URL is either a string or a parsed URL."
 169   (url-do-setup)
 170
 171   (lexical-let ((retrieval-done nil)
 172                 (asynch-buffer nil))
 173     (setq asynch-buffer
 174           (url-retrieve url (lambda (&rest ignored)
 175                               (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer))
 176                               (setq retrieval-done t
 177                                     asynch-buffer (current-buffer)))))
 178     (if (null asynch-buffer)
 179         ;; We do not need to do anything, it was a mailto or something
 180         ;; similar that takes processing completely outside of the URL
 181         ;; package.
 182         nil
 183       (let ((proc (get-buffer-process asynch-buffer)))
 184         ;; If the access method was synchronous, `retrieval-done' should
 185         ;; hopefully already be set to t.  If it is nil, and `proc' is also
 186         ;; nil, it implies that the async process is not running in
 187         ;; asynch-buffer.  This happens e.g. for FTP files.  In such a case
 188         ;; url-file.el should probably set something like a `url-process'
 189         ;; buffer-local variable so we can find the exact process that we
 190         ;; should be waiting for.  In the mean time, we'll just wait for any
 191         ;; process output.
 192         (while (not retrieval-done)
 193           (url-debug 'retrieval
 194                      "Spinning in url-retrieve-synchronously: %S (%S)"
 195                      retrieval-done asynch-buffer)
 196           (if (and proc (memq (process-status proc)
 197                               '(closed exit signal failed)))
 198               ;; FIXME: It's not clear whether url-retrieve's callback is
 199               ;; guaranteed to be called or not.  It seems that url-http
 200               ;; decides sometimes consciously not to call it, so it's not
 201               ;; clear that it's a bug, but even if we need to decide how
 202               ;; url-http can then warn us that the download has completed.
 203               ;; In the mean time, we use this here workaround.
 204               (setq retrieval-done t)
 205             ;; We used to use `sit-for' here, but in some cases it wouldn't
 206             ;; work because apparently pending keyboard input would always
 207             ;; interrupt it before it got a chance to handle process input.
 208             ;; `sleep-for' was tried but it lead to other forms of
 209             ;; hanging.  --Stef
 210             (unless (or (accept-process-output proc) (null proc))
 211               ;; accept-process-output returned nil, maybe because the process
 212               ;; exited (and may have been replaced with another).
 213               (setq proc (get-buffer-process asynch-buffer))))))
 214       asynch-buffer)))
 215
 216 (defun url-mm-callback (&rest ignored)
 217   (let ((handle (mm-dissect-buffer t)))
 218     (url-mark-buffer-as-dead (current-buffer))
 219     (with-current-buffer
 220         (generate-new-buffer (url-recreate-url url-current-object))
 221       (if (eq (mm-display-part handle) 'external)
 222           (progn
 223             (set-process-sentinel
 224              ;; Fixme: this shouldn't have to know the form of the
 225              ;; undisplayer produced by `mm-display-part'.
 226              (get-buffer-process (cdr (mm-handle-undisplayer handle)))
 227              `(lambda (proc event)
 228                 (mm-destroy-parts (quote ,handle))))
 229             (message "Viewing externally")
 230             (kill-buffer (current-buffer)))
 231         (display-buffer (current-buffer))
 232         (add-hook 'kill-buffer-hook
 233                   `(lambda () (mm-destroy-parts ',handle))
 234                   nil
 235                   t)))))
 236
 237 (defun url-mm-url (url)
 238   "Retrieve URL and pass to the appropriate viewing application."
 239   (require 'mm-decode)
 240   (require 'mm-view)
 241   (url-retrieve url 'url-mm-callback nil))
 242
 243 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 244 ;;; Miscellaneous
 245 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 246 (defvar url-dead-buffer-list nil)
 247
 248 (defun url-mark-buffer-as-dead (buff)
 249   (push buff url-dead-buffer-list))
 250
 251 (defun url-gc-dead-buffers ()
 252   (let ((buff))
 253     (while (setq buff (pop url-dead-buffer-list))
 254       (if (buffer-live-p buff)
 255           (kill-buffer buff)))))
 256
 257 (cond
 258  ((fboundp 'display-warning)
 259   (defalias 'url-warn 'display-warning))
 260  ((fboundp 'warn)
 261   (defun url-warn (class message &optional level)
 262     (warn "(%s/%s) %s" class (or level 'warning) message)))
 263  (t
 264   (defun url-warn (class message &optional level)
 265     (with-current-buffer (get-buffer-create "*URL-WARNINGS*")
 266       (goto-char (point-max))
 267       (save-excursion
 268         (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
 269       (display-buffer (current-buffer))))))
 270
 271 (provide 'url)
 272
 273 ;; arch-tag: bc182f1f-d187-4f10-b961-47af2066579a
 274 ;;; url.el ends here