--- a/lisp/packages/time.el	Mon Aug 13 09:21:56 2007 +0200
+++ b/lisp/packages/time.el	Mon Aug 13 09:23:06 2007 +0200
@@ -23,6 +23,10 @@
 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 ;; 02111-1307, USA.
 
+;;; Version: 1.10  (I choose the version number starting at 1.1
+;;;                to indicate that 1.0 was the old version
+;;;                before I hacked away on it -jtl)
+
 ;;; Synched up with: Not synched with FSF.
 
 ;;; Commentary:
@@ -34,10 +38,17 @@
 ;; This uses the XEmacs timeout-event mechanism, via a version
 ;; of Kyle Jones' itimer package.
 
-;;; JTL: This is in a wide part reworked for XEmacs so it won't use
+;;; jtl: This is in a wide part reworked for XEmacs so it won't use
 ;;;      the old mechanism for specifying what is to be displayed.
 ;;;      The starting variable to look at is `display-time-form-list'
 
+;;; It's more advanced features include heavy use of `balloon-help' a
+;;; package again written by Kyle Jones. You need to load this
+;;; explicitely on your own because I don't think a package should make
+;;; decisions which have a global effect (if you want to use it, a
+;;; (require 'balloon-help) in your .emacs should work. But look at the
+;;; documentation in balloon-help.el itself).
+
 ;;; Thanks to Mike Scheidler for the idea to make the time led's fore- and
 ;;; background color customizable
 
@@ -50,13 +61,6 @@
 in the XEmacs mode line or echo area."
   :group 'applications)
 
-(defcustom display-time-compatible nil 
-  "*This variable may be set to t to get the old behaviour of display-time.
-This means no display of a spiffy mail icon or use of the
-display-time-form-list instead of the old display-time-string-form."
-  :group 'display-time
-  :type 'boolean)
-
 (defcustom display-time-mail-file nil
   "*File name of mail inbox file, for indicating existence of new mail.
 Non-nil and not a string means don't check for mail.  nil means use
@@ -98,8 +102,8 @@
    "Time when mail file's file system was recorded to be down.
 If that file system seems to be up, the value is nil.")
 
-(defcustom display-time-ignore-read-mail nil
-  "*Non-nil means displays the mail icon on any non-empty mailbox."
+(defcustom display-time-ignore-read-mail t
+  "*Non-nil means display the mail icon on any non-empty mailbox."
   :group 'display-time
   :type 'boolean)
 
@@ -155,7 +159,7 @@
   :group 'display-time
   :type 'boolean)  
 
-(defvar display-time-icons-dir (concat data-directory "time/"))  
+(defvar display-time-icons-dir (concat data-directory "time/"))
 
 (defcustom display-time-mail-sign-string " Mail" 
   "The string used as mail indicator in the echo area 
@@ -164,7 +168,7 @@
 :group 'display-time
 :type 'string)
 
-(defcustom display-time-no-mail-sign-string ""    
+(defcustom display-time-no-mail-sign-string ""
   "The string used as no-mail indicator in the echo area
 (and in the modeline if display-time-show-icons-maybe is nil)
 if display-time-echo-area is t"
@@ -196,6 +200,112 @@
 		 (const transparent)
 		 (string :tag "Color")))
 
+(defcustom display-time-mail-balloon 'display-time-mail-balloon
+  "What to use to generate the ballon frame of the \"mail\" glyph
+if balloon-help is loaded. This can be the function
+display-time-mail-balloon, nil or a string."
+  :group 'display-time 
+  :type '(choice (const display-time-mail-balloon)
+		 (const nil)
+		 (string)))
+
+(defcustom display-time-no-mail-balloon "No mail is good mail."
+  "The string used in the ballon frame of the \"no mail\" glyph
+if balloon-help is loaded. This can also be nil"
+  :group 'display-time 
+  :type '(choice (const nil)
+		 (string)))
+
+(defcustom display-time-mail-balloon-show-gnus-group nil
+  "Show the mail group gnus would put this message in.
+This is only useful if you use gnus to read your mail and have set the variable
+nnmail-split-methods to split your incoming mail into different groups.
+Look at the documentation for gnus. If you don't know what we're talking about,
+don't care and leave this set to nil"
+  :group 'display-time
+  :type 'boolean)
+
+(defface display-time-mail-balloon-enhance-face '((t (:background  "orange")))
+  "Face used for entries in the mail balloon which match the regexp
+display-time-mail-balloon-enhance"
+  :group 'display-time)
+
+(defface display-time-mail-balloon-gnus-group-face '((t (:foreground "blue")))
+  "Face used for the gnus group entry in the mail balloon
+if display-time-mail-balloon-show-gnus-group is t (see the documentation there
+before you set it to t)"
+  :group 'display-time)
+
+(defcustom display-time-mail-balloon-max-displayed 10
+  "The maximum number of messaged which are displayed in the mail balloon.
+You need to have balloon-help loaded to use this."
+  :group 'display-time
+  :type 'number)
+
+(defcustom display-time-mail-balloon-from-width 20
+  "The width of the `From:' part of the mail balloon.
+You need to have ballon-help loaded to use this"
+  :group 'display-time
+  :type 'number)
+
+(defcustom display-time-mail-balloon-subject-width 25
+  "The width of the `Subject:' part of the mail balloon.
+You need to have ballon-help loaded to use this"
+  :group 'display-time
+  :type 'number)
+
+(defcustom display-time-mail-balloon-gnus-split-width 10
+  "The width of the `Gnus Mail Group' part of the mail balloon.
+This denotes the mail group gnus would decide to put this message in.
+For getting this information, it consults the relevant variables from gnus
+(nnmail-split-methods).
+You need to have ballon-help loaded to use this"
+  :group 'display-time
+  :type 'number)
+
+(defcustom display-time-mail-balloon-enhance nil
+  "A list of regular expressions describing which messages should be highlighted
+in the mail balloon. The regexp will be matched against the complete header block
+of an email. You need to load balloon-help to use this"
+  :group 'display-time
+  :type '(repeat (string :tag "Regexp")))
+
+(defcustom display-time-mail-balloon-suppress nil
+  "A list of regular expressions describing which messages should be completely suppressed
+in the mail balloon. The regexp will be matched against the complete header block
+of an email. It will only take effect if the message is not matched already
+by display-time-mail-balloon-enhance.
+You need to load balloon-help to use this"
+  :group 'display-time
+  :type '(repeat (string :tag "Regexp")))
+
+(defcustom display-time-mail-balloon-enhance-gnus-group nil
+  "A list of regular expressions describing which messages should be highlighted
+in the mail balloon. The regexp will be matched against the group gnus would stuff
+this message into. It will only take effect if the message is not matched already
+by display-time-mail-balloon-suppress.
+
+This requires display-time-mail-balloon-show-gnus-group to be t
+and balloon-help to be loaded"
+  :group 'display-time 
+  :type '(repeat (string :tag "Regexp")))
+
+(defcustom display-time-mail-balloon-suppress-gnus-group nil
+  "A list of regular expressions describing which messages should be completely suppressed
+in the mail balloon. The regexp will be matched against the group gnus would stuff
+this message into. It will only take effect if the message is not matched already
+by display-time-mail-balloon-enhance or display-time-mail-balloon-enhance-gnus-group.
+
+This requires display-time-mail-balloon-show-gnus-group to be t
+and balloon-help to be loaded"
+  :group 'display-time
+  :type '(repeat (string :tag "Regexp")))
+
+(defvar display-time-spool-file-modification nil)
+
+(defvar display-time-mail-header nil)
+
+(defvar display-time-temp-buffer " *Display-time-temp-buffer*")
 
 (defvar display-time-display-pad-old nil)
 
@@ -216,6 +326,15 @@
 	       (number :tag "Threshold 5")
 	       (number :tag "Threshold 6")))
 
+(defcustom display-time-compatible nil 
+  "*This variable may be set to t to get the old behaviour of display-time.
+It should be considered obsolete and only be used if you really want the
+old behaviour (eq. you made extensive customizations yourself).
+This means no display of a spiffy mail icon or use of the
+display-time-form-list instead of the old display-time-string-form."
+  :group 'display-time
+  :type 'boolean)
+
 (defun display-time-string-to-char-list (str)
   (mapcar (function identity) str))
 
@@ -275,8 +394,8 @@
 		 (not (equal display-time-display-time-foreground
 			     display-time-display-time-fg-old))))
 	(progn
-	  (setq display-time-1-glyph
-		(cons (make-extent nil nil)
+	  (setq display-time-1-glyph 
+		(cons (make-extent nil nil) 
 		      (make-glyph (concat display-time-icons-dir "1.xpm"))))
 	  (setq display-time-2-glyph
 		(cons (make-extent nil nil)
@@ -325,9 +444,13 @@
       (defvar display-time-mail-sign
 	(cons (make-extent nil nil)
 	      (make-glyph  (concat display-time-icons-dir "letter.xpm"))))
+      (set-extent-property (car display-time-mail-sign) 'balloon-help
+			   'display-time-mail-balloon)
       (defvar display-time-no-mail-sign
 	(cons (make-extent nil nil)
 	      (make-glyph  (concat display-time-icons-dir "no-letter.xpm"))))
+      (set-extent-property (car display-time-no-mail-sign) 'balloon-help
+			   display-time-no-mail-balloon)
       (defvar display-time-1-glyph  nil)
       (defvar display-time-2-glyph  nil)
       (defvar display-time-3-glyph  nil)
@@ -362,14 +485,26 @@
        
 (defun display-time-convert-num (time-string &optional textual)
   (let ((list (display-time-string-to-char-list time-string))
-	elem tmp)
+	elem tmp balloon-help balloon-ext)
     (if (not (display-time-can-do-graphical-display textual)) time-string 
       (display-time-generate-time-glyphs)
+      (setq balloon-help
+	    (format "%s, %s %s %s %s" dayname day monthname year
+		    (concat "   Average load:"
+			    (if (not (equal load ""))
+				load
+			      " 0"))))
+      (setq balloon-ext (make-extent 0 (length balloon-help) balloon-help))
+      (set-extent-property balloon-ext 'face 'red)
+      (set-extent-property balloon-ext 'duplicable 't)
       (while (setq elem (pop list))
-	(push (eval (intern-soft (concat "display-time-"
+	(setq elem
+	      (eval (intern-soft (concat "display-time-"
 					 (char-to-string elem)
-					 "-glyph"))) tmp))
-      (reverse tmp)))) 
+					 "-glyph"))))
+	(set-extent-property (car elem) 'balloon-help balloon-help)
+	(push elem tmp))
+      (reverse tmp))))
 
 (defun display-time-convert-load (load-string &optional textual)
   (let ((load-number (string-to-number load-string))
@@ -381,16 +516,15 @@
 		    (cons 2.5 (cadr (cdddr display-time-load-list)))
 		    (cons 3.0 (caddr (cdddr display-time-load-list)))
 		    (cons 100000 100000)))
-	result elem)
+	elem load-elem)
     (if (not (display-time-can-do-graphical-display textual))
 	load-string
       (display-time-generate-load-glyphs)
       (while (>= load-number (cdr (setq elem (pop alist))))
-	(setq result (eval (intern-soft (concat
-					 "display-time-load-"
-					 (number-to-string (car elem))
-					 "-glyph")))))
-      result)))
+	(setq load-elem elem))
+      (eval (intern-soft (concat "display-time-load-"
+				 (number-to-string (car load-elem))
+				 "-glyph"))))))
 
 (defun display-time-convert-am-pm (ampm-string &optional textual)
   (if (not (display-time-can-do-graphical-display textual))
@@ -398,24 +532,206 @@
     (cond ((equal ampm-string "am") display-time-am-glyph)
 	  ((equal ampm-string "pm") display-time-pm-glyph))))
 
+(defun display-time-mail-balloon (&rest ciao)
+  (let* ((mail-spool-file (or display-time-mail-file
+			      (getenv "MAIL")
+			      (concat rmail-spool-directory
+				      (user-login-name))))
+	 (show-split (and display-time-mail-balloon-show-gnus-group
+			  (or (featurep 'nnmail) (require 'nnmail))))
+	 (display-time-mail-balloon-gnus-split-width
+	  (if (not show-split) 0
+	    (+ 3 display-time-mail-balloon-gnus-split-width))) ; <space>[...] -> +3
+	 (mod (nth 5 (file-attributes mail-spool-file)))
+	 header	header-ext)
+    (setq header "You have mail:")
+    (setq header-ext
+	  (make-extent 0 (length header) header))
+    (set-extent-property header-ext 'face 'red)
+    (set-extent-property header-ext 'duplicable t)
+    (setq header (concat header "\n"
+			 (make-string (+ display-time-mail-balloon-from-width
+					 display-time-mail-balloon-subject-width
+					 display-time-mail-balloon-gnus-split-width
+					 3) (string-to-char "-"))))
+    (if (not (equal
+	      mod display-time-spool-file-modification))
+	(progn
+	  (setq display-time-spool-file-modification mod)
+	  (setq display-time-mail-header
+		(display-time-scan-mail-file mail-spool-file show-split))))
+    (setq header (concat header display-time-mail-header))
+    ))
+
+
+(defun display-time-scan-mail-file (file show-split)
+  (let ((mail-headers "")
+	(nntp-server-buffer (get-buffer-create " *Display-Time-Split-Buffer*"))
+	(suppress-count 0)
+	(not-displayed 0)
+	(i 0)
+	(suppress-list display-time-mail-balloon-suppress)
+	(enhance-list display-time-mail-balloon-enhance)
+	(gnus-suppress-list display-time-mail-balloon-suppress-gnus-group)
+	(gnus-enhance-list display-time-mail-balloon-enhance-gnus-group)
+	mail-headers-list start end from subject gnus-group tmp
+	suppress enhance line line-ext
+	gnus-suppress-reg gnus-enhance-reg suppress-reg enhance-reg)
+    
+    (erase-buffer (get-buffer-create display-time-temp-buffer))
+    (message "Scanning spool file...")
+    (while (setq tmp (pop enhance-list))
+      (setq enhance-reg
+	    (if (car enhance-list) (concat enhance-reg tmp "\\|")
+	      (concat enhance-reg tmp))))
+    (while (setq tmp (pop suppress-list))
+      (setq suppress-reg
+	    (if (car suppress-list) (concat suppress-reg tmp "\\|")
+	      (concat suppress-reg tmp))))
+    (while (setq tmp (pop gnus-enhance-list))
+      (setq gnus-enhance-reg
+	    (if (car gnus-enhance-list) (concat gnus-enhance-reg tmp "\\|")
+	      (concat gnus-enhance-reg tmp))))
+    (while (setq tmp (pop gnus-suppress-list))
+      (setq gnus-suppress-reg
+	    (if (car gnus-suppress-list) (concat gnus-suppress-reg tmp "\\|")
+	      (concat gnus-suppress-reg tmp))))
+    (save-excursion
+      (set-buffer display-time-temp-buffer)
+      (setq case-fold-search nil)
+      (insert-file-contents file)
+      (goto-char (point-min))
+      (while (setq start (re-search-forward "^From " nil t))
+	(save-excursion
+	  (setq end (re-search-forward "^$" nil t))
+	  (narrow-to-region start end)
+	  (goto-char (point-min))
+	  (setq enhance
+		(save-excursion
+		  (if display-time-mail-balloon-enhance
+		      (re-search-forward enhance-reg nil t))))
+	  (if show-split
+	      (save-excursion
+		(setq point (point-min))
+		(nnmail-article-group '(lambda (name) (setq gnus-group name)))))
+	    
+	  (if enhance () ; this takes prejudice over everything else
+	    (setq suppress ; maybe set suppress only if not already enhanced
+		  (save-excursion
+		    (if display-time-mail-balloon-suppress
+			(re-search-forward suppress-reg nil t))))
+	    (if suppress ()
+	      (or (setq enhance      ;;maybe we enhance because of the gnus group name
+			(save-excursion
+			  (if (and show-split gnus-group
+				   display-time-mail-balloon-enhance-gnus-group)
+			      (string-match gnus-enhance-reg gnus-group))))
+		  (setq suppress  ;; if we didn't enhance then maybe we have to suppress it?
+			(save-excursion
+			  (if (and show-split gnus-group
+				   display-time-mail-balloon-suppress-gnus-group)
+			      (string-match gnus-suppress-reg gnus-group)))))))
+	  
+	  (setq from
+		(save-excursion
+		  (re-search-forward "^From: \\(.*\\)" nil t)
+		  (mail-extract-address-components (match-string 1))))
+	  (setq subject
+		(save-excursion
+		  (re-search-forward "^Subject: \\(.*\\)" nil t)
+		  (match-string 1)))
+	  (if suppress (setq suppress-count (1+ suppress-count))
+	    (if (car from) (setq from (car from))
+	      (setq from (cadr from)))
+	    (if (> (length from) display-time-mail-balloon-from-width)
+		(setq from (substring from 0
+				      display-time-mail-balloon-from-width)))
+	    (if (> (length subject) display-time-mail-balloon-subject-width)
+		(setq subject (substring subject 0
+					 display-time-mail-balloon-subject-width)))
+	    (if (and show-split gnus-group
+		     (> (length gnus-group)
+			(- display-time-mail-balloon-gnus-split-width 3)))
+		(setq gnus-group (substring gnus-group 0
+					    (- display-time-mail-balloon-gnus-split-width 3))))
+		
+	    (setq line (format (concat
+				"\n%-"(number-to-string
+				       display-time-mail-balloon-from-width)
+				"s [%-"(number-to-string
+					display-time-mail-balloon-subject-width)
+				"s]")
+			       from subject))
+	    (if (and show-split gnus-group)
+		(setq line (concat line
+				   (format
+				    (concat
+				     "-> %" (number-to-string
+					     (- display-time-mail-balloon-gnus-split-width 3))
+				     "s") gnus-group))))
+	    (if enhance
+		(progn
+		  (setq line-ext (make-extent 1 (length line) line))
+		  (set-extent-property line-ext 'face
+				       'display-time-mail-balloon-enhance-face)
+		  (set-extent-property line-ext 'duplicable t)
+		  (set-extent-property line-ext 'end-open t)))
+	    (if (and show-split gnus-group)
+		(progn
+		  (setq line-ext (make-extent (- (length line)
+						 display-time-mail-balloon-gnus-split-width)
+					      (length line) line))
+		  (set-extent-property line-ext 'face
+				       'display-time-mail-balloon-gnus-group-face)
+		  (set-extent-property line-ext 'duplicable t)
+		  (set-extent-property line-ext 'end-open t)))
+	    (push line mail-headers-list))
+	  (setq point (point-max))
+	  (setq suppress nil
+		gnus-group nil
+		enhance nil)
+	  (widen)
+	  )))
+    (if (> (length mail-headers-list) display-time-mail-balloon-max-displayed)
+	(setq not-displayed (- (length mail-headers-list)
+			       display-time-mail-balloon-max-displayed)))
+    (while (< i display-time-mail-balloon-max-displayed)
+      (setq mail-headers (concat mail-headers (pop mail-headers-list))) 
+      (setq i (1+ i)))
+    (if (and (equal mail-headers "") (> suppress-count 0))
+	     (setq mail-headers "\nOnly junk mail..."))
+    (concat mail-headers "\n"
+	    (make-string (+ display-time-mail-balloon-from-width
+			    display-time-mail-balloon-subject-width
+			    display-time-mail-balloon-gnus-split-width
+			    3) (string-to-char "-"))
+	    "\n"
+	     (if (> not-displayed 0)
+		 (concat "More:       " (number-to-string not-displayed)"\n"))
+	     (if (> suppress-count 0)
+		 (concat "Suppressed: " (number-to-string suppress-count)))
+	     )))
+
 
 (defun display-time-mail-sign (&optional textual)
   "*A function giving back the object indicating 'mail' which
 is the value of display-time-mail-sign when running under X,
 display-time-echo-area is nil and display-time-show-icons-maybe is t.
-It is the value of display-time-mail-sign-string otherwise." 
+It is the value of display-time-mail-sign-string otherwise or when
+the optional parameter TEXTUAL is non-nil." 
   (if (not (display-time-can-do-graphical-display textual))
       display-time-mail-sign-string
-    display-time-mail-sign))
+    (list " " display-time-mail-sign " ")))
 
 (defun display-time-no-mail-sign (&optional textual)
   "*A function giving back the object indicating 'no mail' which
 is the value of display-time-no-mail-sign when running under X,
 display-time-echo-area is nil and display-time-show-icons-maybe is t.
-It is the value of display-time-no-mail-sign-string otherwise." 
+It is the value of display-time-no-mail-sign-string otherwise or when
+the optional parameter TEXTUAL is non-nil." 
   (if (not (display-time-can-do-graphical-display textual))
       display-time-no-mail-sign-string
-    display-time-no-mail-sign))
+    (list " " display-time-no-mail-sign " ")))
 
 (defcustom display-time-form-list
   (list 'date 'time 'load 'mail)