[COMMIT TIME] Handle mixed TTY and window-system XEmacs better, don't pollute lossage, time.el

APPROVE COMMIT NOTE: This patch has been committed # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # Date 1508871793 -3600 # Tue Oct 24 20:03:13 2017 +0100 # Node ID 7daf4c73004fd4f47ef260baebad26953f7e0f5e # Parent e6d063da5d54876bcf3855c748b9d41453cb73d9 Handle mixed TTY and window-system XEmacs better, don't pollute lossage, time.el ChangeLog addition: 2017-10-24 Aidan Kehoe <kehoea(a)parhasard.net&gt; * time.el: * time.el (display-time-mail-file): * time.el (display-time-insinuated): Moved earlier in the file. * time.el (display-time-mail-sign-string): * time.el (display-time-compatible): Removed. * time.el (load-conversion-table): * time.el (display-time-glyph-table): New. * time.el (display-time-string-to-char-list): Removed. * time.el (display-time-update-load-glyphs): New. * time.el (xpm-color-symbols)): New. * time.el (display-time-generate-time-glyphs): * time.el (display-time-update-time-glyphs): New. * time.el (display-time-insinuate): * time.el (display-time-convert-num): * time.el (display-time-convert-am-pm): * time.el (display-time-init-glyphs): Removed. * time.el (display-time-generate-mail-glyphs): New. * time.el (display-time-can-do-graphical-display): Removed. * time.el (display-time-mail-sign): * time.el (display-time-no-mail-sign): * time.el (display-time-convert-load): Removed. * time.el (display-time-form-list): * time.el (display-time-details): New. * time.el (make-display-time-details): New. * time.el (display-time-evaluate-list): * time.el (display-time-function): * time.el (display-time-string-forms): Removed. Extensive changes to this file. Thematically: 1. Rework very amateur code that called #'eval at runtime to map from a character to a glyph for the LED-type time display, use a hash table instead. 2. Instead of explicitly checking in Lisp within #'display-time-function for whether the current device can handle graphics, and failing to give reasonable output when the modeline is redisplayed on a TTY after being generated on a window-system, use specifier tags, as is the correct approach on XEmacs. This leads to simpler runtime code too. 3. Avoid using dynamic scope to communicate details of the current time to called functions, define a struct instead and pass an instance of that struct around. 4. Remove support for display-time-string-forms, long marked as deprecated. This was a list of forms to be evalled, with the performance and probably security drawbacks that implies. 5. When display-time-echo-area is t, don't log the output; this avoids filling up what #'view-lossage shows with a new message every minute, to the detriment of usability of that command. diff -r e6d063da5d54 -r 7daf4c73004f ChangeLog --- a/ChangeLog Thu May 15 21:13:05 2014 +0200 +++ b/ChangeLog Tue Oct 24 20:03:13 2017 +0100 ＠＠ -1,3 +1,53 ＠＠ +2017-10-24 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * time.el: + * time.el (display-time-mail-file): + * time.el (display-time-insinuated): Moved earlier in the file. + * time.el (display-time-mail-sign-string): + * time.el (display-time-compatible): Removed. + * time.el (load-conversion-table): + * time.el (display-time-glyph-table): New. + * time.el (display-time-string-to-char-list): Removed. + * time.el (display-time-update-load-glyphs): New. + * time.el (xpm-color-symbols)): New. + * time.el (display-time-generate-time-glyphs): + * time.el (display-time-update-time-glyphs): New. + * time.el (display-time-insinuate): + * time.el (display-time-convert-num): + * time.el (display-time-convert-am-pm): + * time.el (display-time-init-glyphs): Removed. + * time.el (display-time-generate-mail-glyphs): New. + * time.el (display-time-can-do-graphical-display): Removed. + * time.el (display-time-mail-sign): + * time.el (display-time-no-mail-sign): + * time.el (display-time-convert-load): Removed. + * time.el (display-time-form-list): + * time.el (display-time-details): New. + * time.el (make-display-time-details): New. + * time.el (display-time-evaluate-list): + * time.el (display-time-function): + * time.el (display-time-string-forms): Removed. + Extensive changes to this file. Thematically: + + 1. Rework very amateur code that called #'eval at runtime to map + from a character to a glyph for the LED-type time display, use a + hash table instead. + 2. Instead of explicitly checking in Lisp within + #'display-time-function for whether the current device can handle + graphics, and failing to give reasonable output when the modeline + is redisplayed on a TTY after being generated on a window-system, + use specifier tags, as is the correct approach on XEmacs. This + leads to simpler runtime code too. + 3. Avoid using dynamic scope to communicate details of the current + time to called functions, define a struct instead and pass an + instance of that struct around. + 4. Remove support for display-time-string-forms, long marked as + deprecated. This was a list of forms to be evalled, with the + performance and probably security drawbacks that implies. + 5. When display-time-echo-area is t, don't log the output; this + avoids filling up what #'view-lossage shows with a new message + every minute, to the detriment of usability of that command. + 2014-05-15 Norbert Koch <viteno(a)xemacs.org&gt; * Makefile (VERSION): XEmacs package 1.16 released. diff -r e6d063da5d54 -r 7daf4c73004f time.el --- a/time.el Thu May 15 21:13:05 2014 +0200 +++ b/time.el Tue Oct 24 20:03:13 2017 +0100 ＠＠ -82,7 +82,6 ＠＠ balloon-help must be loaded before these settings take effect." :group 'display-time) - (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 ＠＠ -129,6 +128,8 ＠＠ :group 'display-time :type 'boolean) +(defvar display-time-insinuated nil) + ;;;###autoload (defun display-time () "Display current time, load level, and mail flag in mode line of each buffer. ＠＠ -187,7 +188,7 ＠＠ (defcustom display-time-mail-sign-string " Mail" "The string used as mail indicator in the echo area -(and in the modeline if display-time-show-icons-maybe is nil) +\(and in the modeline if display-time-show-icons-maybe is nil) if display-time-echo-area is t" :group 'display-time :type 'string) ＠＠ -355,251 +356,213 ＠＠ (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) +(defvar display-time-glyph-table (make-hash-table :test #'eq)) -(defun display-time-string-to-char-list (str) - (mapcar (function identity) str)) +(defsubst display-time-update-load-glyphs () + (if (not (equal display-time-display-pad display-time-display-pad-old)) + (display-time-generate-load-glyphs))) + +(defvar xpm-color-symbols) ;; Silence bytecomp warnings. -(defun display-time-generate-load-glyphs (&optional force) - (let* ((pad-color (if (symbolp display-time-display-pad) - (list "pad-color" '(face-background 'modeline)) - (list "pad-color" display-time-display-pad))) - (xpm-color-symbols (append (list pad-color) xpm-color-symbols))) - (if (and (featurep 'xpm) - (or force (not (equal display-time-display-pad - display-time-display-pad-old)))) - (progn - (setq display-time-load-0.0-glyph - (cons (make-extent nil nil) - (make-glyph - (concat display-time-icons-dir "l-0.0.xpm")))) - (setq display-time-load-0.5-glyph - (cons (make-extent nil nil) - (make-glyph - (concat display-time-icons-dir "l-0.5.xpm")))) - (setq display-time-load-1.0-glyph - (cons (make-extent nil nil) - (make-glyph - (concat display-time-icons-dir "l-1.0.xpm")))) - (setq display-time-load-1.5-glyph - (cons (make-extent nil nil) - (make-glyph - (concat display-time-icons-dir "l-1.5.xpm")))) - (setq display-time-load-2.0-glyph - (cons (make-extent nil nil) - (make-glyph - (concat display-time-icons-dir "l-2.0.xpm")))) - (setq display-time-load-2.5-glyph - (cons (make-extent nil nil) - (make-glyph - (concat display-time-icons-dir "l-2.5.xpm")))) - (setq display-time-load-3.0-glyph - (cons (make-extent nil nil) - (make-glyph - (concat display-time-icons-dir "l-3.0.xpm")))) - (setq display-time-display-pad-old display-time-display-pad) - )))) +(symbol-macrolet + ((load-conversion-table [#:0.0 #:0.5 #:1.0 #:1.5 #:2.0 #:2.5 #:3.0 1000])) + (fset + 'display-time-generate-load-glyphs + #'(lambda () + (let* ((xpm-color-symbols (cons `("pad-color" + ,(if (symbolp + display-time-display-pad) + '(face-background 'modeline) + display-time-display-pad)) + (if (featurep 'xpm) + xpm-color-symbols)))) + (macrolet + ((make-load-glyphs (&rest alist) + (cons + 'setf + (loop for (index string fallback) in alist + append + `((gethash (aref load-conversion-table ,index) + display-time-glyph-table) + (cons (make-extent nil nil) + (make-glyph `((global + ,＠(when (featurep 'xpm) + `((win + . + [xpm :file + ,(concat + display-time-icons-dir + ,(concat string + ".xpm"))]))) + ,,(or fallback + `(vector + 'string :data + (concat + " " + (number-to-string + (elt + display-time-load-list + ,index)))))))))))))) + (make-load-glyphs (0 "l-0.0") (1 "l-0.5") (2 "l-1.0") + (3 "l-1.5") (4 "l-2.0") (5 "l-2.5") + (6 "l-3.0" + (vector 'string :data + (format ">%f" + (elt display-time-load-list + 5)))))) + (setf display-time-display-pad-old + display-time-display-pad)))) + (fset + 'display-time-convert-load + #'(lambda (load-string &optional textual) + (if display-time-echo-area + (concat " " load-string) + (display-time-update-load-glyphs) + (gethash (aref load-conversion-table + (or (position (string-to-number load-string) + display-time-load-list :test #'<) + (1- (length load-conversion-table)))) + display-time-glyph-table))))) +(defsubst display-time-update-time-glyphs () + (when (or (not (equal display-time-display-time-background + display-time-display-time-bg-old)) + (not (equal display-time-display-time-foreground + display-time-display-time-fg-old))) + (display-time-generate-time-glyphs))) -(defun display-time-generate-time-glyphs (&optional force) - (let* ((ledbg (if (symbolp display-time-display-time-background) - (list "ledbg" '(face-background 'modeline)) - (list "ledbg" display-time-display-time-background))) - (ledfg (if (symbolp display-time-display-time-foreground) - (list "ledfg" '(face-foreground 'modeline)) - (list "ledfg" display-time-display-time-foreground))) - (xpm-color-symbols (append (list ledbg) - (list ledfg) xpm-color-symbols))) - (if (and (featurep 'xpm) - (or force (not (equal display-time-display-time-background - display-time-display-time-bg-old)) - (not (equal display-time-display-time-foreground - display-time-display-time-fg-old)))) - (progn - (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) - (make-glyph (concat display-time-icons-dir "2.xpm")))) - (setq display-time-3-glyph - (cons (make-extent nil nil) - (make-glyph (concat display-time-icons-dir "3.xpm")))) - (setq display-time-4-glyph - (cons (make-extent nil nil) - (make-glyph (concat display-time-icons-dir "4.xpm")))) - (setq display-time-5-glyph - (cons (make-extent nil nil) - (make-glyph (concat display-time-icons-dir "5.xpm")))) - (setq display-time-6-glyph - (cons (make-extent nil nil) - (make-glyph (concat display-time-icons-dir "6.xpm")))) - (setq display-time-7-glyph - (cons (make-extent nil nil) - (make-glyph (concat display-time-icons-dir "7.xpm")))) - (setq display-time-8-glyph - (cons (make-extent nil nil) - (make-glyph (concat display-time-icons-dir "8.xpm")))) - (setq display-time-9-glyph - (cons (make-extent nil nil) - (make-glyph (concat display-time-icons-dir "9.xpm")))) - (setq display-time-0-glyph - (cons (make-extent nil nil) - (make-glyph (concat display-time-icons-dir "0.xpm")))) - (setq display-time-:-glyph - (cons (make-extent nil nil) - (make-glyph (concat display-time-icons-dir "dp.xpm")))) - (setq display-time-am-glyph - (cons (make-extent nil nil) - (make-glyph (concat display-time-icons-dir "am.xpm")))) - (setq display-time-pm-glyph - (cons (make-extent nil nil) - (make-glyph (concat display-time-icons-dir "pm.xpm")))) - (setq display-time-display-time-fg-old - display-time-display-time-foreground - display-time-display-time-bg-old - display-time-display-time-background) - )))) +(defun display-time-generate-time-glyphs () + (let* ((xpm-color-symbols (list* + `("ledbg" + ,(if (symbolp + display-time-display-time-background) + '(face-background 'modeline) + display-time-display-time-background)) + `("ledfg" + ,(if (symbolp + display-time-display-time-foreground) + '(face-foreground 'modeline) + display-time-display-time-foreground)) + (if (featurep 'xpm) xpm-color-symbols)))) + (macrolet + ((make-digit-glyphs (&rest digits) + (cons + 'setf + (loop for key in digits + append `((gethash ,key display-time-glyph-table) + (cons (make-extent nil nil) + (make-glyph `((global + ,＠(when + (featurep 'xpm) + `((win + . + [xpm :file + ,(concat + display-time-icons-dir + ,(format "%c.xpm" + key))]))) + ,,(vector 'string :data + (format "%c" key)))))))))) + (make-other-glyphs (&rest alist) + (cons + 'setf + (loop for (key . string) in alist + append `((gethash ,key display-time-glyph-table) + (cons (make-extent nil nil) + (make-glyph `((global + ,＠(when + (featurep 'xpm) + `((win + . + [xpm :file + ,(concat + display-time-icons-dir + ,(concat string + ".xpm"))]))) + ,,(vector + 'string :data + (concat " " + (upcase + string)))))))))))) + (make-digit-glyphs ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?0) + (make-other-glyphs ('am . "am") ('pm . "pm"))) + (setf (gethash ?: display-time-glyph-table) + (cons (make-extent nil nil) + (make-glyph `((global + ,＠(when (featurep 'xpm) + `((win . [xpm :file + ,(concat + display-time-icons-dir + "dp.xpm")]))) + [string :data ":"])))) + display-time-display-time-fg-old + display-time-display-time-foreground + display-time-display-time-bg-old + display-time-display-time-background))) -(defun display-time-init-glyphs () - "This is a hack to have all glyphs be displayed one time at startup. -It helps avoiding problems with the background color of the glyphs if a -balloon-help frame is open and a not yet displayed glyph is going to be -displayed." - (let ((i 0) - (list '("am" "pm" ":")) - elem mlist) - (while (< i 10) - (push (eval (intern-soft (concat "display-time-" - (number-to-string i) - "-glyph"))) mlist) - (setq i (1+ i))) - (setq i 0.0) - (while (<= i 3.0) - (push (eval (intern-soft (concat "display-time-load-" - (number-to-string i) - "-glyph"))) mlist) - (setq i (+ i 0.5))) - (while (setq elem (pop list)) - (push (eval (intern-soft (concat "display-time-" - elem "-glyph"))) mlist)) - (let ((global-mode-string mlist)) - (redisplay-frame)) - )) - -(defvar display-time-insinuated nil) +(defun display-time-generate-mail-glyphs () + (setf (gethash 'mail display-time-glyph-table) + (cons (let ((extent (make-extent nil nil))) + (setf (extent-property extent 'balloon-help) + 'display-time-mail-balloon) + extent) + (make-glyph + `((global + ,＠(when (featurep 'xpm) + `((win . [xpm :file ,(concat display-time-icons-dir + "letter.xpm")]))) + [string :data ,display-time-mail-sign-string])))) + (gethash 'no-mail display-time-glyph-table) + (cons (let ((extent (make-extent nil nil))) + (setf (extent-property extent 'balloon-help) + display-time-no-mail-balloon) ;; Yes, not a symbol. + extent) + (make-glyph + `((global + ,＠(when (featurep 'xpm) + `((win . [xpm :file ,(concat display-time-icons-dir + "no-letter.xpm")]))) + [string :data + ,(if (> (length display-time-no-mail-sign-string) 0) + (concat " " display-time-no-mail-sign-string) + display-time-no-mail-sign-string)])))))) ;; This used to be at top-level! (defun display-time-insinuate () - (when (featurep 'xpm) - (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) -;;; (set-extent-keymap (car display-time-mail-sign) -;;; display-time-keymap) - (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) ;;; (set-extent-keymap (car display-time-no-mail-sign) ;;; display-time-keymap) - (defvar display-time-1-glyph nil) - (defvar display-time-2-glyph nil) - (defvar display-time-3-glyph nil) - (defvar display-time-4-glyph nil) - (defvar display-time-5-glyph nil) - (defvar display-time-6-glyph nil) - (defvar display-time-7-glyph nil) - (defvar display-time-8-glyph nil) - (defvar display-time-9-glyph nil) - (defvar display-time-0-glyph nil) - (defvar display-time-:-glyph nil) - (defvar display-time-am-glyph nil) - (defvar display-time-pm-glyph nil) - (defvar display-time-load-0.0-glyph nil) - (defvar display-time-load-0.5-glyph nil) - (defvar display-time-load-1.0-glyph nil) - (defvar display-time-load-1.5-glyph nil) - (defvar display-time-load-2.0-glyph nil) - (defvar display-time-load-2.5-glyph nil) - (defvar display-time-load-3.0-glyph nil) - (display-time-generate-time-glyphs 'force) - (display-time-generate-load-glyphs 'force) - (display-time-init-glyphs) - (sit-for 0)) + (display-time-generate-time-glyphs) + (display-time-generate-load-glyphs) + (display-time-generate-mail-glyphs) + (sit-for 0) (setq display-time-insinuated t)) +(defun display-time-convert-num (time-string balloon-help help-echo) + (if display-time-echo-area + time-string + (display-time-update-time-glyphs) + (loop for character across time-string + for glyph = (gethash character display-time-glyph-table) + then (gethash character display-time-glyph-table) + collect (prog1 + glyph + (setf (extent-property (car glyph) 'balloon-help) + balloon-help + (extent-property (car glyph) 'help-echo) + help-echo))))) -(defun display-time-can-do-graphical-display (&optional textual) - (and display-time-show-icons-maybe - (not textual) - (console-on-window-system-p) - (featurep 'xpm) - (not display-time-echo-area))) - - -(defun display-time-convert-num (time-string &optional textual) - (let ((list (display-time-string-to-char-list time-string)) - 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 'display-time-time-balloon-face) - (set-extent-property balloon-ext 'duplicable 't) - (while (setq elem (pop list)) - (setq elem - (eval (intern-soft (concat "display-time-" - (char-to-string elem) - "-glyph")))) - (set-extent-property (car elem) 'balloon-help balloon-help) - (set-extent-property (car elem) 'help-echo - (format "%s, %s %s %s" - dayname day monthname year)) -;;; (set-extent-keymap (car elem) display-time-keymap) - (push elem tmp)) - (reverse tmp)))) - -(defun display-time-convert-load (load-string &optional textual) - (let ((load-number (string-to-number load-string)) - (alist (list (cons 0.0 0.0) - (cons 0.5 (car display-time-load-list)) - (cons 1.0 (cadr display-time-load-list)) - (cons 1.5 (caddr display-time-load-list)) - (cons 2.0 (cadddr display-time-load-list)) - (cons 2.5 (cadr (cdddr display-time-load-list))) - (cons 3.0 (caddr (cdddr display-time-load-list))) - (cons 100000 100000))) - 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 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)) - ampm-string - (cond ((equal ampm-string "am") display-time-am-glyph) - ((equal ampm-string "pm") display-time-pm-glyph)))) +(defun display-time-convert-am-pm (ampm-string balloon-help help-echo) + (if display-time-echo-area + (concat " " ampm-string) + (let ((glyph (gethash (if (equal ampm-string "PM") 'pm 'am) + display-time-glyph-table))) + (if glyph + (prog1 + glyph + (setf (extent-property (car glyph) 'balloon-help) + balloon-help + (extent-property (car glyph) 'help-echo) + help-echo)))))) (defun display-time-mail-balloon (&rest ciao) (let* ((mail-spool-file (or display-time-mail-file ＠＠ -784,33 +747,29 ＠＠ ))) -(defun display-time-mail-sign (&optional textual) +(defsubst display-time-mail-sign () "*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 or when -the optional parameter TEXTUAL is non-nil." - (if (not (display-time-can-do-graphical-display textual)) - display-time-mail-sign-string - (list " " display-time-mail-sign " "))) +display-time-echo-area is nil and display-time-show-icons-maybe is t." + (if display-time-echo-area + (concat " " display-time-mail-sign-string) + (list " " (gethash 'mail display-time-glyph-table) " "))) -(defun display-time-no-mail-sign (&optional textual) +(defsubst display-time-no-mail-sign () "*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 or when the optional parameter TEXTUAL is non-nil." - (if (not (display-time-can-do-graphical-display textual)) - display-time-no-mail-sign-string - (list " " display-time-no-mail-sign " "))) + (if display-time-echo-area + (concat " " display-time-no-mail-sign-string) + (list " " (gethash 'no-mail display-time-glyph-table) " "))) (defcustom display-time-form-list (list 'date 'time 'load 'mail) "*This list describes the format of the strings/glyphs which are to be displayed by display-time. -The old variable display-time-string-forms is only used if -display-time-compatible is non-nil. It is a list consisting of -strings or any of the following symbols: +The list comprises strings or any of the following symbols: There are three complex specs whose behaviour is changed via the setting of various variables ＠＠ -897,108 +856,131 ＠＠ (const :tag "Mail sign (text)" mail-text) (string :tag "String")))) -(defun display-time-evaluate-list () +(defstruct (display-time-details (:constructor nil)) + 24-hours hour 12-hours am-pm minutes seconds time-zone day month monthname + year dayname) + +(defun make-display-time-details (&optional time) + (read + (format-time-string + "[cl-struct-display-time-details \"%H\" ;; 24-hours +%k ;; Hour +\"%I\" ;; 12 hours +\"%p\" ;; am-pm +\"%M\" ;; minutes +\"%S\" ;; seconds +\"%Z\" ;; time-zone +\"%d\" ;; day +\"%m\" ;; month +\"%b\" ;; monthname (abbreviated) +\"%Y\" ;; year +\"%a\"] ;; dayname " time))) + +(defun display-time-evaluate-list (details load mail) "Evaluate the variable display-time-form-list" - (let ((list display-time-form-list) elem tmp result) - (while (setq elem (pop list)) + (let* ((help-echo (format "%s, %s %s %s" + (display-time-details-dayname details) + (display-time-details-day details) + (display-time-details-monthname details) + (display-time-details-year details))) + (balloon-help (concat help-echo " Average load:" + (if (not (equal load "")) load " 0"))) + (balloon-ext (make-extent 0 (length balloon-help) balloon-help)) + tmp) + (setf (extent-property balloon-ext 'face) + 'display-time-time-balloon-face + (extent-property balloon-ext 'duplicable) t) + (dolist (elem display-time-form-list) (cond ((stringp elem) (push elem tmp)) ((eq elem 'date) (push (if display-time-day-and-date - (format "%s %s %s " dayname monthname day) "") tmp)) + (concat (display-time-details-dayname details) + (display-time-details-monthname details) + (display-time-details-day details) + " ") + "") tmp)) ((eq elem 'time) (progn (push (display-time-convert-num - (format "%s:%s" - (if display-time-24hr-format 24-hours 12-hours) - minutes)) tmp) + (concat (if display-time-24hr-format + (display-time-details-24-hours details) + (display-time-details-12-hours details)) + ":" (display-time-details-minutes details)) + balloon-help help-echo) + tmp) (if (not display-time-24hr-format) - (push (display-time-convert-am-pm am-pm) tmp)))) + (push (display-time-convert-am-pm + (display-time-details-am-pm details) + balloon-help help-echo) tmp)))) ((eq elem 'time-text) - (push (display-time-convert-num - (format "%s:%s" - (if display-time-24hr-format 24-hours 12-hours) - minutes) t) tmp) + (push (concat (if display-time-24hr-format + (display-time-details-24-hours details) + (display-time-details-12-hours details)) + ":" (display-time-details-minutes details)) + tmp) (if (not display-time-24hr-format) - (push (display-time-convert-am-pm am-pm t) tmp))) - ((eq elem 'day) (push day tmp)) - ((eq elem 'dayname) (push dayname tmp)) - ((eq elem 'month) (push month tmp)) - ((eq elem 'monthname) (push monthname tmp)) + (push (display-time-convert-am-pm + (display-time-details-am-pm details) + balloon-help help-echo) tmp))) + ((eq elem 'day) (push (display-time-details-day details) tmp)) + ((eq elem 'dayname) + (push (display-time-details-dayname details) tmp)) + ((eq elem 'month) (push (display-time-details-month details) tmp)) + ((eq elem 'monthname) + (push (display-time-details-monthname details) tmp)) ((eq elem '24-hours) - (push (display-time-convert-num 24-hours) tmp)) + (push (display-time-convert-num + (display-time-details-24-hours details) + balloon-help help-echo) tmp)) ((eq elem 'year) - (push year tmp)) + (push (display-time-details-year details) tmp)) ((eq elem '24-hours-text) - (push (display-time-convert-num 24-hours t) tmp)) + (push (display-time-details-24-hours details) tmp)) ((eq elem '12-hours) - (push (display-time-convert-num 12-hours) tmp)) + (push (display-time-convert-num + (display-time-details-12-hours details) + balloon-help help-echo) tmp)) ((eq elem '12-hours-text) - (push (display-time-convert-num 12-hours t) tmp)) + (push (display-time-details-12-hours details) tmp)) ((eq elem 'minutes) - (push (display-time-convert-num minutes) tmp)) + (push (display-time-convert-num + (display-time-details-minutes details) + balloon-help help-echo) tmp)) + ((eq elem 'minutes-text) + (push (display-time-details-minutes details) tmp)) ((eq elem 'seconds) - (push (display-time-convert-num seconds) tmp)) - ((eq elem 'minutes-text) - (push (display-time-convert-num minutes t) tmp)) + (push (display-time-convert-num + (display-time-details-seconds details) + balloon-help help-echo) tmp)) ((eq elem 'am-pm) - (push (display-time-convert-am-pm am-pm) tmp)) + (push (display-time-convert-am-pm + (display-time-details-am-pm details) + balloon-help help-echo) tmp)) ((eq elem 'am-pm-text) - (push (display-time-convert-am-pm am-pm t) tmp)) + (push (display-time-details-am-pm details) tmp)) ((eq elem 'timezone) - (push time-zone tmp)) + (push (display-time-details-time-zone details) tmp)) ((eq elem 'load) (push (display-time-convert-load load) tmp)) ((eq elem 'load-text) - (push (display-time-convert-load load t) tmp)) + (push load tmp)) ((eq elem 'mail) (push (if mail (display-time-mail-sign) (display-time-no-mail-sign)) tmp)) ((eq elem 'mail-text) - (push (if mail (display-time-mail-sign t) - (display-time-no-mail-sign t)) tmp)) - )) + (push (if mail + display-time-mail-sign-string + display-time-no-mail-sign-string) tmp)))) ;; We know that we have a list containing only of strings if ;; display-time-echo-area is t. So we construct this string from ;; the list. Else we just reverse the list and give it as result. - (if (not display-time-echo-area) (setq result (reverse tmp)) - (while (setq elem (pop tmp)) - (setq result (concat elem result)))) - result)) - - -(defvar display-time-string-forms - '((if display-time-day-and-date - (format "%s %s %s " dayname monthname day) - "") - (format "%s:%s%s" - (if display-time-24hr-format 24-hours 12-hours) - minutes - (if display-time-24hr-format "" am-pm)) - load - (if mail " Mail" "")) - "*It will only be used if display-time-compatible is t. -A list of expressions governing display of the time in the mode line. -This expression is a list of expressions that can involve the keywords -`load', `day', `month', and `year', `12-hours', `24-hours', `minutes', -`seconds', all numbers in string form, and `monthname', `dayname', `am-pm', -and `time-zone' all alphabetic strings and `mail' a true/nil string value. - -For example, the form - - '((substring year -2) \"/\" month \"/\" day - \" \" 24-hours \":\" minutes \":\" seconds - (if time-zone \" (\") time-zone (if time-zone \")\")) - -would give mode line times like `94/12/30 21:07:48 (UTC)'.") - -(make-obsolete-variable 'display-time-string-forms - "You should use the new facilities for `display-time'. -Look at display-time-form-list.") + (setq tmp (nreverse tmp)) + (if display-time-echo-area (mapconcat #'identity tmp "") tmp))) (defun display-time-function () (let* ((now (current-time)) (nowhigh (* (- (nth 0 now) (* (/ (nth 0 now) 10) 10)) 65536)) - (time (current-time-string now)) + (display-time-details (make-display-time-details now)) (load (condition-case () (if (zerop (car (load-average))) "" (let ((str (format " %03d" (car (load-average))))) ＠＠ -1027,42 +1009,22 ＠＠ (setq display-time-server-down-time (+ (nth 1 now) nowhigh)) ;; Record that mail file is accessible. - (setq display-time-server-down-time nil)))))) - (24-hours (substring time 11 13)) - (hour (string-to-int 24-hours)) - (12-hours (int-to-string (1+ (% (+ hour 11) 12)))) - (am-pm (if (>= hour 12) "pm" "am")) - (minutes (substring time 14 16)) - (seconds (substring time 17 19)) - (time-zone (car (cdr (current-time-zone now)))) - (day (substring time 8 10)) - (year (substring time 20 24)) - (monthname (substring time 4 7)) - (month - (cdr - (assoc - monthname - '(("Jan" . "1") ("Feb" . "2") ("Mar" . "3") ("Apr" . "4") - ("May" . "5") ("Jun" . "6") ("Jul" . "7") ("Aug" . "8") - ("Sep" . "9") ("Oct" . "10") ("Nov" . "11") ("Dec" . "12"))))) - (dayname (substring time 0 3))) + (setq display-time-server-down-time nil))))))) (setq display-time-string - (if display-time-compatible - (mapconcat 'eval display-time-string-forms "") - (display-time-evaluate-list))) + (display-time-evaluate-list display-time-details load mail)) ;; This is inside the let binding, but we are not going to document ;; what variables are available. (run-hooks 'display-time-hook)) (if display-time-echo-area - (or (> (minibuffer-depth) 0) - ;; don't stomp echo-area-buffer if reading from minibuffer now. + (or (> (minibuffer-depth) 0) ;; Don't stomp echo-area-buffer if reading + ;; from minibuffer now. (save-excursion (save-window-excursion (select-window (minibuffer-window)) (erase-buffer) - (indent-to (- (frame-width) (length display-time-string) 1)) - (insert display-time-string) - (message (buffer-string))))) + (insert (format "%*s" (1- (frame-width)) display-time-string)) + ;; Don't leave the time in view-lossage. + (display-message 'no-log (buffer-string))))) (force-mode-line-update) ;; Do redisplay right now, if no input pending. (sit-for 0))) -- ‘As I sat looking up at the Guinness ad, I could never figure out / How your man stayed up on the surfboard after forty pints of stout’ (C. Moore)