Mercurial > hg > xemacs-beta

comparison lisp/packages/time.el @ 116:9f59509498e1 r20-1b10

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b10
author cvs
date Mon, 13 Aug 2007 09:23:06 +0200
parents 8619ce7e4c50
children 7d55a9ba150c
comparison
equal deleted inserted replaced
115:f109f7dabbe2 116:9f59509498e1
21 ;; You should have received a copy of the GNU General Public License 21 ;; You should have received a copy of the GNU General Public License
22 ;; along with XEmacs; see the file COPYING. If not, write to the Free 22 ;; along with XEmacs; see the file COPYING. If not, write to the Free
23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
24 ;; 02111-1307, USA. 24 ;; 02111-1307, USA.
25 25
26 ;;; Version: 1.10 (I choose the version number starting at 1.1
27 ;;; to indicate that 1.0 was the old version
28 ;;; before I hacked away on it -jtl)
29
26 ;;; Synched up with: Not synched with FSF. 30 ;;; Synched up with: Not synched with FSF.
27 31
28 ;;; Commentary: 32 ;;; Commentary:
29 33
30 ;; Facilities to display current time/date and a new-mail indicator 34 ;; Facilities to display current time/date and a new-mail indicator
32 36
33 ;; See also reportmail.el. 37 ;; See also reportmail.el.
34 ;; This uses the XEmacs timeout-event mechanism, via a version 38 ;; This uses the XEmacs timeout-event mechanism, via a version
35 ;; of Kyle Jones' itimer package. 39 ;; of Kyle Jones' itimer package.
36 40
37 ;;; JTL: This is in a wide part reworked for XEmacs so it won't use 41 ;;; jtl: This is in a wide part reworked for XEmacs so it won't use
38 ;;; the old mechanism for specifying what is to be displayed. 42 ;;; the old mechanism for specifying what is to be displayed.
39 ;;; The starting variable to look at is `display-time-form-list' 43 ;;; The starting variable to look at is `display-time-form-list'
44
45 ;;; It's more advanced features include heavy use of `balloon-help' a
46 ;;; package again written by Kyle Jones. You need to load this
47 ;;; explicitely on your own because I don't think a package should make
48 ;;; decisions which have a global effect (if you want to use it, a
49 ;;; (require 'balloon-help) in your .emacs should work. But look at the
50 ;;; documentation in balloon-help.el itself).
40 51
41 ;;; Thanks to Mike Scheidler for the idea to make the time led's fore- and 52 ;;; Thanks to Mike Scheidler for the idea to make the time led's fore- and
42 ;;; background color customizable 53 ;;; background color customizable
43 54
44 ;;; Code: 55 ;;; Code:
47 58
48 (defgroup display-time nil 59 (defgroup display-time nil
49 "Facilities to display the current time/date/load and a new-mail indicator 60 "Facilities to display the current time/date/load and a new-mail indicator
50 in the XEmacs mode line or echo area." 61 in the XEmacs mode line or echo area."
51 :group 'applications) 62 :group 'applications)
52
53 (defcustom display-time-compatible nil
54 "*This variable may be set to t to get the old behaviour of display-time.
55 This means no display of a spiffy mail icon or use of the
56 display-time-form-list instead of the old display-time-string-form."
57 :group 'display-time
58 :type 'boolean)
59 63
60 (defcustom display-time-mail-file nil 64 (defcustom display-time-mail-file nil
61 "*File name of mail inbox file, for indicating existence of new mail. 65 "*File name of mail inbox file, for indicating existence of new mail.
62 Non-nil and not a string means don't check for mail. nil means use 66 Non-nil and not a string means don't check for mail. nil means use
63 default, which is system-dependent, and is the same as used by Rmail." 67 default, which is system-dependent, and is the same as used by Rmail."
96 100
97 (defvar display-time-server-down-time nil 101 (defvar display-time-server-down-time nil
98 "Time when mail file's file system was recorded to be down. 102 "Time when mail file's file system was recorded to be down.
99 If that file system seems to be up, the value is nil.") 103 If that file system seems to be up, the value is nil.")
100 104
101 (defcustom display-time-ignore-read-mail nil 105 (defcustom display-time-ignore-read-mail t
102 "*Non-nil means displays the mail icon on any non-empty mailbox." 106 "*Non-nil means display the mail icon on any non-empty mailbox."
103 :group 'display-time 107 :group 'display-time
104 :type 'boolean) 108 :type 'boolean)
105 109
106 ;;;###autoload 110 ;;;###autoload
107 (defun display-time () 111 (defun display-time ()
153 "Use icons for time, load and mail status if possible 157 "Use icons for time, load and mail status if possible
154 and not specified different explicitely" 158 and not specified different explicitely"
155 :group 'display-time 159 :group 'display-time
156 :type 'boolean) 160 :type 'boolean)
157 161
158 (defvar display-time-icons-dir (concat data-directory "time/")) 162 (defvar display-time-icons-dir (concat data-directory "time/"))
159 163
160 (defcustom display-time-mail-sign-string " Mail" 164 (defcustom display-time-mail-sign-string " Mail"
161 "The string used as mail indicator in the echo area 165 "The string used as mail indicator in the echo area
162 (and in the modeline if display-time-show-icons-maybe is nil) 166 (and in the modeline if display-time-show-icons-maybe is nil)
163 if display-time-echo-area is t" 167 if display-time-echo-area is t"
164 :group 'display-time 168 :group 'display-time
165 :type 'string) 169 :type 'string)
166 170
167 (defcustom display-time-no-mail-sign-string "" 171 (defcustom display-time-no-mail-sign-string ""
168 "The string used as no-mail indicator in the echo area 172 "The string used as no-mail indicator in the echo area
169 (and in the modeline if display-time-show-icons-maybe is nil) 173 (and in the modeline if display-time-show-icons-maybe is nil)
170 if display-time-echo-area is t" 174 if display-time-echo-area is t"
171 :group 'display-time 175 :group 'display-time
172 :type 'string) 176 :type 'string)
194 :group 'display-time 198 :group 'display-time
195 :type '(choice :tag "Value" 199 :type '(choice :tag "Value"
196 (const transparent) 200 (const transparent)
197 (string :tag "Color"))) 201 (string :tag "Color")))
198 202
203 (defcustom display-time-mail-balloon 'display-time-mail-balloon
204 "What to use to generate the ballon frame of the \"mail\" glyph
205 if balloon-help is loaded. This can be the function
206 display-time-mail-balloon, nil or a string."
207 :group 'display-time
208 :type '(choice (const display-time-mail-balloon)
209 (const nil)
210 (string)))
211
212 (defcustom display-time-no-mail-balloon "No mail is good mail."
213 "The string used in the ballon frame of the \"no mail\" glyph
214 if balloon-help is loaded. This can also be nil"
215 :group 'display-time
216 :type '(choice (const nil)
217 (string)))
218
219 (defcustom display-time-mail-balloon-show-gnus-group nil
220 "Show the mail group gnus would put this message in.
221 This is only useful if you use gnus to read your mail and have set the variable
222 nnmail-split-methods to split your incoming mail into different groups.
223 Look at the documentation for gnus. If you don't know what we're talking about,
224 don't care and leave this set to nil"
225 :group 'display-time
226 :type 'boolean)
227
228 (defface display-time-mail-balloon-enhance-face '((t (:background "orange")))
229 "Face used for entries in the mail balloon which match the regexp
230 display-time-mail-balloon-enhance"
231 :group 'display-time)
232
233 (defface display-time-mail-balloon-gnus-group-face '((t (:foreground "blue")))
234 "Face used for the gnus group entry in the mail balloon
235 if display-time-mail-balloon-show-gnus-group is t (see the documentation there
236 before you set it to t)"
237 :group 'display-time)
238
239 (defcustom display-time-mail-balloon-max-displayed 10
240 "The maximum number of messaged which are displayed in the mail balloon.
241 You need to have balloon-help loaded to use this."
242 :group 'display-time
243 :type 'number)
244
245 (defcustom display-time-mail-balloon-from-width 20
246 "The width of the `From:' part of the mail balloon.
247 You need to have ballon-help loaded to use this"
248 :group 'display-time
249 :type 'number)
250
251 (defcustom display-time-mail-balloon-subject-width 25
252 "The width of the `Subject:' part of the mail balloon.
253 You need to have ballon-help loaded to use this"
254 :group 'display-time
255 :type 'number)
256
257 (defcustom display-time-mail-balloon-gnus-split-width 10
258 "The width of the `Gnus Mail Group' part of the mail balloon.
259 This denotes the mail group gnus would decide to put this message in.
260 For getting this information, it consults the relevant variables from gnus
261 (nnmail-split-methods).
262 You need to have ballon-help loaded to use this"
263 :group 'display-time
264 :type 'number)
265
266 (defcustom display-time-mail-balloon-enhance nil
267 "A list of regular expressions describing which messages should be highlighted
268 in the mail balloon. The regexp will be matched against the complete header block
269 of an email. You need to load balloon-help to use this"
270 :group 'display-time
271 :type '(repeat (string :tag "Regexp")))
272
273 (defcustom display-time-mail-balloon-suppress nil
274 "A list of regular expressions describing which messages should be completely suppressed
275 in the mail balloon. The regexp will be matched against the complete header block
276 of an email. It will only take effect if the message is not matched already
277 by display-time-mail-balloon-enhance.
278 You need to load balloon-help to use this"
279 :group 'display-time
280 :type '(repeat (string :tag "Regexp")))
281
282 (defcustom display-time-mail-balloon-enhance-gnus-group nil
283 "A list of regular expressions describing which messages should be highlighted
284 in the mail balloon. The regexp will be matched against the group gnus would stuff
285 this message into. It will only take effect if the message is not matched already
286 by display-time-mail-balloon-suppress.
287
288 This requires display-time-mail-balloon-show-gnus-group to be t
289 and balloon-help to be loaded"
290 :group 'display-time
291 :type '(repeat (string :tag "Regexp")))
292
293 (defcustom display-time-mail-balloon-suppress-gnus-group nil
294 "A list of regular expressions describing which messages should be completely suppressed
295 in the mail balloon. The regexp will be matched against the group gnus would stuff
296 this message into. It will only take effect if the message is not matched already
297 by display-time-mail-balloon-enhance or display-time-mail-balloon-enhance-gnus-group.
298
299 This requires display-time-mail-balloon-show-gnus-group to be t
300 and balloon-help to be loaded"
301 :group 'display-time
302 :type '(repeat (string :tag "Regexp")))
303
304 (defvar display-time-spool-file-modification nil)
305
306 (defvar display-time-mail-header nil)
307
308 (defvar display-time-temp-buffer " *Display-time-temp-buffer*")
199 309
200 (defvar display-time-display-pad-old nil) 310 (defvar display-time-display-pad-old nil)
201 311
202 (defvar display-time-display-time-fg-old nil) 312 (defvar display-time-display-time-fg-old nil)
203 313
213 (number :tag "Threshold 2") 323 (number :tag "Threshold 2")
214 (number :tag "Threshold 3") 324 (number :tag "Threshold 3")
215 (number :tag "Threshold 4") 325 (number :tag "Threshold 4")
216 (number :tag "Threshold 5") 326 (number :tag "Threshold 5")
217 (number :tag "Threshold 6"))) 327 (number :tag "Threshold 6")))
328
329 (defcustom display-time-compatible nil
330 "*This variable may be set to t to get the old behaviour of display-time.
331 It should be considered obsolete and only be used if you really want the
332 old behaviour (eq. you made extensive customizations yourself).
333 This means no display of a spiffy mail icon or use of the
334 display-time-form-list instead of the old display-time-string-form."
335 :group 'display-time
336 :type 'boolean)
218 337
219 (defun display-time-string-to-char-list (str) 338 (defun display-time-string-to-char-list (str)
220 (mapcar (function identity) str)) 339 (mapcar (function identity) str))
221 340
222 (defun display-time-generate-load-glyphs (&optional force) 341 (defun display-time-generate-load-glyphs (&optional force)
273 (or force (not (equal display-time-display-time-background 392 (or force (not (equal display-time-display-time-background
274 display-time-display-time-bg-old)) 393 display-time-display-time-bg-old))
275 (not (equal display-time-display-time-foreground 394 (not (equal display-time-display-time-foreground
276 display-time-display-time-fg-old)))) 395 display-time-display-time-fg-old))))
277 (progn 396 (progn
278 (setq display-time-1-glyph 397 (setq display-time-1-glyph
279 (cons (make-extent nil nil) 398 (cons (make-extent nil nil)
280 (make-glyph (concat display-time-icons-dir "1.xpm")))) 399 (make-glyph (concat display-time-icons-dir "1.xpm"))))
281 (setq display-time-2-glyph 400 (setq display-time-2-glyph
282 (cons (make-extent nil nil) 401 (cons (make-extent nil nil)
283 (make-glyph (concat display-time-icons-dir "2.xpm")))) 402 (make-glyph (concat display-time-icons-dir "2.xpm"))))
284 (setq display-time-3-glyph 403 (setq display-time-3-glyph
323 (if (featurep 'xpm) 442 (if (featurep 'xpm)
324 (progn 443 (progn
325 (defvar display-time-mail-sign 444 (defvar display-time-mail-sign
326 (cons (make-extent nil nil) 445 (cons (make-extent nil nil)
327 (make-glyph (concat display-time-icons-dir "letter.xpm")))) 446 (make-glyph (concat display-time-icons-dir "letter.xpm"))))
447 (set-extent-property (car display-time-mail-sign) 'balloon-help
448 'display-time-mail-balloon)
328 (defvar display-time-no-mail-sign 449 (defvar display-time-no-mail-sign
329 (cons (make-extent nil nil) 450 (cons (make-extent nil nil)
330 (make-glyph (concat display-time-icons-dir "no-letter.xpm")))) 451 (make-glyph (concat display-time-icons-dir "no-letter.xpm"))))
452 (set-extent-property (car display-time-no-mail-sign) 'balloon-help
453 display-time-no-mail-balloon)
331 (defvar display-time-1-glyph nil) 454 (defvar display-time-1-glyph nil)
332 (defvar display-time-2-glyph nil) 455 (defvar display-time-2-glyph nil)
333 (defvar display-time-3-glyph nil) 456 (defvar display-time-3-glyph nil)
334 (defvar display-time-4-glyph nil) 457 (defvar display-time-4-glyph nil)
335 (defvar display-time-5-glyph nil) 458 (defvar display-time-5-glyph nil)
360 (not display-time-echo-area))) 483 (not display-time-echo-area)))
361 484
362 485
363 (defun display-time-convert-num (time-string &optional textual) 486 (defun display-time-convert-num (time-string &optional textual)
364 (let ((list (display-time-string-to-char-list time-string)) 487 (let ((list (display-time-string-to-char-list time-string))
365 elem tmp) 488 elem tmp balloon-help balloon-ext)
366 (if (not (display-time-can-do-graphical-display textual)) time-string 489 (if (not (display-time-can-do-graphical-display textual)) time-string
367 (display-time-generate-time-glyphs) 490 (display-time-generate-time-glyphs)
491 (setq balloon-help
492 (format "%s, %s %s %s %s" dayname day monthname year
493 (concat " Average load:"
494 (if (not (equal load ""))
495 load
496 " 0"))))
497 (setq balloon-ext (make-extent 0 (length balloon-help) balloon-help))
498 (set-extent-property balloon-ext 'face 'red)
499 (set-extent-property balloon-ext 'duplicable 't)
368 (while (setq elem (pop list)) 500 (while (setq elem (pop list))
369 (push (eval (intern-soft (concat "display-time-" 501 (setq elem
502 (eval (intern-soft (concat "display-time-"
370 (char-to-string elem) 503 (char-to-string elem)
371 "-glyph"))) tmp)) 504 "-glyph"))))
372 (reverse tmp)))) 505 (set-extent-property (car elem) 'balloon-help balloon-help)
506 (push elem tmp))
507 (reverse tmp))))
373 508
374 (defun display-time-convert-load (load-string &optional textual) 509 (defun display-time-convert-load (load-string &optional textual)
375 (let ((load-number (string-to-number load-string)) 510 (let ((load-number (string-to-number load-string))
376 (alist (list (cons 0.0 0.0) 511 (alist (list (cons 0.0 0.0)
377 (cons 0.5 (car display-time-load-list)) 512 (cons 0.5 (car display-time-load-list))
379 (cons 1.5 (caddr display-time-load-list)) 514 (cons 1.5 (caddr display-time-load-list))
380 (cons 2.0 (cadddr display-time-load-list)) 515 (cons 2.0 (cadddr display-time-load-list))
381 (cons 2.5 (cadr (cdddr display-time-load-list))) 516 (cons 2.5 (cadr (cdddr display-time-load-list)))
382 (cons 3.0 (caddr (cdddr display-time-load-list))) 517 (cons 3.0 (caddr (cdddr display-time-load-list)))
383 (cons 100000 100000))) 518 (cons 100000 100000)))
384 result elem) 519 elem load-elem)
385 (if (not (display-time-can-do-graphical-display textual)) 520 (if (not (display-time-can-do-graphical-display textual))
386 load-string 521 load-string
387 (display-time-generate-load-glyphs) 522 (display-time-generate-load-glyphs)
388 (while (>= load-number (cdr (setq elem (pop alist)))) 523 (while (>= load-number (cdr (setq elem (pop alist))))
389 (setq result (eval (intern-soft (concat 524 (setq load-elem elem))
390 "display-time-load-" 525 (eval (intern-soft (concat "display-time-load-"
391 (number-to-string (car elem)) 526 (number-to-string (car load-elem))
392 "-glyph"))))) 527 "-glyph"))))))
393 result)))
394 528
395 (defun display-time-convert-am-pm (ampm-string &optional textual) 529 (defun display-time-convert-am-pm (ampm-string &optional textual)
396 (if (not (display-time-can-do-graphical-display textual)) 530 (if (not (display-time-can-do-graphical-display textual))
397 ampm-string 531 ampm-string
398 (cond ((equal ampm-string "am") display-time-am-glyph) 532 (cond ((equal ampm-string "am") display-time-am-glyph)
399 ((equal ampm-string "pm") display-time-pm-glyph)))) 533 ((equal ampm-string "pm") display-time-pm-glyph))))
400 534
535 (defun display-time-mail-balloon (&rest ciao)
536 (let* ((mail-spool-file (or display-time-mail-file
537 (getenv "MAIL")
538 (concat rmail-spool-directory
539 (user-login-name))))
540 (show-split (and display-time-mail-balloon-show-gnus-group
541 (or (featurep 'nnmail) (require 'nnmail))))
542 (display-time-mail-balloon-gnus-split-width
543 (if (not show-split) 0
544 (+ 3 display-time-mail-balloon-gnus-split-width))) ; <space>[...] -> +3
545 (mod (nth 5 (file-attributes mail-spool-file)))
546 header header-ext)
547 (setq header "You have mail:")
548 (setq header-ext
549 (make-extent 0 (length header) header))
550 (set-extent-property header-ext 'face 'red)
551 (set-extent-property header-ext 'duplicable t)
552 (setq header (concat header "\n"
553 (make-string (+ display-time-mail-balloon-from-width
554 display-time-mail-balloon-subject-width
555 display-time-mail-balloon-gnus-split-width
556 3) (string-to-char "-"))))
557 (if (not (equal
558 mod display-time-spool-file-modification))
559 (progn
560 (setq display-time-spool-file-modification mod)
561 (setq display-time-mail-header
562 (display-time-scan-mail-file mail-spool-file show-split))))
563 (setq header (concat header display-time-mail-header))
564 ))
565
566
567 (defun display-time-scan-mail-file (file show-split)
568 (let ((mail-headers "")
569 (nntp-server-buffer (get-buffer-create " *Display-Time-Split-Buffer*"))
570 (suppress-count 0)
571 (not-displayed 0)
572 (i 0)
573 (suppress-list display-time-mail-balloon-suppress)
574 (enhance-list display-time-mail-balloon-enhance)
575 (gnus-suppress-list display-time-mail-balloon-suppress-gnus-group)
576 (gnus-enhance-list display-time-mail-balloon-enhance-gnus-group)
577 mail-headers-list start end from subject gnus-group tmp
578 suppress enhance line line-ext
579 gnus-suppress-reg gnus-enhance-reg suppress-reg enhance-reg)
580
581 (erase-buffer (get-buffer-create display-time-temp-buffer))
582 (message "Scanning spool file...")
583 (while (setq tmp (pop enhance-list))
584 (setq enhance-reg
585 (if (car enhance-list) (concat enhance-reg tmp "\\|")
586 (concat enhance-reg tmp))))
587 (while (setq tmp (pop suppress-list))
588 (setq suppress-reg
589 (if (car suppress-list) (concat suppress-reg tmp "\\|")
590 (concat suppress-reg tmp))))
591 (while (setq tmp (pop gnus-enhance-list))
592 (setq gnus-enhance-reg
593 (if (car gnus-enhance-list) (concat gnus-enhance-reg tmp "\\|")
594 (concat gnus-enhance-reg tmp))))
595 (while (setq tmp (pop gnus-suppress-list))
596 (setq gnus-suppress-reg
597 (if (car gnus-suppress-list) (concat gnus-suppress-reg tmp "\\|")
598 (concat gnus-suppress-reg tmp))))
599 (save-excursion
600 (set-buffer display-time-temp-buffer)
601 (setq case-fold-search nil)
602 (insert-file-contents file)
603 (goto-char (point-min))
604 (while (setq start (re-search-forward "^From " nil t))
605 (save-excursion
606 (setq end (re-search-forward "^$" nil t))
607 (narrow-to-region start end)
608 (goto-char (point-min))
609 (setq enhance
610 (save-excursion
611 (if display-time-mail-balloon-enhance
612 (re-search-forward enhance-reg nil t))))
613 (if show-split
614 (save-excursion
615 (setq point (point-min))
616 (nnmail-article-group '(lambda (name) (setq gnus-group name)))))
617
618 (if enhance () ; this takes prejudice over everything else
619 (setq suppress ; maybe set suppress only if not already enhanced
620 (save-excursion
621 (if display-time-mail-balloon-suppress
622 (re-search-forward suppress-reg nil t))))
623 (if suppress ()
624 (or (setq enhance ;;maybe we enhance because of the gnus group name
625 (save-excursion
626 (if (and show-split gnus-group
627 display-time-mail-balloon-enhance-gnus-group)
628 (string-match gnus-enhance-reg gnus-group))))
629 (setq suppress ;; if we didn't enhance then maybe we have to suppress it?
630 (save-excursion
631 (if (and show-split gnus-group
632 display-time-mail-balloon-suppress-gnus-group)
633 (string-match gnus-suppress-reg gnus-group)))))))
634
635 (setq from
636 (save-excursion
637 (re-search-forward "^From: \\(.*\\)" nil t)
638 (mail-extract-address-components (match-string 1))))
639 (setq subject
640 (save-excursion
641 (re-search-forward "^Subject: \\(.*\\)" nil t)
642 (match-string 1)))
643 (if suppress (setq suppress-count (1+ suppress-count))
644 (if (car from) (setq from (car from))
645 (setq from (cadr from)))
646 (if (> (length from) display-time-mail-balloon-from-width)
647 (setq from (substring from 0
648 display-time-mail-balloon-from-width)))
649 (if (> (length subject) display-time-mail-balloon-subject-width)
650 (setq subject (substring subject 0
651 display-time-mail-balloon-subject-width)))
652 (if (and show-split gnus-group
653 (> (length gnus-group)
654 (- display-time-mail-balloon-gnus-split-width 3)))
655 (setq gnus-group (substring gnus-group 0
656 (- display-time-mail-balloon-gnus-split-width 3))))
657
658 (setq line (format (concat
659 "\n%-"(number-to-string
660 display-time-mail-balloon-from-width)
661 "s [%-"(number-to-string
662 display-time-mail-balloon-subject-width)
663 "s]")
664 from subject))
665 (if (and show-split gnus-group)
666 (setq line (concat line
667 (format
668 (concat
669 "-> %" (number-to-string
670 (- display-time-mail-balloon-gnus-split-width 3))
671 "s") gnus-group))))
672 (if enhance
673 (progn
674 (setq line-ext (make-extent 1 (length line) line))
675 (set-extent-property line-ext 'face
676 'display-time-mail-balloon-enhance-face)
677 (set-extent-property line-ext 'duplicable t)
678 (set-extent-property line-ext 'end-open t)))
679 (if (and show-split gnus-group)
680 (progn
681 (setq line-ext (make-extent (- (length line)
682 display-time-mail-balloon-gnus-split-width)
683 (length line) line))
684 (set-extent-property line-ext 'face
685 'display-time-mail-balloon-gnus-group-face)
686 (set-extent-property line-ext 'duplicable t)
687 (set-extent-property line-ext 'end-open t)))
688 (push line mail-headers-list))
689 (setq point (point-max))
690 (setq suppress nil
691 gnus-group nil
692 enhance nil)
693 (widen)
694 )))
695 (if (> (length mail-headers-list) display-time-mail-balloon-max-displayed)
696 (setq not-displayed (- (length mail-headers-list)
697 display-time-mail-balloon-max-displayed)))
698 (while (< i display-time-mail-balloon-max-displayed)
699 (setq mail-headers (concat mail-headers (pop mail-headers-list)))
700 (setq i (1+ i)))
701 (if (and (equal mail-headers "") (> suppress-count 0))
702 (setq mail-headers "\nOnly junk mail..."))
703 (concat mail-headers "\n"
704 (make-string (+ display-time-mail-balloon-from-width
705 display-time-mail-balloon-subject-width
706 display-time-mail-balloon-gnus-split-width
707 3) (string-to-char "-"))
708 "\n"
709 (if (> not-displayed 0)
710 (concat "More: " (number-to-string not-displayed)"\n"))
711 (if (> suppress-count 0)
712 (concat "Suppressed: " (number-to-string suppress-count)))
713 )))
714
401 715
402 (defun display-time-mail-sign (&optional textual) 716 (defun display-time-mail-sign (&optional textual)
403 "*A function giving back the object indicating 'mail' which 717 "*A function giving back the object indicating 'mail' which
404 is the value of display-time-mail-sign when running under X, 718 is the value of display-time-mail-sign when running under X,
405 display-time-echo-area is nil and display-time-show-icons-maybe is t. 719 display-time-echo-area is nil and display-time-show-icons-maybe is t.
406 It is the value of display-time-mail-sign-string otherwise." 720 It is the value of display-time-mail-sign-string otherwise or when
721 the optional parameter TEXTUAL is non-nil."
407 (if (not (display-time-can-do-graphical-display textual)) 722 (if (not (display-time-can-do-graphical-display textual))
408 display-time-mail-sign-string 723 display-time-mail-sign-string
409 display-time-mail-sign)) 724 (list " " display-time-mail-sign " ")))
410 725
411 (defun display-time-no-mail-sign (&optional textual) 726 (defun display-time-no-mail-sign (&optional textual)
412 "*A function giving back the object indicating 'no mail' which 727 "*A function giving back the object indicating 'no mail' which
413 is the value of display-time-no-mail-sign when running under X, 728 is the value of display-time-no-mail-sign when running under X,
414 display-time-echo-area is nil and display-time-show-icons-maybe is t. 729 display-time-echo-area is nil and display-time-show-icons-maybe is t.
415 It is the value of display-time-no-mail-sign-string otherwise." 730 It is the value of display-time-no-mail-sign-string otherwise or when
731 the optional parameter TEXTUAL is non-nil."
416 (if (not (display-time-can-do-graphical-display textual)) 732 (if (not (display-time-can-do-graphical-display textual))
417 display-time-no-mail-sign-string 733 display-time-no-mail-sign-string
418 display-time-no-mail-sign)) 734 (list " " display-time-no-mail-sign " ")))
419 735
420 (defcustom display-time-form-list 736 (defcustom display-time-form-list
421 (list 'date 'time 'load 'mail) 737 (list 'date 'time 'load 'mail)
422 "*This list describes the format of the strings/glyphs 738 "*This list describes the format of the strings/glyphs
423 which are to be displayed by display-time. 739 which are to be displayed by display-time.