;;; url.el --- Uniform Resource Locator retrieval tool
+
+;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004,
+;; 2005, 2006, 2007 Free Software Foundation, Inc.
+
;; Author: Bill Perry <wmperry@gnu.org>
;; Keywords: comm, data, processes, hypermedia
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
-;;; Copyright (c) 1996, 97, 98, 99, 2001 Free Software Foundation, Inc.
-;;;
-;;; This file is part of GNU Emacs.
-;;;
-;;; GNU Emacs is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2, or (at your option)
-;;; any later version.
-;;;
-;;; GNU Emacs is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Emacs; see the file COPYING. If not, write to the
-;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;;; Boston, MA 02111-1307, USA.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
;; Registered URI schemes: http://www.iana.org/assignments/uri-schemes
+;;; Code:
+
(eval-when-compile (require 'cl))
-;; Don't require CL at runtime if we can avoid it (Emacs 21).
-;; Otherwise we need it for hashing functions. `puthash' was never
-;; defined in the Emacs 20 cl.el for some reason.
-(if (fboundp 'puthash)
- nil ; internal or CL is loaded
- (defalias 'puthash 'cl-puthash)
- (autoload 'cl-puthash "cl")
- (autoload 'gethash "cl")
- (autoload 'maphash "cl")
- (autoload 'make-hash-table "cl"))
(eval-when-compile
(require 'mm-decode)
(require 'url-parse)
(require 'url-util)
-;; Fixme: customize? convert-standard-filename?
-;;;###autoload
-(defvar url-configuration-directory "~/.url")
+;; Fixme: customize? convert-standard-filename?
+(defvar url-configuration-directory
+ (cond
+ ((file-directory-p "~/.url") "~/.url")
+ ((file-directory-p user-emacs-directory)
+ (concat user-emacs-directory "url"))
+ (t "~/.url")))
(defun url-do-setup ()
"Setup the url package.
(mailcap-parse-mailcaps)
(mailcap-parse-mimetypes)
-
+
;; Register all the authentication schemes we can handle
(url-register-auth-scheme "basic" nil 4)
(url-register-auth-scheme "digest" nil 7)
(setq url-cookie-file
(or url-cookie-file
(expand-file-name "cookies" url-configuration-directory)))
-
+
(setq url-history-file
(or url-history-file
(expand-file-name "history" url-configuration-directory)))
-
+
;; Parse the global history file if it exists, so that it can be used
;; for URL completion, etc.
(url-history-parse-history)
noproxy "") "\\)"))
url-proxy-services))))
- ;; Set the password entry funtion based on user defaults or guess
- ;; based on which remote-file-access package they are using.
- (cond
- (url-passwd-entry-func nil) ; Already been set
- ((fboundp 'read-passwd) ; Use secure password if available
- (setq url-passwd-entry-func 'read-passwd))
- ((or (featurep 'efs) ; Using EFS
- (featurep 'efs-auto)) ; or autoloading efs
- (if (not (fboundp 'read-passwd))
- (autoload 'read-passwd "passwd" "Read in a password" nil))
- (setq url-passwd-entry-func 'read-passwd))
- ((or (featurep 'ange-ftp) ; Using ange-ftp
- (and (boundp 'file-name-handler-alist)
- (not (featurep 'xemacs)))) ; ??
- (setq url-passwd-entry-func 'ange-ftp-read-passwd))
- (t
- (url-warn
- 'security
- "(url-setup): Can't determine how to read passwords, winging it.")))
-
(url-setup-privacy-info)
(run-hooks 'url-load-hook)
(setq url-setup-done t)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Retrieval functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar url-redirect-buffer nil
+ "New buffer into which the retrieval will take place.
+Sometimes while retrieving a URL, the URL library needs to use another buffer
+than the one returned initially by `url-retrieve'. In this case, it sets this
+variable in the original buffer as a forwarding pointer.")
+
+;;;###autoload
(defun url-retrieve (url callback &optional cbargs)
"Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
-The callback is called when the object has been completely retrieved, with
+URL is either a string or a parsed URL.
+
+CALLBACK is called when the object has been completely retrieved, with
the current buffer containing the object, and any MIME headers associated
-with it. URL is either a string or a parsed URL.
+with it. It is called as (apply CALLBACK STATUS CBARGS).
+STATUS is a list with an even number of elements representing
+what happened during the request, with most recent events first,
+or an empty list if no events have occurred. Each pair is one of:
+
+\(:redirect REDIRECTED-TO) - the request was redirected to this URL
+\(:error (ERROR-SYMBOL . DATA)) - an error occurred. The error can be
+signaled with (signal ERROR-SYMBOL DATA).
Return the buffer URL will load into, or nil if the process has
-already completed."
+already completed (i.e. URL was a mailto URL or similar; in this case
+the callback is not called).
+
+The variables `url-request-data', `url-request-method' and
+`url-request-extra-headers' can be dynamically bound around the
+request; dynamic binding of other variables doesn't necessarily
+take effect."
+;;; XXX: There is code in Emacs that does dynamic binding
+;;; of the following variables around url-retrieve:
+;;; url-standalone-mode, url-gateway-unplugged, w3-honor-stylesheets,
+;;; url-confirmation-func, url-cookie-multiple-line,
+;;; url-cookie-{{,secure-}storage,confirmation}
+;;; url-standalone-mode and url-gateway-unplugged should work as
+;;; usual. url-confirmation-func is only used in nnwarchive.el and
+;;; webmail.el; the latter should be updated. Is
+;;; url-cookie-multiple-line needed anymore? The other url-cookie-*
+;;; are (for now) only used in synchronous retrievals.
+ (url-retrieve-internal url callback (cons nil cbargs)))
+
+(defun url-retrieve-internal (url callback cbargs)
+ "Internal function; external interface is `url-retrieve'.
+CBARGS is what the callback will actually receive - the first item is
+the list of events, as described in the docstring of `url-retrieve'."
(url-do-setup)
(url-gc-dead-buffers)
(if (stringp url)
(setq buffer (funcall loader url callback cbargs))
(setq buffer (funcall loader url))
(if buffer
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(apply callback cbargs))))
- (url-history-update-url url (current-time))
+ (if url-history-track
+ (url-history-update-url url (current-time)))
buffer))
+;;;###autoload
(defun url-retrieve-synchronously (url)
"Retrieve URL synchronously.
Return the buffer containing the data, or nil if there are no data
(url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer))
(setq retrieval-done t
asynch-buffer (current-buffer)))))
- (if (not asynch-buffer)
- ;; We do not need to do anything, it was a mailto or something
- ;; similar that takes processing completely outside of the URL
- ;; package.
- nil
- (while (not retrieval-done)
- (url-debug 'retrieval "Spinning in url-retrieve-synchronously: %S (%S)"
- retrieval-done asynch-buffer)
- ;; Quoth monnier:
- ;; It turns out that the problem seems to be that the (sit-for
- ;; 0.1) below doesn't actually process the data: instead it
- ;; returns immediately because there is keyboard input
- ;; waiting, so we end up spinning endlessly waiting for the
- ;; process to finish while not letting it finish.
-
- ;; However, raman claims that it blocks Emacs with Emacspeak
- ;; for unexplained reasons. Put back for his benefit until
- ;; someone can understand it.
- ;; (sleep-for 0.1)
- (sit-for 0.1))
+ (if (null asynch-buffer)
+ ;; We do not need to do anything, it was a mailto or something
+ ;; similar that takes processing completely outside of the URL
+ ;; package.
+ nil
+ (let ((proc (get-buffer-process asynch-buffer)))
+ ;; If the access method was synchronous, `retrieval-done' should
+ ;; hopefully already be set to t. If it is nil, and `proc' is also
+ ;; nil, it implies that the async process is not running in
+ ;; asynch-buffer. This happens e.g. for FTP files. In such a case
+ ;; url-file.el should probably set something like a `url-process'
+ ;; buffer-local variable so we can find the exact process that we
+ ;; should be waiting for. In the mean time, we'll just wait for any
+ ;; process output.
+ (while (not retrieval-done)
+ (url-debug 'retrieval
+ "Spinning in url-retrieve-synchronously: %S (%S)"
+ retrieval-done asynch-buffer)
+ (if (buffer-local-value 'url-redirect-buffer asynch-buffer)
+ (setq proc (get-buffer-process
+ (setq asynch-buffer
+ (buffer-local-value 'url-redirect-buffer
+ asynch-buffer))))
+ (if (and proc (memq (process-status proc)
+ '(closed exit signal failed))
+ ;; Make sure another process hasn't been started.
+ (eq proc (or (get-buffer-process asynch-buffer) proc)))
+ ;; FIXME: It's not clear whether url-retrieve's callback is
+ ;; guaranteed to be called or not. It seems that url-http
+ ;; decides sometimes consciously not to call it, so it's not
+ ;; clear that it's a bug, but even then we need to decide how
+ ;; url-http can then warn us that the download has completed.
+ ;; In the mean time, we use this here workaround.
+ ;; XXX: The callback must always be called. Any
+ ;; exception is a bug that should be fixed, not worked
+ ;; around.
+ (setq retrieval-done t))
+ ;; We used to use `sit-for' here, but in some cases it wouldn't
+ ;; work because apparently pending keyboard input would always
+ ;; interrupt it before it got a chance to handle process input.
+ ;; `sleep-for' was tried but it lead to other forms of
+ ;; hanging. --Stef
+ (unless (or (with-local-quit
+ (accept-process-output proc))
+ (null proc))
+ ;; accept-process-output returned nil, maybe because the process
+ ;; exited (and may have been replaced with another). If we got
+ ;; a quit, just stop.
+ (when quit-flag
+ (delete-process proc))
+ (setq proc (and (not quit-flag)
+ (get-buffer-process asynch-buffer)))))))
asynch-buffer)))
(defun url-mm-callback (&rest ignored)
(let ((handle (mm-dissect-buffer t)))
- (save-excursion
- (url-mark-buffer-as-dead (current-buffer))
- (set-buffer (generate-new-buffer (url-recreate-url url-current-object)))
+ (url-mark-buffer-as-dead (current-buffer))
+ (with-current-buffer
+ (generate-new-buffer (url-recreate-url url-current-object))
(if (eq (mm-display-part handle) 'external)
(progn
(set-process-sentinel
(message "Viewing externally")
(kill-buffer (current-buffer)))
(display-buffer (current-buffer))
- (mm-destroy-parts handle)))))
+ (add-hook 'kill-buffer-hook
+ `(lambda () (mm-destroy-parts ',handle))
+ nil
+ t)))))
(defun url-mm-url (url)
"Retrieve URL and pass to the appropriate viewing application."
+ ;; These requires could advantageously be moved to url-mm-callback or
+ ;; turned into autoloads, but I suspect that it would introduce some bugs
+ ;; because loading those files from a process sentinel or filter may
+ ;; result in some undesirable carner cases.
(require 'mm-decode)
(require 'mm-view)
(url-retrieve url 'url-mm-callback nil))
(warn "(%s/%s) %s" class (or level 'warning) message)))
(t
(defun url-warn (class message &optional level)
- (save-excursion
- (set-buffer (get-buffer-create "*URL-WARNINGS*"))
+ (with-current-buffer (get-buffer-create "*URL-WARNINGS*")
(goto-char (point-max))
(save-excursion
(insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
(provide 'url)
-;;; arch-tag: bc182f1f-d187-4f10-b961-47af2066579a
+;; arch-tag: bc182f1f-d187-4f10-b961-47af2066579a
;;; url.el ends here
HCoop / bpt / emacs.git / blobdiff