From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 25 May 2000 05:06:55 +0000 (+0000)
Subject: Implement mechanism to poll the IMAP server in the background at a
X-Git-Tag: 20090517-FFI~3681
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=172aee83b2bbd215164be228c1b3ec55143a2675;p=mit-scheme.git

Implement mechanism to poll the IMAP server in the background at a
specified interval.
---

diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index e1acc54ca..fe30e984c 100644
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-top.scm,v 1.107 2000/05/24 23:21:53 cph Exp $
+;;; $Id: imail-top.scm,v 1.108 2000/05/25 05:06:38 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -113,6 +113,16 @@ The pass phrase is deleted if unused for this long.
 Set this to zero if you don't want pass-phrase retention."
   30
   exact-nonnegative-integer?)
+
+(define-variable imail-update-interval
+  "How often to update a folder's contents, in seconds.
+IMAIL will periodically poll the mail server for changes at this interval.
+The polls will only occur when there is an open connection to the server;
+  it will not reestablish a connection when there is none.
+This has no effect on file-based folders.
+Set this variable to #F to disable updating."
+  600
+  (lambda (x) (or (not x) (and (exact-integer? x) (positive? x)))))
 
 (define-command imail
   "Read and edit incoming mail.
@@ -692,7 +702,9 @@ With prefix argument N moves backward N messages with these flags."
        (lambda (folder type parameters)
 	 type parameters
 	 (maybe-add-command-suffix! notice-folder-modifications folder)))
-     (add-kill-buffer-hook buffer delete-associated-buffers))))
+     (add-kill-buffer-hook buffer delete-associated-buffers)
+     (add-kill-buffer-hook buffer stop-probe-folder-thread)
+     (start-probe-folder-thread buffer))))
 
 (define (delete-associated-buffers folder-buffer)
   (for-each (lambda (buffer)
@@ -728,6 +740,57 @@ With prefix argument N moves backward N messages with these flags."
   (or (buffer-get buffer 'IMAIL-FOLDER-BUFFER #f)
       buffer))
 
+(define (start-probe-folder-thread buffer)
+  (stop-probe-folder-thread buffer)
+  (let ((folder (buffer-get buffer 'IMAIL-FOLDER #f))
+	(interval (ref-variable imail-update-interval #f)))
+    (if (and folder interval
+	     (not (get-property folder 'PROBE-REGISTRATION #f)))
+	(let ((registration (list #f)))
+	  (set-car! registration
+		    (register-inferior-thread!
+		     (let ((thread
+			    (create-thread
+			     editor-thread-root-continuation
+			     (probe-folder-thread registration
+						  (* 1000 interval)))))
+		       (detach-thread thread)
+		       thread)
+		     (probe-folder-output-processor
+		      (weak-cons folder unspecific))))
+	  (store-property! folder 'PROBE-REGISTRATION registration)))))
+
+(define ((probe-folder-thread registration interval))
+  (do () (#f)
+    (let ((registration (car registration)))
+      (cond ((eq? registration 'KILL-THREAD) (exit-current-thread unspecific))
+	    (registration (inferior-thread-output! registration))))
+    (sleep-current-thread interval)))
+
+(define ((probe-folder-output-processor folder))
+  (let ((folder (weak-car folder)))
+    (and folder
+	 (eq? (folder-connection-status folder) 'ONLINE)
+	 (begin
+	   (probe-folder folder)
+	   #t))))
+
+(define (stop-probe-folder-thread buffer)
+  (without-interrupts
+   (lambda ()
+     (let ((folder (buffer-get buffer 'IMAIL-FOLDER #f)))
+       (if folder
+	   (begin
+	     (let ((holder (get-property folder 'PROBE-REGISTRATION #f)))
+	       (if holder
+		   (begin
+		     (let ((registration (car holder)))
+		       (if (and registration
+				(not (eq? registration 'KILL-THREAD)))
+			   (deregister-inferior-thread! registration)))
+		     (set-car! holder 'KILL-THREAD))))
+	     (remove-property! folder 'PROBE-REGISTRATION)))))))
+
 (define (selected-folder #!optional error? buffer)
   (let ((buffer
 	 (chase-imail-buffer
diff --git a/v7/src/imail/load.scm b/v7/src/imail/load.scm
index 2ded80a46..c6f0498d3 100644
--- a/v7/src/imail/load.scm
+++ b/v7/src/imail/load.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: load.scm,v 1.10 2000/05/24 20:23:07 cph Exp $
+;;; $Id: load.scm,v 1.11 2000/05/25 05:06:45 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -94,4 +94,5 @@
 	    edwin-variable$imail-summary-mode-hook
 	    edwin-variable$imail-summary-pop-up-message
 	    edwin-variable$imail-summary-show-date
-	    edwin-variable$imail-summary-subject-width))
\ No newline at end of file
+	    edwin-variable$imail-summary-subject-width
+	    edwin-variable$imail-update-interval))
\ No newline at end of file
diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index 2f1916632..1102d46cb 100644
--- a/v7/src/imail/todo.txt
+++ b/v7/src/imail/todo.txt
@@ -1,5 +1,5 @@
 IMAIL To-Do List
-$Id: todo.txt,v 1.49 2000/05/24 19:45:21 cph Exp $
+$Id: todo.txt,v 1.50 2000/05/25 05:06:55 cph Exp $
 
 Bug fixes
 ---------
@@ -38,9 +38,6 @@ New features
 * Add mail notification in mode line, active across the editor as long
   as there is an IMAP connection open in some buffer.
 
-* Implement background thread to periodically send NOOP to IMAP server
-  both to check for new mail and to keep the connection alive.
-
 * Implement cache that saves information about messages on disk.  This
   should use UIDs for IMAP folders; for other folders perhaps the
   message ID can be used.  (Or perhaps no cache is required for