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