LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031627. :SYSTEM-TYPE :LOGICAL :VERSION 9. :TYPE "LISP" :NAME "MISC" :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 2758716561. :AUTHOR "REL3" :LENGTH-IN-BYTES 17183. :LENGTH-IN-BLOCKS 17. :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.;;;;;; Misc utility functions;;;(defun UTTER (stream format-string &rest format-args)  (if (eq stream t)      (setq stream *terminal-io*)    (if (not (streamp stream))(setq stream *query-io*)))  (if *mail-background-p*      (apply #'tv:notify nil format-string format-args)    (apply #'format stream format-string format-args)))(defprop read-mail-mode mail-move-bp MAJOR-MODE-MOVE-BP-FUNCTION)(defun MAIL-MOVE-BP (bp to-bp)  ;;Called only from MOVE-TO-BP.  If BP is eq to point, be sure the correct message is selected before moving    (if (neq bp (point))      (move-bp bp to-bp)    (let ((msg (bp-message to-bp))  (buffer (bp-top-level-node to-bp)))      (cond ((and msg (message-sequence-p buffer))     (unless (eq buffer *interval*)       (if (mail-buffer-window buffer)   (make-window-current (mail-buffer-window buffer)) (make-mail-buffer-current buffer :message)))     (select-message msg buffer)     (move-bp bp to-bp)     (must-redisplay-mail-buffer buffer dis-text dis-bps)     bp)    (t     (move-bp bp to-bp))))))(defmethod (message-node :after :DESCRIBE) ()  (format t "~%Text of message follows:~%~%")  (let ((stream (interval-stream self)))    (stream-copy-until-eof stream *standard-output*))  nil)(defmethod (message-sequence :after :DESCRIBE) ()  (format t "~%Contents of message sequence follows:~%~%")  (let ((stream (interval-stream self)))    (stream-copy-until-eof stream *standard-output*))  nil)(defun SPLICE-LINE-INTO-INTERVAL (new-line at-line)    ;; like insert-line-with-leader execpt can be used on any interval  ;; since it doesn't call mung-bp-interval.  also doesn't check undo or read-only  ;; or cons up a BP -- the caller must handle these if desired.    (let ((prev (line-previous at-line)))    (when prev      (setf (line-next prev) new-line))    (setf (line-next new-line) at-line)    (setf (line-previous new-line) prev)    (setf (line-previous at-line) new-line)    (setf (line-tick new-line) *tick*)    (unless (line-node new-line)      (setf (line-node new-line) (line-node at-line)))    ;; Fix up the BPs     (dolist (bp (line-bp-list at-line))      (when (eq (bp-status bp) :normal)(setf (line-bp-list at-line) (deleq bp (line-bp-list at-line)))(push bp (line-bp-list new-line))(setf (bp-line bp) new-line)(setf (bp-index bp) 0)))))(defun INTERVAL-LAST-NON-BLANK-LINE (from-bp &optional to-bp)    ;;Find last non-blank line  (get-interval from-bp to-bp nil)  (let ((last-line (bp-line to-bp))(first-line (bp-line from-bp)))    (loop      for line = last-line then (line-previous line)      when (or (null line) (eq line first-line))      return last-line      ;; Cant use line-blank-p because it references *interval* (grrr)      unless (loop       for i from 0 below (line-length line)       unless (member (char-code (aref line i)) (the list *blanks*))       return nil       finally (return t))      return line)))(defun APPEND-TO-LINE (line string-or-bp &optional (from 0) to width)  "Append the contents of STRING-OR-BP to LINE starting at FROM (or atbp-index if a bp is supplied) and ending at TO.  The text is leftjustified in a field of WIDTH (which may override the TO arg) and filledwith blanks; right justification occurs if WIDTH is negative."     (let ((right-justify (and width (minusp width)))string)    (if (stringp string-or-bp)(setq string string-or-bp)(setq string (bp-line string-or-bp)      from (bp-index string-or-bp)))        (or to (setq to (length string)))    (setq width (if width    (abs width)    (- to from)))    (let* ((copy-length (- to from))   (pad-length (- width copy-length))   (old-line-length (line-length line)))            ;; Width overrides other values if it is smaller      (when (< width copy-length)(setq copy-length width)(setq pad-length 0)(setq to (+ from width)))            ;; Adjust line length to hold new contents      (set-line-length line (+ (line-length line) width))      (cond (right-justify     (let ((copy-start (+ old-line-length pad-length)))       (when (plusp pad-length) (fill line #\Space :start old-line-length :end copy-start))       (when (plusp copy-length) (copy-array-portion string from to line copy-start (line-length line)))))        (t     (let ((pad-start (+ old-line-length copy-length)))       (when (plusp copy-length) (copy-array-portion string from to line old-line-length pad-start))       (when (plusp pad-length) (fill line #\Space :start pad-start :end (line-length line))))))))  line)(defun PARSE-FILTER-ALIST (string &optional (pkg (find-package "ZWEI")))    (let ((*package* (find-package (or pkg *package*))))    (loop      with index = 0      with (filter-item list)      do      (multiple-value-setq (filter-item index)(read-from-string string nil :eof :start index))      (when (eq filter-item :eof)(return list))      (when (and (consp filter-item) (>= (length filter-item) 2) (stringp (first filter-item)) (symbolp (second filter-item)))      (push-end filter-item list)      (incf index)      (when (>= index (length string))(return list))))))(defun READ-MAIL-ATTRIBUTES (prompt &optional defaults)  (let ((result (read-comma-delimited-list prompt *mail-attribute-completion-alist* defaults)))    (if (consp result)(delete-duplicates (the list result) :test #'eq)result)))(defun READ-MAIL-KEYWORDS (prompt &optional defaults)  (let ((result (read-comma-delimited-list prompt *mail-keywords-completion-alist* defaults *upcase-message-keywords-p*)))    (if (consp result)(delete-duplicates (the list result) :test #'eq)result)))(defvar *KEYWORD-CHOOSE-MARGIN-CHOICE-ALIST*'((:do-it    ("Do It" :eval (progn (setq *margin-choice* t) (funcall self :highlighted-values))     :documentation "Choose Highlighted keyword(s)"))  (:new-keyword    ("New Keyword" :eval (progn (setq *margin-choice* :new-keyword) (funcall self :highlighted-values))     :documentation '(:mouse-any "Choose highlighted keyword(s) and prompt for a new keyword.")))  (:any    ("Any" :eval (progn (setq *margin-choice* :any) (funcall self :highlighted-values))     :documentation '(mouse-any "Select messages that contain ANY of the highlighted keywords.If none chosen, then select messages that contain any keyword at all.")))  (:all    ("All" :eval (progn (setq *margin-choice* :all) (funcall self :highlighted-values))     :documentation '(mouse-any "Select messages that contain ALL of the highlighted keywords.If none chosen, then select messages that contain no keywords.")))))(defun CHOOSE-MAIL-KEYWORDS (choices label &optional defaults (margin-choices '(:do-it :new-keyword)))    (cond ((null choices) (if (memeq :new-keyword margin-choices)     (values (read-mail-keywords "Enter new keywords (separated by commas):") t)   (barf "There are no keywords in this buffer.")))(t (let ((*margin-choice* nil))   (declare (special *margin-choice*))   (multiple-value-bind (keywords do-something)       (w:multiple-menu-choose  choices :label label :highlighted-items defaults :menu-margin-choices (loopfor margin-key in margin-choicesfor item = (assoc margin-key *keyword-choose-margin-choice-alist*)when itemcollect (cadr item) into margin-choice-itemsfinally(return (or margin-choice-items    (cdr (assoc :do-it *keyword-choose-margin-choice-alist*))))))     (cond ((not do-something)    (values nil nil))   ((eq *margin-choice* :new-keyword)    (values        (read-mail-keywords "Enter keywords (separated by commas):" keywords)      :new-keyword))   (t    (values (sort keywords #'string-lessp) *margin-choice*))))))))  (defvar *read-comma-list-comtab* nil)(eval-when (compile load)  (setq *read-comma-list-comtab* (set-comtab 'read-comma-list-comtab     '(#\altmode com-comma-list-complete       #\space com-comma-list-complete       #\end com-comma-list-complete-and-exit-if-unique       #\C-? com-list-comma-list-completions       #\Help com-read-comma-list-documentation)))  (set-comtab-indirection *read-comma-list-comtab* *mini-buffer-comtab*))(defvar *read-comma-list-help-displayed* :unbound)(defun READ-COMMA-DELIMITED-LIST (prompt *completing-alist* &optional initial-contents (upcase? t) return-strings)    (let ((default-string (if (null initial-contents) ""    (if (consp initial-contents)(format nil "~{~A, ~}" initial-contents)(string initial-contents))))(*read-comma-list-help-displayed* nil))        (multiple-value-bind (nil nil interval)(edit-in-mini-buffer *read-comma-list-comtab*     default-string     (length default-string)      `(,prompt (:right-flush " (Completion)")))      (delimited-string-to-list (string-interval interval) #\, 0 nil nil *mail-utility-package* upcase? return-strings))))(defcom COM-COMMA-LIST-COMPLETE"Complete item within comma delimited list at point."()  (or (complete-comma-list-item (point))      (insert-moving (point) " "))  dis-text)(defcom COM-COMMA-LIST-COMPLETE-AND-EXIT-IF-UNIQUE"Complete item within comma-delimited list at point, and exit if that item completes uniquely."        ()  (let ((completions (complete-comma-list-item (point))))    (cond ((null completions)   (beep 'no-completion))  ((null (cdr completions)); Bingo.   (com-end-of-minibuffer))  (:else; No good way to check for exact match in list.   nil))    dis-text))(defun COMPLETE-COMMA-LIST-ITEM (bp)    (let* ((line (bp-line bp)) (index (bp-index bp)) ;;(at-end-p (= index (line-length line))) )    (multiple-value-bind (substring start end leading-comma-p trailing-comma-p)(comma-delimited-substring line index)      (multiple-value-bind (completed-string possibilities completed-p char-pos magic-pos)  (complete-string substring *completing-alist*    '(#\Space #\-) t index nil t)  char-pos completed-p(when possibilities  (delete-interval (create-bp line start) (create-bp line end))  (when leading-comma-p    (insert-moving bp " "))  (insert-moving bp completed-string))(cond ((and possibilities (null (cdr possibilities)) (not trailing-comma-p))       (insert-moving bp ", "))      (magic-pos       (move-bp bp line (+ magic-pos start (if leading-comma-p 1 0)))))possibilities))))(defcom COM-LIST-COMMA-LIST-COMPLETIONS"List completions for item in comma delimited list."()  (let ((string (comma-delimited-substring (bp-line (point)) (bp-index (point)))))    (multiple-value-bind (nil possibilities)(complete-string string *completing-alist*  '(#\Space))      (unless possibilities (barf))      (unless *read-comma-list-help-displayed*(com-read-comma-list-documentation))      (format t "~&Completion~P of the text you have typed:~2%" (length possibilities))      (send *standard-output* :item-list 'comma-list-completion    (sort (mapcar #'car possibilities) #'string-lessp))      (terpri *standard-output*)))  dis-none)(tv:add-typeout-item-type *typeout-command-alist* comma-list-completion "Select" comma-list-select-completion t  "Use this completion.")(defun COMMA-LIST-SELECT-COMPLETION (string)    (or (eq *interval* (window-interval *mini-buffer-window*)) (barf))  (let ((line (bp-line (point)))(index (bp-index (point))))    (multiple-value-bind (nil start end leading-comma-p trailing-comma-p)(comma-delimited-substring line index)      (send *standard-output* :make-complete);Only one completion can be meaningful      (delete-interval (create-bp line start) (create-bp line end))      (when leading-comma-p(insert-moving (point) " "))      (insert-moving (point) string)      (unless trailing-comma-p(insert-moving (point) ", ")))    (must-redisplay *window* dis-text)    dis-text))(defcom COM-READ-COMMA-LIST-DOCUMENTATION"Help for entering comma delimited lists."()  (setq *read-comma-list-help-displayed* t)  (format t "~&You are typing a comma delimited string in a minibuffer.Enter any number of items separated by commas.ESCAPE completes the item under the cursor.  This can be done at anypoint in the string.C-? lists all the strings that match what you have typed so far.The items listed are mouse sensitive.~%")  dis-none)(defun COMMA-DELIMITED-SUBSTRING (string index)  "Search within STRING for a comma delimited substring around INDEX.  Returns 5 values: the comma delimited substring minus any surrounding  white space, the index of the leading comma in STRING or 0, the index  of the trailing comma or the length of STRING, an idication of whether  there is a leading comma, and an indication of whether there is a  trailing comma." (declare (values substring start end leading-comma-p  trailing-comma-p))  (let* ((length (length string)) start end leading-comma-p trailing-comma-p)    (setq start  (do ((i (1- index) (1- i)))      ((< i 0) 0)    (when (char= (aref string i) #\,)      (setq leading-comma-p t)      (return (1+ i)))))    (setq end  (do ((i index (1+ i)))      ((>= i length) length)    (when (char= (aref string i) #\,)      (setq trailing-comma-p t)      (return i))))    (values (if (> (- end start) 0)(string-trim #\Space (subseq (the vector string) start end))"")    start end leading-comma-p trailing-comma-p)))(defun DELIMITED-STRING-TO-LIST (string delimiter &optional (from 0) to copy-p package-to-use (upcase? t) strings)    (when copy-p    (setq string (copy-seq string)))  (when upcase?    (nstring-upcase string))  (do* ((len (length string))(i (or from 0) (1+ i))start end list)       ((= i (or to len)) (if (and start end)      (if strings  (push-end (subseq (the vector string) start end) list)(push-end (intern (subseq (the vector string) start end) package-to-use) list))    list))    (cond ((member (aref string i) '(#\Space #\Tab #\Newline)))    ((eql (aref string i) delimiter)   (when (and start end)     (if strings (push-end (subseq (the vector string) start end) list)       (push-end (intern (subseq (the vector string) start end) package-to-use) list)))   (setq start nil end nil))  (t    (if start(setq end (1+ i))      (setq start i    end (1+ i)))))))(defun KBD-VIEW-MAIL (arg)  (let ((user (string-upcase user-id))(host fs:user-login-machine)dir file)    (using-resource (window tv:pop-up-finger-window)      (setf (tv:sheet-truncate-line-out-flag window) 1)      (send window :set-label (if (eq arg 1) "View file" "View mail"))      (send window :set-process current-process)      (tv:window-call (window :deactivate)(let ((*terminal-io* window) (*query-io* window))  (setq tv:kbd-terminal-time nil);Window configuration stable.  (case arg    (0 (setq user (read-line *standard-input* nil nil nil '((:prompt "View whose mail: "))))       (let ((@-pos (position #\@ user))     (luser (string-upcase user))) (when (not (null @-pos));Figure out if user wants a different machine   (setq host (si:parse-host (subseq user (1+ @-pos))))   (setq user (subseq luser 0 @-pos)))))    (1 (setq file (prompt-and-read :pathname "View File: "))       (send window :set-label (format nil "Viewing ~A" file))))  (unless (eq arg 1)    (send window :set-label (format nil "Viewing ~A's new mail on ~A" user host))    (setq dir (fs:user-homedir host nil user));this still isn't right, but...    (setq file (send dir :new-mail-pathname)))  (with-open-file (s file :error nil :characters t)    (cond ((errorp s)   (if (eq arg 1)       (format window "~&Error opening ~A: ~A" file s)     (if (condition-typep s 'fs:file-not-found) (format window "~&~A's mail file appears to be empty." user)       (format window "~&Unable to view ~A's mail because ~A." user s)))   ;;(FORMAT WINDOW "~3%~A" *REMOVE-TYPEOUT-STANDARD-MESSAGE*)   ;;(await-user-typeahead window)   (send window :tyi))  (t   (stream-copy-until-eof s window)   (send window :clear-input);just to be safe   (format window   "~3&Type ~@[~*~:C to delete ~A's mail, or ~]a space to flush: "   (neq arg 1) #\C-D user)   (let ((response (send window :tyi)))     (when (and (char= response #\C-D)(neq arg 1)(yes-or-no-p "Do you REALLY want to delete this mail ? "))       (send s :delete)))))))))    nil))(w:add-terminal-key #\V 'KBD-VIEW-MAIL    "View new mail. TERM 1 V - view any file."    :TYPEAHEAD)pend-to-line new-line prefix)) (append-to-line new-line " " 0 1 body-start) (append-to-line new-line line (or old-start 0)) (setf (car line-list-tail) new-line))   (loop for function in *reformat-one-header-hook*