Mercurial > hg > xemacs-beta

comparison lisp/w3/url.el @ 82:6a378aca36af r20-0b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b91
author cvs
date Mon, 13 Aug 2007 09:07:36 +0200
parents 9ee227acff29
children 364816949b59
comparison
equal deleted inserted replaced
81:ebca3d831cea 82:6a378aca36af
1 ;;; url.el --- Uniform Resource Locator retrieval tool 1 ;;; url.el --- Uniform Resource Locator retrieval tool
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1996/12/19 21:53:03 3 ;; Created: 1997/01/19 01:12:24
4 ;; Version: 1.40 4 ;; Version: 1.46
5 ;; Keywords: comm, data, processes, hypermedia 5 ;; Keywords: comm, data, processes, hypermedia
6 6
7 ;;; LCD Archive Entry: 7 ;;; LCD Archive Entry:
8 ;;; url|William M. Perry|wmperry@cs.indiana.edu| 8 ;;; url|William M. Perry|wmperry@cs.indiana.edu|
9 ;;; Major mode for manipulating URLs| 9 ;;; Functions for retrieving/manipulating URLs|
10 ;;; 1996/12/19 21:53:03|1.40|Location Undetermined 10 ;;; 1997/01/19 01:12:24|1.46|Location Undetermined
11 ;;; 11 ;;;
12 12
13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
14 ;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu) 14 ;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
15 ;;; Copyright (c) 1996 Free Software Foundation, Inc. 15 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
16 ;;; 16 ;;;
17 ;;; This file is not part of GNU Emacs, but the same permissions apply. 17 ;;; This file is not part of GNU Emacs, but the same permissions apply.
18 ;;; 18 ;;;
19 ;;; GNU Emacs is free software; you can redistribute it and/or modify 19 ;;; GNU Emacs is free software; you can redistribute it and/or modify
20 ;;; it under the terms of the GNU General Public License as published by 20 ;;; it under the terms of the GNU General Public License as published by
34 34
35 35
36 (require 'cl) 36 (require 'cl)
37 (require 'url-vars) 37 (require 'url-vars)
38 (require 'url-parse) 38 (require 'url-parse)
39 (require 'urlauth)
40 (require 'url-cookie)
41 (require 'mm) 39 (require 'mm)
42 (require 'md5)
43 (require 'base64)
44 (require 'mule-sysdp) 40 (require 'mule-sysdp)
45 (or (featurep 'efs) 41 (or (featurep 'efs)
46 (featurep 'efs-auto) 42 (featurep 'efs-auto)
47 (condition-case () 43 (condition-case ()
48 (require 'ange-ftp) 44 (require 'ange-ftp)
89 (autoload 'url-mailserver "url-mail") 85 (autoload 'url-mailserver "url-mail")
90 (autoload 'url-mailto "url-mail") 86 (autoload 'url-mailto "url-mail")
91 (autoload 'url-info "url-misc") 87 (autoload 'url-info "url-misc")
92 (autoload 'url-shttp "url-http") 88 (autoload 'url-shttp "url-http")
93 (autoload 'url-https "url-http") 89 (autoload 'url-https "url-http")
90 (autoload 'url-data "url-misc")
94 (autoload 'url-finger "url-misc") 91 (autoload 'url-finger "url-misc")
95 (autoload 'url-rlogin "url-misc") 92 (autoload 'url-rlogin "url-misc")
96 (autoload 'url-telnet "url-misc") 93 (autoload 'url-telnet "url-misc")
97 (autoload 'url-tn3270 "url-misc") 94 (autoload 'url-tn3270 "url-misc")
98 (autoload 'url-proxy "url-misc") 95 (autoload 'url-proxy "url-misc")
100 (autoload 'url-news "url-news") 97 (autoload 'url-news "url-news")
101 (autoload 'url-nntp "url-news") 98 (autoload 'url-nntp "url-news")
102 (autoload 'url-decode-pgp/pem "url-pgp") 99 (autoload 'url-decode-pgp/pem "url-pgp")
103 (autoload 'url-wais "url-wais") 100 (autoload 'url-wais "url-wais")
104 101
105 (autoload 'url-save-newsrc "url-news") 102 (autoload 'url-open-stream "url-gw")
106 (autoload 'url-news-generate-reply-form "url-news")
107 (autoload 'url-parse-newsrc "url-news")
108 (autoload 'url-mime-response-p "url-http") 103 (autoload 'url-mime-response-p "url-http")
109 (autoload 'url-parse-mime-headers "url-http") 104 (autoload 'url-parse-mime-headers "url-http")
110 (autoload 'url-handle-refresh-header "url-http") 105 (autoload 'url-handle-refresh-header "url-http")
111 (autoload 'url-create-mime-request "url-http") 106 (autoload 'url-create-mime-request "url-http")
112 (autoload 'url-create-message-id "url-http") 107 (autoload 'url-create-message-id "url-http")
113 (autoload 'url-create-multipart-request "url-http") 108 (autoload 'url-create-multipart-request "url-http")
114 (autoload 'url-parse-viewer-types "url-http") 109 (autoload 'url-parse-viewer-types "url-http")
110
111 (autoload 'url-get-authentication "url-auth")
112 (autoload 'url-register-auth-scheme "url-auth")
113 (autoload 'url-cookie-write-file "url-cookie")
114 (autoload 'url-cookie-retrieve "url-cookie")
115 (autoload 'url-cookie-generate-header-lines "url-cookie")
116 (autoload 'url-cookie-handle-set-cookie "url-cookie")
117
118 (require 'md5)
119 (require 'base64)
115 120
116 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 121 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
117 ;;; File-name-handler-alist functions 122 ;;; File-name-handler-alist functions
118 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
119 (defun url-setup-file-name-handlers () 124 (defun url-setup-file-name-handlers ()
741 (setq url-lazy-message-time (nth 1 (current-time))))) 746 (setq url-lazy-message-time (nth 1 (current-time)))))
742 nil 747 nil
743 (apply 'message args))) 748 (apply 'message args)))
744 749
745 750
746 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
747 ;;; Gateway Support
748 ;;; ---------------
749 ;;; Fairly good/complete gateway support
750 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
751 (defun url-kill-process (proc) 751 (defun url-kill-process (proc)
752 "Kill the process PROC - knows about all the various gateway types, 752 "Kill the process PROC - knows about all the various gateway types,
753 and acts accordingly." 753 and acts accordingly."
754 (cond 754 (delete-process proc))
755 ((eq url-gateway-method 'native) (delete-process proc))
756 ((eq url-gateway-method 'program) (kill-process proc))
757 (t (error "Unknown url-gateway-method %s" url-gateway-method))))
758 755
759 (defun url-accept-process-output (proc) 756 (defun url-accept-process-output (proc)
760 "Allow any pending output from subprocesses to be read by Emacs. 757 "Allow any pending output from subprocesses to be read by Emacs.
761 It is read into the process' buffers or given to their filter functions. 758 It is read into the process' buffers or given to their filter functions.
762 Where possible, this will not exit until some output is received from PROC, 759 Where possible, this will not exit until some output is received from PROC,
763 or 1 second has elapsed." 760 or 1 second has elapsed."
764 (accept-process-output proc 1)) 761 (accept-process-output proc 1))
765 762
766 (defun url-process-status (proc) 763 (defun url-process-status (proc)
767 "Return the process status of a url buffer" 764 "Return the process status of a url buffer"
768 (cond 765 (process-status proc))
769 ((memq url-gateway-method '(native ssl program)) (process-status proc))
770 (t (error "Unkown url-gateway-method %s" url-gateway-method))))
771
772 (defun url-open-stream (name buffer host service)
773 "Open a stream to a host"
774 (let ((tmp-gateway-method (if (and url-gateway-local-host-regexp
775 (not (eq 'ssl url-gateway-method))
776 (string-match
777 url-gateway-local-host-regexp
778 host))
779 'native
780 url-gateway-method))
781 (tcp-binary-process-output-services (if (stringp service)
782 (list service)
783 (list service
784 (int-to-string service)))))
785 (and (eq url-gateway-method 'tcp)
786 (require 'tcp)
787 (setq url-gateway-method 'native
788 tmp-gateway-method 'native))
789 (cond
790 ((eq tmp-gateway-method 'ssl)
791 (open-ssl-stream name buffer host service))
792 ((eq tmp-gateway-method 'native)
793 (if url-broken-resolution
794 (setq host
795 (cond
796 ((featurep 'ange-ftp) (ange-ftp-nslookup-host host))
797 ((featurep 'efs) (efs-nslookup-host host))
798 ((featurep 'efs-auto) (efs-nslookup-host host))
799 (t host))))
800 (let ((max-retries url-connection-retries)
801 (cur-retries 0)
802 (retry t)
803 (errobj nil)
804 (conn nil))
805 (while (and (not conn) retry)
806 (condition-case errobj
807 (setq conn (open-network-stream name buffer host service))
808 (error
809 (url-save-error errobj)
810 (save-window-excursion
811 (save-excursion
812 (switch-to-buffer-other-window " *url-error*")
813 (shrink-window-if-larger-than-buffer)
814 (goto-char (point-min))
815 (if (and (re-search-forward "in use" nil t)
816 (< cur-retries max-retries))
817 (progn
818 (setq retry t
819 cur-retries (1+ cur-retries))
820 (sleep-for 0.5))
821 (setq cur-retries 0
822 retry (funcall url-confirmation-func
823 (concat "Connection to " host
824 " failed, retry? "))))
825 (kill-buffer (current-buffer)))))))
826 (if (not conn)
827 (error "Unable to connect to %s:%s" host service)
828 (mule-inhibit-code-conversion conn)
829 conn)))
830 ((eq tmp-gateway-method 'program)
831 (let ((proc (start-process name buffer url-gateway-telnet-program host
832 (int-to-string service)))
833 (tmp nil))
834 (save-excursion
835 (set-buffer buffer)
836 (setq tmp (point))
837 (while (not (progn
838 (goto-char (point-min))
839 (re-search-forward
840 url-gateway-telnet-ready-regexp nil t)))
841 (url-accept-process-output proc))
842 (delete-region tmp (point))
843 (goto-char (point-min))
844 (if (re-search-forward "connect:" nil t)
845 (progn
846 (condition-case ()
847 (delete-process proc)
848 (error nil))
849 (url-replace-regexp ".*connect:.*" "")
850 nil)
851 proc))))
852 (t (error "Unknown url-gateway-method %s" url-gateway-method)))))
853 766
854 767
855 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 768 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
856 ;;; Miscellaneous functions 769 ;;; Miscellaneous functions
857 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 770 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
972 (url-register-protocol 'finger nil 'url-identity-expander "79") 885 (url-register-protocol 'finger nil 'url-identity-expander "79")
973 (url-register-protocol 'mailto nil 'url-identity-expander) 886 (url-register-protocol 'mailto nil 'url-identity-expander)
974 (url-register-protocol 'news nil 'url-identity-expander "119") 887 (url-register-protocol 'news nil 'url-identity-expander "119")
975 (url-register-protocol 'nntp nil 'url-identity-expander "119") 888 (url-register-protocol 'nntp nil 'url-identity-expander "119")
976 (url-register-protocol 'irc nil 'url-identity-expander "6667") 889 (url-register-protocol 'irc nil 'url-identity-expander "6667")
890 (url-register-protocol 'data nil 'url-identity-expander)
977 (url-register-protocol 'rlogin) 891 (url-register-protocol 'rlogin)
978 (url-register-protocol 'shttp nil nil "80") 892 (url-register-protocol 'shttp nil nil "80")
979 (url-register-protocol 'telnet) 893 (url-register-protocol 'telnet)
980 (url-register-protocol 'tn3270) 894 (url-register-protocol 'tn3270)
981 (url-register-protocol 'wais) 895 (url-register-protocol 'wais)
1423 If DEFAULT is nil or missing, the current buffer's URL is used. 1337 If DEFAULT is nil or missing, the current buffer's URL is used.
1424 Path components that are `.' are removed, and 1338 Path components that are `.' are removed, and
1425 path components followed by `..' are removed, along with the `..' itself." 1339 path components followed by `..' are removed, along with the `..' itself."
1426 (if url 1340 (if url
1427 (setq url (mapconcat (function (lambda (x) 1341 (setq url (mapconcat (function (lambda (x)
1428 (if (= x ?\n) "" (char-to-string x)))) 1342 (if (memq x '(?\n ?\r))
1343 ""
1344 (char-to-string x))))
1429 (url-strip-leading-spaces 1345 (url-strip-leading-spaces
1430 (url-eat-trailing-space url)) ""))) 1346 (url-eat-trailing-space url)) "")))
1431 (cond 1347 (cond
1432 ((null url) nil) ; Something hosed! Be graceful 1348 ((null url) nil) ; Something hosed! Be graceful
1433 ((string-match "^#" url) ; Offset link, use it raw 1349 ((string-match "^#" url) ; Offset link, use it raw