(FILECREATED "16-May-86 10:55:33" {QV}<BAGLEY>LISP>UNDIGESTIFY.;31 13881
changes to: (FNS INSTALL-UNDIGESTIFY)
previous date: "30-Apr-86 15:09:04" {QV}<BAGLEY>LISP>UNDIGESTIFY.;30)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT UNDIGESTIFYCOMS)
(RPAQQ UNDIGESTIFYCOMS ((INITVARS *DELETE-DIGEST-FLAG* *MOVE-TO-FIRST-DIGEST-MESSAGE-FLAG*
*DONT-UPDATE-HEADERS-FLAG* SEPARATOR1 SEPARATOR2)
(FNS INSTALL-UNDIGESTIFY LAFITE-DISPLAY LAFITE-TRUNCATE-FILE
LAFITE-UNDIGESTIFY MOVE-TO-EOL OPEN-SPACE-IN-FILE
PARSE-AND-MAYBE-MERGE-HEADER SKIP-EOLS BACKUP-PTR
TEDIT.FIND.NOT.CASELESS)
(DECLARE: EVAL@COMPILE DONTCOPY (FILES {ERIS}<LAFITE>SOURCES>LAFITEDECLS))
(P (INSTALL-UNDIGESTIFY))))
(RPAQ? *DELETE-DIGEST-FLAG* NIL)
(RPAQ? *MOVE-TO-FIRST-DIGEST-MESSAGE-FLAG* NIL)
(RPAQ? *DONT-UPDATE-HEADERS-FLAG* NIL)
(RPAQ? SEPARATOR1 NIL)
(RPAQ? SEPARATOR2 NIL)
(DEFINEQ
(INSTALL-UNDIGESTIFY
(LAMBDA NIL (* SCB: "16-May-86 10:55")
(* Put "Undigest" on the browser menu after Display,
if it isn't already there.)
(if (NOT (SASSOC "Undigest" LAFITEBROWSERMENUITEMS))
then (* Copy the list because the menus will share its
structure.)
(SETQ LAFITEBROWSERMENUITEMS (COPY LAFITEBROWSERMENUITEMS))
(for ITEMS on LAFITEBROWSERMENUITEMS when (EQUAL (QUOTE Forward)
(CAAR ITEMS))
do
(RPLACD ITEMS (CONS (QUOTE ("Undigest" (QUOTE LAFITE-UNDIGESTIFY)
"Unpacks network digest into separate messages."))
(CDR ITEMS)))
(RETURN T)))
(* Update the width of the browser. Use the larger of the previous width and the minimum possible width, it case
they like wide browsers.)
(AND (REGIONP LAFITEBROWSERREGION)
(REPLACE (REGION WIDTH)
OF LAFITEBROWSERREGION WITH
(IMAX (FETCH (REGION WIDTH)
OF LAFITEBROWSERREGION)
(fetch (REGION WIDTH)
of
(WINDOWPROP (MENUWINDOW (create MENU ITEMS ←
LAFITEBROWSERMENUITEMS
CENTERFLG ← T MENUFONT ←
LAFITEMENUFONT))
(QUOTE REGION))))))
(SETQ *DELETE-DIGEST-FLAG* T)
(SETQ *MOVE-TO-FIRST-DIGEST-MESSAGE-FLAG* NIL)
(SETQ *DONT-UPDATE-HEADERS-FLAG* NIL)
(SETQ SEPARATOR1 (QUOTE "-----------------------------------------------------------------"))
(SETQ SEPARATOR2 (QUOTE "--------"))))
(LAFITE-DISPLAY
(LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* SCB: "26-Mar-86 10:44")
(COND
((EQ KEY (QUOTE LEFT))
(\LAFITE.DISPLAY WINDOW MAILFOLDER ITEM MENU KEY))
((EQ KEY (QUOTE MIDDLE))
(LAFITE-UNDIGESTIFY WINDOW MAILFOLDER ITEM MENU KEY)))))
(LAFITE-TRUNCATE-FILE
(LAMBDA (FILE LENGTH) (* SCB: "30-Apr-86 14:24")
(* Truncate the folder. FILE is the filename, not a
stream. Returns T if we did the truncation.)
(CLOSEF? FILE)
(if (NEQ (GETFILEINFO FILE (QUOTE LENGTH))
LENGTH)
then
(SETFILEINFO FILE (QUOTE LENGTH)
LENGTH)
T)))
(LAFITE-UNDIGESTIFY
(LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* SCB: "30-Apr-86 14:51")
(RESETLST
(LA.RESETSHADE ITEM MENU)
(PROG (REPORTWINDOW MSG1 MSGN MESSAGES DIGEST-MSG-DESC MESSAGE-STREAM MESSAGE-POSITIONS
DIGEST-HEADER-PARSE DIGEST-TO)
(SETQ REPORTWINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW)
of MAILFOLDER))
(SETQ MSG1 (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE)
of MAILFOLDER))
(SETQ MSGN (fetch (MAILFOLDER LASTSELECTEDMESSAGE)
of MAILFOLDER))
(CLEARW REPORTWINDOW)
(if (NOT (AND (NUMBERP MSG1)
(NUMBERP MSGN)
(IEQP MSG1 MSGN)))
then
(PRINTOUT REPORTWINDOW "Must select a single message.")
else
(PRINTOUT REPORTWINDOW "Parsing digest... ")
(WITH.MONITOR
(fetch FOLDERLOCK of MAILFOLDER)
(SETQ DIGEST-MSG-DESC (NTHMESSAGE (SETQ MESSAGES (fetch (MAILFOLDER
MESSAGEDESCRIPTORS)
of MAILFOLDER))
MSG1))
(LA.COPY.MESSAGE.TEXT MAILFOLDER (SETQ MESSAGE-STREAM (OPENTEXTSTREAM))
DIGEST-MSG-DESC)
(SETQ DIGEST-HEADER-PARSE (LAFITE.PARSE.HEADER MESSAGE-STREAM \LAPARSE.FULL 0
-1 NIL T))
(SETQ DIGEST-TO (CADR (ASSOC (QUOTE To)
DIGEST-HEADER-PARSE)))
(* Parse the digest, looking for the separators
between each submessage.)
(PROG (TEXTOBJ MSGS L1 L2 P1 P2 P3)
(SETQ TEXTOBJ (TEXTOBJ MESSAGE-STREAM))
(SETQ MSGS NIL)
(SETQ L1 (NCHARS SEPARATOR1))
(SETQ L2 (NCHARS SEPARATOR2))
(SETQ P1 (TEDIT.FIND.NOT.CASELESS TEXTOBJ SEPARATOR1 1))
(if (NULL P1)
then
(PRINTOUT REPORTWINDOW "Can't find first separator.")
(GO ERROR))
(SETQ P1 (SKIP-EOLS MESSAGE-STREAM (MOVE-TO-EOL MESSAGE-STREAM
(IPLUS P1 L1))))
(if (EQ (QUOTE ERROR)
(PARSE-AND-MAYBE-MERGE-HEADER MESSAGE-STREAM P1
(IPLUS P1 1000)
DIGEST-TO))
then
(PRINTOUT REPORTWINDOW "Can't parse header of digest message #1")
(GO ERROR))
(SETQ P2 P1)
(* P1 points to the beginning of the message. P2 points to the separator that might end the message.
P3 points to the beginning of the next message's header.)
(until (NULL (SETQ P2 (TEDIT.FIND.NOT.CASELESS TEXTOBJ SEPARATOR2
P2)))
do
(SETQ P3 (SKIP-EOLS MESSAGE-STREAM (MOVE-TO-EOL
MESSAGE-STREAM
(IPLUS P2 L2))))
(if (EQ (QUOTE ERROR)
(PARSE-AND-MAYBE-MERGE-HEADER MESSAGE-STREAM P3
(IPLUS P3 1000)
DIGEST-TO))
then
(SETQ P2 P3) (* Keep looking for end of message.)
else (* Message ends at char just before P2 because of
TEDIT.FIND.NOT.CASELESS)
(push MSGS (LIST P1 (SUB1 P2)))
(SETQ P1 P3)
(SETQ P2 P3))) (* We're allowed to throw away up to 50 characters at
the end of the message.)
(if (IGEQ (IDIFFERENCE (GETEOFPTR MESSAGE-STREAM)
P1)
50)
then
(push MSGS (LIST P1 (GETEOFPTR MESSAGE-STREAM))))
(SETQ MESSAGE-POSITIONS (DREVERSE MSGS))
(RETURN)
ERROR
(SETQ MESSAGE-POSITIONS (QUOTE ERROR))
(RETURN))
(if (EQ (QUOTE ERROR)
MESSAGE-POSITIONS)
then
(PRINTOUT REPORTWINDOW " Aborted.")
else
(PROG (OUTSTREAM BEGIN MSG-DESC MSG-START MSG-END NEW-MESSAGE-DESCRIPTORS)
(SETQ OUTSTREAM (\LAFITE.OPEN.FOLDER MAILFOLDER (QUOTE OUTPUT)))
(* Protect against the user typing an interrupt char
while we're writing to the mailfolder.)
(RESETSAVE NIL
(BQUOTE
(AND RESETSTATE
(LAFITE-TRUNCATE-FILE
(QUOTE (\, (fetch (MAILFOLDER
VERSIONLESSFOLDERNAME)
of MAILFOLDER)))
(QUOTE (\, (fetch (MAILFOLDER FOLDEREOFPTR)
of MAILFOLDER)))))))
(SETFILEPTR OUTSTREAM -1)
(COND
((NOT (IEQP (SETQ BEGIN (GETFILEPTR OUTSTREAM))
(fetch FOLDEREOFPTR of MAILFOLDER)))
(RETURN (HELP "Folder inconsistent with browser"))))
(SETQ NEW-MESSAGE-DESCRIPTORS NIL)
(for MSG-POS in MESSAGE-POSITIONS do (SETQ MSG-START (CAR MSG-POS)
)
(SETQ MSG-END (CADR MSG-POS))
(SETQ MSG-DESC
(create LAFITEMSG BEGIN ← BEGIN SEEN? ← NIL MARKCHAR ←
UNSEENMARK STAMPLENGTH ← LAFITESTAMPLENGTH
MESSAGELENGTH ← (SETQ LEN (IPLUS LAFITESTAMPLENGTH
(IDIFFERENCE
MSG-END
MSG-START)))))
(push NEW-MESSAGE-DESCRIPTORS MSG-DESC)
(SETQ BEGIN (IPLUS BEGIN LEN))
(LA.PRINTSTAMP OUTSTREAM)
(LA.PRINTCOUNT LEN OUTSTREAM)
(LA.PRINTCOUNT LAFITESTAMPLENGTH OUTSTREAM)
(BOUT OUTSTREAM UNDELETEDFLAG)
(BOUT OUTSTREAM SEENFLAG)
(BOUT OUTSTREAM SEENMARK)
(BOUT OUTSTREAM (CHARCODE CR))
(COPYBYTES MESSAGE-STREAM OUTSTREAM MSG-START MSG-END))
(LAB.APPENDMESSAGES MAILFOLDER (SETQ NEW-MESSAGE-DESCRIPTORS
(DREVERSE NEW-MESSAGE-DESCRIPTORS)))
(SEENMESSAGE DIGEST-MSG-DESC MAILFOLDER)
(if *DELETE-DIGEST-FLAG* then (DELETEMESSAGE DIGEST-MSG-DESC
MAILFOLDER))
(if *MOVE-TO-FIRST-DIGEST-MESSAGE-FLAG* then (UNSELECTALLMESSAGES
MAILFOLDER)
(SELECTMESSAGE (CAR NEW-MESSAGE-DESCRIPTORS)
MAILFOLDER)
(LAB.EXPOSEMESSAGE MAILFOLDER (CAR NEW-MESSAGE-DESCRIPTORS))
else (* Treat digest message as if it had been displayed,
and move to next undeleted message.)
(for N from (ADD1 MSG1)
to
(fetch (MAILFOLDER #OFMESSAGES)
of MAILFOLDER)
do
(if (NOT (fetch (LAFITEMSG DELETED?)
of
(SETQ MSG-DESC (NTHMESSAGE MESSAGES N))
))
then
(LA.SHOW.SELECTION MAILFOLDER DIGEST-MSG-DESC
(QUOTE ERASE))
(LA.SHOW.SELECTION MAILFOLDER MSG-DESC (QUOTE
REPLACE))
(replace (LAFITEMSG SELECTED?)
of DIGEST-MSG-DESC with NIL)
(replace (LAFITEMSG SELECTED?)
of MSG-DESC with T)
(replace FIRSTSELECTEDMESSAGE of MAILFOLDER with N)
(replace LASTSELECTEDMESSAGE of MAILFOLDER with N)
(RETURN))))
(PRINTOUT REPORTWINDOW " done. ")))))))))
(MOVE-TO-EOL
(LAMBDA (TEXTSTREAM POSITION) (* SCB: "27-Mar-86 10:34")
(* POSITION points into a line. Return the position immediately following the CR at the end of this line, i.e., the
first char on the next line.)
(AND POSITION (SETFILEPTR TEXTSTREAM POSITION))
(until (IEQP (CHARCODE CR)
(\BIN TEXTSTREAM))
do)
(GETFILEPTR TEXTSTREAM)))
(OPEN-SPACE-IN-FILE
(LAMBDA (FILE POSITION NCHARS) (* SCB: "25-Mar-86 12:52")
(* Open a space in file starting at POSITION for
length NCHARS by sliding the rest of the file down.)
(LET ((TEMP (OPENFILE (QUOTE {NODIRCORE})
(QUOTE BOTH))))
(COPYBYTES FILE TEMP POSITION (GETEOFPTR FILE))
(SETFILEPTR FILE (IPLUS POSITION NCHARS))
(SETFILEPTR TEMP 0)
(COPYBYTES TEMP FILE)
(CLOSEF? TEMP))))
(PARSE-AND-MAYBE-MERGE-HEADER
(LAMBDA (MESSAGE-STREAM P1 P2 DIGEST-TO) (* SCB: "14-Apr-86 12:31")
(PROG (MSG-HEADER-PARSE END-OF-HEADER STRING CR)
(SETQ MSG-HEADER-PARSE (LAFITE.PARSE.HEADER MESSAGE-STREAM \LAPARSE.FULL P1 P2 NIL T))
(if (NULL (CDR MSG-HEADER-PARSE))
then (* Nothing in the header, probably not a legal
message.)
(RETURN (QUOTE ERROR)))
(if *DONT-UPDATE-HEADERS-FLAG* then (RETURN P2))
(SETQ END-OF-HEADER (CADR (ASSOC (QUOTE EOF)
MSG-HEADER-PARSE)))
(if (NULL (ASSOC (QUOTE To)
MSG-HEADER-PARSE))
then
(TEDIT.INSERT MESSAGE-STREAM (SETQ STRING (CONCAT (SETQ CR
(CHARACTER (CHARCODE
CR)))
"To: " DIGEST-TO CR))
END-OF-HEADER)
(add END-OF-HEADER (NCHARS STRING))
(add P2 (NCHARS STRING)))
(RETURN P2))))
(SKIP-EOLS
(LAMBDA (TEXTSTREAM POSITION) (* SCB: "27-Mar-86 10:35")
(AND POSITION (SETFILEPTR TEXTSTREAM POSITION))
(until (NOT (IEQP (CHARCODE CR)
(\BIN TEXTSTREAM)))
do)
(SETFILEPTR TEXTSTREAM (SUB1 (GETFILEPTR TEXTSTREAM)))))
(BACKUP-PTR
(LAMBDA (STREAM) (* SCB: "27-Mar-86 10:20")
(SETFILEPTR STREAM (SUB1 (GETFILEPTR STREAM)))))
(TEDIT.FIND.NOT.CASELESS
(LAMBDA (TEXTOBJ TARGETSTRING START# END# WILDCARDS?) (* SCB: " 9-Apr-86 13:53")
(* This function exists because you might be using
Shrager's caseless search in TEdit.)
(LET ((TEDIT:*CASE-FOLD-SEARCH-P* NIL))
(TEDIT.FIND TEXTOBJ TARGETSTRING START# END# WILDCARDS?))))
)
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD {ERIS}<LAFITE>SOURCES>LAFITEDECLS)
)
(INSTALL-UNDIGESTIFY)
(PUTPROPS UNDIGESTIFY COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (989 13696 (INSTALL-UNDIGESTIFY 999 . 2747) (LAFITE-DISPLAY 2749 . 3068) (
LAFITE-TRUNCATE-FILE 3070 . 3535) (LAFITE-UNDIGESTIFY 3537 . 10723) (MOVE-TO-EOL 10725 . 11174) (
OPEN-SPACE-IN-FILE 11176 . 11779) (PARSE-AND-MAYBE-MERGE-HEADER 11781 . 12781) (SKIP-EOLS 12783 .
13109) (BACKUP-PTR 13111 . 13283) (TEDIT.FIND.NOT.CASELESS 13285 . 13694)))))
STOP