Mercurial > hg > xemacs-beta

comparison lisp/w3/url.el @ 30:ec9a17fef872 r19-15b98

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b98
author cvs
date Mon, 13 Aug 2007 08:52:29 +0200
parents 441bb1e64a06
children e04119814345
comparison
equal deleted inserted replaced
29:7976500f47f9 30:ec9a17fef872
1 ;;; url.el --- Uniform Resource Locator retrieval tool 1 ;;; url.el --- Uniform Resource Locator retrieval tool
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/02/20 15:34:07 3 ;; Created: 1997/03/05 23:37:22
4 ;; Version: 1.57 4 ;; Version: 1.61
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 ;;; Functions for retrieving/manipulating URLs| 9 ;;; Functions for retrieving/manipulating URLs|
10 ;;; 1997/02/20 15:34:07|1.57|Location Undetermined 10 ;;; 1997/03/05 23:37:22|1.61|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, 1997 Free Software Foundation, Inc. 15 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
117 (autoload 'url-cookie-handle-set-cookie "url-cookie") 117 (autoload 'url-cookie-handle-set-cookie "url-cookie")
118 118
119 (autoload 'url-is-cached "url-cache") 119 (autoload 'url-is-cached "url-cache")
120 (autoload 'url-store-in-cache "url-cache") 120 (autoload 'url-store-in-cache "url-cache")
121 (autoload 'url-is-cached "url-cache") 121 (autoload 'url-is-cached "url-cache")
122 (autoload 'url-create-cached-filename "url-cache") 122 (autoload 'url-cache-create-filename "url-cache")
123 (autoload 'url-extract-from-cache "url-cache") 123 (autoload 'url-cache-extract "url-cache")
124 (autoload 'url-cache-expired "url-cache") 124 (autoload 'url-cache-expired "url-cache")
125 125
126 (require 'md5) 126 (require 'md5)
127 (require 'base64) 127 (require 'base64)
128 128
794 (cond 794 (cond
795 ((or (eq url-privacy-level 'paranoid) 795 ((or (eq url-privacy-level 'paranoid)
796 (and (listp url-privacy-level) 796 (and (listp url-privacy-level)
797 (memq 'os url-privacy-level))) 797 (memq 'os url-privacy-level)))
798 nil) 798 nil)
799 ;; First, we handle the inseparable OS/Windowing system
800 ;; combinations
799 ((eq system-type 'Apple-Macintosh) "Macintosh") 801 ((eq system-type 'Apple-Macintosh) "Macintosh")
800 ((eq system-type 'next-mach) "NeXT") 802 ((eq system-type 'next-mach) "NeXT")
801 ((eq system-type 'windows-nt) "Windows-NT; 32bit") 803 ((eq system-type 'windows-nt) "Windows-NT; 32bit")
802 ((eq system-type 'ms-windows) "Windows; 16bit") 804 ((eq system-type 'ms-windows) "Windows; 16bit")
803 ((eq system-type 'ms-dos) "MS-DOS; 32bit") 805 ((eq system-type 'ms-dos) "MS-DOS; 32bit")
804 ((and (eq system-type 'vax-vms) (device-type))
805 "VMS; X11")
806 ((eq system-type 'vax-vms) "VMS; TTY")
807 ((eq (device-type) 'x) "X11")
808 ((eq (device-type) 'ns) "NeXTStep")
809 ((eq (device-type) 'pm) "OS/2")
810 ((eq (device-type) 'win32) "Windows; 32bit") 806 ((eq (device-type) 'win32) "Windows; 32bit")
811 ((eq (device-type) 'tty) "(Unix?); TTY") 807 ((eq (device-type) 'pm) "OS/2; 32bit")
812 (t "UnkownPlatform"))) 808 (t
809 (case (device-type)
810 (x "X11")
811 (ns "OpenStep")
812 (tty "TTY")
813 (otherwise nil)))))
813 814
814 (setq url-personal-mail-address (or url-personal-mail-address 815 (setq url-personal-mail-address (or url-personal-mail-address
815 user-mail-address 816 user-mail-address
816 (format "%s@%s" (user-real-login-name) 817 (format "%s@%s" (user-real-login-name)
817 (system-name)))) 818 (system-name))))
819 (if (or (memq url-privacy-level '(paranoid high)) 820 (if (or (memq url-privacy-level '(paranoid high))
820 (and (listp url-privacy-level) 821 (and (listp url-privacy-level)
821 (memq 'email url-privacy-level))) 822 (memq 'email url-privacy-level)))
822 (setq url-personal-mail-address nil)) 823 (setq url-personal-mail-address nil))
823 824
824 (if (or (eq url-privacy-level 'paranoid) 825 (setq url-os-type
825 (and (listp url-privacy-level) 826 (cond
826 (memq 'os url-privacy-level))) 827 ((or (eq url-privacy-level 'paranoid)
827 (setq url-os-type nil) 828 (and (listp url-privacy-level)
828 (let ((vers (emacs-version))) 829 (memq 'os url-privacy-level)))
829 (if (string-match "(\\([^, )]+\\))$" vers) 830 nil)
830 (setq url-os-type (url-match vers 1)) 831 ((boundp 'system-configuration)
831 (setq url-os-type (symbol-name system-type)))))) 832 system-configuration)
833 ((boundp 'system-type)
834 (symbol-name system-type))
835 (t nil))))
832 836
833 (defun url-handle-no-scheme (url) 837 (defun url-handle-no-scheme (url)
834 (let ((temp url-registered-protocols) 838 (let ((temp url-registered-protocols)
835 (found nil)) 839 (found nil))
836 (while (and temp (not found)) 840 (while (and temp (not found))
1045 (buffer-substring start (point))))) 1049 (buffer-substring start (point)))))
1046 (if (string-match "^URL:" url) 1050 (if (string-match "^URL:" url)
1047 (setq url (substring url 4 nil))) 1051 (setq url (substring url 4 nil)))
1048 (if (string-match "\\.$" url) 1052 (if (string-match "\\.$" url)
1049 (setq url (substring url 0 -1))) 1053 (setq url (substring url 0 -1)))
1054 (if (string-match "^www\\." url)
1055 (setq url (concat "http://" url)))
1050 (if (not (string-match url-nonrelative-link url)) 1056 (if (not (string-match url-nonrelative-link url))
1051 (setq url nil)) 1057 (setq url nil))
1052 url))) 1058 url)))
1053 1059
1054 (defun url-eat-trailing-space (x) 1060 (defun url-eat-trailing-space (x)
1343 (url-current-callback-data 1349 (url-current-callback-data
1344 (funcall url-current-callback-func 1350 (funcall url-current-callback-func
1345 url-current-callback-data)) 1351 url-current-callback-data))
1346 (t 1352 (t
1347 (funcall url-current-callback-func)))))) 1353 (funcall url-current-callback-func))))))
1348 ((fboundp 'w3-sentinel) 1354 ((and (fboundp 'w3-sentinel) (get-buffer buf))
1349 (set-variable 'w3-working-buffer buf)
1350 (w3-sentinel)) 1355 (w3-sentinel))
1351 (t 1356 (t
1352 (message "Retrieval for %s complete." buf)))) 1357 (message "Retrieval for %s complete." buf))))
1353 1358
1354 (defun url-sentinel (proc string) 1359 (defun url-sentinel (proc string)
1370 (setq status (url-parse-mime-headers)))) 1375 (setq status (url-parse-mime-headers))))
1371 (if (not url-current-mime-type) 1376 (if (not url-current-mime-type)
1372 (setq url-current-mime-type (mm-extension-to-mime 1377 (setq url-current-mime-type (mm-extension-to-mime
1373 (url-file-extension 1378 (url-file-extension
1374 (url-filename 1379 (url-filename
1375 url-current-object))))) 1380 url-current-object))))))))
1376 (if (member status '(401 301 302 303 204)) 1381 (if (member status '(401 301 302 303 204))
1377 nil 1382 nil
1378 (funcall url-default-retrieval-proc (buffer-name url-working-buffer))))))))) 1383 (funcall url-default-retrieval-proc (buffer-name url-working-buffer))))))
1379 1384
1380 (defun url-remove-relative-links (name) 1385 (defun url-remove-relative-links (name)
1381 ;; Strip . and .. from pathnames 1386 ;; Strip . and .. from pathnames
1382 (let ((new (if (not (string-match "^/" name)) 1387 (let ((new (if (not (string-match "^/" name))
1383 (concat "/" name) 1388 (concat "/" name)
1919 (cached nil)) 1924 (cached nil))
1920 (if url-using-proxy (setq type "proxy")) 1925 (if url-using-proxy (setq type "proxy"))
1921 (setq cached (url-is-cached url) 1926 (setq cached (url-is-cached url)
1922 cached (and cached (not (url-cache-expired url cached))) 1927 cached (and cached (not (url-cache-expired url cached)))
1923 handler (if cached 1928 handler (if cached
1924 'url-extract-from-cache 1929 'url-cache-extract
1925 (car-safe 1930 (car-safe
1926 (cdr-safe (assoc (or type "auto") 1931 (cdr-safe (assoc (or type "auto")
1927 url-registered-protocols)))) 1932 url-registered-protocols))))
1928 url (if cached (url-create-cached-filename url) url)) 1933 url (if cached (url-cache-create-filename url) url))
1929 (save-excursion 1934 (save-excursion
1930 (set-buffer (get-buffer-create url-working-buffer)) 1935 (set-buffer (get-buffer-create url-working-buffer))
1931 (setq url-current-can-be-cached (not no-cache) 1936 (setq url-current-can-be-cached (not no-cache)
1932 url-current-object urlobj)) 1937 url-current-object urlobj))
1933 (if (and handler (fboundp handler)) 1938 (if (and handler (fboundp handler))
1944 "<p><address>William Perry</address><br>" 1949 "<p><address>William Perry</address><br>"
1945 "<address>" url-bug-address "</address>")) 1950 "<address>" url-bug-address "</address>"))
1946 (cond 1951 (cond
1947 ((and url-be-asynchronous (not cached) (member type '("http" "proxy"))) 1952 ((and url-be-asynchronous (not cached) (member type '("http" "proxy")))
1948 nil) 1953 nil)
1949 (url-be-asynchronous 1954 ((and url-be-asynchronous (get-buffer url-working-buffer))
1950 (funcall url-default-retrieval-proc (buffer-name))) 1955 (funcall url-default-retrieval-proc (buffer-name)))
1951 ((not (get-buffer url-working-buffer)) nil) 1956 ((not (get-buffer url-working-buffer)) nil)
1952 ((and (not url-inhibit-mime-parsing) 1957 ((and (not url-inhibit-mime-parsing)
1953 (or cached (url-mime-response-p t))) 1958 (or cached (url-mime-response-p t)))
1954 (or cached (url-parse-mime-headers nil t)))) 1959 (or cached (url-parse-mime-headers nil t))))