Mercurial > hg > xemacs-beta

comparison lisp/packages/time.el @ 165:5a88923fcbfe r20-3b9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b9
author cvs
date Mon, 13 Aug 2007 09:44:42 +0200
parents 1370575f1259
children 3d6bfa290dbd
comparison
equal deleted inserted replaced
164:4e0740e5aab2 165:5a88923fcbfe
22 ;; You should have received a copy of the GNU General Public License 22 ;; You should have received a copy of the GNU General Public License
23 ;; along with XEmacs; see the file COPYING. If not, write to the Free 23 ;; along with XEmacs; see the file COPYING. If not, write to the Free
24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
25 ;; 02111-1307, USA. 25 ;; 02111-1307, USA.
26 26
27 ;;; Version: 1.15 (I choose the version number starting at 1.1 27 ;;; Version: 1.17 (I choose the version number starting at 1.1
28 ;;; to indicate that 1.0 was the old version 28 ;;; to indicate that 1.0 was the old version
29 ;;; before I hacked away on it -jtl) 29 ;;; before I hacked away on it -jtl)
30 30
31 ;;; Synched up with: Not synched with FSF. 31 ;;; Synched up with: Not synched with FSF.
32 32
54 ;;; background color customizable 54 ;;; background color customizable
55 55
56 ;;; Code: 56 ;;; Code:
57 57
58 (require 'itimer) 58 (require 'itimer)
59 ;;; Not sure for now...
60 ;;;(require 'balloon-help)
59 61
60 (defconst display-time-version-number "1.15" "Version number of time.el") 62 (defconst display-time-version-number "1.15" "Version number of time.el")
61 (defconst display-time-version (format "Time.el version %s for XEmacs" 63 (defconst display-time-version (format "Time.el version %s for XEmacs"
62 display-time-version-number) 64 display-time-version-number)
63 "The full version string for time.el") 65 "The full version string for time.el")
66
67 ;;; Doesn't work by now....
68 ;;;(defvar display-time-keymap nil)
69 ;;;
70 ;;;(if display-time-keymap ()
71 ;;; (setq display-time-keymap (make-sparse-keymap))
72 ;;; (suppress-keymap display-time-keymap)
73 ;;; (define-key display-time-keymap 'button1 'balloon-help))
64 74
65 ;; We need the progn to kill off the defgroup-tracking mechanism. 75 ;; We need the progn to kill off the defgroup-tracking mechanism.
66 ;; This package changes the state of XEmacs by loading it, which is 76 ;; This package changes the state of XEmacs by loading it, which is
67 ;; why it's potentially dangerous. 77 ;; why it's potentially dangerous.
68 (progn 78 (progn
491 (defvar display-time-mail-sign 501 (defvar display-time-mail-sign
492 (cons (make-extent nil nil) 502 (cons (make-extent nil nil)
493 (make-glyph (concat display-time-icons-dir "letter.xpm")))) 503 (make-glyph (concat display-time-icons-dir "letter.xpm"))))
494 (set-extent-property (car display-time-mail-sign) 'balloon-help 504 (set-extent-property (car display-time-mail-sign) 'balloon-help
495 'display-time-mail-balloon) 505 'display-time-mail-balloon)
506 ;;; (set-extent-keymap (car display-time-mail-sign)
507 ;;; display-time-keymap)
496 (defvar display-time-no-mail-sign 508 (defvar display-time-no-mail-sign
497 (cons (make-extent nil nil) 509 (cons (make-extent nil nil)
498 (make-glyph (concat display-time-icons-dir "no-letter.xpm")))) 510 (make-glyph (concat display-time-icons-dir "no-letter.xpm"))))
499 (set-extent-property (car display-time-no-mail-sign) 'balloon-help 511 (set-extent-property (car display-time-no-mail-sign) 'balloon-help
500 display-time-no-mail-balloon) 512 display-time-no-mail-balloon)
513 ;;; (set-extent-keymap (car display-time-no-mail-sign)
514 ;;; display-time-keymap)
501 (defvar display-time-1-glyph nil) 515 (defvar display-time-1-glyph nil)
502 (defvar display-time-2-glyph nil) 516 (defvar display-time-2-glyph nil)
503 (defvar display-time-3-glyph nil) 517 (defvar display-time-3-glyph nil)
504 (defvar display-time-4-glyph nil) 518 (defvar display-time-4-glyph nil)
505 (defvar display-time-5-glyph nil) 519 (defvar display-time-5-glyph nil)
551 (setq elem 565 (setq elem
552 (eval (intern-soft (concat "display-time-" 566 (eval (intern-soft (concat "display-time-"
553 (char-to-string elem) 567 (char-to-string elem)
554 "-glyph")))) 568 "-glyph"))))
555 (set-extent-property (car elem) 'balloon-help balloon-help) 569 (set-extent-property (car elem) 'balloon-help balloon-help)
570 ;;; (set-extent-keymap (car elem) display-time-keymap)
556 (push elem tmp)) 571 (push elem tmp))
557 (reverse tmp)))) 572 (reverse tmp))))
558 573
559 (defun display-time-convert-load (load-string &optional textual) 574 (defun display-time-convert-load (load-string &optional textual)
560 (let ((load-number (string-to-number load-string)) 575 (let ((load-number (string-to-number load-string))
974 "You should use the new facilities for `display-time'. 989 "You should use the new facilities for `display-time'.
975 Look at display-time-form-list.") 990 Look at display-time-form-list.")
976 991
977 (defun display-time-function () 992 (defun display-time-function ()
978 (let* ((now (current-time)) 993 (let* ((now (current-time))
994 (nowhigh (* (- (nth 0 now) (* (/ (nth 0 now) 10) 10)) 65536))
979 (time (current-time-string now)) 995 (time (current-time-string now))
980 (load (condition-case () 996 (load (condition-case ()
981 (if (zerop (car (load-average))) "" 997 (if (zerop (car (load-average))) ""
982 (let ((str (format " %03d" (car (load-average))))) 998 (let ((str (format " %03d" (car (load-average)))))
983 (concat (substring str 0 -2) "." (substring str -2)))) 999 (concat (substring str 0 -2) "." (substring str -2))))
987 (concat rmail-spool-directory 1003 (concat rmail-spool-directory
988 (user-login-name)))) 1004 (user-login-name))))
989 (mail (and (stringp mail-spool-file) 1005 (mail (and (stringp mail-spool-file)
990 (or (null display-time-server-down-time) 1006 (or (null display-time-server-down-time)
991 ;; If have been down for 20 min, try again. 1007 ;; If have been down for 20 min, try again.
992 (> (- (nth 1 (current-time)) 1008 (> (- (+ (nth 1 now) nowhigh)
993 display-time-server-down-time) 1009 display-time-server-down-time)
994 1200)) 1010 1200))
995 (let ((start-time (current-time))) 1011 (let ((start-time (current-time)))
996 (prog1 1012 (prog1
997 (display-time-file-nonempty-p mail-spool-file) 1013 (display-time-file-nonempty-p mail-spool-file)
998 (if (> (- (nth 1 (current-time)) (nth 1 start-time)) 1014 (setq now (current-time)
1015 nowhigh (* (- (nth 0 now) (* (/ (nth 0 now) 10) 10)) 65536))
1016 (if (> (- (+ (nth 1 now) nowhigh)
1017 (+ (nth 1 start-time)
1018 (* (- (nth 0 start-time) (* (/ (nth 0 start-time) 10) 10)) 65536)))
999 20) 1019 20)
1000 ;; Record that mail file is not accessible. 1020 ;; Record that mail file is not accessible.
1001 (setq display-time-server-down-time 1021 (setq display-time-server-down-time
1002 (nth 1 (current-time))) 1022 (+ (nth 1 now) nowhigh))
1003 ;; Record that mail file is accessible. 1023 ;; Record that mail file is accessible.
1004 (setq display-time-server-down-time nil)))))) 1024 (setq display-time-server-down-time nil))))))
1005 (24-hours (substring time 11 13)) 1025 (24-hours (substring time 11 13))
1006 (hour (string-to-int 24-hours)) 1026 (hour (string-to-int 24-hours))
1007 (12-hours (int-to-string (1+ (% (+ hour 11) 12)))) 1027 (12-hours (int-to-string (1+ (% (+ hour 11) 12))))