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, 2006, 2007, 2008  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 3 of the License, or
  14 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Registered URI schemes: http://www.iana.org/assignments/uri-schemes
  27
  28 ;;; Code:
  29
  30 (eval-when-compile (require 'cl))
  31
  32 (eval-when-compile
  33   (require 'mm-decode)
  34   (require 'mm-view))
  35
  36 (require 'mailcap)
  37 (require 'url-vars)
  38 (require 'url-cookie)
  39 (require 'url-history)
  40 (require 'url-expand)
  41 (require 'url-privacy)
  42 (require 'url-methods)
  43 (require 'url-proxy)
  44 (require 'url-parse)
  45 (require 'url-util)
  46
  47
  48 ;; FIXME convert-standard-filename?
  49 (defcustom url-configuration-directory
  50   (if (and (file-directory-p user-emacs-directory)
  51            (not (file-directory-p "~/.url")))
  52       (expand-file-name "url" user-emacs-directory)
  53     "~/.url")
  54   "Directory used by the URL package for cookies, history, etc."
  55   :type 'directory
  56   :group 'url)
  57
  58 (defun url-do-setup ()
  59   "Setup the url package.
  60 This is to avoid conflict with user settings if URL is dumped with
  61 Emacs."
  62   (unless url-setup-done
  63
  64     ;; Make OS/2 happy
  65     ;;(push '("http" "80") tcp-binary-process-input-services)
  66
  67     (mailcap-parse-mailcaps)
  68     (mailcap-parse-mimetypes)
  69
  70     ;; Register all the authentication schemes we can handle
  71     (url-register-auth-scheme "basic" nil 4)
  72     (url-register-auth-scheme "digest" nil 7)
  73
  74     (setq url-cookie-file
  75           (or url-cookie-file
  76               (expand-file-name "cookies" url-configuration-directory)))
  77
  78     (setq url-history-file
  79           (or url-history-file
  80               (expand-file-name "history" url-configuration-directory)))
  81
  82     ;; Parse the global history file if it exists, so that it can be used
  83     ;; for URL completion, etc.
  84     (url-history-parse-history)
  85     (url-history-setup-save-timer)
  86
  87     ;; Ditto for cookies
  88     (url-cookie-setup-save-timer)
  89     (url-cookie-parse-file url-cookie-file)
  90
  91     ;; Read in proxy gateways
  92     (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services))
  93                         (or (getenv "NO_PROXY")
  94                             (getenv "no_PROXY")
  95                             (getenv "no_proxy")))))
  96       (if noproxy
  97           (setq url-proxy-services
  98                 (cons (cons "no_proxy"
  99                             (concat "\\("
 100                                     (mapconcat
 101                                      (lambda (x)
 102                                        (cond
 103                                         ((= x ?,) "\\|")
 104                                         ((= x ? ) "")
 105                                         ((= x ?.) (regexp-quote "."))
 106                                         ((= x ?*) ".*")
 107                                         ((= x ??) ".")
 108                                         (t (char-to-string x))))
 109                                      noproxy "") "\\)"))
 110                       url-proxy-services))))
 111
 112     (url-setup-privacy-info)
 113     (run-hooks 'url-load-hook)
 114     (setq url-setup-done t)))
 115
 116 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 117 ;;; Retrieval functions
 118 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 119
 120 (defvar url-redirect-buffer nil
 121   "New buffer into which the retrieval will take place.
 122 Sometimes while retrieving a URL, the URL library needs to use another buffer
 123 than the one returned initially by `url-retrieve'.  In this case, it sets this
 124 variable in the original buffer as a forwarding pointer.")
 125
 126 ;;;###autoload
 127 (defun url-retrieve (url callback &optional cbargs)
 128   "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
 129 URL is either a string or a parsed URL.
 130
 131 CALLBACK is called when the object has been completely retrieved, with
 132 the current buffer containing the object, and any MIME headers associated
 133 with it.  It is called as (apply CALLBACK STATUS CBARGS).
 134 STATUS is a list with an even number of elements representing
 135 what happened during the request, with most recent events first,
 136 or an empty list if no events have occurred.  Each pair is one of:
 137
 138 \(:redirect REDIRECTED-TO) - the request was redirected to this URL
 139 \(:error (ERROR-SYMBOL . DATA)) - an error occurred.  The error can be
 140 signaled with (signal ERROR-SYMBOL DATA).
 141
 142 Return the buffer URL will load into, or nil if the process has
 143 already completed (i.e. URL was a mailto URL or similar; in this case
 144 the callback is not called).
 145
 146 The variables `url-request-data', `url-request-method' and
 147 `url-request-extra-headers' can be dynamically bound around the
 148 request; dynamic binding of other variables doesn't necessarily
 149 take effect."
 150 ;;; XXX: There is code in Emacs that does dynamic binding
 151 ;;; of the following variables around url-retrieve:
 152 ;;; url-standalone-mode, url-gateway-unplugged, w3-honor-stylesheets,
 153 ;;; url-confirmation-func, url-cookie-multiple-line,
 154 ;;; url-cookie-{{,secure-}storage,confirmation}
 155 ;;; url-standalone-mode and url-gateway-unplugged should work as
 156 ;;; usual.  url-confirmation-func is only used in nnwarchive.el and
 157 ;;; webmail.el; the latter should be updated.  Is
 158 ;;; url-cookie-multiple-line needed anymore?  The other url-cookie-*
 159 ;;; are (for now) only used in synchronous retrievals.
 160   (url-retrieve-internal url callback (cons nil cbargs)))
 161
 162 (defun url-retrieve-internal (url callback cbargs)
 163   "Internal function; external interface is `url-retrieve'.
 164 CBARGS is what the callback will actually receive - the first item is
 165 the list of events, as described in the docstring of `url-retrieve'."
 166   (url-do-setup)
 167   (url-gc-dead-buffers)
 168   (if (stringp url)
 169        (set-text-properties 0 (length url) nil url))
 170   (if (not (vectorp url))
 171       (setq url (url-generic-parse-url url)))
 172   (if (not (functionp callback))
 173       (error "Must provide a callback function to url-retrieve"))
 174   (unless (url-type url)
 175     (error "Bad url: %s" (url-recreate-url url)))
 176   (let ((loader (url-scheme-get-property (url-type url) 'loader))
 177         (url-using-proxy (if (url-host url)
 178                              (url-find-proxy-for-url url (url-host url))))
 179         (buffer nil)
 180         (asynch (url-scheme-get-property (url-type url) 'asynchronous-p)))
 181     (if url-using-proxy
 182         (setq asynch t
 183               loader 'url-proxy))
 184     (if asynch
 185         (setq buffer (funcall loader url callback cbargs))
 186       (setq buffer (funcall loader url))
 187       (if buffer
 188           (with-current-buffer buffer
 189             (apply callback cbargs))))
 190     (if url-history-track
 191         (url-history-update-url url (current-time)))
 192     buffer))
 193
 194 ;;;###autoload
 195 (defun url-retrieve-synchronously (url)
 196   "Retrieve URL synchronously.
 197 Return the buffer containing the data, or nil if there are no data
 198 associated with it (the case for dired, info, or mailto URLs that need
 199 no further processing).  URL is either a string or a parsed URL."
 200   (url-do-setup)
 201
 202   (lexical-let ((retrieval-done nil)
 203                 (asynch-buffer nil))
 204     (setq asynch-buffer
 205           (url-retrieve url (lambda (&rest ignored)
 206                               (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer))
 207                               (setq retrieval-done t
 208                                     asynch-buffer (current-buffer)))))
 209     (if (null asynch-buffer)
 210         ;; We do not need to do anything, it was a mailto or something
 211         ;; similar that takes processing completely outside of the URL
 212         ;; package.
 213         nil
 214       (let ((proc (get-buffer-process asynch-buffer)))
 215         ;; If the access method was synchronous, `retrieval-done' should
 216         ;; hopefully already be set to t.  If it is nil, and `proc' is also
 217         ;; nil, it implies that the async process is not running in
 218         ;; asynch-buffer.  This happens e.g. for FTP files.  In such a case
 219         ;; url-file.el should probably set something like a `url-process'
 220         ;; buffer-local variable so we can find the exact process that we
 221         ;; should be waiting for.  In the mean time, we'll just wait for any
 222         ;; process output.
 223         (while (not retrieval-done)
 224           (url-debug 'retrieval
 225                      "Spinning in url-retrieve-synchronously: %S (%S)"
 226                      retrieval-done asynch-buffer)
 227           (if (buffer-local-value 'url-redirect-buffer asynch-buffer)
 228               (setq proc (get-buffer-process
 229                           (setq asynch-buffer
 230                                 (buffer-local-value 'url-redirect-buffer
 231                                                     asynch-buffer))))
 232             (if (and proc (memq (process-status proc)
 233                                 '(closed exit signal failed))
 234                      ;; Make sure another process hasn't been started.
 235                      (eq proc (or (get-buffer-process asynch-buffer) proc)))
 236                 ;; FIXME: It's not clear whether url-retrieve's callback is
 237                 ;; guaranteed to be called or not.  It seems that url-http
 238                 ;; decides sometimes consciously not to call it, so it's not
 239                 ;; clear that it's a bug, but even then we need to decide how
 240                 ;; url-http can then warn us that the download has completed.
 241                 ;; In the mean time, we use this here workaround.
 242                 ;; XXX: The callback must always be called.  Any
 243                 ;; exception is a bug that should be fixed, not worked
 244                 ;; around.
 245                 (progn ;; Call delete-process so we run any sentinel now.
 246                   (delete-process proc)
 247                   (setq retrieval-done t)))
 248             ;; We used to use `sit-for' here, but in some cases it wouldn't
 249             ;; work because apparently pending keyboard input would always
 250             ;; interrupt it before it got a chance to handle process input.
 251             ;; `sleep-for' was tried but it lead to other forms of
 252             ;; hanging.  --Stef
 253             (unless (or (with-local-quit
 254                           (accept-process-output proc))
 255                         (null proc))
 256               ;; accept-process-output returned nil, maybe because the process
 257               ;; exited (and may have been replaced with another).  If we got
 258               ;; a quit, just stop.
 259               (when quit-flag
 260                 (delete-process proc))
 261               (setq proc (and (not quit-flag)
 262                               (get-buffer-process asynch-buffer)))))))
 263       asynch-buffer)))
 264
 265 (defun url-mm-callback (&rest ignored)
 266   (let ((handle (mm-dissect-buffer t)))
 267     (url-mark-buffer-as-dead (current-buffer))
 268     (with-current-buffer
 269         (generate-new-buffer (url-recreate-url url-current-object))
 270       (if (eq (mm-display-part handle) 'external)
 271           (progn
 272             (set-process-sentinel
 273              ;; Fixme: this shouldn't have to know the form of the
 274              ;; undisplayer produced by `mm-display-part'.
 275              (get-buffer-process (cdr (mm-handle-undisplayer handle)))
 276              `(lambda (proc event)
 277                 (mm-destroy-parts (quote ,handle))))
 278             (message "Viewing externally")
 279             (kill-buffer (current-buffer)))
 280         (display-buffer (current-buffer))
 281         (add-hook 'kill-buffer-hook
 282                   `(lambda () (mm-destroy-parts ',handle))
 283                   nil
 284                   t)))))
 285
 286 (defun url-mm-url (url)
 287   "Retrieve URL and pass to the appropriate viewing application."
 288   ;; These requires could advantageously be moved to url-mm-callback or
 289   ;; turned into autoloads, but I suspect that it would introduce some bugs
 290   ;; because loading those files from a process sentinel or filter may
 291   ;; result in some undesirable carner cases.
 292   (require 'mm-decode)
 293   (require 'mm-view)
 294   (url-retrieve url 'url-mm-callback nil))
 295
 296 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 297 ;;; Miscellaneous
 298 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 299 (defvar url-dead-buffer-list nil)
 300
 301 (defun url-mark-buffer-as-dead (buff)
 302   (push buff url-dead-buffer-list))
 303
 304 (defun url-gc-dead-buffers ()
 305   (let ((buff))
 306     (while (setq buff (pop url-dead-buffer-list))
 307       (if (buffer-live-p buff)
 308           (kill-buffer buff)))))
 309
 310 (cond
 311  ((fboundp 'display-warning)
 312   (defalias 'url-warn 'display-warning))
 313  ((fboundp 'warn)
 314   (defun url-warn (class message &optional level)
 315     (warn "(%s/%s) %s" class (or level 'warning) message)))
 316  (t
 317   (defun url-warn (class message &optional level)
 318     (with-current-buffer (get-buffer-create "*URL-WARNINGS*")
 319       (goto-char (point-max))
 320       (save-excursion
 321         (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
 322       (display-buffer (current-buffer))))))
 323
 324 (provide 'url)
 325
 326 ;; arch-tag: bc182f1f-d187-4f10-b961-47af2066579a
 327 ;;; url.el ends here