url.el 9.18 KB
Newer Older
Stefan Monnier's avatar
Stefan Monnier committed
1
;;; url.el --- Uniform Resource Locator retrieval tool
2

3 4
;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004,
;;   2005 Free Software Foundation, Inc.
5

Stefan Monnier's avatar
Stefan Monnier committed
6 7 8
;; Author: Bill Perry <wmperry@gnu.org>
;; Keywords: comm, data, processes, hypermedia

9 10 11 12 13 14 15 16 17 18 19 20 21 22
;; This file is part of GNU Emacs.
;;
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
Lute Kamstra's avatar
Lute Kamstra committed
23 24
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
25 26

;;; Commentary:
Stefan Monnier's avatar
Stefan Monnier committed
27 28 29

;; Registered URI schemes: http://www.iana.org/assignments/uri-schemes

30 31
;;; Code:

Stefan Monnier's avatar
Stefan Monnier committed
32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48
(eval-when-compile (require 'cl))

(eval-when-compile
  (require 'mm-decode)
  (require 'mm-view))

(require 'mailcap)
(require 'url-vars)
(require 'url-cookie)
(require 'url-history)
(require 'url-expand)
(require 'url-privacy)
(require 'url-methods)
(require 'url-proxy)
(require 'url-parse)
(require 'url-util)

49
;; Fixme: customize? convert-standard-filename?
Stefan Monnier's avatar
Stefan Monnier committed
50 51 52 53 54 55 56 57 58 59 60 61 62 63
;;;###autoload
(defvar url-configuration-directory "~/.url")

(defun url-do-setup ()
  "Setup the url package.
This is to avoid conflict with user settings if URL is dumped with
Emacs."
  (unless url-setup-done

    ;; Make OS/2 happy
    ;;(push '("http" "80") tcp-binary-process-input-services)

    (mailcap-parse-mailcaps)
    (mailcap-parse-mimetypes)
64

Stefan Monnier's avatar
Stefan Monnier committed
65 66 67 68 69 70 71
    ;; Register all the authentication schemes we can handle
    (url-register-auth-scheme "basic" nil 4)
    (url-register-auth-scheme "digest" nil 7)

    (setq url-cookie-file
	  (or url-cookie-file
	      (expand-file-name "cookies" url-configuration-directory)))
72

Stefan Monnier's avatar
Stefan Monnier committed
73 74 75
    (setq url-history-file
	  (or url-history-file
	      (expand-file-name "history" url-configuration-directory)))
76

Stefan Monnier's avatar
Stefan Monnier committed
77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115
    ;; Parse the global history file if it exists, so that it can be used
    ;; for URL completion, etc.
    (url-history-parse-history)
    (url-history-setup-save-timer)

    ;; Ditto for cookies
    (url-cookie-setup-save-timer)
    (url-cookie-parse-file url-cookie-file)

    ;; Read in proxy gateways
    (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services))
			(or (getenv "NO_PROXY")
			    (getenv "no_PROXY")
			    (getenv "no_proxy")))))
      (if noproxy
	  (setq url-proxy-services
		(cons (cons "no_proxy"
			    (concat "\\("
				    (mapconcat
				     (lambda (x)
				       (cond
					((= x ?,) "\\|")
					((= x ? ) "")
					((= x ?.) (regexp-quote "."))
					((= x ?*) ".*")
					((= x ??) ".")
					(t (char-to-string x))))
				     noproxy "") "\\)"))
		      url-proxy-services))))

    (url-setup-privacy-info)
    (run-hooks 'url-load-hook)
    (setq url-setup-done t)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Retrieval functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun url-retrieve (url callback &optional cbargs)
  "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
116 117 118
URL is either a string or a parsed URL.

CALLBACK is called when the object has been completely retrieved, with
Stefan Monnier's avatar
Stefan Monnier committed
119
the current buffer containing the object, and any MIME headers associated
120 121 122 123
with it.  Normally it gets the arguments in the list CBARGS.
However, if what we find is a redirect, CALLBACK is given
two additional args, `:redirect' and the redirected URL,
followed by CBARGS.
Stefan Monnier's avatar
Stefan Monnier committed
124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148

Return the buffer URL will load into, or nil if the process has
already completed."
  (url-do-setup)
  (url-gc-dead-buffers)
  (if (stringp url)
       (set-text-properties 0 (length url) nil url))
  (if (not (vectorp url))
      (setq url (url-generic-parse-url url)))
  (if (not (functionp callback))
      (error "Must provide a callback function to url-retrieve"))
  (unless (url-type url)
    (error "Bad url: %s" (url-recreate-url url)))
  (let ((loader (url-scheme-get-property (url-type url) 'loader))
	(url-using-proxy (if (url-host url)
			     (url-find-proxy-for-url url (url-host url))))
	(buffer nil)
	(asynch (url-scheme-get-property (url-type url) 'asynchronous-p)))
    (if url-using-proxy
	(setq asynch t
	      loader 'url-proxy))
    (if asynch
	(setq buffer (funcall loader url callback cbargs))
      (setq buffer (funcall loader url))
      (if buffer
149
	  (with-current-buffer buffer
Stefan Monnier's avatar
Stefan Monnier committed
150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167
	    (apply callback cbargs))))
    (url-history-update-url url (current-time))
    buffer))

(defun url-retrieve-synchronously (url)
  "Retrieve URL synchronously.
Return the buffer containing the data, or nil if there are no data
associated with it (the case for dired, info, or mailto URLs that need
no further processing).  URL is either a string or a parsed URL."
  (url-do-setup)

  (lexical-let ((retrieval-done nil)
		(asynch-buffer nil))
    (setq asynch-buffer
	  (url-retrieve url (lambda (&rest ignored)
			      (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer))
			      (setq retrieval-done t
				    asynch-buffer (current-buffer)))))
168 169 170 171 172 173 174 175 176 177 178 179 180 181
    (if (null asynch-buffer)
        ;; We do not need to do anything, it was a mailto or something
        ;; similar that takes processing completely outside of the URL
        ;; package.
        nil
      (let ((proc (get-buffer-process asynch-buffer)))
	;; If the access method was synchronous, `retrieval-done' should
	;; hopefully already be set to t.  If it is nil, and `proc' is also
	;; nil, it implies that the async process is not running in
	;; asynch-buffer.  This happens e.g. for FTP files.  In such a case
	;; url-file.el should probably set something like a `url-process'
	;; buffer-local variable so we can find the exact process that we
	;; should be waiting for.  In the mean time, we'll just wait for any
	;; process output.
182 183 184 185
	(while (not retrieval-done)
	  (url-debug 'retrieval
		     "Spinning in url-retrieve-synchronously: %S (%S)"
		     retrieval-done asynch-buffer)
186 187
	  (if (and proc (memq (process-status proc)
                              '(closed exit signal failed)))
188 189 190 191 192 193 194 195 196 197 198 199
	      ;; FIXME: It's not clear whether url-retrieve's callback is
	      ;; guaranteed to be called or not.  It seems that url-http
	      ;; decides sometimes consciously not to call it, so it's not
	      ;; clear that it's a bug, but even if we need to decide how
	      ;; url-http can then warn us that the download has completed.
              ;; In the mean time, we use this here workaround.
              (setq retrieval-done t)
            ;; We used to use `sit-for' here, but in some cases it wouldn't
            ;; work because apparently pending keyboard input would always
            ;; interrupt it before it got a chance to handle process input.
            ;; `sleep-for' was tried but it lead to other forms of
            ;; hanging.  --Stef
200
            (unless (or (accept-process-output proc) (null proc))
201 202 203
              ;; accept-process-output returned nil, maybe because the process
              ;; exited (and may have been replaced with another).
              (setq proc (get-buffer-process asynch-buffer))))))
Stefan Monnier's avatar
Stefan Monnier committed
204 205 206 207
      asynch-buffer)))

(defun url-mm-callback (&rest ignored)
  (let ((handle (mm-dissect-buffer t)))
208 209 210
    (url-mark-buffer-as-dead (current-buffer))
    (with-current-buffer
        (generate-new-buffer (url-recreate-url url-current-object))
Stefan Monnier's avatar
Stefan Monnier committed
211 212 213 214 215 216 217 218 219 220 221
      (if (eq (mm-display-part handle) 'external)
	  (progn
	    (set-process-sentinel
	     ;; Fixme: this shouldn't have to know the form of the
	     ;; undisplayer produced by `mm-display-part'.
	     (get-buffer-process (cdr (mm-handle-undisplayer handle)))
	     `(lambda (proc event)
		(mm-destroy-parts (quote ,handle))))
	    (message "Viewing externally")
	    (kill-buffer (current-buffer)))
	(display-buffer (current-buffer))
222
	(add-hook 'kill-buffer-hook
223 224 225
		  `(lambda () (mm-destroy-parts ',handle))
		  nil
		  t)))))
Stefan Monnier's avatar
Stefan Monnier committed
226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254

(defun url-mm-url (url)
  "Retrieve URL and pass to the appropriate viewing application."
  (require 'mm-decode)
  (require 'mm-view)
  (url-retrieve url 'url-mm-callback nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Miscellaneous
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar url-dead-buffer-list nil)

(defun url-mark-buffer-as-dead (buff)
  (push buff url-dead-buffer-list))

(defun url-gc-dead-buffers ()
  (let ((buff))
    (while (setq buff (pop url-dead-buffer-list))
      (if (buffer-live-p buff)
	  (kill-buffer buff)))))

(cond
 ((fboundp 'display-warning)
  (defalias 'url-warn 'display-warning))
 ((fboundp 'warn)
  (defun url-warn (class message &optional level)
    (warn "(%s/%s) %s" class (or level 'warning) message)))
 (t
  (defun url-warn (class message &optional level)
255
    (with-current-buffer (get-buffer-create "*URL-WARNINGS*")
Stefan Monnier's avatar
Stefan Monnier committed
256 257 258 259 260 261 262
      (goto-char (point-max))
      (save-excursion
	(insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
      (display-buffer (current-buffer))))))

(provide 'url)

263
;; arch-tag: bc182f1f-d187-4f10-b961-47af2066579a
Stefan Monnier's avatar
Stefan Monnier committed
264
;;; url.el ends here