Mercurial > hg > xemacs-beta

comparison lisp/w3/url.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents 821dec489c24
children a145efe76779
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
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/01/29 14:32:36 3 ;; Created: 1997/02/07 14:30:25
4 ;; Version: 1.48 4 ;; Version: 1.51
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/01/29 14:32:36|1.48|Location Undetermined 10 ;;; 1997/02/07 14:30:25|1.51|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.
42 (featurep 'efs-auto) 42 (featurep 'efs-auto)
43 (condition-case () 43 (condition-case ()
44 (require 'ange-ftp) 44 (require 'ange-ftp)
45 (error nil))) 45 (error nil)))
46 46
47 (require 'w3-sysdp) 47 (eval-and-compile
48 (if (not (and (string-match "XEmacs" emacs-version)
49 (or (> emacs-major-version 19)
50 (>= emacs-minor-version 14))))
51 (require 'w3-sysdp)))
48 52
49 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
50 ;;; Functions that might not exist in old versions of emacs 54 ;;; Functions that might not exist in old versions of emacs
51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
52 (defun url-save-error (errobj) 56 (defun url-save-error (errobj)
275 (defun url-percentage (x y) 279 (defun url-percentage (x y)
276 (if (fboundp 'float) 280 (if (fboundp 'float)
277 (round (* 100 (/ x (float y)))) 281 (round (* 100 (/ x (float y))))
278 (/ (* x 100) y))) 282 (/ (* x 100) y)))
279 283
284 (defun url-pretty-length (n)
285 (cond
286 ((< n 1024)
287 (format "%d bytes" n))
288 ((< n (* 1024 1024))
289 (format "%dk" (/ n 1024.0)))
290 (t
291 (format "%2.2fM" (/ n (* 1024 1024.0))))))
292
280 (defun url-after-change-function (&rest args) 293 (defun url-after-change-function (&rest args)
281 ;; The nitty gritty details of messaging the HTTP/1.0 status messages 294 ;; The nitty gritty details of messaging the HTTP/1.0 status messages
282 ;; in the minibuffer." 295 ;; in the minibuffer."
283 (or url-current-content-length 296 (or url-current-content-length
284 (save-excursion 297 (save-excursion
309 (- (point-max) url-current-isindex) 322 (- (point-max) url-current-isindex)
310 (point-max))))) 323 (point-max)))))
311 (cond 324 (cond
312 ((and url-current-content-length (> url-current-content-length 1) 325 ((and url-current-content-length (> url-current-content-length 1)
313 url-current-mime-type) 326 url-current-mime-type)
314 (url-lazy-message "Reading [%s]... %d of %d bytes (%d%%)" 327 (url-lazy-message "Reading [%s]... %s of %s (%d%%)"
315 url-current-mime-type 328 url-current-mime-type
316 current-length 329 (url-pretty-length current-length)
317 url-current-content-length 330 (url-pretty-length url-current-content-length)
318 (url-percentage current-length 331 (url-percentage current-length
319 url-current-content-length))) 332 url-current-content-length)))
320 ((and url-current-content-length (> url-current-content-length 1)) 333 ((and url-current-content-length (> url-current-content-length 1))
321 (url-lazy-message "Reading... %d of %d bytes (%d%%)" 334 (url-lazy-message "Reading... %s of %s (%d%%)"
322 current-length url-current-content-length 335 (url-pretty-length current-length)
336 (url-pretty-length url-current-content-length)
323 (url-percentage current-length 337 (url-percentage current-length
324 url-current-content-length))) 338 url-current-content-length)))
325 ((and (/= 1 current-length) url-current-mime-type) 339 ((and (/= 1 current-length) url-current-mime-type)
326 (url-lazy-message "Reading [%s]... %d bytes" 340 (url-lazy-message "Reading [%s]... %s"
327 url-current-mime-type current-length)) 341 url-current-mime-type
342 (url-pretty-length current-length)))
328 ((/= 1 current-length) 343 ((/= 1 current-length)
329 (url-lazy-message "Reading... %d bytes." current-length)) 344 (url-lazy-message "Reading... %s."
345 (url-pretty-length current-length)))
330 (t (url-lazy-message "Waiting for response..."))))) 346 (t (url-lazy-message "Waiting for response...")))))
331 347
332 (defun url-insert-entities-in-string (string) 348 (defun url-insert-entities-in-string (string)
333 "Convert HTML markup-start characters to entity references in STRING. 349 "Convert HTML markup-start characters to entity references in STRING.
334 Also replaces the \" character, so that the result may be safely used as 350 Also replaces the \" character, so that the result may be safely used as
1525 (code-1 (cdr-safe 1541 (code-1 (cdr-safe
1526 (assoc "content-transfer-encoding" 1542 (assoc "content-transfer-encoding"
1527 url-current-mime-headers))) 1543 url-current-mime-headers)))
1528 (code-2 (cdr-safe 1544 (code-2 (cdr-safe
1529 (assoc "content-encoding" url-current-mime-headers))) 1545 (assoc "content-encoding" url-current-mime-headers)))
1530 (code-3 (and (not code-1) (not code-2)
1531 (cdr-safe (assoc extn url-uncompressor-alist))))
1532 (done nil) 1546 (done nil)
1533 (default-process-coding-system 1547 (default-process-coding-system
1534 (cons mule-no-coding-system mule-no-coding-system))) 1548 (cons mule-no-coding-system mule-no-coding-system)))
1535 (mapcar 1549 (mapcar
1536 (function 1550 (function
1537 (lambda (code) 1551 (lambda (code)
1538 (setq decoder (and (not (member code done)) 1552 (setq decoder (and (not (member code done))
1539 (cdr-safe 1553 (cdr-safe
1540 (assoc code mm-content-transfer-encodings))) 1554 (assoc code mm-content-transfer-encodings)))
1541 done (cons code done)) 1555 done (cons code done))
1542 (cond 1556 (if (not decoder)
1543 ((null decoder) nil) 1557 nil
1544 ((stringp decoder) 1558 (message "Decoding (%s)..." code)
1545 (message "Decoding...") 1559 (cond
1546 (call-process-region (point-min) (point-max) decoder t t nil) 1560 ((stringp decoder)
1547 (message "Decoding... done.")) 1561 (call-process-region (point-min) (point-max) decoder t t nil))
1548 ((listp decoder) 1562 ((listp decoder)
1549 (apply 'call-process-region (point-min) (point-max) 1563 (apply 'call-process-region (point-min) (point-max)
1550 (car decoder) t t nil (cdr decoder))) 1564 (car decoder) t t nil (cdr decoder)))
1551 ((and (symbolp decoder) (fboundp decoder)) 1565 ((and (symbolp decoder) (fboundp decoder))
1552 (message "Decoding...") 1566 (funcall decoder (point-min) (point-max)))
1553 (funcall decoder (point-min) (point-max)) 1567 (t
1554 (message "Decoding... done.")) 1568 (error "Bad entry for %s in `mm-content-transfer-encodings'"
1555 (t 1569 code)))
1556 (error "Bad entry for %s in `mm-content-transfer-encodings'" 1570 (message "Decoding (%s)... done." code))))
1557 code))))) 1571 (list code-1 code-2))))
1558 (list code-1 code-2 code-3))))
1559 (set-buffer-modified-p nil)) 1572 (set-buffer-modified-p nil))
1560 1573
1561 (defun url-filter (proc string) 1574 (defun url-filter (proc string)
1562 (save-excursion 1575 (save-excursion
1563 (set-buffer url-working-buffer) 1576 (set-buffer url-working-buffer)