1 ;;; url.el --- Uniform Resource Locator retrieval tool
3 ;; Copyright (c) 1996,97,98,99,2001,2004 Free Software Foundation, Inc.
4 ;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
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., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
28 ;; Registered URI schemes: http://www.iana.org/assignments/uri-schemes
32 (eval-when-compile (require 'cl
))
33 ;; Don't require CL at runtime if we can avoid it (Emacs 21).
34 ;; Otherwise we need it for hashing functions. `puthash' was never
35 ;; defined in the Emacs 20 cl.el for some reason.
36 (if (fboundp 'puthash
)
37 nil
; internal or CL is loaded
38 (defalias 'puthash
'cl-puthash
)
39 (autoload 'cl-puthash
"cl")
40 (autoload 'gethash
"cl")
41 (autoload 'maphash
"cl")
42 (autoload 'make-hash-table
"cl"))
51 (require 'url-history
)
53 (require 'url-privacy
)
54 (require 'url-methods
)
59 ;; Fixme: customize? convert-standard-filename?
61 (defvar url-configuration-directory
"~/.url")
63 (defun url-do-setup ()
64 "Setup the url package.
65 This is to avoid conflict with user settings if URL is dumped with
67 (unless url-setup-done
70 ;;(push '("http" "80") tcp-binary-process-input-services)
72 (mailcap-parse-mailcaps)
73 (mailcap-parse-mimetypes)
75 ;; Register all the authentication schemes we can handle
76 (url-register-auth-scheme "basic" nil
4)
77 (url-register-auth-scheme "digest" nil
7)
81 (expand-file-name "cookies" url-configuration-directory
)))
83 (setq url-history-file
85 (expand-file-name "history" url-configuration-directory
)))
87 ;; Parse the global history file if it exists, so that it can be used
88 ;; for URL completion, etc.
89 (url-history-parse-history)
90 (url-history-setup-save-timer)
93 (url-cookie-setup-save-timer)
94 (url-cookie-parse-file url-cookie-file
)
96 ;; Read in proxy gateways
97 (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services
))
98 (or (getenv "NO_PROXY")
100 (getenv "no_proxy")))))
102 (setq url-proxy-services
103 (cons (cons "no_proxy"
110 ((= x ?.
) (regexp-quote "."))
113 (t (char-to-string x
))))
115 url-proxy-services
))))
117 ;; Set the password entry funtion based on user defaults or guess
118 ;; based on which remote-file-access package they are using.
120 (url-passwd-entry-func nil
) ; Already been set
121 ((fboundp 'read-passwd
) ; Use secure password if available
122 (setq url-passwd-entry-func
'read-passwd
))
123 ((or (featurep 'efs
) ; Using EFS
124 (featurep 'efs-auto
)) ; or autoloading efs
125 (if (not (fboundp 'read-passwd
))
126 (autoload 'read-passwd
"passwd" "Read in a password" nil
))
127 (setq url-passwd-entry-func
'read-passwd
))
128 ((or (featurep 'ange-ftp
) ; Using ange-ftp
129 (and (boundp 'file-name-handler-alist
)
130 (not (featurep 'xemacs
)))) ; ??
131 (setq url-passwd-entry-func
'ange-ftp-read-passwd
))
135 "(url-setup): Can't determine how to read passwords, winging it.")))
137 (url-setup-privacy-info)
138 (run-hooks 'url-load-hook
)
139 (setq url-setup-done t
)))
141 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
142 ;;; Retrieval functions
143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
144 (defun url-retrieve (url callback
&optional cbargs
)
145 "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
146 The callback is called when the object has been completely retrieved, with
147 the current buffer containing the object, and any MIME headers associated
148 with it. URL is either a string or a parsed URL.
150 Return the buffer URL will load into, or nil if the process has
153 (url-gc-dead-buffers)
155 (set-text-properties 0 (length url
) nil url
))
156 (if (not (vectorp url
))
157 (setq url
(url-generic-parse-url url
)))
158 (if (not (functionp callback
))
159 (error "Must provide a callback function to url-retrieve"))
160 (unless (url-type url
)
161 (error "Bad url: %s" (url-recreate-url url
)))
162 (let ((loader (url-scheme-get-property (url-type url
) 'loader
))
163 (url-using-proxy (if (url-host url
)
164 (url-find-proxy-for-url url
(url-host url
))))
166 (asynch (url-scheme-get-property (url-type url
) 'asynchronous-p
)))
171 (setq buffer
(funcall loader url callback cbargs
))
172 (setq buffer
(funcall loader url
))
174 (with-current-buffer buffer
175 (apply callback cbargs
))))
176 (url-history-update-url url
(current-time))
179 (defun url-retrieve-synchronously (url)
180 "Retrieve URL synchronously.
181 Return the buffer containing the data, or nil if there are no data
182 associated with it (the case for dired, info, or mailto URLs that need
183 no further processing). URL is either a string or a parsed URL."
186 (lexical-let ((retrieval-done nil
)
189 (url-retrieve url
(lambda (&rest ignored
)
190 (url-debug 'retrieval
"Synchronous fetching done (%S)" (current-buffer))
191 (setq retrieval-done t
192 asynch-buffer
(current-buffer)))))
193 (if (not asynch-buffer
)
194 ;; We do not need to do anything, it was a mailto or something
195 ;; similar that takes processing completely outside of the URL
198 (while (not retrieval-done
)
199 (url-debug 'retrieval
"Spinning in url-retrieve-synchronously: %S (%S)"
200 retrieval-done asynch-buffer
)
202 ;; It turns out that the problem seems to be that the (sit-for
203 ;; 0.1) below doesn't actually process the data: instead it
204 ;; returns immediately because there is keyboard input
205 ;; waiting, so we end up spinning endlessly waiting for the
206 ;; process to finish while not letting it finish.
208 ;; However, raman claims that it blocks Emacs with Emacspeak
209 ;; for unexplained reasons. Put back for his benefit until
210 ;; someone can understand it.
215 (defun url-mm-callback (&rest ignored
)
216 (let ((handle (mm-dissect-buffer t
)))
218 (url-mark-buffer-as-dead (current-buffer))
219 (set-buffer (generate-new-buffer (url-recreate-url url-current-object
)))
220 (if (eq (mm-display-part handle
) 'external
)
222 (set-process-sentinel
223 ;; Fixme: this shouldn't have to know the form of the
224 ;; undisplayer produced by `mm-display-part'.
225 (get-buffer-process (cdr (mm-handle-undisplayer handle
)))
226 `(lambda (proc event
)
227 (mm-destroy-parts (quote ,handle
))))
228 (message "Viewing externally")
229 (kill-buffer (current-buffer)))
230 (display-buffer (current-buffer))
231 (mm-destroy-parts handle
)))))
233 (defun url-mm-url (url)
234 "Retrieve URL and pass to the appropriate viewing application."
237 (url-retrieve url
'url-mm-callback nil
))
239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
241 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
242 (defvar url-dead-buffer-list nil
)
244 (defun url-mark-buffer-as-dead (buff)
245 (push buff url-dead-buffer-list
))
247 (defun url-gc-dead-buffers ()
249 (while (setq buff
(pop url-dead-buffer-list
))
250 (if (buffer-live-p buff
)
251 (kill-buffer buff
)))))
254 ((fboundp 'display-warning
)
255 (defalias 'url-warn
'display-warning
))
257 (defun url-warn (class message
&optional level
)
258 (warn "(%s/%s) %s" class
(or level
'warning
) message
)))
260 (defun url-warn (class message
&optional level
)
261 (with-current-buffer (get-buffer-create "*URL-WARNINGS*")
262 (goto-char (point-max))
264 (insert (format "(%s/%s) %s\n" class
(or level
'warning
) message
)))
265 (display-buffer (current-buffer))))))
269 ;; arch-tag: bc182f1f-d187-4f10-b961-47af2066579a