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
  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 ;; Fixme: customize? convert-standard-filename?
  50 ;;;###autoload
  51 (defvar url-configuration-directory "~/.url")
  52
  53 (defun url-do-setup ()
  54   "Setup the url package.
  55 This is to avoid conflict with user settings if URL is dumped with
  56 Emacs."
  57   (unless url-setup-done
  58
  59     ;; Make OS/2 happy
  60     ;;(push '("http" "80") tcp-binary-process-input-services)
  61
  62     (mailcap-parse-mailcaps)
  63     (mailcap-parse-mimetypes)
  64
  65     ;; Register all the authentication schemes we can handle
  66     (url-register-auth-scheme "basic" nil 4)
  67     (url-register-auth-scheme "digest" nil 7)
  68
  69     (setq url-cookie-file
  70           (or url-cookie-file
  71               (expand-file-name "cookies" url-configuration-directory)))
  72
  73     (setq url-history-file
  74           (or url-history-file
  75               (expand-file-name "history" url-configuration-directory)))
  76
  77     ;; Parse the global history file if it exists, so that it can be used
  78     ;; for URL completion, etc.
  79     (url-history-parse-history)
  80     (url-history-setup-save-timer)
  81
  82     ;; Ditto for cookies
  83     (url-cookie-setup-save-timer)
  84     (url-cookie-parse-file url-cookie-file)
  85
  86     ;; Read in proxy gateways
  87     (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services))
  88                         (or (getenv "NO_PROXY")
  89                             (getenv "no_PROXY")
  90                             (getenv "no_proxy")))))
  91       (if noproxy
  92           (setq url-proxy-services
  93                 (cons (cons "no_proxy"
  94                             (concat "\\("
  95                                     (mapconcat
  96                                      (lambda (x)
  97                                        (cond
  98                                         ((= x ?,) "\\|")
  99                                         ((= x ? ) "")
 100                                         ((= x ?.) (regexp-quote "."))
 101                                         ((= x ?*) ".*")
 102                                         ((= x ??) ".")
 103                                         (t (char-to-string x))))
 104                                      noproxy "") "\\)"))
 105                       url-proxy-services))))
 106
 107     (url-setup-privacy-info)
 108     (run-hooks 'url-load-hook)
 109     (setq url-setup-done t)))
 110
 111 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 112 ;;; Retrieval functions
 113 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 114 (defun url-retrieve (url callback &optional cbargs)
 115   "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
 116 URL is either a string or a parsed URL.
 117
 118 CALLBACK is called when the object has been completely retrieved, with
 119 the current buffer containing the object, and any MIME headers associated
 120 with it.  Normally it gets the arguments in the list CBARGS.
 121 However, if what we find is a redirect, CALLBACK is given
 122 two additional args, `:redirect' and the redirected URL,
 123 followed by CBARGS.
 124
 125 Return the buffer URL will load into, or nil if the process has
 126 already completed."
 127   (url-do-setup)
 128   (url-gc-dead-buffers)
 129   (if (stringp url)
 130        (set-text-properties 0 (length url) nil url))
 131   (if (not (vectorp url))
 132       (setq url (url-generic-parse-url url)))
 133   (if (not (functionp callback))
 134       (error "Must provide a callback function to url-retrieve"))
 135   (unless (url-type url)
 136     (error "Bad url: %s" (url-recreate-url url)))
 137   (let ((loader (url-scheme-get-property (url-type url) 'loader))
 138         (url-using-proxy (if (url-host url)
 139                              (url-find-proxy-for-url url (url-host url))))
 140         (buffer nil)
 141         (asynch (url-scheme-get-property (url-type url) 'asynchronous-p)))
 142     (if url-using-proxy
 143         (setq asynch t
 144               loader 'url-proxy))
 145     (if asynch
 146         (setq buffer (funcall loader url callback cbargs))
 147       (setq buffer (funcall loader url))
 148       (if buffer
 149           (with-current-buffer buffer
 150             (apply callback cbargs))))
 151     (url-history-update-url url (current-time))
 152     buffer))
 153
 154 (defun url-retrieve-synchronously (url)
 155   "Retrieve URL synchronously.
 156 Return the buffer containing the data, or nil if there are no data
 157 associated with it (the case for dired, info, or mailto URLs that need
 158 no further processing).  URL is either a string or a parsed URL."
 159   (url-do-setup)
 160
 161   (lexical-let ((retrieval-done nil)
 162                 (asynch-buffer nil))
 163     (setq asynch-buffer
 164           (url-retrieve url (lambda (&rest ignored)
 165                               (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer))
 166                               (setq retrieval-done t
 167                                     asynch-buffer (current-buffer)))))
 168     (if (null asynch-buffer)
 169         ;; We do not need to do anything, it was a mailto or something
 170         ;; similar that takes processing completely outside of the URL
 171         ;; package.
 172         nil
 173       (let ((proc (get-buffer-process asynch-buffer)))
 174         ;; If the access method was synchronous, `retrieval-done' should
 175         ;; hopefully already be set to t.  If it is nil, and `proc' is also
 176         ;; nil, it implies that the async process is not running in
 177         ;; asynch-buffer.  This happens e.g. for FTP files.  In such a case
 178         ;; url-file.el should probably set something like a `url-process'
 179         ;; buffer-local variable so we can find the exact process that we
 180         ;; should be waiting for.  In the mean time, we'll just wait for any
 181         ;; process output.
 182         (while (not retrieval-done)
 183           (url-debug 'retrieval
 184                      "Spinning in url-retrieve-synchronously: %S (%S)"
 185                      retrieval-done asynch-buffer)
 186           (if (and proc (memq (process-status proc)
 187                               '(closed exit signal failed)))
 188               ;; FIXME: It's not clear whether url-retrieve's callback is
 189               ;; guaranteed to be called or not.  It seems that url-http
 190               ;; decides sometimes consciously not to call it, so it's not
 191               ;; clear that it's a bug, but even if we need to decide how
 192               ;; url-http can then warn us that the download has completed.
 193               ;; In the mean time, we use this here workaround.
 194               (setq retrieval-done t)
 195             ;; We used to use `sit-for' here, but in some cases it wouldn't
 196             ;; work because apparently pending keyboard input would always
 197             ;; interrupt it before it got a chance to handle process input.
 198             ;; `sleep-for' was tried but it lead to other forms of
 199             ;; hanging.  --Stef
 200             (unless (or (accept-process-output proc) (null proc))
 201               ;; accept-process-output returned nil, maybe because the process
 202               ;; exited (and may have been replaced with another).
 203               (setq proc (get-buffer-process asynch-buffer))))))
 204       asynch-buffer)))
 205
 206 (defun url-mm-callback (&rest ignored)
 207   (let ((handle (mm-dissect-buffer t)))
 208     (url-mark-buffer-as-dead (current-buffer))
 209     (with-current-buffer
 210         (generate-new-buffer (url-recreate-url url-current-object))
 211       (if (eq (mm-display-part handle) 'external)
 212           (progn
 213             (set-process-sentinel
 214              ;; Fixme: this shouldn't have to know the form of the
 215              ;; undisplayer produced by `mm-display-part'.
 216              (get-buffer-process (cdr (mm-handle-undisplayer handle)))
 217              `(lambda (proc event)
 218                 (mm-destroy-parts (quote ,handle))))
 219             (message "Viewing externally")
 220             (kill-buffer (current-buffer)))
 221         (display-buffer (current-buffer))
 222         (add-hook 'kill-buffer-hook
 223                   `(lambda () (mm-destroy-parts ',handle))
 224                   nil
 225                   t)))))
 226
 227 (defun url-mm-url (url)
 228   "Retrieve URL and pass to the appropriate viewing application."
 229   ;; These requires could advantageously be moved to url-mm-callback or
 230   ;; turned into autoloads, but I suspect that it would introduce some bugs
 231   ;; because loading those files from a process sentinel or filter may
 232   ;; result in some undesirable carner cases.
 233   (require 'mm-decode)
 234   (require 'mm-view)
 235   (url-retrieve url 'url-mm-callback nil))
 236
 237 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 238 ;;; Miscellaneous
 239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 240 (defvar url-dead-buffer-list nil)
 241
 242 (defun url-mark-buffer-as-dead (buff)
 243   (push buff url-dead-buffer-list))
 244
 245 (defun url-gc-dead-buffers ()
 246   (let ((buff))
 247     (while (setq buff (pop url-dead-buffer-list))
 248       (if (buffer-live-p buff)
 249           (kill-buffer buff)))))
 250
 251 (cond
 252  ((fboundp 'display-warning)
 253   (defalias 'url-warn 'display-warning))
 254  ((fboundp 'warn)
 255   (defun url-warn (class message &optional level)
 256     (warn "(%s/%s) %s" class (or level 'warning) message)))
 257  (t
 258   (defun url-warn (class message &optional level)
 259     (with-current-buffer (get-buffer-create "*URL-WARNINGS*")
 260       (goto-char (point-max))
 261       (save-excursion
 262         (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
 263       (display-buffer (current-buffer))))))
 264
 265 (provide 'url)
 266
 267 ;; arch-tag: bc182f1f-d187-4f10-b961-47af2066579a
 268 ;;; url.el ends here