Mercurial > hg > xemacs-beta

comparison lisp/url/mm.el @ 2:ac2d302a0011 r19-15b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b2
author cvs
date Mon, 13 Aug 2007 08:46:35 +0200
parents 376386a54a3c
children
comparison
equal deleted inserted replaced
1:c0c6a60d29db 2:ac2d302a0011
90 ;;; information for this specific viewer is returned. 90 ;;; information for this specific viewer is returned.
91 ;;; 91 ;;;
92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
93 ;;; Variables, etc 93 ;;; Variables, etc
94 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 94 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
95 (eval-and-compile
96 (require 'cl))
97
95 (defconst mm-version (let ((x "1.96")) 98 (defconst mm-version (let ((x "1.96"))
96 (if (string-match "Revision: \\([^ \t\n]+\\)" x) 99 (if (string-match "Revision: \\([^ \t\n]+\\)" x)
97 (substring x (match-beginning 1) (match-end 1)) 100 (substring x (match-beginning 1) (match-end 1))
98 x)) 101 x))
99 "Version # of MM package") 102 "Version # of MM package")
345 (expand-file-name fname mm-temporary-directory)) 348 (expand-file-name fname mm-temporary-directory))
346 (setq x (1+ x) 349 (setq x (1+ x)
347 fname (format fmt (concat base (int-to-string x))))) 350 fname (format fmt (concat base (int-to-string x)))))
348 (expand-file-name fname mm-temporary-directory)))) 351 (expand-file-name fname mm-temporary-directory))))
349 352
350 (if (not (fboundp 'copy-tree)) 353 (if (and (fboundp 'copy-tree)
351 (defun copy-tree (tree) 354 (subrp (symbol-function 'copy-tree)))
352 (if (consp tree) 355 (fset 'mm-copy-tree 'copy-tree)
353 (cons (copy-tree (car tree)) 356 (defun mm-copy-tree (tree)
354 (copy-tree (cdr tree))) 357 (if (consp tree)
355 (if (vectorp tree) 358 (cons (mm-copy-tree (car tree))
356 (let* ((new (copy-sequence tree)) 359 (mm-copy-tree (cdr tree)))
357 (i (1- (length new)))) 360 (if (vectorp tree)
358 (while (>= i 0) 361 (let* ((new (copy-sequence tree))
359 (aset new i (copy-tree (aref new i))) 362 (i (1- (length new))))
360 (setq i (1- i))) 363 (while (>= i 0)
361 new) 364 (aset new i (mm-copy-tree (aref new i)))
362 tree)))) 365 (setq i (1- i)))
366 new)
367 tree))))
363 368
364 (if (not (fboundp 'w3-save-binary-file)) 369 (if (not (fboundp 'w3-save-binary-file))
365 (defun mm-save-binary-file () 370 (defun mm-save-binary-file ()
366 (let ((x (read-file-name "Filename to save as: " 371 ;; Ok, this is truly fucked. In XEmacs, if you use the mouse to select
367 (or mm-download-directory "~/"))) 372 ;; a URL that gets saved via this function, read-file-name will pop up a
368 (require-final-newline nil)) 373 ;; dialog box for file selection. For some reason which buffer we are in
369 (save-excursion 374 ;; gets royally screwed (even with save-excursions and the whole nine
370 (if (featurep 'mule) 375 ;; yards). SO, we just keep the old buffer name around and away we go.
371 (let ((mc-flag t)) 376 (let ((old-buff (current-buffer))
372 (write-region (point-min) (point-max) x nil nil *noconv*)) 377 (file (read-file-name "Filename to save as: "
373 (write-region (point-min) (point-max) x)) 378 (or mm-download-directory "~/")
374 (kill-buffer (current-buffer))))) 379 (file-name-nondirectory (url-view-url t))
380 nil
381 (file-name-nondirectory (url-view-url t))))
382 (require-final-newline nil))
383 (set-buffer old-buff)
384 (if (featurep 'mule)
385 (let ((mc-flag t))
386 (write-region (point-min) (point-max) file nil nil *noconv*))
387 (write-region (point-min) (point-max) file))
388 (kill-buffer (current-buffer))))
375 (fset 'mm-save-binary-file 'w3-save-binary-file)) 389 (fset 'mm-save-binary-file 'w3-save-binary-file))
376 390
377 (if (not (fboundp 'w3-maybe-eval)) 391 (if (not (fboundp 'w3-maybe-eval))
378 (defun mm-maybe-eval () 392 (defun mm-maybe-eval ()
379 "Maybe evaluate a buffer of emacs lisp code" 393 "Maybe evaluate a buffer of emacs lisp code"
384 398
385 399
386 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 400 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
387 ;;; The mailcap parser 401 ;;; The mailcap parser
388 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 402 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
403 (defun mm-viewer-unescape (format &optional filename url)
404 (save-excursion
405 (set-buffer (get-buffer-create " *mm-parse*"))
406 (erase-buffer)
407 (insert format)
408 (goto-char (point-min))
409 (while (re-search-forward "%\\(.\\)" nil t)
410 (let ((escape (aref (match-string 1) 0)))
411 (replace-match "" t t)
412 (case escape
413 (?% (insert "%"))
414 (?s (insert (or filename "\"\"")))
415 (?u (insert (or url "\"\""))))))
416 (buffer-string)))
417
389 (defun mm-in-assoc (elt list) 418 (defun mm-in-assoc (elt list)
390 ;; Check to see if ELT matches any of the regexps in the car elements of LIST 419 ;; Check to see if ELT matches any of the regexps in the car elements of LIST
391 (let (rslt) 420 (let (rslt)
392 (while (and list (not rslt)) 421 (while (and list (not rslt))
393 (and (car (car list)) 422 (and (car (car list))
839 ((stringp request) 868 ((stringp request)
840 (if (or (string= request "test") (string= request "viewer")) 869 (if (or (string= request "test") (string= request "viewer"))
841 (mm-unescape-mime-test (cdr-safe (assoc request viewer)) info))) 870 (mm-unescape-mime-test (cdr-safe (assoc request viewer)) info)))
842 (t 871 (t
843 ;; MUST make a copy *sigh*, else we modify mm-mime-data 872 ;; MUST make a copy *sigh*, else we modify mm-mime-data
844 (setq viewer (copy-tree viewer)) 873 (setq viewer (mm-copy-tree viewer))
845 (let ((view (assoc "viewer" viewer)) 874 (let ((view (assoc "viewer" viewer))
846 (test (assoc "test" viewer))) 875 (test (assoc "test" viewer)))
847 (if view (setcdr view (mm-unescape-mime-test (cdr view) info))) 876 (if view (setcdr view (mm-unescape-mime-test (cdr view) info)))
848 (if test (setcdr test (mm-unescape-mime-test (cdr test) info)))) 877 (if test (setcdr test (mm-unescape-mime-test (cdr test) info))))
849 viewer))))) 878 viewer)))))