diff lisp/vm/vm-misc.el @ 54:05472e90ae02 r19-16-pre2

Import from CVS: tag r19-16-pre2
author cvs
date Mon, 13 Aug 2007 08:57:55 +0200
parents c53a95d3c46d
children 131b0175ea99
line wrap: on
line diff
--- a/lisp/vm/vm-misc.el	Mon Aug 13 08:57:25 2007 +0200
+++ b/lisp/vm/vm-misc.el	Mon Aug 13 08:57:55 2007 +0200
@@ -92,6 +92,86 @@
 	     (nreverse list)) ; jwz: fixed order
 	(and work-buffer (kill-buffer work-buffer)))))))
 
+(defun vm-parse-structured-header (string &optional sepchar keep-quotes)
+  (if (null string)
+      ()
+    (let ((work-buffer nil))
+      (save-excursion
+       (unwind-protect
+	   (let ((list nil)
+		 (nonspecials "^\"\\( \t\n\r\f")
+		 start s char sp+sepchar)
+	     (if sepchar
+		 (setq nonspecials (concat nonspecials (list sepchar))
+		       sp+sepchar (concat "\t\f\n\r " (list sepchar))))
+	     (setq work-buffer (generate-new-buffer "*vm-work*"))
+	     (buffer-disable-undo work-buffer)
+	     (set-buffer work-buffer)
+	     (insert string)
+	     (goto-char (point-min))
+	     (skip-chars-forward "\t\f\n\r ")
+	     (setq start (point))
+	     (while (not (eobp))
+	       (skip-chars-forward nonspecials)
+	       (setq char (following-char))
+	       (cond ((looking-at "[ \t\n\r\f]")
+		      (delete-char 1))
+		     ((= char ?\\)
+		      (forward-char 1)
+		      (if (not (eobp))
+			  (forward-char 1)))
+		     ((and sepchar (= char sepchar))
+		      (setq s (buffer-substring start (point)))
+		      (if (or (null (string-match "^[\t\f\n\r ]+$" s))
+			      (not (string= s "")))
+			  (setq list (cons s list)))
+		      (skip-chars-forward sp+sepchar)
+		      (setq start (point)))
+		     ((looking-at " \t\n\r\f")
+		      (skip-chars-forward " \t\n\r\f"))
+		     ((= char ?\")
+		      (let ((done nil))
+			(if keep-quotes
+			    (forward-char 1)
+			  (delete-char 1))
+			(while (not done)
+			  (if (null (re-search-forward "[\\\"]" nil t))
+			      (setq done t)
+			    (setq char (char-after (1- (point))))
+			    (cond ((char-equal char ?\\)
+				   (delete-char -1)
+				   (if (eobp)
+				       (setq done t)
+				     (forward-char 1)))
+				  (t (if (not keep-quotes)
+					 (delete-char -1))
+				     (setq done t)))))))
+		     ((= char ?\()
+		      (let ((done nil)
+			    (pos (point))
+			    (parens 1))
+			(forward-char 1)
+			(while (not done)
+			  (if (null (re-search-forward "[\\()]" nil t))
+			      (setq done t)
+			    (setq char (char-after (1- (point))))
+			    (cond ((char-equal char ?\\)
+				   (if (eobp)
+				       (setq done t)
+				     (forward-char 1)))
+				  ((char-equal char ?\()
+				   (setq parens (1+ parens)))
+				  (t
+				   (setq parens (1- parens)
+					 done (zerop parens))))))
+			(delete-region pos (point))))))
+	     (setq s (buffer-substring start (point)))
+	     (if (and (null (string-match "^[\t\f\n\r ]+$" s))
+		      (not (string= s "")))
+		 (setq list (cons s list)))
+	     (nreverse list))
+	(and work-buffer (kill-buffer work-buffer)))))))
+
 (defun vm-write-string (where string)
   (if (bufferp where)
       (vm-save-buffer-excursion
@@ -108,7 +188,7 @@
 	    ;; writing out message separators
 	    (setq buffer-file-type nil)
 	    ;; Tell XEmacs/MULE to pick the correct newline conversion.
-	    (and (vm-xemacs-mule-p)
+	    (and vm-xemacs-mule-p
 		 (set-file-coding-system 'no-conversion nil))
 	    (write-region (point-min) (point-max) where t 'quiet))
 	(and temp-buffer (kill-buffer temp-buffer))))))
@@ -343,52 +423,40 @@
 	((markerp object) (copy-marker object))
 	(t object)))
 
-(defun vm-xemacs-p ()
-  (let ((case-fold-search nil))
-    (string-match "XEmacs" emacs-version)))
-
-(defun vm-xemacs-mule-p ()
-  (and (vm-xemacs-p)
-       (featurep 'mule)
-       (fboundp 'set-file-coding-system)
-       (fboundp 'get-coding-system)))
-
-(defun vm-fsfemacs-19-p ()
-  (and (string-match "^19" emacs-version)
-       (not (string-match "XEmacs\\|Lucid" emacs-version))))
-
-;; make-frame might be defined and still not work.  This would
-;; be true since the user could be running on a tty and using
-;; XEmacs 19.12, or using FSF Emacs 19.28 (or prior FSF Emacs versions).
-;;
-;; make-frame works on ttys in FSF Emacs 19.29, but other than
-;; looking at the version number I don't know a sane way to
-;; test for it without just running make-frame.  I'll just
-;; let it not work for now... someone will complain eventually
-;; and I'll think of something.
-(defun vm-multiple-frames-possible-p ()
-  (or (and (boundp 'window-system) (not (eq window-system nil)))
-      (and (fboundp 'device-type) (eq (device-type) 'x))))
-
-(defun vm-mouse-support-possible-p ()
-  (vm-multiple-frames-possible-p))
+(defun vm-multiple-frames-possible-p () 
+  (cond (vm-xemacs-p 
+	 (or (memq 'win (device-matching-specifier-tag-list))
+	     (featurep 'tty-frames)))
+        (vm-fsfemacs-19-p 
+         (fboundp 'make-frame))))
+ 
+(defun vm-mouse-support-possible-p () 
+  (cond (vm-xemacs-p 
+         (featurep 'window-system)) 
+        (vm-fsfemacs-19-p 
+         (fboundp 'track-mouse))))
+ 
+(defun vm-mouse-support-possible-here-p ()
+  (cond (vm-xemacs-p
+	 (memq 'win (device-matching-specifier-tag-list)))
+	(vm-fsfemacs-19-p
+	 (eq window-system 'x))))
 
 (defun vm-menu-support-possible-p ()
-  (or (and (boundp 'window-system)
-	   (or (eq window-system 'x)
-	       (eq window-system 'ns)      ;; NextStep
-	       (eq window-system 'win32)))
-      (and (fboundp 'device-type) (eq (device-type) 'x))))
-
+  (cond (vm-xemacs-p
+	 (featurep 'menubar))
+	(vm-fsfemacs-19-p
+	 (fboundp 'menu-bar-mode))))
+ 
 (defun vm-toolbar-support-possible-p ()
-  (and (vm-xemacs-p)
-       (vm-multiple-frames-possible-p)
-       (featurep 'toolbar)))
+  (and vm-xemacs-p (featurep 'toolbar)))
 
 (defun vm-multiple-fonts-possible-p ()
-  (or (eq window-system 'x)
-      (and (fboundp 'device-type)
-	   (eq (device-type) 'x))))
+  (cond (vm-xemacs-p
+	 (eq (device-type) 'x))
+	(vm-fsfemacs-19-p
+	 (or (eq window-system 'x)
+	     (eq window-system 'win32)))))
 
 (defun vm-run-message-hook (message &optional hook-variable)
   (save-excursion
@@ -435,13 +503,15 @@
 	;; save this work so we won't have to do it again
 	(setq vm-sortable-date-alist
 	      (cons (cons string
-			  (timezone-make-date-sortable
-			   (format "%s %s %s %s %s"
-				   (aref vect 1)
-				   (aref vect 2)
-				   (aref vect 3)
-				   (aref vect 4)
-				   (aref vect 5))))
+			  (condition-case nil
+			      (timezone-make-date-sortable
+			       (format "%s %s %s %s %s"
+				       (aref vect 1)
+				       (aref vect 2)
+				       (aref vect 3)
+				       (aref vect 4)
+				       (aref vect 5)))
+			    (error "1970010100:00:00")))
 		    vm-sortable-date-alist))
 	;; return result
 	(cdr (car vm-sortable-date-alist)))))
@@ -497,12 +567,8 @@
 	   (get-file-buffer (file-truename file)))))
 
 (defun vm-set-region-face (start end face)
-  (cond ((fboundp 'make-overlay)
-	 (let ((o (make-overlay start end)))
-	   (overlay-put o 'face face)))
-	((fboundp 'make-extent)
-	 (let ((o (make-extent start end)))
-	   (set-extent-property o 'face face)))))
+  (let ((e (vm-make-extent start end)))
+    (vm-set-extent-property e 'face face)))
 
 (defun vm-default-buffer-substring-no-properties (beg end &optional buffer)
   (let ((s (if buffer
@@ -516,7 +582,7 @@
 (fset 'vm-buffer-substring-no-properties
   (cond ((fboundp 'buffer-substring-no-properties)
 	 (function buffer-substring-no-properties))
-	((vm-xemacs-p)
+	(vm-xemacs-p
 	 (function buffer-substring))
 	(t (function vm-default-buffer-substring-no-properties))))
 
@@ -535,37 +601,45 @@
       (set-buffer buffer))
     (set-buffer target-buffer)))
 
-(if (fboundp 'overlay-get)
-    (fset 'vm-extent-property 'overlay-get)
-  (fset 'vm-extent-property 'extent-property))
+(if (not (fboundp 'vm-extent-property))
+    (if (fboundp 'overlay-get)
+	(fset 'vm-extent-property 'overlay-get)
+      (fset 'vm-extent-property 'extent-property)))
 
-(if (fboundp 'overlay-put)
-    (fset 'vm-set-extent-property 'overlay-put)
-  (fset 'vm-set-extent-property 'set-extent-property))
+(if (not (fboundp 'vm-set-extent-property))
+    (if (fboundp 'overlay-put)
+	(fset 'vm-set-extent-property 'overlay-put)
+      (fset 'vm-set-extent-property 'set-extent-property)))
 
-(if (fboundp 'move-overlay)
-    (fset 'vm-set-extent-endpoints 'move-overlay)
-  (fset 'vm-set-extent-endpoints 'set-extent-endpoints))
+(if (not (fboundp 'vm-set-extent-endpoints))
+    (if (fboundp 'move-overlay)
+	(fset 'vm-set-extent-endpoints 'move-overlay)
+      (fset 'vm-set-extent-endpoints 'set-extent-endpoints)))
 
-(if (fboundp 'make-overlay)
-    (fset 'vm-make-extent 'make-overlay)
-  (fset 'vm-make-extent 'make-extent))
+(if (not (fboundp 'vm-make-extent))
+    (if (fboundp 'make-overlay)
+	(fset 'vm-make-extent 'make-overlay)
+      (fset 'vm-make-extent 'make-extent)))
 
-(if (fboundp 'overlay-end)
-    (fset 'vm-extent-end-position 'overlay-end)
-  (fset 'vm-extent-end-position 'extent-end-position))
+(if (not (fboundp 'vm-extent-end-position))
+    (if (fboundp 'overlay-end)
+	(fset 'vm-extent-end-position 'overlay-end)
+      (fset 'vm-extent-end-position 'extent-end-position)))
 
-(if (fboundp 'overlay-start)
-    (fset 'vm-extent-start-position 'overlay-start)
-  (fset 'vm-extent-start-position 'extent-start-position))
+(if (not (fboundp 'vm-extent-start-position))
+    (if (fboundp 'overlay-start)
+	(fset 'vm-extent-start-position 'overlay-start)
+      (fset 'vm-extent-start-position 'extent-start-position)))
 
-(if (fboundp 'delete-overlay)
-    (fset 'vm-detach-extent 'delete-overlay)
-  (fset 'vm-detach-extent 'detach-extent))
+(if (not (fboundp 'vm-detach-extent))
+    (if (fboundp 'delete-overlay)
+	(fset 'vm-detach-extent 'delete-overlay)
+      (fset 'vm-detach-extent 'detach-extent)))
 
-(if (fboundp 'overlay-properties)
-    (fset 'vm-extent-properties 'overlay-properties)
-  (fset 'vm-extent-properties 'extent-properties))
+(if (not (fboundp 'vm-extent-properties))
+    (if (fboundp 'overlay-properties)
+	(fset 'vm-extent-properties 'overlay-properties)
+      (fset 'vm-extent-properties 'extent-properties)))
 
 (defun vm-copy-extent (e)
   (let ((props (vm-extent-properties e))