1;;; url.el --- Uniform Resource Locator retrieval tool 2 3;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Bill Perry <wmperry@gnu.org> 7;; Keywords: comm, data, processes, hypermedia 8 9;; This file is part of GNU Emacs. 10;; 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) 14;; any later version. 15;; 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. 20;; 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. 25 26;;; Commentary: 27 28;; Registered URI schemes: http://www.iana.org/assignments/uri-schemes 29 30;;; Code: 31 32(eval-when-compile (require 'cl)) 33 34(eval-when-compile 35 (require 'mm-decode) 36 (require 'mm-view)) 37 38(require 'mailcap) 39(require 'url-vars) 40(require 'url-cookie) 41(require 'url-history) 42(require 'url-expand) 43(require 'url-privacy) 44(require 'url-methods) 45(require 'url-proxy) 46(require 'url-parse) 47(require 'url-util) 48 49;; Fixme: customize? convert-standard-filename? 50(defvar url-configuration-directory 51 (cond 52 ((file-directory-p "~/.url") "~/.url") 53 ((file-directory-p "~/.emacs.d") "~/.emacs.d/url") 54 (t "~/.url"))) 55 56(defun url-do-setup () 57 "Setup the url package. 58This is to avoid conflict with user settings if URL is dumped with 59Emacs." 60 (unless url-setup-done 61 62 ;; Make OS/2 happy 63 ;;(push '("http" "80") tcp-binary-process-input-services) 64 65 (mailcap-parse-mailcaps) 66 (mailcap-parse-mimetypes) 67 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) 71 72 (setq url-cookie-file 73 (or url-cookie-file 74 (expand-file-name "cookies" url-configuration-directory))) 75 76 (setq url-history-file 77 (or url-history-file 78 (expand-file-name "history" url-configuration-directory))) 79 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) 84 85 ;; Ditto for cookies 86 (url-cookie-setup-save-timer) 87 (url-cookie-parse-file url-cookie-file) 88 89 ;; Read in proxy gateways 90 (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services)) 91 (or (getenv "NO_PROXY") 92 (getenv "no_PROXY") 93 (getenv "no_proxy"))))) 94 (if noproxy 95 (setq url-proxy-services 96 (cons (cons "no_proxy" 97 (concat "\\(" 98 (mapconcat 99 (lambda (x) 100 (cond 101 ((= x ?,) "\\|") 102 ((= x ? ) "") 103 ((= x ?.) (regexp-quote ".")) 104 ((= x ?*) ".*") 105 ((= x ??) ".") 106 (t (char-to-string x)))) 107 noproxy "") "\\)")) 108 url-proxy-services)))) 109 110 (url-setup-privacy-info) 111 (run-hooks 'url-load-hook) 112 (setq url-setup-done t))) 113 114;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 115;;; Retrieval functions 116;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 117 118(defvar url-redirect-buffer nil 119 "New buffer into which the retrieval will take place. 120Sometimes while retrieving a URL, the URL library needs to use another buffer 121than the one returned initially by `url-retrieve'. In this case, it sets this 122variable in the original buffer as a forwarding pointer.") 123 124;;;###autoload 125(defun url-retrieve (url callback &optional cbargs) 126 "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished. 127URL is either a string or a parsed URL. 128 129CALLBACK is called when the object has been completely retrieved, with 130the current buffer containing the object, and any MIME headers associated 131with it. It is called as (apply CALLBACK STATUS CBARGS). 132STATUS is a list with an even number of elements representing 133what happened during the request, with most recent events first, 134or an empty list if no events have occurred. Each pair is one of: 135 136\(:redirect REDIRECTED-TO) - the request was redirected to this URL 137\(:error (ERROR-SYMBOL . DATA)) - an error occurred. The error can be 138signaled with (signal ERROR-SYMBOL DATA). 139 140Return the buffer URL will load into, or nil if the process has 141already completed (i.e. URL was a mailto URL or similar; in this case 142the callback is not called). 143 144The variables `url-request-data', `url-request-method' and 145`url-request-extra-headers' can be dynamically bound around the 146request; dynamic binding of other variables doesn't necessarily 147take effect." 148;;; XXX: There is code in Emacs that does dynamic binding 149;;; of the following variables around url-retrieve: 150;;; url-standalone-mode, url-gateway-unplugged, w3-honor-stylesheets, 151;;; url-confirmation-func, url-cookie-multiple-line, 152;;; url-cookie-{{,secure-}storage,confirmation} 153;;; url-standalone-mode and url-gateway-unplugged should work as 154;;; usual. url-confirmation-func is only used in nnwarchive.el and 155;;; webmail.el; the latter should be updated. Is 156;;; url-cookie-multiple-line needed anymore? The other url-cookie-* 157;;; are (for now) only used in synchronous retrievals. 158 (url-retrieve-internal url callback (cons nil cbargs))) 159 160(defun url-retrieve-internal (url callback cbargs) 161 "Internal function; external interface is `url-retrieve'. 162CBARGS is what the callback will actually receive - the first item is 163the list of events, as described in the docstring of `url-retrieve'." 164 (url-do-setup) 165 (url-gc-dead-buffers) 166 (if (stringp url) 167 (set-text-properties 0 (length url) nil url)) 168 (if (not (vectorp url)) 169 (setq url (url-generic-parse-url url))) 170 (if (not (functionp callback)) 171 (error "Must provide a callback function to url-retrieve")) 172 (unless (url-type url) 173 (error "Bad url: %s" (url-recreate-url url))) 174 (let ((loader (url-scheme-get-property (url-type url) 'loader)) 175 (url-using-proxy (if (url-host url) 176 (url-find-proxy-for-url url (url-host url)))) 177 (buffer nil) 178 (asynch (url-scheme-get-property (url-type url) 'asynchronous-p))) 179 (if url-using-proxy 180 (setq asynch t 181 loader 'url-proxy)) 182 (if asynch 183 (setq buffer (funcall loader url callback cbargs)) 184 (setq buffer (funcall loader url)) 185 (if buffer 186 (with-current-buffer buffer 187 (apply callback cbargs)))) 188 (if url-history-track 189 (url-history-update-url url (current-time))) 190 buffer)) 191 192;;;###autoload 193(defun url-retrieve-synchronously (url) 194 "Retrieve URL synchronously. 195Return the buffer containing the data, or nil if there are no data 196associated with it (the case for dired, info, or mailto URLs that need 197no further processing). URL is either a string or a parsed URL." 198 (url-do-setup) 199 200 (lexical-let ((retrieval-done nil) 201 (asynch-buffer nil)) 202 (setq asynch-buffer 203 (url-retrieve url (lambda (&rest ignored) 204 (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer)) 205 (setq retrieval-done t 206 asynch-buffer (current-buffer))))) 207 (if (null asynch-buffer) 208 ;; We do not need to do anything, it was a mailto or something 209 ;; similar that takes processing completely outside of the URL 210 ;; package. 211 nil 212 (let ((proc (get-buffer-process asynch-buffer))) 213 ;; If the access method was synchronous, `retrieval-done' should 214 ;; hopefully already be set to t. If it is nil, and `proc' is also 215 ;; nil, it implies that the async process is not running in 216 ;; asynch-buffer. This happens e.g. for FTP files. In such a case 217 ;; url-file.el should probably set something like a `url-process' 218 ;; buffer-local variable so we can find the exact process that we 219 ;; should be waiting for. In the mean time, we'll just wait for any 220 ;; process output. 221 (while (not retrieval-done) 222 (url-debug 'retrieval 223 "Spinning in url-retrieve-synchronously: %S (%S)" 224 retrieval-done asynch-buffer) 225 (if (buffer-local-value 'url-redirect-buffer asynch-buffer) 226 (setq proc (get-buffer-process 227 (setq asynch-buffer 228 (buffer-local-value 'url-redirect-buffer 229 asynch-buffer)))) 230 (if (and proc (memq (process-status proc) 231 '(closed exit signal failed)) 232 ;; Make sure another process hasn't been started. 233 (eq proc (or (get-buffer-process asynch-buffer) proc))) 234 ;; FIXME: It's not clear whether url-retrieve's callback is 235 ;; guaranteed to be called or not. It seems that url-http 236 ;; decides sometimes consciously not to call it, so it's not 237 ;; clear that it's a bug, but even then we need to decide how 238 ;; url-http can then warn us that the download has completed. 239 ;; In the mean time, we use this here workaround. 240 ;; XXX: The callback must always be called. Any 241 ;; exception is a bug that should be fixed, not worked 242 ;; around. 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))) 260 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)) 279 nil 280 t))))) 281 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)) 291 292;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 293;;; Miscellaneous 294;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 295(defvar url-dead-buffer-list nil) 296 297(defun url-mark-buffer-as-dead (buff) 298 (push buff url-dead-buffer-list)) 299 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))))) 305 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))) 312 (t 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)))))) 319 320(provide 'url) 321 322;; arch-tag: bc182f1f-d187-4f10-b961-47af2066579a 323;;; url.el ends here 324