Mercurial > hg > xemacs-beta

comparison lisp/w3/url.el @ 16:0293115a14e9 r19-15b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b91
author cvs
date Mon, 13 Aug 2007 08:49:20 +0200
parents 9ee227acff29
children 859a2309aef8
comparison
equal deleted inserted replaced
15:ad457d5f7d04 16:0293115a14e9
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/29 14:32:36
4 ;; Version: 1.40 4 ;; Version: 1.48
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/29 14:32:36|1.48|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 ()
590 (let ((old-asynch url-be-asynchronous)) 595 (let ((old-asynch url-be-asynchronous))
591 (setq-default url-be-asynchronous nil) 596 (setq-default url-be-asynchronous nil)
592 (let ((buf (current-buffer)) 597 (let ((buf (current-buffer))
593 (url-working-buffer (cdr (url-retrieve url)))) 598 (url-working-buffer (cdr (url-retrieve url))))
594 (setq-default url-be-asynchronous old-asynch) 599 (setq-default url-be-asynchronous old-asynch)
600 (set-buffer url-working-buffer)
601 (url-uncompress)
595 (set-buffer buf) 602 (set-buffer buf)
596 (insert-buffer url-working-buffer) 603 (insert-buffer url-working-buffer)
597 (setq buffer-file-name url) 604 (setq buffer-file-name url)
598 (save-excursion 605 (save-excursion
599 (set-buffer url-working-buffer) 606 (set-buffer url-working-buffer)
741 (setq url-lazy-message-time (nth 1 (current-time))))) 748 (setq url-lazy-message-time (nth 1 (current-time)))))
742 nil 749 nil
743 (apply 'message args))) 750 (apply 'message args)))
744 751
745 752
746 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
747 ;;; Gateway Support
748 ;;; ---------------
749 ;;; Fairly good/complete gateway support
750 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
751 (defun url-kill-process (proc) 753 (defun url-kill-process (proc)
752 "Kill the process PROC - knows about all the various gateway types, 754 "Kill the process PROC - knows about all the various gateway types,
753 and acts accordingly." 755 and acts accordingly."
754 (cond 756 (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 757
759 (defun url-accept-process-output (proc) 758 (defun url-accept-process-output (proc)
760 "Allow any pending output from subprocesses to be read by Emacs. 759 "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. 760 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, 761 Where possible, this will not exit until some output is received from PROC,
763 or 1 second has elapsed." 762 or 1 second has elapsed."
764 (accept-process-output proc 1)) 763 (accept-process-output proc 1))
765 764
766 (defun url-process-status (proc) 765 (defun url-process-status (proc)
767 "Return the process status of a url buffer" 766 "Return the process status of a url buffer"
768 (cond 767 (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 768
854 769
855 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 770 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
856 ;;; Miscellaneous functions 771 ;;; Miscellaneous functions
857 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 772 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
972 (url-register-protocol 'finger nil 'url-identity-expander "79") 887 (url-register-protocol 'finger nil 'url-identity-expander "79")
973 (url-register-protocol 'mailto nil 'url-identity-expander) 888 (url-register-protocol 'mailto nil 'url-identity-expander)
974 (url-register-protocol 'news nil 'url-identity-expander "119") 889 (url-register-protocol 'news nil 'url-identity-expander "119")
975 (url-register-protocol 'nntp nil 'url-identity-expander "119") 890 (url-register-protocol 'nntp nil 'url-identity-expander "119")
976 (url-register-protocol 'irc nil 'url-identity-expander "6667") 891 (url-register-protocol 'irc nil 'url-identity-expander "6667")
892 (url-register-protocol 'data nil 'url-identity-expander)
977 (url-register-protocol 'rlogin) 893 (url-register-protocol 'rlogin)
978 (url-register-protocol 'shttp nil nil "80") 894 (url-register-protocol 'shttp nil nil "80")
979 (url-register-protocol 'telnet) 895 (url-register-protocol 'telnet)
980 (url-register-protocol 'tn3270) 896 (url-register-protocol 'tn3270)
981 (url-register-protocol 'wais) 897 (url-register-protocol 'wais)
1423 If DEFAULT is nil or missing, the current buffer's URL is used. 1339 If DEFAULT is nil or missing, the current buffer's URL is used.
1424 Path components that are `.' are removed, and 1340 Path components that are `.' are removed, and
1425 path components followed by `..' are removed, along with the `..' itself." 1341 path components followed by `..' are removed, along with the `..' itself."
1426 (if url 1342 (if url
1427 (setq url (mapconcat (function (lambda (x) 1343 (setq url (mapconcat (function (lambda (x)
1428 (if (= x ?\n) "" (char-to-string x)))) 1344 (if (memq x '(? ?\n ?\r))
1345 ""
1346 (char-to-string x))))
1429 (url-strip-leading-spaces 1347 (url-strip-leading-spaces
1430 (url-eat-trailing-space url)) ""))) 1348 (url-eat-trailing-space url)) "")))
1431 (cond 1349 (cond
1432 ((null url) nil) ; Something hosed! Be graceful 1350 ((null url) nil) ; Something hosed! Be graceful
1433 ((string-match "^#" url) ; Offset link, use it raw 1351 ((string-match "^#" url) ; Offset link, use it raw