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