From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 17 May 2000 20:53:32 +0000 (+0000)
Subject: First cut at implementation of summary buffers.
X-Git-Tag: 20090517-FFI~3829
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e7b889cdcaec2251d5ab67fcc53f34ce752f3337;p=mit-scheme.git

First cut at implementation of summary buffers.
---

diff --git a/v7/src/imail/compile.scm b/v7/src/imail/compile.scm
index 7b0fde759..321625d24 100644
--- a/v7/src/imail/compile.scm
+++ b/v7/src/imail/compile.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: compile.scm,v 1.6 2000/04/22 01:53:42 cph Exp $
+;;; $Id: compile.scm,v 1.7 2000/05/17 20:53:24 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -41,7 +41,8 @@
 		     (access edwin-syntax-table (->environment '(EDWIN)))))
 		(lambda (filename)
 		  (compile-file filename '() syntax-table)))
-	      '("imail-top"))
+	      '("imail-summary"
+		"imail-top"))
     (cref/generate-constructors "imail")
     (sf "imail.con")
     (sf "imail.ldr")))
\ No newline at end of file
diff --git a/v7/src/imail/ed-ffi.scm b/v7/src/imail/ed-ffi.scm
index b62e07169..3846fd99a 100644
--- a/v7/src/imail/ed-ffi.scm
+++ b/v7/src/imail/ed-ffi.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: ed-ffi.scm,v 1.8 2000/04/22 01:53:43 cph Exp $
+;;; $Id: ed-ffi.scm,v 1.9 2000/05/17 20:53:26 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -25,6 +25,7 @@
     ("imail-file"	(edwin imail)		system-global-syntax-table)
     ("imail-imap"	(edwin imail)		system-global-syntax-table)
     ("imail-rmail"	(edwin imail)		system-global-syntax-table)
+    ("imail-summary"	(edwin imail)		edwin-syntax-table)
     ("imail-top"	(edwin imail)		edwin-syntax-table)
     ("imail-umail"	(edwin imail)		system-global-syntax-table)
     ("imail-util"	(edwin imail)		system-global-syntax-table)
diff --git a/v7/src/imail/imail-summary.scm b/v7/src/imail/imail-summary.scm
new file mode 100644
index 000000000..5ca01a9d5
--- /dev/null
+++ b/v7/src/imail/imail-summary.scm
@@ -0,0 +1,176 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: imail-summary.scm,v 1.1 2000/05/17 20:53:29 cph Exp $
+;;;
+;;; Copyright (c) 2000 Massachusetts Institute of Technology
+;;;
+;;; This program 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.
+;;;
+;;; This program 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 this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;; IMAIL mail reader: summary buffer
+
+(declare (usual-integrations))
+
+(define-command imail-summary
+  "Display a summary of the selected folder, one line per message."
+  ()
+  (lambda () (imail-summary "All" (lambda (m) m #t))))
+
+(define-command imail-summary-by-flags
+  "Display a summary of the selected folder, one line per message.
+Only messages marked with one of the given flags are shown.
+The flags are specified as a comma-separated list of names."
+  "sFlags to summarize by"
+  (lambda (flags-string)
+    (imail-summary
+     (string-append "Flags " flags-string)
+     (let ((flags
+	    (list-transform-negative
+		(map string-trim (burst-string flags-string #\, #f))
+	      string-null?)))
+       (lambda (m)
+	 (flags-intersect? (message-flags m) flags))))))
+
+(define (flags-intersect? f1 f2)
+  (there-exists? f1
+    (lambda (flag)
+      (flags-member? flag f2))))
+
+(define-command imail-summary-by-recipients
+  "Display a summary of the selected folder, one line per message.
+Only messages addressed to one of the given recipients are shown.
+Normally checks the To, From and CC fields of headers;
+ but if prefix arg given, only look in the To and From fields.
+The recipients are specified as a comma-separated list of names."
+  "sRecipients to summarize by\nP"
+  (lambda (recipients-string primary-only?)
+    (imail-summary
+     (string-append "Recipients " recipients-string)
+     (let ((recipients
+	    (list-transform-negative
+		(map string-trim (burst-string recipients-string #\, #f))
+	      string-null?)))
+       (lambda (m)
+	 ???)))))
+
+(define (imail-summary description predicate)
+  (let* ((folder (selected-folder))
+	 (folder-buffer (imail-folder->buffer folder #t))
+	 (summary-buffer
+	  (or (buffer-get folder-buffer 'IMAIL-SUMMARY-BUFFER #f)
+	      (let ((buffer
+		     (new-buffer
+		      (string-append (buffer-name folder-buffer)
+				     "-summary"))))
+		(buffer-put! folder-buffer 'IMAIL-SUMMARY-BUFFER buffer)
+		buffer))))
+    (buffer-reset! summary-buffer)
+    (fill-imail-summary-buffer! summary-buffer folder predicate)
+    (set-buffer-major-mode! summary-buffer (ref-mode-object imail))
+    (buffer-not-modified! summary-buffer)
+    (local-set-variable! truncate-lines #t summary-buffer)
+    (local-set-variable! mode-line-process (list ": " description)
+			 summary-buffer)
+    (associate-buffer-with-imail-buffer folder-buffer summary-buffer)
+    (buffer-put! summary-buffer 'IMAIL-MESSAGE-METHOD
+		 imail-summary-selected-message)
+    (imail-summary-select-message summary-buffer
+				  (selected-message #f folder-buffer))
+    (select-buffer summary-buffer)))
+
+(define (imail-summary-selected-message buffer)
+  (let ((folder (selected-folder #f buffer))
+	(index
+	 (count-lines (buffer-start buffer)
+		      (line-start (buffer-point buffer) 0))))
+    (and folder
+	 (< index (folder-length folder))
+	 (get-message folder index))))
+
+(define (imail-summary-select-message buffer message)
+  (let ((mark (line-start (buffer-start buffer) (message-index message))))
+    (if mark
+	(set-buffer-point! buffer mark))))
+
+(define (fill-imail-summary-buffer! buffer folder predicate)
+  (let ((mark (mark-left-inserting-copy (buffer-start buffer))))
+    (for-each
+     (lambda (message)
+       (if (predicate message)
+	   (begin
+	     (insert-string " " mark)
+	     (insert-string-pad-left
+	      (number->string (message-index message))
+	      4
+	      #\space
+	      mark)
+	     (insert-string "  " mark)
+	     (insert-string-pad-right
+	      (message-summary-date-string message)
+	      11
+	      #\space
+	      mark)
+	     (insert-string "  " mark)
+	     (insert-string-pad-right
+	      (let ((s (message-summary-from-string message)))
+		(if (> (string-length s) 24)
+		    (string-head s 24)
+		    s))
+	      24
+	      #\space
+	      mark)
+	     (insert-string " " mark)
+	     (insert-string (message-summary-subject-string message) mark)
+	     (insert-newline mark))))
+     (let ((end (folder-length folder)))
+       (let loop ((i 0) (messages '()))
+	 (if (< i end)
+	     (loop (+ i 1) (cons (get-message folder i) messages))
+	     (reverse! messages)))))))
+
+(define (message-summary-date-string message)
+  (let ((t (message-time message)))
+    (if t
+	(let ((dt (universal-time->local-decoded-time t)))
+	  (string-append
+	   (string-pad-left (number->string (decoded-time/day dt)) 2)
+	   " "
+	   (month/short-string (decoded-time/month dt))
+	   " "
+	   (number->string (decoded-time/year dt))))
+	"")))
+
+(define (message-summary-from-string message)
+  (let* ((s
+	  (decorated-string-append
+	   "" " " ""
+	   (map string-trim
+		(string->lines
+		 (or (get-first-header-field-value message "from" #f) "")))))
+	 (field (lambda (n) (lambda (regs) (re-match-extract s regs n)))))
+    (cond ((re-string-search-forward "[ \t\"]*\\<\\(.*\\)\\>[\" \t]*<.*>" s)
+	   => (field 1))
+	  ;; Chris VanHaren (Athena User Consultant) <vanharen>
+	  ((re-string-search-forward "[ \t\"]*\\<\\(.*\\)\\>.*(.*).*<.*>.*" s)
+	   => (field 1))
+	  ((re-string-search-forward ".*(\\(.*\\))" s)
+	   => (field 1))
+	  ((re-string-search-forward ".*<\\(.*\\)>.*" s)
+	   => (field 1))
+	  ((re-string-search-forward " *\\<\\(.*\\)\\> *" s)
+	   => (field 1))
+	  (else s))))
+
+(define (message-summary-subject-string message)
+  (or (get-first-header-field-value message "subject" #f) ""))
\ No newline at end of file
diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index 368e5addc..3e45e6480 100644
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.33 2000/05/16 03:33:47 cph Exp $
+;;; $Id: imail.pkg,v 1.34 2000/05/17 20:53:27 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -122,7 +122,9 @@
 	  rfc822:received-header-components
 	  rfc822:string->addresses
 	  rfc822:string->tokens
-	  rfc822:strip-quoted-names))
+	  rfc822:strip-comments
+	  rfc822:strip-quoted-names
+	  rfc822:tokens->string))
 
 (define-package (edwin imail imap-syntax)
   (files "imap-syntax")
@@ -197,8 +199,6 @@
 	 "imail-rmail"
 	 "imail-umail"
 	 "imail-imap"
-	 "imail-top")
-  (parent (edwin))
-  (import (edwin rmail)
-	  guarantee-rmail-variables-initialized
-	  rmail-spool-directory))
\ No newline at end of file
+	 "imail-top"
+	 "imail-summary")
+  (parent (edwin)))
\ No newline at end of file
diff --git a/v7/src/imail/print.sh b/v7/src/imail/print.sh
index c907e2826..368cfcd09 100755
--- a/v7/src/imail/print.sh
+++ b/v7/src/imail/print.sh
@@ -1,6 +1,6 @@
 #!/bin/sh
 #
-# $Id: print.sh,v 1.5 2000/05/11 00:48:06 cph Exp $
+# $Id: print.sh,v 1.6 2000/05/17 20:53:31 cph Exp $
 #
 # Copyright (c) 1999-2000 Massachusetts Institute of Technology
 #
@@ -18,7 +18,7 @@
 # along with this program; if not, write to the Free Software
 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
-prlist todo.txt imail-top.scm imail-core.scm \
+prlist todo.txt imail-top.scm imail-summary.scm imail-core.scm \
   imail-file.scm imail-rmail.scm imail-umail.scm \
   imail-imap.scm imap-response.scm imap-syntax.scm \
   imail-util.scm rfc822.scm url.scm parser.scm rexp.scm
diff --git a/v7/src/imail/rfc822.scm b/v7/src/imail/rfc822.scm
index c6321bf20..cd57ec092 100644
--- a/v7/src/imail/rfc822.scm
+++ b/v7/src/imail/rfc822.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: rfc822.scm,v 1.6 2000/05/15 17:47:50 cph Exp $
+;;; $Id: rfc822.scm,v 1.7 2000/05/17 20:53:32 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -95,6 +95,12 @@
 			       (eqv? #\> (cadr addr-spec))
 			       (cons (car addr-spec)
 				     (cddr addr-spec))))))))))))
+
+(define (rfc822:strip-comments tokens)
+  (list-transform-negative tokens
+    (lambda (token)
+      (and (string? token)
+	   (char=? #\( (string-ref token 0))))))
 
 (define (rfc822:received-header-components string)
   (let ((from #f)
@@ -208,7 +214,8 @@
 		  (eq? 'ILLEGAL (caar tokens)))
 	     (write-char (cdar tokens) port))
 	    (else
-	     (error "Malformed RFC-822 token stream:" tokens))))))
+	     (error "Malformed RFC-822 token stream:" tokens))))
+    (get-output-from-accumulator port)))
 
 ;;;; Parser