lisp/url/url.el

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