Mercurial > hg > xemacs-beta

comparison lisp/w3/url.el @ 26:441bb1e64a06 r19-15b96

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b96
author cvs
date Mon, 13 Aug 2007 08:51:32 +0200
parents 859a2309aef8
children ec9a17fef872
comparison
equal deleted inserted replaced
25:383a494979f8 26:441bb1e64a06
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/07 14:30:25 3 ;; Created: 1997/02/20 15:34:07
4 ;; Version: 1.51 4 ;; Version: 1.57
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/07 14:30:25|1.51|Location Undetermined 10 ;;; 1997/02/20 15:34:07|1.57|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.
95 (autoload 'url-finger "url-misc") 95 (autoload 'url-finger "url-misc")
96 (autoload 'url-rlogin "url-misc") 96 (autoload 'url-rlogin "url-misc")
97 (autoload 'url-telnet "url-misc") 97 (autoload 'url-telnet "url-misc")
98 (autoload 'url-tn3270 "url-misc") 98 (autoload 'url-tn3270 "url-misc")
99 (autoload 'url-proxy "url-misc") 99 (autoload 'url-proxy "url-misc")
100 (autoload 'url-x-exec "url-misc")
101 (autoload 'url-news "url-news") 100 (autoload 'url-news "url-news")
102 (autoload 'url-nntp "url-news") 101 (autoload 'url-nntp "url-news")
103 (autoload 'url-decode-pgp/pem "url-pgp")
104 (autoload 'url-wais "url-wais")
105 102
106 (autoload 'url-open-stream "url-gw") 103 (autoload 'url-open-stream "url-gw")
107 (autoload 'url-mime-response-p "url-http") 104 (autoload 'url-mime-response-p "url-http")
108 (autoload 'url-parse-mime-headers "url-http") 105 (autoload 'url-parse-mime-headers "url-http")
109 (autoload 'url-handle-refresh-header "url-http") 106 (autoload 'url-handle-refresh-header "url-http")
116 (autoload 'url-register-auth-scheme "url-auth") 113 (autoload 'url-register-auth-scheme "url-auth")
117 (autoload 'url-cookie-write-file "url-cookie") 114 (autoload 'url-cookie-write-file "url-cookie")
118 (autoload 'url-cookie-retrieve "url-cookie") 115 (autoload 'url-cookie-retrieve "url-cookie")
119 (autoload 'url-cookie-generate-header-lines "url-cookie") 116 (autoload 'url-cookie-generate-header-lines "url-cookie")
120 (autoload 'url-cookie-handle-set-cookie "url-cookie") 117 (autoload 'url-cookie-handle-set-cookie "url-cookie")
118
119 (autoload 'url-is-cached "url-cache")
120 (autoload 'url-store-in-cache "url-cache")
121 (autoload 'url-is-cached "url-cache")
122 (autoload 'url-create-cached-filename "url-cache")
123 (autoload 'url-extract-from-cache "url-cache")
124 (autoload 'url-cache-expired "url-cache")
121 125
122 (require 'md5) 126 (require 'md5)
123 (require 'base64) 127 (require 'base64)
124 128
125 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 129 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
130 '(cond 134 '(cond
131 ((not (boundp 'file-name-handler-alist)) 135 ((not (boundp 'file-name-handler-alist))
132 nil) ; Don't load if no alist 136 nil) ; Don't load if no alist
133 ((rassq 'url-file-handler file-name-handler-alist) 137 ((rassq 'url-file-handler file-name-handler-alist)
134 nil) ; Don't load twice 138 nil) ; Don't load twice
135 ((and (string-match "XEmacs\\|Lucid" emacs-version)
136 (< url-emacs-minor-version 11)) ; Don't load in lemacs 19.10
137 nil)
138 (t 139 (t
139 (setq file-name-handler-alist 140 (setq file-name-handler-alist
140 (let ((new-handler (cons 141 (let ((new-handler (cons
141 (concat "^/*" 142 (concat "^/*"
142 (substring url-nonrelative-link1 nil)) 143 (substring url-nonrelative-link1 nil))
564 (and (not data) 565 (and (not data)
565 (setq data (list (url-file-directory-p url) 566 (setq data (list (url-file-directory-p url)
566 1 0 0 (cons 0 0) (cons 0 0) (cons 0 0) 567 1 0 0 (cons 0 0) (cons 0 0) (cons 0 0)
567 -1 (mm-extension-to-mime 568 -1 (mm-extension-to-mime
568 (url-file-extension 569 (url-file-extension
569 url-current-file)) 570 (url-filename
571 url-current-object)))
570 nil 0 0))) 572 nil 0 0)))
571 (kill-buffer " *url-temp*")))))) 573 (kill-buffer " *url-temp*"))))))
572 ((member type '("ftp" "file")) 574 ((member type '("ftp" "file"))
573 (let ((fname (if (url-host urlobj) 575 (let ((fname (if (url-host urlobj)
574 (concat "/" 576 (concat "/"
807 ((eq (device-type) 'pm) "OS/2") 809 ((eq (device-type) 'pm) "OS/2")
808 ((eq (device-type) 'win32) "Windows; 32bit") 810 ((eq (device-type) 'win32) "Windows; 32bit")
809 ((eq (device-type) 'tty) "(Unix?); TTY") 811 ((eq (device-type) 'tty) "(Unix?); TTY")
810 (t "UnkownPlatform"))) 812 (t "UnkownPlatform")))
811 813
812 ;; Set up the entity definition for PGP and PEM authentication
813 (setq url-pgp/pem-entity (or url-pgp/pem-entity
814 user-mail-address
815 (format "%s@%s" (user-real-login-name)
816 (system-name))))
817
818 (setq url-personal-mail-address (or url-personal-mail-address 814 (setq url-personal-mail-address (or url-personal-mail-address
819 url-pgp/pem-entity 815 user-mail-address
820 user-mail-address)) 816 (format "%s@%s" (user-real-login-name)
817 (system-name))))
821 818
822 (if (or (memq url-privacy-level '(paranoid high)) 819 (if (or (memq url-privacy-level '(paranoid high))
823 (and (listp url-privacy-level) 820 (and (listp url-privacy-level)
824 (memq 'email url-privacy-level))) 821 (memq 'email url-privacy-level)))
825 (setq url-personal-mail-address nil)) 822 (setq url-personal-mail-address nil))
905 (url-register-protocol 'news nil 'url-identity-expander "119") 902 (url-register-protocol 'news nil 'url-identity-expander "119")
906 (url-register-protocol 'nntp nil 'url-identity-expander "119") 903 (url-register-protocol 'nntp nil 'url-identity-expander "119")
907 (url-register-protocol 'irc nil 'url-identity-expander "6667") 904 (url-register-protocol 'irc nil 'url-identity-expander "6667")
908 (url-register-protocol 'data nil 'url-identity-expander) 905 (url-register-protocol 'data nil 'url-identity-expander)
909 (url-register-protocol 'rlogin) 906 (url-register-protocol 'rlogin)
910 (url-register-protocol 'shttp nil nil "80")
911 (url-register-protocol 'telnet) 907 (url-register-protocol 'telnet)
912 (url-register-protocol 'tn3270) 908 (url-register-protocol 'tn3270)
913 (url-register-protocol 'wais)
914 (url-register-protocol 'x-exec)
915 (url-register-protocol 'proxy) 909 (url-register-protocol 'proxy)
916 (url-register-protocol 'auto 'url-handle-no-scheme) 910 (url-register-protocol 'auto 'url-handle-no-scheme)
917 911
918 ;; Register all the authentication schemes we can handle 912 ;; Register all the authentication schemes we can handle
919 (url-register-auth-scheme "basic" nil 4) 913 (url-register-auth-scheme "basic" nil 4)
969 ((= x ??) ".") 963 ((= x ??) ".")
970 (t (char-to-string x))))) 964 (t (char-to-string x)))))
971 noproxy "") "\\)")) 965 noproxy "") "\\)"))
972 url-proxy-services)))) 966 url-proxy-services))))
973 967
974 ;; Set the url-use-transparent with decent defaults
975 (if (not (eq (device-type) 'tty))
976 (setq url-use-transparent nil))
977 (and url-use-transparent (require 'transparent))
978
979 ;; Set the password entry funtion based on user defaults or guess 968 ;; Set the password entry funtion based on user defaults or guess
980 ;; based on which remote-file-access package they are using. 969 ;; based on which remote-file-access package they are using.
981 (cond 970 (cond
982 (url-passwd-entry-func nil) ; Already been set 971 (url-passwd-entry-func nil) ; Already been set
983 ((boundp 'read-passwd) ; Use secure password if available 972 ((fboundp 'read-passwd) ; Use secure password if available
984 (setq url-passwd-entry-func 'read-passwd)) 973 (setq url-passwd-entry-func 'read-passwd))
985 ((or (featurep 'efs) ; Using EFS 974 ((or (featurep 'efs) ; Using EFS
986 (featurep 'efs-auto)) ; or autoloading efs 975 (featurep 'efs-auto)) ; or autoloading efs
987 (if (not (fboundp 'read-passwd)) 976 (if (not (fboundp 'read-passwd))
988 (autoload 'read-passwd "passwd" "Read in a password" nil)) 977 (autoload 'read-passwd "passwd" "Read in a password" nil))
990 ((or (featurep 'ange-ftp) ; Using ange-ftp 979 ((or (featurep 'ange-ftp) ; Using ange-ftp
991 (and (boundp 'file-name-handler-alist) 980 (and (boundp 'file-name-handler-alist)
992 (not (string-match "Lucid" (emacs-version))))) 981 (not (string-match "Lucid" (emacs-version)))))
993 (setq url-passwd-entry-func 'ange-ftp-read-passwd)) 982 (setq url-passwd-entry-func 'ange-ftp-read-passwd))
994 (t 983 (t
995 (url-warn 'security 984 (url-warn
996 "Can't determine how to read passwords, winging it."))) 985 'security
986 "(url-setup): Can't determine how to read passwords, winging it.")))
997 987
998 ;; Set up the news service if they haven't done so 988 ;; Set up the news service if they haven't done so
999 (setq url-news-server 989 (setq url-news-server
1000 (cond 990 (cond
1001 (url-news-server url-news-server) 991 (url-news-server url-news-server)
1023 ", "))) 1013 ", ")))
1024 1014
1025 (url-setup-privacy-info) 1015 (url-setup-privacy-info)
1026 (run-hooks 'url-load-hook) 1016 (run-hooks 'url-load-hook)
1027 (setq url-setup-done t))) 1017 (setq url-setup-done t)))
1028
1029 (defun url-cache-file-writable-p (file)
1030 "Follows the documentation of file-writable-p, unlike file-writable-p."
1031 (and (file-writable-p file)
1032 (if (file-exists-p file)
1033 (not (file-directory-p file))
1034 (file-directory-p (file-name-directory file)))))
1035
1036 (defun url-prepare-cache-for-file (file)
1037 "Makes it possible to cache data in FILE.
1038 Creates any necessary parent directories, deleting any non-directory files
1039 that would stop this. Returns nil if parent directories can not be
1040 created. If FILE already exists as a non-directory, it changes
1041 permissions of FILE or deletes FILE to make it possible to write a new
1042 version of FILE. Returns nil if this can not be done. Returns nil if
1043 FILE already exists as a directory. Otherwise, returns t, indicating that
1044 FILE can be created or overwritten."
1045
1046 ;; COMMENT: We don't delete directories because that requires
1047 ;; recursively deleting the directories's contents, which might
1048 ;; eliminate a substantial portion of the cache.
1049
1050 (cond
1051 ((url-cache-file-writable-p file)
1052 t)
1053 ((file-directory-p file)
1054 nil)
1055 (t
1056 (catch 'upcff-tag
1057 (let ((dir (file-name-directory file))
1058 dir-parent dir-last-component)
1059 (if (string-equal dir file)
1060 ;; *** Should I have a warning here?
1061 ;; FILE must match a pattern like /foo/bar/, indicating it is a
1062 ;; name only suitable for a directory. So presume we won't be
1063 ;; able to overwrite FILE and return nil.
1064 (throw 'upcff-tag nil))
1065
1066 ;; Make sure the containing directory exists, or throw a failure
1067 ;; if we can't create it.
1068 (if (file-directory-p dir)
1069 nil
1070 (or (fboundp 'make-directory)
1071 (throw 'upcff-tag nil))
1072 (make-directory dir t)
1073 ;; make-directory silently fails if there is an obstacle, so
1074 ;; we must verify its results.
1075 (if (file-directory-p dir)
1076 nil
1077 ;; Look at prefixes of the path to find the obstacle that is
1078 ;; stopping us from making the directory. Unfortunately, there
1079 ;; is no portable function in Emacs to find the parent directory
1080 ;; of a *directory*. So this code may not work on VMS.
1081 (while (progn
1082 (if (eq ?/ (aref dir (1- (length dir))))
1083 (setq dir (substring dir 0 -1))
1084 ;; Maybe we're on VMS where the syntax is different.
1085 (throw 'upcff-tag nil))
1086 (setq dir-parent (file-name-directory dir))
1087 (not (file-directory-p dir-parent)))
1088 (setq dir dir-parent))
1089 ;; We have found the longest path prefix that exists as a
1090 ;; directory. Deal with any obstacles in this directory.
1091 (if (file-exists-p dir)
1092 (condition-case nil
1093 (delete-file dir)
1094 (error (throw 'upcff-tag nil))))
1095 (if (file-exists-p dir)
1096 (throw 'upcff-tag nil))
1097 ;; Try making the directory again.
1098 (setq dir (file-name-directory file))
1099 (make-directory dir t)
1100 (or (file-directory-p dir)
1101 (throw 'upcff-tag nil))))
1102
1103 ;; The containing directory exists. Let's see if there is
1104 ;; something in the way in this directory.
1105 (if (url-cache-file-writable-p file)
1106 (throw 'upcff-tag t)
1107 (condition-case nil
1108 (delete-file file)
1109 (error (throw 'upcff-tag nil))))
1110
1111 ;; The return value, if we get this far.
1112 (url-cache-file-writable-p file))))))
1113
1114 (defun url-store-in-cache (&optional buff)
1115 "Store buffer BUFF in the cache"
1116 (if (or (not (get-buffer buff))
1117 (member url-current-type '("www" "about" "https" "shttp"
1118 "news" "mailto"))
1119 (and (member url-current-type '("file" "ftp" nil))
1120 (not url-current-server))
1121 )
1122 nil
1123 (save-excursion
1124 (and buff (set-buffer buff))
1125 (let* ((fname (url-create-cached-filename (url-view-url t)))
1126 (fname-hdr (concat (if (memq system-type '(ms-windows ms-dos os2))
1127 (url-file-extension fname t)
1128 fname) ".hdr"))
1129 (info (mapcar (function (lambda (var)
1130 (cons (symbol-name var)
1131 (symbol-value var))))
1132 '( url-current-content-length
1133 url-current-file
1134 url-current-isindex
1135 url-current-mime-encoding
1136 url-current-mime-headers
1137 url-current-mime-type
1138 url-current-port
1139 url-current-server
1140 url-current-type
1141 url-current-user
1142 ))))
1143 (cond ((and (url-prepare-cache-for-file fname)
1144 (url-prepare-cache-for-file fname-hdr))
1145 (write-region (point-min) (point-max) fname nil 5)
1146 (set-buffer (get-buffer-create " *cache-tmp*"))
1147 (erase-buffer)
1148 (insert "(setq ")
1149 (mapcar
1150 (function
1151 (lambda (x)
1152 (insert (car x) " "
1153 (cond ((null (setq x (cdr x))) "nil")
1154 ((stringp x) (prin1-to-string x))
1155 ((listp x) (concat "'" (prin1-to-string x)))
1156 ((numberp x) (int-to-string x))
1157 (t "'???")) "\n")))
1158 info)
1159 (insert ")\n")
1160 (write-region (point-min) (point-max) fname-hdr nil 5)))))))
1161
1162
1163 (defun url-is-cached (url)
1164 "Return non-nil if the URL is cached."
1165 (let* ((fname (url-create-cached-filename url))
1166 (attribs (file-attributes fname)))
1167 (and fname ; got a filename
1168 (file-exists-p fname) ; file exists
1169 (not (eq (nth 0 attribs) t)) ; Its not a directory
1170 (nth 5 attribs)))) ; Can get last mod-time
1171
1172 (defun url-create-cached-filename-using-md5 (url)
1173 (if url
1174 (expand-file-name (md5 url)
1175 (concat url-temporary-directory "/"
1176 (user-real-login-name)))))
1177
1178 (defun url-create-cached-filename (url)
1179 "Return a filename in the local cache for URL"
1180 (if url
1181 (let* ((url url)
1182 (urlobj (if (vectorp url)
1183 url
1184 (url-generic-parse-url url)))
1185 (protocol (url-type urlobj))
1186 (hostname (url-host urlobj))
1187 (host-components
1188 (cons
1189 (user-real-login-name)
1190 (cons (or protocol "file")
1191 (nreverse
1192 (delq nil
1193 (mm-string-to-tokens
1194 (or hostname "localhost") ?.))))))
1195 (fname (url-filename urlobj)))
1196 (if (and fname (/= (length fname) 0) (= (aref fname 0) ?/))
1197 (setq fname (substring fname 1 nil)))
1198 (if fname
1199 (let ((slash nil))
1200 (setq fname
1201 (mapconcat
1202 (function
1203 (lambda (x)
1204 (cond
1205 ((and (= ?/ x) slash)
1206 (setq slash nil)
1207 "%2F")
1208 ((= ?/ x)
1209 (setq slash t)
1210 "/")
1211 (t
1212 (setq slash nil)
1213 (char-to-string x))))) fname ""))))
1214
1215 (if (and fname (memq system-type '(ms-windows ms-dos windows-nt))
1216 (string-match "\\([A-Za-z]\\):[/\\]" fname))
1217 (setq fname (concat (url-match fname 1) "/"
1218 (substring fname (match-end 0)))))
1219
1220 (setq fname (and fname
1221 (mapconcat
1222 (function (lambda (x)
1223 (if (= x ?~) "" (char-to-string x))))
1224 fname ""))
1225 fname (cond
1226 ((null fname) nil)
1227 ((or (string= "" fname) (string= "/" fname))
1228 url-directory-index-file)
1229 ((= (string-to-char fname) ?/)
1230 (if (string= (substring fname -1 nil) "/")
1231 (concat fname url-directory-index-file)
1232 (substring fname 1 nil)))
1233 (t
1234 (if (string= (substring fname -1 nil) "/")
1235 (concat fname url-directory-index-file)
1236 fname))))
1237
1238 ;; Honor hideous 8.3 filename limitations on dos and windows
1239 ;; we don't have to worry about this in Windows NT/95 (or OS/2?)
1240 (if (and fname (memq system-type '(ms-windows ms-dos)))
1241 (let ((base (url-file-extension fname t))
1242 (ext (url-file-extension fname nil)))
1243 (setq fname (concat (substring base 0 (min 8 (length base)))
1244 (substring ext 0 (min 4 (length ext)))))
1245 (setq host-components
1246 (mapcar
1247 (function
1248 (lambda (x)
1249 (if (> (length x) 8)
1250 (concat
1251 (substring x 0 8) "."
1252 (substring x 8 (min (length x) 11)))
1253 x)))
1254 host-components))))
1255
1256 (and fname
1257 (expand-file-name fname
1258 (expand-file-name
1259 (mapconcat 'identity host-components "/")
1260 url-temporary-directory))))))
1261
1262 (defun url-extract-from-cache (fnam)
1263 "Extract FNAM from the local disk cache"
1264 (set-buffer (get-buffer-create url-working-buffer))
1265 (erase-buffer)
1266 (setq url-current-mime-viewer nil)
1267 (insert-file-contents-literally fnam)
1268 (load (concat (if (memq system-type '(ms-windows ms-dos os2))
1269 (url-file-extension fnam t)
1270 fnam) ".hdr") t t))
1271 1018
1272 ;;;###autoload 1019 ;;;###autoload
1273 (defun url-get-url-at-point (&optional pt) 1020 (defun url-get-url-at-point (&optional pt)
1274 "Get the URL closest to point, but don't change your 1021 "Get the URL closest to point, but don't change your
1275 position. Has a preference for looking backward when not 1022 position. Has a preference for looking backward when not
1534 1281
1535 (defun url-uncompress () 1282 (defun url-uncompress ()
1536 "Do any necessary uncompression on `url-working-buffer'" 1283 "Do any necessary uncompression on `url-working-buffer'"
1537 (set-buffer url-working-buffer) 1284 (set-buffer url-working-buffer)
1538 (if (not url-inhibit-uncompression) 1285 (if (not url-inhibit-uncompression)
1539 (let* ((extn (url-file-extension url-current-file)) 1286 (let* ((decoder nil)
1540 (decoder nil)
1541 (code-1 (cdr-safe 1287 (code-1 (cdr-safe
1542 (assoc "content-transfer-encoding" 1288 (assoc "content-transfer-encoding"
1543 url-current-mime-headers))) 1289 url-current-mime-headers)))
1544 (code-2 (cdr-safe 1290 (code-2 (cdr-safe
1545 (assoc "content-encoding" url-current-mime-headers))) 1291 (assoc "content-encoding" url-current-mime-headers)))
1580 (url-sentinel proc string)))) 1326 (url-sentinel proc string))))
1581 string) 1327 string)
1582 1328
1583 (defun url-default-callback (buf) 1329 (defun url-default-callback (buf)
1584 (url-download-minor-mode nil) 1330 (url-download-minor-mode nil)
1331 (url-store-in-cache)
1585 (cond 1332 (cond
1586 ((save-excursion (set-buffer buf) 1333 ((save-excursion (set-buffer buf)
1587 (and url-current-callback-func 1334 (and url-current-callback-func
1588 (fboundp url-current-callback-func))) 1335 (fboundp url-current-callback-func)))
1589 (save-excursion 1336 (save-excursion
1622 ((url-mime-response-p) 1369 ((url-mime-response-p)
1623 (setq status (url-parse-mime-headers)))) 1370 (setq status (url-parse-mime-headers))))
1624 (if (not url-current-mime-type) 1371 (if (not url-current-mime-type)
1625 (setq url-current-mime-type (mm-extension-to-mime 1372 (setq url-current-mime-type (mm-extension-to-mime
1626 (url-file-extension 1373 (url-file-extension
1627 url-current-file))))))) 1374 (url-filename
1628 (if (member status '(401 301 302 303 204)) 1375 url-current-object)))))
1629 nil 1376 (if (member status '(401 301 302 303 204))
1630 (funcall url-default-retrieval-proc (buffer-name url-working-buffer)))))) 1377 nil
1378 (funcall url-default-retrieval-proc (buffer-name url-working-buffer)))))))))
1631 1379
1632 (defun url-remove-relative-links (name) 1380 (defun url-remove-relative-links (name)
1633 ;; Strip . and .. from pathnames 1381 ;; Strip . and .. from pathnames
1634 (let ((new (if (not (string-match "^/" name)) 1382 (let ((new (if (not (string-match "^/" name))
1635 (concat "/" name) 1383 (concat "/" name)
1680 1428
1681 (defun url-view-url (&optional no-show) 1429 (defun url-view-url (&optional no-show)
1682 "View the current document's URL. Optional argument NO-SHOW means 1430 "View the current document's URL. Optional argument NO-SHOW means
1683 just return the URL, don't show it in the minibuffer." 1431 just return the URL, don't show it in the minibuffer."
1684 (interactive) 1432 (interactive)
1685 (let ((url "")) 1433 (if (not url-current-object)
1686 (cond 1434 nil
1687 ((equal url-current-type "gopher") 1435 (if no-show
1688 (setq url (format "%s://%s%s/%s" 1436 (url-recreate-url url-current-object)
1689 url-current-type url-current-server 1437 (message "%s" (url-recreate-url url-current-object)))))
1690 (if (or (null url-current-port)
1691 (string= "70" url-current-port)) ""
1692 (concat ":" url-current-port))
1693 url-current-file)))
1694 ((equal url-current-type "news")
1695 (setq url (concat "news:"
1696 (if (not (equal url-current-server
1697 url-news-server))
1698 (concat "//" url-current-server
1699 (if (or (null url-current-port)
1700 (string= "119" url-current-port))
1701 ""
1702 (concat ":" url-current-port)) "/"))
1703 url-current-file)))
1704 ((equal url-current-type "about")
1705 (setq url (concat "about:" url-current-file)))
1706 ((member url-current-type '("http" "shttp" "https"))
1707 (setq url (format "%s://%s%s/%s" url-current-type url-current-server
1708 (if (or (null url-current-port)
1709 (string= "80" url-current-port))
1710 ""
1711 (concat ":" url-current-port))
1712 (if (and url-current-file
1713 (= ?/ (string-to-char url-current-file)))
1714 (substring url-current-file 1 nil)
1715 url-current-file))))
1716 ((equal url-current-type "ftp")
1717 (setq url (format "%s://%s%s/%s" url-current-type
1718 (if (and url-current-user
1719 (not (string= "anonymous" url-current-user)))
1720 (concat url-current-user "@") "")
1721 url-current-server
1722 (if (and url-current-file
1723 (= ?/ (string-to-char url-current-file)))
1724 (substring url-current-file 1 nil)
1725 url-current-file))))
1726 ((and (member url-current-type '("file" nil)) url-current-file)
1727 (setq url (format "file:%s" url-current-file)))
1728 ((equal url-current-type "www")
1729 (setq url (format "www:/%s/%s" url-current-server url-current-file)))
1730 (t
1731 (setq url nil)))
1732 (if (not no-show) (message "%s" url) url)))
1733 1438
1734 (defun url-parse-Netscape-history (fname) 1439 (defun url-parse-Netscape-history (fname)
1735 ;; Parse a Netscape/X style global history list. 1440 ;; Parse a Netscape/X style global history list.
1736 (let (pos ; Position holder 1441 (let (pos ; Position holder
1737 url ; The URL 1442 url ; The URL
2112 (url-file-directly-accessible-p urlobj)) 1817 (url-file-directly-accessible-p urlobj))
2113 (url-retrieve-internally url) 1818 (url-retrieve-internally url)
2114 (url-lazy-message "Retrieving %s..." url) 1819 (url-lazy-message "Retrieving %s..." url)
2115 (apply 'call-process url-external-retrieval-program 1820 (apply 'call-process url-external-retrieval-program
2116 nil t nil args) 1821 nil t nil args)
2117 (url-lazy-message "Retrieving %s... done" url) 1822 (url-lazy-message "Retrieving %s... done" url)))))
2118 (if (and type urlobj)
2119 (setq url-current-server (url-host urlobj)
2120 url-current-type (url-type urlobj)
2121 url-current-port (url-port urlobj)
2122 url-current-file (url-filename urlobj)))
2123 (if (member url-current-file '("/" ""))
2124 (setq url-current-mime-type "text/html"))))))
2125 1823
2126 (defun url-get-normalized-date (&optional specified-time) 1824 (defun url-get-normalized-date (&optional specified-time)
2127 ;; Return a 'real' date string that most HTTP servers can understand. 1825 ;; Return a 'real' date string that most HTTP servers can understand.
2128 (require 'timezone) 1826 (require 'timezone)
2129 (let* ((raw (if specified-time (current-time-string specified-time) 1827 (let* ((raw (if specified-time (current-time-string specified-time)
2150 (concat day ", " (aref parsed 2) "-" month "-" year " " 1848 (concat day ", " (aref parsed 2) "-" month "-" year " "
2151 (aref parsed 3) " " (or (aref parsed 4) 1849 (aref parsed 3) " " (or (aref parsed 4)
2152 (concat "[" (nth 1 (current-time-zone)) 1850 (concat "[" (nth 1 (current-time-zone))
2153 "]"))))) 1851 "]")))))
2154 1852
2155 ;;;###autoload
2156 (defun url-cache-expired (url mod)
2157 "Return t iff a cached file has expired."
2158 (if (not (string-match url-nonrelative-link url))
2159 t
2160 (let* ((urlobj (url-generic-parse-url url))
2161 (type (url-type urlobj)))
2162 (cond
2163 (url-standalone-mode
2164 (not (file-exists-p (url-create-cached-filename urlobj))))
2165 ((string= type "http")
2166 (if (not url-standalone-mode) t
2167 (not (file-exists-p (url-create-cached-filename urlobj)))))
2168 ((not (fboundp 'current-time))
2169 t)
2170 ((member type '("file" "ftp"))
2171 (if (or (equal mod '(0 0)) (not mod))
2172 (return t)
2173 (or (> (nth 0 mod) (nth 0 (current-time)))
2174 (> (nth 1 mod) (nth 1 (current-time))))))
2175 (t nil)))))
2176
2177 (defun url-get-working-buffer-name () 1853 (defun url-get-working-buffer-name ()
2178 "Get a working buffer name such as ` *URL-<i>*' without a live process and empty" 1854 "Get a working buffer name such as ` *URL-<i>*' without a live process and empty"
2179 (let ((num 1) 1855 (let ((num 1)
2180 name buf) 1856 name buf)
2181 (while (progn (setq name (format " *URL-%d*" num)) 1857 (while (progn (setq name (format " *URL-%d*" num))
2222 (t 1898 (t
2223 (url-warn 'url (format "Unknown proxy directive: %s" proxy) 'critical) 1899 (url-warn 'url (format "Unknown proxy directive: %s" proxy) 'critical)
2224 nil)))) 1900 nil))))
2225 1901
2226 (defun url-retrieve-internally (url &optional no-cache) 1902 (defun url-retrieve-internally (url &optional no-cache)
2227 (let ((url-working-buffer (if (and url-multiple-p 1903 (let* ((url-working-buffer (if (and url-multiple-p
2228 (string-equal 1904 (string-equal
2229 (if (bufferp url-working-buffer) 1905 (if (bufferp url-working-buffer)
2230 (buffer-name url-working-buffer) 1906 (buffer-name url-working-buffer)
2231 url-working-buffer) 1907 url-working-buffer)
2232 url-default-working-buffer)) 1908 url-default-working-buffer))
2233 (url-get-working-buffer-name) 1909 (url-get-working-buffer-name)
2234 url-working-buffer))) 1910 url-working-buffer))
2235 (if (get-buffer url-working-buffer) 1911 (urlobj (url-generic-parse-url url))
2236 (save-excursion 1912 (type (url-type urlobj))
2237 (set-buffer url-working-buffer) 1913 (url-using-proxy (if (url-host urlobj)
2238 (erase-buffer) 1914 (url-find-proxy-for-url urlobj
2239 (setq url-current-can-be-cached (not no-cache)) 1915 (url-host urlobj))
2240 (set-buffer-modified-p nil))) 1916 nil))
2241 (let* ((urlobj (url-generic-parse-url url)) 1917 (handler nil)
2242 (type (url-type urlobj)) 1918 (original-url url)
2243 (url-using-proxy (if (url-host urlobj) 1919 (cached nil))
2244 (url-find-proxy-for-url urlobj 1920 (if url-using-proxy (setq type "proxy"))
2245 (url-host urlobj)) 1921 (setq cached (url-is-cached url)
2246 nil)) 1922 cached (and cached (not (url-cache-expired url cached)))
2247 (handler nil) 1923 handler (if cached
2248 (original-url url) 1924 'url-extract-from-cache
2249 (cached nil) 1925 (car-safe
2250 (tmp url-current-file)) 1926 (cdr-safe (assoc (or type "auto")
2251 (if url-using-proxy (setq type "proxy")) 1927 url-registered-protocols))))
2252 (setq cached (url-is-cached url) 1928 url (if cached (url-create-cached-filename url) url))
2253 cached (and cached (not (url-cache-expired url cached))) 1929 (save-excursion
2254 handler (if cached 'url-extract-from-cache 1930 (set-buffer (get-buffer-create url-working-buffer))
2255 (car-safe 1931 (setq url-current-can-be-cached (not no-cache)
2256 (cdr-safe (assoc (or type "auto") 1932 url-current-object urlobj))
2257 url-registered-protocols)))) 1933 (if (and handler (fboundp handler))
2258 url (if cached (url-create-cached-filename url) url)) 1934 (funcall handler url)
2259 (save-excursion 1935 (set-buffer (get-buffer-create url-working-buffer))
2260 (set-buffer (get-buffer-create url-working-buffer)) 1936 (erase-buffer)
2261 (setq url-current-can-be-cached (not no-cache))) 1937 (setq url-current-mime-type "text/html")
2262 ; (if url-be-asynchronous 1938 (insert "<title> Link Error! </title>\n"
2263 ; (url-download-minor-mode t)) 1939 "<h1> An error has occurred... </h1>\n"
2264 (if (and handler (fboundp handler)) 1940 (format "The link type `<code>%s</code>'" type)
2265 (funcall handler url) 1941 " is unrecognized or unsupported at this time.<p>\n"
2266 (set-buffer (get-buffer-create url-working-buffer)) 1942 "If you feel this is an error in Emacs-W3, please "
2267 (setq url-current-file tmp) 1943 "<a href=\"mailto://" url-bug-address "\">send me mail.</a>"
2268 (erase-buffer) 1944 "<p><address>William Perry</address><br>"
2269 (insert "<title> Link Error! </title>\n" 1945 "<address>" url-bug-address "</address>"))
2270 "<h1> An error has occurred... </h1>\n" 1946 (cond
2271 (format "The link type `<code>%s</code>'" type) 1947 ((and url-be-asynchronous (not cached) (member type '("http" "proxy")))
2272 " is unrecognized or unsupported at this time.<p>\n" 1948 nil)
2273 "If you feel this is an error, please " 1949 (url-be-asynchronous
2274 "<a href=\"mailto://" url-bug-address "\">send me mail.</a>" 1950 (funcall url-default-retrieval-proc (buffer-name)))
2275 "<p><address>William Perry</address><br>" 1951 ((not (get-buffer url-working-buffer)) nil)
2276 "<address>" url-bug-address "</address>") 1952 ((and (not url-inhibit-mime-parsing)
2277 (setq url-current-file "error.html")) 1953 (or cached (url-mime-response-p t)))
2278 (if (and 1954 (or cached (url-parse-mime-headers nil t))))
2279 (not url-be-asynchronous) 1955 (if (and (or (not url-be-asynchronous)
2280 (get-buffer url-working-buffer)) 1956 (not (equal type "http")))
2281 (progn 1957 url-current-object
2282 (set-buffer url-working-buffer) 1958 (not url-current-mime-type))
2283 1959 (if (url-buffer-is-hypertext)
2284 (url-clean-text))) 1960 (setq url-current-mime-type "text/html")
2285 (cond 1961 (setq url-current-mime-type (mm-extension-to-mime
2286 ((equal type "wais") nil) 1962 (url-file-extension
2287 ((and url-be-asynchronous (not cached) (member type '("http" "proxy"))) 1963 (url-filename
2288 nil) 1964 url-current-object))))))
2289 (url-be-asynchronous 1965 (if (not url-be-asynchronous)
2290 (funcall url-default-retrieval-proc (buffer-name))) 1966 (url-store-in-cache url-working-buffer))
2291 ((not (get-buffer url-working-buffer)) nil) 1967 (if (not url-global-history-hash-table)
2292 ((and (not url-inhibit-mime-parsing) 1968 (setq url-global-history-hash-table (make-hash-table :size 131
2293 (or cached (url-mime-response-p t))) 1969 :test 'equal)))
2294 (or cached (url-parse-mime-headers nil t)))) 1970 (if (not (string-match "^\\(about\\|www\\):" original-url))
2295 (if (and (or (not url-be-asynchronous) 1971 (progn
2296 (not (equal type "http"))) 1972 (setq url-history-changed-since-last-save t)
2297 (not url-current-mime-type)) 1973 (cl-puthash original-url (current-time)
2298 (if (url-buffer-is-hypertext) 1974 url-global-history-hash-table)))
2299 (setq url-current-mime-type "text/html") 1975 (cons cached url-working-buffer)))
2300 (setq url-current-mime-type (mm-extension-to-mime
2301 (url-file-extension
2302 url-current-file)))))
2303 (if (and url-automatic-caching url-current-can-be-cached
2304 (not url-be-asynchronous))
2305 (save-excursion
2306 (url-store-in-cache url-working-buffer)))
2307 (if (not url-global-history-hash-table)
2308 (setq url-global-history-hash-table (make-hash-table :size 131
2309 :test 'equal)))
2310 (if (not (string-match "^about:" original-url))
2311 (progn
2312 (setq url-history-changed-since-last-save t)
2313 (cl-puthash original-url (current-time)
2314 url-global-history-hash-table)))
2315 (cons cached url-working-buffer))))
2316 1976
2317 ;;;###autoload 1977 ;;;###autoload
2318 (defun url-retrieve (url &optional no-cache expected-md5) 1978 (defun url-retrieve (url &optional no-cache expected-md5)
2319 "Retrieve a document over the World Wide Web. 1979 "Retrieve a document over the World Wide Web.
2320 The document should be specified by its fully specified 1980 The document should be specified by its fully specified
2329 (subrp (symbol-function 'set-text-properties))) 1989 (subrp (symbol-function 'set-text-properties)))
2330 (set-text-properties 0 (length url) nil url)) 1990 (set-text-properties 0 (length url) nil url))
2331 (if (and url (string-match "^url:" url)) 1991 (if (and url (string-match "^url:" url))
2332 (setq url (substring url (match-end 0) nil))) 1992 (setq url (substring url (match-end 0) nil)))
2333 (let ((status (url-retrieve-internally url no-cache))) 1993 (let ((status (url-retrieve-internally url no-cache)))
2334 (if (and expected-md5 url-check-md5s)
2335 (let ((cur-md5 (md5 (current-buffer))))
2336 (if (not (string= cur-md5 expected-md5))
2337 (and (not (funcall url-confirmation-func
2338 "MD5s do not match, use anyway? "))
2339 (error "MD5 error.")))))
2340 status)) 1994 status))
2341 1995
2342 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1996 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2343 ;;; How to register a protocol 1997 ;;; How to register a protocol
2344 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1998 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;