re: Wanted: New Mail Flag

[Robert Scheifler <RWS@zermatt.lcs.mit.edu>]

I wrote this as a facility here:

;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-

(defvar *new-mail-interval* (* 3 60))
(defvar *old-mail-interval* (* 1 60))

(defvar *new-mail-arrival-time* nil)
(defvar *new-mail-for-user* nil)

(defun stop-new-mail-checks (&optional (deinitialize t))
  (loop while (ignore-errors
		(si:remove-timer-queue-entry-named "New Mail Check")
		t))
  (when deinitialize
    (setq *new-mail-for-user* nil)))

(defun check-new-mail (&optional path (initialize t))
  (when initialize
    (if path
	(setq path (fs:parse-pathname path))
	(loop for mail-file in (zwei:possible-default-mail-file-pathnames
				 (fs:user-homedir (second (send si:*user* :mail-address))))
	      until (setq path (zwei:default-inbox-pathname mail-file))))
    (unless (assoc 'stop-new-mail-checks sys:logout-list)
      (push '(stop-new-mail-checks) sys:logout-list))
    (multiple-value-bind (window template)
	(tv:get-who-line-field :user)
      (send window :set-who-line-update-function 'who-line-mail-user-or-process)
      (setf (zl:get template :function) 'who-line-mail-user-or-process)))
  (when path
    (let (arrival-time)
      (condition-case ()
	   (let* ((props (cdr (fs:file-properties path)))
		  (write (or (getf props :modification-date)
			     (getf props :creation-date)))
		  (read (getf props :reference-date)))
	     (when (and write
			(or (null read)
			    (eql read write)
			    (time-lessp read write)))
	       (setq arrival-time read)))
	 ((fs:file-error sys:network-error)))
      (unless (eql arrival-time *new-mail-arrival-time*)
	(setq *new-mail-arrival-time* arrival-time)
	(setq *new-mail-for-user*
	      (when arrival-time
		(string-append
		  zl:user-id
		  " Mail at "
		  (with-output-to-string (stream)
		    (time:print-brief-universal-time arrival-time stream)))))))
    (stop-new-mail-checks nil)
    (si:add-timer-queue-entry (+ (get-universal-time)
				 (if *new-mail-arrival-time*
				     *old-mail-interval*
				     *new-mail-interval*))
			      :once
			      "New Mail Check"
			      'check-new-mail
			      path
			      nil)))

(defun who-line-mail-user-or-process (who-sheet state extra-state)
  (if *new-mail-for-user*
      (tv:who-line-string who-sheet state *new-mail-for-user*)
      (tv:who-line-user-or-process who-sheet state extra-state)))

(check-new-mail)