LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031634. :SYSTEM-TYPE :LOGICAL :VERSION 10. :TYPE "LISP" :NAME "SUMMARY" :DIRECTORY ("REL3-SOURCE" "MAIL-READER") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758716666. :AUTHOR "REL3" :LENGTH-IN-BYTES 14577. :LENGTH-IN-BLOCKS 15. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        ;;; -*- Mode:Common-Lisp; Package:ZWEI; Base:10 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1985,1987 Texas Instruments Incorporated. All rights reserved.(defvar *mail-summary-line-pool* nil)                                                                                                                             ;;; Note that the re-use of summary lines can be dangerous.  Y'see during redisplay ZMACS likes to;;; use EQ to compare lines in the interval against certain lines (like top-line) stored away in;;; instance variables of the window.  So when a line is reused, it is possible for a comparison;;; using EQ to return T when it "shouldn't".  I don't fully understand all the implications of this,;;; but some care has been taken to use force-new-line-p when there may be danger.(defun ALLOCATE-SUMMARY-LINE (&optional force-new-line-p)    (setq force-new-line-p t);Until more confident *always* create new lines  (let ((line (if force-new-line-p nil (without-interrupts (pop *mail-summary-line-pool*)))))    (cond (line   (setf (line-next line) nil (line-previous line) nil (line-bp-list line) nil (line-node line) nil (line-contents-plist line) nil (line-plist line) nil))  (t   (setq line (create-line 'art-string 128. nil))))    (setf (line-length line) 0  (line-tick line) (tick))    line))(defun DEALLOCATE-SUMMARY-LINE (line)  (declare (ignore line))  ;; NO-OP -- always create new lines so don't save old ones  ;;(without-interrupts (pushnew line *mail-summary-line-pool*))  )(defun FIRST-MESSAGE-SUMMARY-LINE (summary)  "Return the first line in SUMMARY that actually summarizes a message.If there are no summary lines, return the last line in SUMMARY."    (loop for line first (bp-line (interval-first-bp summary)) then (line-next line)do(unless line  (return (bp-line (interval-last-bp summary))))(when (getf (line-plist line) :summary-message)  (return line))))(defun SUMMARY-LINE-MESSAGE-EQUAL (line message &optional sequence-buffer)  "T if LINE summarizes MESSAGE.  If SEQUENCE-BUFFER is supplied,LINE must also be within a summary for that sequence (for Dired style summaries)."    (let* ((msg (getf (line-plist line) :summary-message)) (seq (getf (line-plist line) :summary-sequence)))        (and (eq msg message) (or (null sequence-buffer);If no sequence supplied, ok     (null seq);If not a Dired style summary, ok     (eq seq sequence-buffer)))));Else, sequences must be the same.(defun SUMMARY-MAKE-MESSAGE-CURRENT (message summary-buffer &optional sequence-buffer)  "Update SUMMARY-BUFFER to point at MESSAGE and return the updated bpor NIL if MESSAGE not found.  If SEQUENCE-BUFFER is supplied, ensurethat the summary line selected is from that sequence (for Dired stylesummaries)."    (when (eq summary-buffer *interval*)    (move-bp (buffer-saved-point summary-buffer) (point)))  (let ((bp (buffer-saved-point summary-buffer)))        (cond ((summary-line-message-equal (bp-line bp) message sequence-buffer)   ;; no need to move, just return current bp   bp)  (t   (do ((line (bp-line (interval-first-bp summary-buffer)) (line-next line)))       ((null line) nil)          (when (summary-line-message-equal line message sequence-buffer)       (move-bp bp line(min (bp-index bp) (line-length line)));Stay in same column if possible       (return bp)))))))(defun MAKE-SUMMARY (sequence)    (when (and (boundp '*window*) *window* (send *window* :exposed-p))    (format *query-io* "~&Creating summary."))  (let* ((name (string-append (buffer-name sequence) " S")) (summary (find-buffer-named name)) line)    (cond (summary   (update-summary summary sequence)   summary)  (t   (setq summary (make-instance 'mail-summary-buffer :name (string-append (buffer-name sequence) " S")))   (with-read-only-suppressed (summary)     (insert-summary-heading (interval-last-bp summary))     (insert-line-with-leader (make-diagram-line 'mail-summary-black-line-diagram)      (bp-line (interval-last-bp summary)))     (domsgs (msg sequence index)       (setq line (make-summary-line msg (1+ index)))       (setf (line-node line) summary)       (insert-line-with-leader line (bp-line (interval-last-bp summary)))))   (send summary :activate)   (setf (buffer-sequence-buffer summary) sequence)   (setf (buffer-summary-buffer sequence) summary)   (setf (buffer-pathname summary) (buffer-pathname sequence))   (setf (buffer-file-id summary) nil)   (setf (buffer-version-string summary) (buffer-version-string sequence))   summary))))    (defun MAKE-SUMMARY-LINE (message sequence &optional line)    (let (number)    (cond ((numberp sequence)   (setq number sequence)   (setq sequence nil))  (t   (setq number (message-index message sequence))   (if number       (incf number)     (setq number 0))))    (if (null line)(setq line (allocate-summary-line))      (setf (line-length line) 0)      (mung-line line))    (summary-assure-message-parsed message)    (setf (getf (line-plist line) :summary-message) message)    (setf (getf (line-plist line) :summary-sequence) sequence)    (setf (getf (line-plist line) :summary-message-number) number)        (append-to-line line "       ")    (if (numberp number)(format line "~4D " number)      (append-to-line line "     "))        (loop for (item value) on *mail-summary-template* by #'cddr  with pad  do  (when pad    (append-to-line line "" 0 nil pad))  (setq pad 2)  (select item    (:length     (format line "~5D" (if (eq value :chars)    (message-char-count message)  (message-line-count message))))    ((:from :recipients)     (append-to-line line (or (summary-from message) "") 0 nil (if (numberp value) value 30)))    (:subject     (append-to-line line (or (summary-subject message) "") 0 nil (if (numberp value) value 30)))    (:date     (select value       (:date-and-time(append-to-line line (or (summary-date message) "") 0 nil 15))       (:date (append-to-line line (or (summary-date message) "") 0 nil 9))       (:brief-date(append-to-line line (or (summary-date message) "") 0 nil 6))))    (:keywords     (let* ((str (message-keywords-string message))    (len (and str (length str))))       (unless (numberp value) (setq value 30))       (cond ((null str)      (incf pad value))     ((<= len value)      (append-to-line line str)      (when (< len value)(incf pad (- value len))))     (t      (when (> value 3)(append-to-line line str 0 (- value 3))(append-to-line line "..."))))))))        (dolist (attr (message-attributes message))      (add-summary-attribute attr line))    (pushnew line (message-summary-lines message))    ;; Make sure line's bps are ok in case line became shorter    (let ((length (line-length line)))      (dolist (bp (line-bp-list line))(when (> (bp-index bp) length)  (setf (bp-index bp) length)))))  line)(defun INSERT-SUMMARY-HEADING (bp)    (insert-moving bp #\return)  (let ((line (create-line 'art-string 100 (bp-node bp))))    (setf (line-length line) 0)    (append-to-line line "Attrs. Msg# ")    (loop      for (item value) on *mail-summary-template* by #'cddr      do      (cond ((eq item :length)     (append-to-line line (if (eq value :chars) "Chars  " "Lines  ")))    ((symbolp item)     (append-to-line line (string-capitalize (string item)) 0 nil     (+ 2(cond ((numberp value)       (abs value))      ((symbolp value)       (case value (:date-and-time 15) (:date 9) (:brief-date 6) (t 30)))      (t       30)))))))    (insert-moving bp line)    (insert-moving bp #\Return)))(defflavor mail-summary-black-line-diagram   ()   (line-diagram-mixin))  (defmethod (mail-summary-black-line-diagram :draw) (ignore sheet &aux height)  (setq height (floor (tv:sheet-line-height sheet) 4))  (tv:prepare-sheet (sheet)    (system:%draw-rectangle (tv:sheet-inside-width sheet) height (tv:sheet-inside-left sheet)    (+ (tv:sheet-cursor-y sheet) (floor (* height 3) 2))    (tv:sheet-char-aluf sheet) sheet)))   (defmethod (mail-summary-black-line-diagram :string-for-file) (line)  line  "-----------------------------------------------------------------------")   (defun UPDATE-MESSAGE-SUMMARY (msg)  "Update all summary lines which summarize MESSAGE."  (dolist (line (message-summary-lines msg))    (make-summary-line msg (getf (line-plist line) :summary-message-number) line)    (mung-line line)))(defun ADD-SUMMARY-ATTRIBUTE (attribute line)    (let ((elem (assoc attribute *mail-summary-attribute-char-alist* :test #'eq)))    (when elem       (setf (char line (third elem)) (second elem))      (mung-line line)      (when (typep (line-node line) 'zmacs-buffer)(must-redisplay-buffer (line-node line) dis-line line 0)))))(defun DELETE-SUMMARY-ATTRIBUTE (attribute line)    (let ((elem (assoc attribute *mail-summary-attribute-char-alist* :test #'eq)))    (when elem       (setf (char line (third elem)) #\Space)      (mung-line line)      (when (typep (line-node line) 'zmacs-buffer)(must-redisplay-buffer (line-node line) dis-line line 0)))))(defun SUMMARY-ASSURE-MESSAGE-PARSED (msg)    (unless (message-summary-parsed-p msg)    (summary-parse-message msg)));; Format for fixed width date that lines up nicely in columns(defprop :|DD MMM YY-FIXED| "~2D ~*~A~:[ ~2,'0D~]" TIME:DATE-FORMAT)(defun SUMMARY-PARSE-MESSAGE (msg)  (assure-message-parsed msg)  ;; All that is required now is to create a date string... everthing else is retrived  ;; from the message-status  (let* ((utime (get-message-header msg :date :universal-time)) (string (make-array 20 :element-type 'string-char :fill-pointer 0)))    (setf (get msg :summary-date)  (if (not (numberp utime))      ""    (time:print-brief-universal-time utime string 0 :|DD MMM YY-FIXED|))))  (setf (message-summary-parsed-p msg) t))(defun SUMMARY-SUBJECT (msg)  ;; If message has been parsed, get from the status  (let ((interval (get-message-header msg :subject :interval)))    (if interval(interval-first-bp interval)      ;;else use the value tucked away when reading the file.      (get msg :summary-subject))))(defun SUMMARY-FROM (msg)  ;; If message has been parsed, get from the status  (let ((interval (get-message-header msg :from :interval)))    (if interval(interval-first-bp interval)      ;;else use the value tucked away when reading the file.      (get msg :summary-from))))(defun SUMMARY-DATE (msg)  (or (get msg :summary-date)      (let ((date-string (get msg :summary-date-string))    (brief-string (make-array 20 :element-type 'string-char :fill-pointer 0)))(when date-string  (ignore-errors     (time:print-brief-universal-time (time:parse-universal-time date-string 0 nil nil)     brief-string 0 :|DD MMM YY-FIXED|))  (setf (get msg :summary-date) brief-string)))))(defun REMOVE-SUMMARY-LINE (line-or-bp)    ;; This is a very internal routine for update-summary  ;; Note that *interval* and read-only-suppressed must be taken care of by the caller    (let* ((bp (if (stringp line-or-bp) (create-bp line-or-bp 0) line-or-bp)) (msg (getf (line-plist (bp-line bp)) :summary-message)))    (setf (bp-index bp) 0)    (when msg      (setf (message-summary-lines msg) (deleq (bp-line bp) (message-summary-lines msg) 1)))    (delete-interval bp (beg-line bp 1 t))    (deallocate-summary-line (bp-line bp))))(defun UPDATE-SUMMARY (summary &optional sequence start-bp stop-bp)  "Update SUMMARY to reflect the current contents of SEQUENCE. If START-BP and STOP-BP supplied, only update summary lines within thedefined interval, otherwise do the whole buffer.  Update message numbersand insert/delete summary lines for messages that have beenadded/removed.  Other summary info must already be correct."    (unless sequence    (setq sequence (message-sequence-of summary)))  (let ((*interval* summary);needed because delete-interval and beg-line may reference *interval*(*undo-save-small-changes* nil))    (with-read-only-suppressed (summary)      (loopwith stop-line = (if stop-bp (bp-line stop-bp) (bp-line (interval-last-bp summary)))with line = (if start-bp (bp-line start-bp) (first-message-summary-line summary))with bp = (create-bp line 0)with index = 0with len = (length (buffer-message-array sequence))for msg = (and (< index len) (aref (buffer-message-array sequence) index))for line-msg = (getf (line-plist line) :summary-message)while (or (< index len) (neq line stop-line))do(cond  ((and (neq line stop-line) msg line-msg (eq msg line-msg))   ;; Summary line's message matches message in sequence... ensure message number is correct.   (unless (eql (1+ index) (getf (line-plist line) :summary-message-number))     (make-summary-line msg (1+ index) line));update existing line to reflect correct message number   ;; Advance both summary line and sequence   (setq line (or (line-next line) stop-line))   (incf index))  ((and msg(or (lisp:find line-msg (buffer-message-array sequence) :test #'eq :start index)    (eq line stop-line)))   ;; This summary line's message exists further down or we've exausted the summary lines but not the sequence...   ;; Insert new summary for this message   (let ((new-line (allocate-summary-line t)))     (splice-line-into-interval (make-summary-line msg (1+ index) new-line) line)     (setf (line-node new-line) summary))   (incf index))  ((neq line stop-line)   ;; This summary line's message is gone from sequence or we've exausted the sequence but not the summary lines...   ;; remove the summary line.   (move-bp bp line 0);position bp at line to delete   (setq line (or (line-next line) stop-line));advance to next line before deleting   (remove-summary-line bp))  (t   ;; Already covered all the bases... shouldn't get here.   (return))))))  (must-redisplay-buffer summary dis-text))bject nil nil)    (when subject       (if (not (search (interval-first-bp subject) "RE:" nil nil nil (interval-last-bp subject)))  (insert-moving (point) "Re: "))      (insert-interval-moving (point) subject))    (insert-moving (point) #\return)    (insert-in-reply-to-field *msg*)    (insert-moving (point) #\return)))(defun INSERT-IN-REPLY-TO-FIELD (msg)   (when *in-reply-to-template*     (insert-header-field (point) :in-reply-to nil nil)     (loop for element in *in-reply-to-template*   doing (cond ((stringp element)(insert-moving (point) element))       ((member element '(:date :from :to :message-id) :test #'eq)(insert-interval-moving (point) (get-message-header msg element :interval "??")))       ((eq element :phrase)(let ((from-addr (f