Mercurial > emacs
view lisp/url/url.el @ 83376:de684325b343
Merged in changes from CVS trunk.
Patches applied:
* lorentey@elte.hu--2004/emacs--cvs-trunk--0--patch-6
Update from CVS
* lorentey@elte.hu--2004/emacs--cvs-trunk--0--patch-7
Sync with miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-539.
* lorentey@elte.hu--2004/emacs--cvs-trunk--0--version-0
Branch closed. Use miles@gnu.org--gnu-2005/emacs--cvs-trunk--0 instead.
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-475
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-476
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-477
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-478
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-479
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-480
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-481
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-482
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-483
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-484
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-485
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-486
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-487
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-488
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-489
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-490
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-491
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-492
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-493
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-494
Update from CVS: lisp/startup.el (command-line): Fix typo.
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-495
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-496
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-497
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-498
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-499
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-500
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-501
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-502
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-503
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-504
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-505
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-506
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-507
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-508
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-509
Update from CVS: .cvsignore: Add `lock'.
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-510
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-511
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-512
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-513
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-514
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-515
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-516
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-517
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-518
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-519
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-520
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-521
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-522
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-523
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-524
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-525
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-526
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-527
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-528
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-529
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-530
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-531
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-532
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-533
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-534
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-535
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-536
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-537
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-538
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-539
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-88
Merge from emacs--cvs-trunk--0
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-89
Merge from emacs--cvs-trunk--0
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-90
Update FSF's address in GPL notices
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-91
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-92
Merge from emacs--cvs-trunk--0
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-93
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-94
Merge from emacs--cvs-trunk--0
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-95
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-96
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-97
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-98
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-99
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-100
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-101
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-102
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-103
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-104
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-105
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-106
Merge from emacs--cvs-trunk--0
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-107
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-108
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-109
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-110
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-111
Merge from emacs--cvs-trunk--0
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-112
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-113
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-114
Update from CVS
git-archimport-id: lorentey@elte.hu--2004/emacs--multi-tty--0--patch-416
author | Karoly Lorentey <lorentey@elte.hu> |
---|---|
date | Sun, 11 Sep 2005 08:23:50 +0000 |
parents | 532e0a9335a9 |
children | db4e74787e6f |
line wrap: on
line source
;;; url.el --- Uniform Resource Locator retrieval tool ;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004, ;; 2005 Free Software Foundation, Inc. ;; Author: Bill Perry <wmperry@gnu.org> ;; Keywords: comm, data, processes, hypermedia ;; 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., 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 'mm-view)) (require 'mailcap) (require 'url-vars) (require 'url-cookie) (require 'url-history) (require 'url-expand) (require 'url-privacy) (require 'url-methods) (require 'url-proxy) (require 'url-parse) (require 'url-util) ;; Fixme: customize? convert-standard-filename? ;;;###autoload (defvar url-configuration-directory "~/.url") (defun url-do-setup () "Setup the url package. This is to avoid conflict with user settings if URL is dumped with Emacs." (unless url-setup-done ;; Make OS/2 happy ;;(push '("http" "80") tcp-binary-process-input-services) (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) (url-history-setup-save-timer) ;; Ditto for cookies (url-cookie-setup-save-timer) (url-cookie-parse-file url-cookie-file) ;; Read in proxy gateways (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services)) (or (getenv "NO_PROXY") (getenv "no_PROXY") (getenv "no_proxy"))))) (if noproxy (setq url-proxy-services (cons (cons "no_proxy" (concat "\\(" (mapconcat (lambda (x) (cond ((= x ?,) "\\|") ((= x ? ) "") ((= x ?.) (regexp-quote ".")) ((= x ?*) ".*") ((= x ??) ".") (t (char-to-string x)))) noproxy "") "\\)")) url-proxy-services)))) (url-setup-privacy-info) (run-hooks 'url-load-hook) (setq url-setup-done t))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Retrieval functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun url-retrieve (url callback &optional cbargs) "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished. 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. Normally it gets the arguments in the list CBARGS. However, if what we find is a redirect, CALLBACK is given two additional args, `:redirect' and the redirected URL, followed by CBARGS. Return the buffer URL will load into, or nil if the process has already completed." (url-do-setup) (url-gc-dead-buffers) (if (stringp url) (set-text-properties 0 (length url) nil url)) (if (not (vectorp url)) (setq url (url-generic-parse-url url))) (if (not (functionp callback)) (error "Must provide a callback function to url-retrieve")) (unless (url-type url) (error "Bad url: %s" (url-recreate-url url))) (let ((loader (url-scheme-get-property (url-type url) 'loader)) (url-using-proxy (if (url-host url) (url-find-proxy-for-url url (url-host url)))) (buffer nil) (asynch (url-scheme-get-property (url-type url) 'asynchronous-p))) (if url-using-proxy (setq asynch t loader 'url-proxy)) (if asynch (setq buffer (funcall loader url callback cbargs)) (setq buffer (funcall loader url)) (if buffer (with-current-buffer buffer (apply callback cbargs)))) (url-history-update-url url (current-time)) buffer)) (defun url-retrieve-synchronously (url) "Retrieve URL synchronously. Return the buffer containing the data, or nil if there are no data associated with it (the case for dired, info, or mailto URLs that need no further processing). URL is either a string or a parsed URL." (url-do-setup) (lexical-let ((retrieval-done nil) (asynch-buffer nil)) (setq asynch-buffer (url-retrieve url (lambda (&rest ignored) (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer)) (setq retrieval-done t asynch-buffer (current-buffer))))) (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 (and proc (memq (process-status proc) '(closed exit signal failed))) ;; 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 if 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. (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 (accept-process-output proc) (null proc)) ;; accept-process-output returned nil, maybe because the process ;; exited (and may have been replaced with another). (setq proc (get-buffer-process asynch-buffer)))))) asynch-buffer))) (defun url-mm-callback (&rest ignored) (let ((handle (mm-dissect-buffer t))) (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 ;; Fixme: this shouldn't have to know the form of the ;; undisplayer produced by `mm-display-part'. (get-buffer-process (cdr (mm-handle-undisplayer handle))) `(lambda (proc event) (mm-destroy-parts (quote ,handle)))) (message "Viewing externally") (kill-buffer (current-buffer))) (display-buffer (current-buffer)) (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." (require 'mm-decode) (require 'mm-view) (url-retrieve url 'url-mm-callback nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Miscellaneous ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar url-dead-buffer-list nil) (defun url-mark-buffer-as-dead (buff) (push buff url-dead-buffer-list)) (defun url-gc-dead-buffers () (let ((buff)) (while (setq buff (pop url-dead-buffer-list)) (if (buffer-live-p buff) (kill-buffer buff))))) (cond ((fboundp 'display-warning) (defalias 'url-warn 'display-warning)) ((fboundp 'warn) (defun url-warn (class message &optional level) (warn "(%s/%s) %s" class (or level 'warning) message))) (t (defun url-warn (class message &optional level) (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))) (display-buffer (current-buffer)))))) (provide 'url) ;; arch-tag: bc182f1f-d187-4f10-b961-47af2066579a ;;; url.el ends here