217 lines
6.7 KiB
Scheme
217 lines
6.7 KiB
Scheme
#| -*-Scheme-*-
|
||
|
||
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
||
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
||
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
||
|
||
This file is part of MIT/GNU Scheme.
|
||
|
||
MIT/GNU Scheme is free software; you can redistribute it and/or modify
|
||
it under the terms of the GNU General Public License as published by
|
||
the Free Software Foundation; either version 2 of the License, or (at
|
||
your option) any later version.
|
||
|
||
MIT/GNU Scheme is distributed in the hope that it will be useful, but
|
||
WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
General Public License for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with MIT/GNU Scheme; if not, write to the Free Software
|
||
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
||
USA.
|
||
|
||
|#
|
||
|
||
;;;; Mode-line notifications (e.g. presence of mail, load average)
|
||
|
||
|
||
|
||
(define-variable notify-show-time
|
||
"If true, the notifier displays the current time."
|
||
#t
|
||
boolean?)
|
||
|
||
(define (notifier:time)
|
||
(let ((time (get-decoded-time)))
|
||
(let ((hour (decoded-time/hour time))
|
||
(minute (decoded-time/minute time)))
|
||
(string-append (write-to-string
|
||
(cond ((zero? hour) 12)
|
||
((< hour 13) hour)
|
||
(else (- hour 12))))
|
||
(if (< minute 10) ":0" ":")
|
||
(write-to-string minute)
|
||
(if (< hour 12) "am" "pm")))))
|
||
|
||
(define-variable notify-show-date
|
||
"If true, the notifier displays the current date."
|
||
#f
|
||
boolean?)
|
||
|
||
(define (notifier:date)
|
||
(let ((time (get-decoded-time)))
|
||
(string-append (vector-ref
|
||
'#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")
|
||
(decoded-time/day-of-week time))
|
||
(vector-ref
|
||
'#("??" " Jan " " Feb " " Mar " " Apr " " May " " Jun "
|
||
" Jul " " Aug " " Sep " " Oct " " Nov " " Dec ")
|
||
(decoded-time/month time))
|
||
(write-to-string (decoded-time/day time)))))
|
||
|
||
(define-variable notify-show-load
|
||
"If true, the notifier displays the load average."
|
||
#f
|
||
boolean?)
|
||
|
||
(define (notifier:load-average)
|
||
(let ((temporary-buffer (temporary-buffer "*uptime*")))
|
||
(let ((start (buffer-start temporary-buffer)))
|
||
(shell-command #f start #f #f "uptime")
|
||
(let ((result
|
||
(if (re-search-forward
|
||
".*load average:[ ]*\\([0-9.]*\\),"
|
||
start
|
||
(buffer-end temporary-buffer))
|
||
(extract-string (re-match-start 1)
|
||
(re-match-end 1))
|
||
"")))
|
||
(kill-buffer temporary-buffer)
|
||
result))))
|
||
|
||
(define-variable notify-show-mail
|
||
"If true, the notifier displays your mail status."
|
||
#t
|
||
boolean?)
|
||
|
||
(define-variable notify-mail-present
|
||
"A string to be displayed in the modeline when mail is present.
|
||
Ignored if notify-show-mail is false."
|
||
"Mail"
|
||
string?)
|
||
|
||
(define-variable notify-mail-not-present
|
||
"A string to be displayed in the modeline when mail is not present.
|
||
Ignored if notify-show-mail is false."
|
||
""
|
||
string?)
|
||
|
||
(define-variable mail-notify-directory
|
||
"Directory in which MAIL-NOTIFY checks for mail."
|
||
#f
|
||
(lambda (object) (or (not object) (file-directory? object))))
|
||
|
||
(define (notifier:mail-present)
|
||
(if (not (ref-variable mail-notify-directory))
|
||
(begin
|
||
(guarantee-rmail-variables-initialized)
|
||
(set-variable! mail-notify-directory rmail-spool-directory)))
|
||
(if (let ((pathname
|
||
(merge-pathnames (ref-variable mail-notify-directory)
|
||
(current-user-name))))
|
||
(and (file-exists? pathname)
|
||
(> (file-length pathname) 0)))
|
||
(ref-variable notify-mail-present)
|
||
(ref-variable notify-mail-not-present)))
|
||
|
||
(define (notifier:set-mail-string! string)
|
||
;; STRING is either #F, meaning use the internal mail notifier, or a
|
||
;; string. A null string means no mail, and a non-null string means
|
||
;; new mail is available.
|
||
(without-interrupts
|
||
(lambda ()
|
||
(set! override-notifier-mail-string string)
|
||
(if (not notifier-thread-registration)
|
||
(set-variable! global-mode-string string #f))
|
||
(global-window-modeline-event!))))
|
||
|
||
(define-variable notify-interval
|
||
"How often the notifier updates the modeline, in seconds."
|
||
60
|
||
exact-nonnegative-integer?)
|
||
|
||
(define notifier-elements
|
||
(list (cons (ref-variable-object notify-show-date) notifier:date)
|
||
(cons (ref-variable-object notify-show-time) notifier:time)
|
||
(cons (ref-variable-object notify-show-load) notifier:load-average)))
|
||
|
||
(define (notifier:get-string window)
|
||
window
|
||
(string-append-separated notifier-element-string
|
||
(if override-notifier-mail-string
|
||
(if (string-null? override-notifier-mail-string)
|
||
(ref-variable notify-mail-not-present)
|
||
(ref-variable notify-mail-present))
|
||
notifier-mail-string)))
|
||
|
||
(define (update-notifier-strings! element mail)
|
||
(set! notifier-element-string element)
|
||
(set! notifier-mail-string mail)
|
||
(global-window-modeline-event!))
|
||
|
||
(define notifier-element-string "")
|
||
(define notifier-mail-string "")
|
||
(define override-notifier-mail-string #f)
|
||
(define mail-notify-hook-installed? #f)
|
||
(define notifier-thread-registration #f)
|
||
|
||
(define-command run-notifier
|
||
"Run the notifier.
|
||
The notifier maintains a simple display in the modeline,
|
||
which can show various things including time, load average, and mail status."
|
||
()
|
||
(lambda ()
|
||
(if (and (not mail-notify-hook-installed?)
|
||
(command-defined? rmail))
|
||
(begin
|
||
(add-event-receiver!
|
||
(ref-variable rmail-new-mail-hook)
|
||
(lambda ()
|
||
(update-notifier-strings!
|
||
notifier-element-string
|
||
(if (ref-variable notify-show-mail)
|
||
(ref-variable notify-mail-not-present)
|
||
""))))
|
||
(set! mail-notify-hook-installed? #t)
|
||
unspecific))
|
||
((ref-command kill-notifier))
|
||
(set-variable! global-mode-string `("" ,notifier:get-string))
|
||
(set! notifier-thread-registration
|
||
(start-standard-polling-thread (* (ref-variable notify-interval #f)
|
||
1000)
|
||
notifier
|
||
(cons 'notifier current-editor)))
|
||
unspecific))
|
||
|
||
(define (notifier)
|
||
(update-notifier-strings!
|
||
(reduce-right string-append-separated
|
||
""
|
||
(map (lambda (element)
|
||
(if (and (car element)
|
||
(variable-value (car element)))
|
||
((cdr element))
|
||
""))
|
||
notifier-elements))
|
||
(if (and mail-notify-hook-installed?
|
||
(ref-variable notify-show-mail))
|
||
(notifier:mail-present)
|
||
""))
|
||
#t)
|
||
|
||
(define-command kill-notifier
|
||
"Kill the current notifier, if any."
|
||
()
|
||
(lambda ()
|
||
(without-interrupts
|
||
(lambda ()
|
||
(if notifier-thread-registration
|
||
(begin
|
||
(stop-standard-polling-thread notifier-thread-registration)
|
||
(set! notifier-thread-registration #f)
|
||
unspecific))))
|
||
(update-notifier-strings! "" "")
|
||
(set-variable! global-mode-string override-notifier-mail-string #f)))
|