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