url.el 12.2 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, 2006, 2007,
;;   2008, 2009, 2010  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
;; This file is part of GNU Emacs.
;;
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 14 15
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

16 17 18 19
;; 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.
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:
Stefan Monnier's avatar
Stefan Monnier committed
25 26 27

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

28 29
;;; Code:

Stefan Monnier's avatar
Stefan Monnier committed
30 31
(eval-when-compile (require 'cl))

32 33
(require 'mailcap)

Stefan Monnier's avatar
Stefan Monnier committed
34 35 36 37 38 39 40 41 42 43 44 45 46 47
(eval-when-compile
  (require 'mm-decode)
  (require 'mm-view))

(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)

48 49

(defcustom url-configuration-directory
50
  (locate-user-emacs-file "url/" ".url/")
51 52 53
  "Directory used by the URL package for cookies, history, etc."
  :type 'directory
  :group 'url)
Stefan Monnier's avatar
Stefan Monnier committed
54 55

(defun url-do-setup ()
Juanma Barranquero's avatar
Juanma Barranquero committed
56
  "Setup the URL package.
Stefan Monnier's avatar
Stefan Monnier committed
57 58 59 60 61 62 63 64 65
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)
66

Stefan Monnier's avatar
Stefan Monnier committed
67 68 69 70 71 72 73
    ;; 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)))
74

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

Stefan Monnier's avatar
Stefan Monnier committed
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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
116 117 118 119 120 121 122

(defvar url-redirect-buffer nil
  "New buffer into which the retrieval will take place.
Sometimes while retrieving a URL, the URL library needs to use another buffer
than the one returned initially by `url-retrieve'.  In this case, it sets this
variable in the original buffer as a forwarding pointer.")

123
;;;###autoload
124
(defun url-retrieve (url callback &optional cbargs silent)
Stefan Monnier's avatar
Stefan Monnier committed
125
  "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
126 127 128
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
129
the current buffer containing the object, and any MIME headers associated
130 131 132 133
with it.  It is called as (apply CALLBACK STATUS CBARGS).
STATUS is a list with an even number of elements representing
what happened during the request, with most recent events first,
or an empty list if no events have occurred.  Each pair is one of:
134 135 136 137

\(:redirect REDIRECTED-TO) - the request was redirected to this URL
\(:error (ERROR-SYMBOL . DATA)) - an error occurred.  The error can be
signaled with (signal ERROR-SYMBOL DATA).
Stefan Monnier's avatar
Stefan Monnier committed
138 139

Return the buffer URL will load into, or nil if the process has
140 141 142 143 144 145
already completed (i.e. URL was a mailto URL or similar; in this case
the callback is not called).

The variables `url-request-data', `url-request-method' and
`url-request-extra-headers' can be dynamically bound around the
request; dynamic binding of other variables doesn't necessarily
146 147 148
take effect.

If SILENT, then don't message progress reports and the like."
149 150 151 152 153 154 155 156 157 158
;;; XXX: There is code in Emacs that does dynamic binding
;;; of the following variables around url-retrieve:
;;; url-standalone-mode, url-gateway-unplugged, w3-honor-stylesheets,
;;; url-confirmation-func, url-cookie-multiple-line,
;;; url-cookie-{{,secure-}storage,confirmation}
;;; url-standalone-mode and url-gateway-unplugged should work as
;;; usual.  url-confirmation-func is only used in nnwarchive.el and
;;; webmail.el; the latter should be updated.  Is
;;; url-cookie-multiple-line needed anymore?  The other url-cookie-*
;;; are (for now) only used in synchronous retrievals.
159
  (url-retrieve-internal url callback (cons nil cbargs) silent))
160

161
(defun url-retrieve-internal (url callback cbargs &optional silent)
162 163
  "Internal function; external interface is `url-retrieve'.
CBARGS is what the callback will actually receive - the first item is
164 165 166
the list of events, as described in the docstring of `url-retrieve'.

If SILENT, don't message progress reports and the like."
Stefan Monnier's avatar
Stefan Monnier committed
167 168 169 170 171 172 173 174 175 176
  (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)))
177
  (setf (url-silent url) silent)
Stefan Monnier's avatar
Stefan Monnier committed
178 179 180 181 182 183 184 185 186
  (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
187 188
	(let ((url-current-object url))
	  (setq buffer (funcall loader url callback cbargs)))
Stefan Monnier's avatar
Stefan Monnier committed
189 190
      (setq buffer (funcall loader url))
      (if buffer
191
	  (with-current-buffer buffer
Stefan Monnier's avatar
Stefan Monnier committed
192
	    (apply callback cbargs))))
193 194
    (if url-history-track
	(url-history-update-url url (current-time)))
Stefan Monnier's avatar
Stefan Monnier committed
195 196
    buffer))

197
;;;###autoload
Stefan Monnier's avatar
Stefan Monnier committed
198 199 200 201 202 203 204 205 206 207 208 209 210 211
(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)))))
212 213 214 215 216 217 218 219 220 221 222 223 224 225
    (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.
226 227 228 229
	(while (not retrieval-done)
	  (url-debug 'retrieval
		     "Spinning in url-retrieve-synchronously: %S (%S)"
		     retrieval-done asynch-buffer)
230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
          (if (buffer-local-value 'url-redirect-buffer asynch-buffer)
              (setq proc (get-buffer-process
                          (setq asynch-buffer
                                (buffer-local-value 'url-redirect-buffer
                                                    asynch-buffer))))
            (if (and proc (memq (process-status proc)
                                '(closed exit signal failed))
                     ;; Make sure another process hasn't been started.
                     (eq proc (or (get-buffer-process asynch-buffer) proc)))
                ;; 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 then 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.
245 246 247
		;; XXX: The callback must always be called.  Any
		;; exception is a bug that should be fixed, not worked
		;; around.
248 249 250
		(progn ;; Call delete-process so we run any sentinel now.
		  (delete-process proc)
		  (setq retrieval-done t)))
251 252 253 254 255
            ;; 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
256 257 258
            (unless (or (with-local-quit 
			  (accept-process-output proc))
			(null proc))
259
              ;; accept-process-output returned nil, maybe because the process
260 261 262 263 264 265
              ;; exited (and may have been replaced with another).  If we got
	      ;; a quit, just stop.
	      (when quit-flag
		(delete-process proc))
              (setq proc (and (not quit-flag)
			      (get-buffer-process asynch-buffer)))))))
Stefan Monnier's avatar
Stefan Monnier committed
266 267 268 269
      asynch-buffer)))

(defun url-mm-callback (&rest ignored)
  (let ((handle (mm-dissect-buffer t)))
270 271 272
    (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
273 274 275 276 277 278 279 280 281 282 283
      (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))
284
	(add-hook 'kill-buffer-hook
285 286 287
		  `(lambda () (mm-destroy-parts ',handle))
		  nil
		  t)))))
Stefan Monnier's avatar
Stefan Monnier committed
288 289 290

(defun url-mm-url (url)
  "Retrieve URL and pass to the appropriate viewing application."
Stefan Monnier's avatar
Stefan Monnier committed
291 292 293 294
  ;; These requires could advantageously be moved to url-mm-callback or
  ;; turned into autoloads, but I suspect that it would introduce some bugs
  ;; because loading those files from a process sentinel or filter may
  ;; result in some undesirable carner cases.
Stefan Monnier's avatar
Stefan Monnier committed
295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320
  (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)
321
    (with-current-buffer (get-buffer-create "*URL-WARNINGS*")
Stefan Monnier's avatar
Stefan Monnier committed
322 323 324 325 326 327 328
      (goto-char (point-max))
      (save-excursion
	(insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
      (display-buffer (current-buffer))))))

(provide 'url)

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