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

Import from CVS: tag r19-15b2
author cvs
date Mon, 13 Aug 2007 08:46:35 +0200
parents 376386a54a3c
children
line wrap: on
line diff
--- a/lisp/url/mm.el	Mon Aug 13 08:45:53 2007 +0200
+++ b/lisp/url/mm.el	Mon Aug 13 08:46:35 2007 +0200
@@ -92,6 +92,9 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Variables, etc
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(eval-and-compile
+  (require 'cl))
+
 (defconst mm-version (let ((x "1.96"))
 		       (if (string-match "Revision: \\([^ \t\n]+\\)" x)
 			   (substring x (match-beginning 1) (match-end 1))
@@ -347,31 +350,42 @@
 	      fname (format fmt (concat base (int-to-string x)))))
       (expand-file-name fname mm-temporary-directory))))
 
-(if (not (fboundp 'copy-tree))
-    (defun copy-tree (tree)
-      (if (consp tree)
-	  (cons (copy-tree (car tree))
-		(copy-tree (cdr tree)))
-	(if (vectorp tree)
-	    (let* ((new (copy-sequence tree))
-		   (i (1- (length new))))
-	      (while (>= i 0)
-		(aset new i (copy-tree (aref new i)))
-		(setq i (1- i)))
-	      new)
-	  tree))))
+(if (and (fboundp 'copy-tree)
+	 (subrp (symbol-function 'copy-tree)))
+    (fset 'mm-copy-tree 'copy-tree)
+  (defun mm-copy-tree (tree)
+    (if (consp tree)
+	(cons (mm-copy-tree (car tree))
+	      (mm-copy-tree (cdr tree)))
+      (if (vectorp tree)
+	  (let* ((new (copy-sequence tree))
+		 (i (1- (length new))))
+	    (while (>= i 0)
+	      (aset new i (mm-copy-tree (aref new i)))
+	      (setq i (1- i)))
+	    new)
+	tree))))
 
 (if (not (fboundp 'w3-save-binary-file))
     (defun mm-save-binary-file ()
-      (let ((x (read-file-name "Filename to save as: "
-			       (or mm-download-directory "~/")))
-            (require-final-newline nil))
-	(save-excursion
-	  (if (featurep 'mule)
-	      (let ((mc-flag t))
-		(write-region (point-min) (point-max) x nil nil *noconv*))
-	    (write-region (point-min) (point-max) x))
-	  (kill-buffer (current-buffer)))))
+      ;; Ok, this is truly fucked.  In XEmacs, if you use the mouse to select
+      ;; a URL that gets saved via this function, read-file-name will pop up a
+      ;; dialog box for file selection.  For some reason which buffer we are in
+      ;; gets royally screwed (even with save-excursions and the whole nine
+      ;; yards).  SO, we just keep the old buffer name around and away we go.
+      (let ((old-buff (current-buffer))
+	    (file (read-file-name "Filename to save as: "
+				  (or mm-download-directory "~/")
+				  (file-name-nondirectory (url-view-url t))
+				  nil
+				  (file-name-nondirectory (url-view-url t))))
+	    (require-final-newline nil))
+	(set-buffer old-buff)
+	(if (featurep 'mule)
+	    (let ((mc-flag t))
+	      (write-region (point-min) (point-max) file nil nil *noconv*))
+	  (write-region (point-min) (point-max) file))
+	(kill-buffer (current-buffer))))
   (fset 'mm-save-binary-file 'w3-save-binary-file))
 
 (if (not (fboundp 'w3-maybe-eval))
@@ -386,6 +400,21 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; The mailcap parser
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun mm-viewer-unescape (format &optional filename url)
+  (save-excursion
+    (set-buffer (get-buffer-create " *mm-parse*"))
+    (erase-buffer)
+    (insert format)
+    (goto-char (point-min))
+    (while (re-search-forward "%\\(.\\)" nil t)
+       (let ((escape (aref (match-string 1) 0)))
+	 (replace-match "" t t)
+	 (case escape
+	   (?% (insert "%"))
+	   (?s (insert (or filename "\"\"")))
+	   (?u (insert (or url "\"\""))))))
+    (buffer-string)))
+
 (defun mm-in-assoc (elt list)
   ;; Check to see if ELT matches any of the regexps in the car elements of LIST
   (let (rslt)
@@ -841,7 +870,7 @@
 	    (mm-unescape-mime-test (cdr-safe (assoc request viewer)) info)))
        (t
 	;; MUST make a copy *sigh*, else we modify mm-mime-data
-	(setq viewer (copy-tree viewer))
+	(setq viewer (mm-copy-tree viewer))
 	(let ((view (assoc "viewer" viewer))
 	      (test (assoc "test" viewer)))
 	  (if view (setcdr view (mm-unescape-mime-test (cdr view) info)))