Regenerate ldefs-boot.el.
[emacs.git] / lisp / url / url.el
blob9f47e104043b466231b6a8485f1ad60266ca6ae9
1 ;;; url.el --- Uniform Resource Locator retrieval tool
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004,
4 ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Author: Bill Perry <wmperry@gnu.org>
7 ;; Keywords: comm, data, processes, hypermedia
9 ;; 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 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
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.
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/>.
24 ;;; Commentary:
26 ;; Registered URI schemes: http://www.iana.org/assignments/uri-schemes
28 ;;; Code:
30 (eval-when-compile (require 'cl))
32 (eval-when-compile
33 (require 'mm-decode)
34 (require 'mm-view))
36 (require 'mailcap)
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)
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)
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
60 ;; Make OS/2 happy
61 ;;(push '("http" "80") tcp-binary-process-input-services)
63 (mailcap-parse-mailcaps)
64 (mailcap-parse-mimetypes)
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)
70 (setq url-cookie-file
71 (or url-cookie-file
72 (expand-file-name "cookies" url-configuration-directory)))
74 (setq url-history-file
75 (or url-history-file
76 (expand-file-name "history" url-configuration-directory)))
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)
83 ;; Ditto for cookies
84 (url-cookie-setup-save-timer)
85 (url-cookie-parse-file url-cookie-file)
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))))
108 (url-setup-privacy-info)
109 (run-hooks 'url-load-hook)
110 (setq url-setup-done t)))
112 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
113 ;;; Retrieval functions
114 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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.")
122 ;;;###autoload
123 (defun url-retrieve (url callback &optional cbargs)
124 "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
125 URL is either a string or a parsed URL.
127 CALLBACK is called when the object has been completely retrieved, with
128 the current buffer containing the object, and any MIME headers associated
129 with it. It is called as (apply CALLBACK STATUS CBARGS).
130 STATUS is a list with an even number of elements representing
131 what happened during the request, with most recent events first,
132 or an empty list if no events have occurred. Each pair is one of:
134 \(:redirect REDIRECTED-TO) - the request was redirected to this URL
135 \(:error (ERROR-SYMBOL . DATA)) - an error occurred. The error can be
136 signaled with (signal ERROR-SYMBOL DATA).
138 Return the buffer URL will load into, or nil if the process has
139 already completed (i.e. URL was a mailto URL or similar; in this case
140 the callback is not called).
142 The variables `url-request-data', `url-request-method' and
143 `url-request-extra-headers' can be dynamically bound around the
144 request; dynamic binding of other variables doesn't necessarily
145 take effect."
146 ;;; XXX: There is code in Emacs that does dynamic binding
147 ;;; of the following variables around url-retrieve:
148 ;;; url-standalone-mode, url-gateway-unplugged, w3-honor-stylesheets,
149 ;;; url-confirmation-func, url-cookie-multiple-line,
150 ;;; url-cookie-{{,secure-}storage,confirmation}
151 ;;; url-standalone-mode and url-gateway-unplugged should work as
152 ;;; usual. url-confirmation-func is only used in nnwarchive.el and
153 ;;; webmail.el; the latter should be updated. Is
154 ;;; url-cookie-multiple-line needed anymore? The other url-cookie-*
155 ;;; are (for now) only used in synchronous retrievals.
156 (url-retrieve-internal url callback (cons nil cbargs)))
158 (defun url-retrieve-internal (url callback cbargs)
159 "Internal function; external interface is `url-retrieve'.
160 CBARGS is what the callback will actually receive - the first item is
161 the list of events, as described in the docstring of `url-retrieve'."
162 (url-do-setup)
163 (url-gc-dead-buffers)
164 (if (stringp url)
165 (set-text-properties 0 (length url) nil url))
166 (if (not (vectorp url))
167 (setq url (url-generic-parse-url url)))
168 (if (not (functionp callback))
169 (error "Must provide a callback function to url-retrieve"))
170 (unless (url-type url)
171 (error "Bad url: %s" (url-recreate-url url)))
172 (let ((loader (url-scheme-get-property (url-type url) 'loader))
173 (url-using-proxy (if (url-host url)
174 (url-find-proxy-for-url url (url-host url))))
175 (buffer nil)
176 (asynch (url-scheme-get-property (url-type url) 'asynchronous-p)))
177 (if url-using-proxy
178 (setq asynch t
179 loader 'url-proxy))
180 (if asynch
181 (setq buffer (funcall loader url callback cbargs))
182 (setq buffer (funcall loader url))
183 (if buffer
184 (with-current-buffer buffer
185 (apply callback cbargs))))
186 (if url-history-track
187 (url-history-update-url url (current-time)))
188 buffer))
190 ;;;###autoload
191 (defun url-retrieve-synchronously (url)
192 "Retrieve URL synchronously.
193 Return the buffer containing the data, or nil if there are no data
194 associated with it (the case for dired, info, or mailto URLs that need
195 no further processing). URL is either a string or a parsed URL."
196 (url-do-setup)
198 (lexical-let ((retrieval-done nil)
199 (asynch-buffer nil))
200 (setq asynch-buffer
201 (url-retrieve url (lambda (&rest ignored)
202 (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer))
203 (setq retrieval-done t
204 asynch-buffer (current-buffer)))))
205 (if (null asynch-buffer)
206 ;; We do not need to do anything, it was a mailto or something
207 ;; similar that takes processing completely outside of the URL
208 ;; package.
210 (let ((proc (get-buffer-process asynch-buffer)))
211 ;; If the access method was synchronous, `retrieval-done' should
212 ;; hopefully already be set to t. If it is nil, and `proc' is also
213 ;; nil, it implies that the async process is not running in
214 ;; asynch-buffer. This happens e.g. for FTP files. In such a case
215 ;; url-file.el should probably set something like a `url-process'
216 ;; buffer-local variable so we can find the exact process that we
217 ;; should be waiting for. In the mean time, we'll just wait for any
218 ;; process output.
219 (while (not retrieval-done)
220 (url-debug 'retrieval
221 "Spinning in url-retrieve-synchronously: %S (%S)"
222 retrieval-done asynch-buffer)
223 (if (buffer-local-value 'url-redirect-buffer asynch-buffer)
224 (setq proc (get-buffer-process
225 (setq asynch-buffer
226 (buffer-local-value 'url-redirect-buffer
227 asynch-buffer))))
228 (if (and proc (memq (process-status proc)
229 '(closed exit signal failed))
230 ;; Make sure another process hasn't been started.
231 (eq proc (or (get-buffer-process asynch-buffer) proc)))
232 ;; FIXME: It's not clear whether url-retrieve's callback is
233 ;; guaranteed to be called or not. It seems that url-http
234 ;; decides sometimes consciously not to call it, so it's not
235 ;; clear that it's a bug, but even then we need to decide how
236 ;; url-http can then warn us that the download has completed.
237 ;; In the mean time, we use this here workaround.
238 ;; XXX: The callback must always be called. Any
239 ;; exception is a bug that should be fixed, not worked
240 ;; around.
241 (progn ;; Call delete-process so we run any sentinel now.
242 (delete-process proc)
243 (setq retrieval-done t)))
244 ;; We used to use `sit-for' here, but in some cases it wouldn't
245 ;; work because apparently pending keyboard input would always
246 ;; interrupt it before it got a chance to handle process input.
247 ;; `sleep-for' was tried but it lead to other forms of
248 ;; hanging. --Stef
249 (unless (or (with-local-quit
250 (accept-process-output proc))
251 (null proc))
252 ;; accept-process-output returned nil, maybe because the process
253 ;; exited (and may have been replaced with another). If we got
254 ;; a quit, just stop.
255 (when quit-flag
256 (delete-process proc))
257 (setq proc (and (not quit-flag)
258 (get-buffer-process asynch-buffer)))))))
259 asynch-buffer)))
261 (defun url-mm-callback (&rest ignored)
262 (let ((handle (mm-dissect-buffer t)))
263 (url-mark-buffer-as-dead (current-buffer))
264 (with-current-buffer
265 (generate-new-buffer (url-recreate-url url-current-object))
266 (if (eq (mm-display-part handle) 'external)
267 (progn
268 (set-process-sentinel
269 ;; Fixme: this shouldn't have to know the form of the
270 ;; undisplayer produced by `mm-display-part'.
271 (get-buffer-process (cdr (mm-handle-undisplayer handle)))
272 `(lambda (proc event)
273 (mm-destroy-parts (quote ,handle))))
274 (message "Viewing externally")
275 (kill-buffer (current-buffer)))
276 (display-buffer (current-buffer))
277 (add-hook 'kill-buffer-hook
278 `(lambda () (mm-destroy-parts ',handle))
280 t)))))
282 (defun url-mm-url (url)
283 "Retrieve URL and pass to the appropriate viewing application."
284 ;; These requires could advantageously be moved to url-mm-callback or
285 ;; turned into autoloads, but I suspect that it would introduce some bugs
286 ;; because loading those files from a process sentinel or filter may
287 ;; result in some undesirable carner cases.
288 (require 'mm-decode)
289 (require 'mm-view)
290 (url-retrieve url 'url-mm-callback nil))
292 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
293 ;;; Miscellaneous
294 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
295 (defvar url-dead-buffer-list nil)
297 (defun url-mark-buffer-as-dead (buff)
298 (push buff url-dead-buffer-list))
300 (defun url-gc-dead-buffers ()
301 (let ((buff))
302 (while (setq buff (pop url-dead-buffer-list))
303 (if (buffer-live-p buff)
304 (kill-buffer buff)))))
306 (cond
307 ((fboundp 'display-warning)
308 (defalias 'url-warn 'display-warning))
309 ((fboundp 'warn)
310 (defun url-warn (class message &optional level)
311 (warn "(%s/%s) %s" class (or level 'warning) message)))
313 (defun url-warn (class message &optional level)
314 (with-current-buffer (get-buffer-create "*URL-WARNINGS*")
315 (goto-char (point-max))
316 (save-excursion
317 (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
318 (display-buffer (current-buffer))))))
320 (provide 'url)
322 ;; arch-tag: bc182f1f-d187-4f10-b961-47af2066579a
323 ;;; url.el ends here