]> code.delx.au - gnu-emacs/blob - lisp/url/url.el
Update header and footer.
[gnu-emacs] / lisp / url / url.el
1 ;;; url.el --- Uniform Resource Locator retrieval tool
2
3 ;; Copyright (c) 1996,1997,1998,1999,2001,2004 Free Software Foundation, Inc.
4
5 ;; Author: Bill Perry <wmperry@gnu.org>
6 ;; Keywords: comm, data, processes, hypermedia
7
8 ;; This file is part of GNU Emacs.
9 ;;
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14 ;;
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
19 ;;
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24
25 ;;; Commentary:
26
27 ;; Registered URI schemes: http://www.iana.org/assignments/uri-schemes
28
29 ;;; Code:
30
31 (eval-when-compile (require 'cl))
32 ;; Don't require CL at runtime if we can avoid it (Emacs 21).
33 ;; Otherwise we need it for hashing functions. `puthash' was never
34 ;; defined in the Emacs 20 cl.el for some reason.
35 (if (fboundp 'puthash)
36 nil ; internal or CL is loaded
37 (defalias 'puthash 'cl-puthash)
38 (autoload 'cl-puthash "cl")
39 (autoload 'gethash "cl")
40 (autoload 'maphash "cl")
41 (autoload 'make-hash-table "cl"))
42
43 (eval-when-compile
44 (require 'mm-decode)
45 (require 'mm-view))
46
47 (require 'mailcap)
48 (require 'url-vars)
49 (require 'url-cookie)
50 (require 'url-history)
51 (require 'url-expand)
52 (require 'url-privacy)
53 (require 'url-methods)
54 (require 'url-proxy)
55 (require 'url-parse)
56 (require 'url-util)
57
58 ;; Fixme: customize? convert-standard-filename?
59 ;;;###autoload
60 (defvar url-configuration-directory "~/.url")
61
62 (defun url-do-setup ()
63 "Setup the url package.
64 This is to avoid conflict with user settings if URL is dumped with
65 Emacs."
66 (unless url-setup-done
67
68 ;; Make OS/2 happy
69 ;;(push '("http" "80") tcp-binary-process-input-services)
70
71 (mailcap-parse-mailcaps)
72 (mailcap-parse-mimetypes)
73
74 ;; Register all the authentication schemes we can handle
75 (url-register-auth-scheme "basic" nil 4)
76 (url-register-auth-scheme "digest" nil 7)
77
78 (setq url-cookie-file
79 (or url-cookie-file
80 (expand-file-name "cookies" url-configuration-directory)))
81
82 (setq url-history-file
83 (or url-history-file
84 (expand-file-name "history" url-configuration-directory)))
85
86 ;; Parse the global history file if it exists, so that it can be used
87 ;; for URL completion, etc.
88 (url-history-parse-history)
89 (url-history-setup-save-timer)
90
91 ;; Ditto for cookies
92 (url-cookie-setup-save-timer)
93 (url-cookie-parse-file url-cookie-file)
94
95 ;; Read in proxy gateways
96 (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services))
97 (or (getenv "NO_PROXY")
98 (getenv "no_PROXY")
99 (getenv "no_proxy")))))
100 (if noproxy
101 (setq url-proxy-services
102 (cons (cons "no_proxy"
103 (concat "\\("
104 (mapconcat
105 (lambda (x)
106 (cond
107 ((= x ?,) "\\|")
108 ((= x ? ) "")
109 ((= x ?.) (regexp-quote "."))
110 ((= x ?*) ".*")
111 ((= x ??) ".")
112 (t (char-to-string x))))
113 noproxy "") "\\)"))
114 url-proxy-services))))
115
116 (url-setup-privacy-info)
117 (run-hooks 'url-load-hook)
118 (setq url-setup-done t)))
119
120 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
121 ;;; Retrieval functions
122 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
123 (defun url-retrieve (url callback &optional cbargs)
124 "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
125 The callback is called when the object has been completely retrieved, with
126 the current buffer containing the object, and any MIME headers associated
127 with it. URL is either a string or a parsed URL.
128
129 Return the buffer URL will load into, or nil if the process has
130 already completed."
131 (url-do-setup)
132 (url-gc-dead-buffers)
133 (if (stringp url)
134 (set-text-properties 0 (length url) nil url))
135 (if (not (vectorp url))
136 (setq url (url-generic-parse-url url)))
137 (if (not (functionp callback))
138 (error "Must provide a callback function to url-retrieve"))
139 (unless (url-type url)
140 (error "Bad url: %s" (url-recreate-url url)))
141 (let ((loader (url-scheme-get-property (url-type url) 'loader))
142 (url-using-proxy (if (url-host url)
143 (url-find-proxy-for-url url (url-host url))))
144 (buffer nil)
145 (asynch (url-scheme-get-property (url-type url) 'asynchronous-p)))
146 (if url-using-proxy
147 (setq asynch t
148 loader 'url-proxy))
149 (if asynch
150 (setq buffer (funcall loader url callback cbargs))
151 (setq buffer (funcall loader url))
152 (if buffer
153 (with-current-buffer buffer
154 (apply callback cbargs))))
155 (url-history-update-url url (current-time))
156 buffer))
157
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."
163 (url-do-setup)
164
165 (lexical-let ((retrieval-done nil)
166 (asynch-buffer nil))
167 (setq asynch-buffer
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 (not 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
175 ;; package.
176 nil
177 (while (not retrieval-done)
178 (url-debug 'retrieval "Spinning in url-retrieve-synchronously: %S (%S)"
179 retrieval-done asynch-buffer)
180 ;; Quoth Stef:
181 ;; It turns out that the problem seems to be that the (sit-for
182 ;; 0.1) below doesn't actually process the data: instead it
183 ;; returns immediately because there is keyboard input
184 ;; waiting, so we end up spinning endlessly waiting for the
185 ;; process to finish while not letting it finish.
186
187 ;; However, raman claims that it blocks Emacs with Emacspeak
188 ;; for unexplained reasons. Put back for his benefit until
189 ;; someone can understand it.
190 ;; (sleep-for 0.1)
191 (sit-for 0.1))
192 asynch-buffer)))
193
194 (defun url-mm-callback (&rest ignored)
195 (let ((handle (mm-dissect-buffer t)))
196 (save-excursion
197 (url-mark-buffer-as-dead (current-buffer))
198 (set-buffer (generate-new-buffer (url-recreate-url url-current-object)))
199 (if (eq (mm-display-part handle) 'external)
200 (progn
201 (set-process-sentinel
202 ;; Fixme: this shouldn't have to know the form of the
203 ;; undisplayer produced by `mm-display-part'.
204 (get-buffer-process (cdr (mm-handle-undisplayer handle)))
205 `(lambda (proc event)
206 (mm-destroy-parts (quote ,handle))))
207 (message "Viewing externally")
208 (kill-buffer (current-buffer)))
209 (display-buffer (current-buffer))
210 (mm-destroy-parts handle)))))
211
212 (defun url-mm-url (url)
213 "Retrieve URL and pass to the appropriate viewing application."
214 (require 'mm-decode)
215 (require 'mm-view)
216 (url-retrieve url 'url-mm-callback nil))
217
218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
219 ;;; Miscellaneous
220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
221 (defvar url-dead-buffer-list nil)
222
223 (defun url-mark-buffer-as-dead (buff)
224 (push buff url-dead-buffer-list))
225
226 (defun url-gc-dead-buffers ()
227 (let ((buff))
228 (while (setq buff (pop url-dead-buffer-list))
229 (if (buffer-live-p buff)
230 (kill-buffer buff)))))
231
232 (cond
233 ((fboundp 'display-warning)
234 (defalias 'url-warn 'display-warning))
235 ((fboundp 'warn)
236 (defun url-warn (class message &optional level)
237 (warn "(%s/%s) %s" class (or level 'warning) message)))
238 (t
239 (defun url-warn (class message &optional level)
240 (with-current-buffer (get-buffer-create "*URL-WARNINGS*")
241 (goto-char (point-max))
242 (save-excursion
243 (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
244 (display-buffer (current-buffer))))))
245
246 (provide 'url)
247
248 ;; arch-tag: bc182f1f-d187-4f10-b961-47af2066579a
249 ;;; url.el ends here