(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "29-Jul-87 08:47:18" {PHYLUM}<LISPUSERS>LYRIC>UNDIGESTIFY.;2 16839
changes to%: (FNS INSTALL-UNDIGESTIFY)
previous date%: "16-May-86 10:55:33" {PHYLUM}<LISPUSERS>LYRIC>UNDIGESTIFY.;1)
(* "
Copyright (c) 1986, 1987 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 (* ; "Edited 29-Jul-87 08:44 by Rao")
(* ;
"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 "Forward" (CAAR ITEMS))
do (RPLACD ITEMS (CONS '("Undigest" '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))
'REGION]
(SETQ *DELETE-DIGEST-FLAG* T)
(SETQ *MOVE-TO-FIRST-DIGEST-MESSAGE-FLAG* NIL)
(SETQ *DONT-UPDATE-HEADERS-FLAG* NIL)
(SETQ SEPARATOR1 '"-----------------------------------------------------------------")
(SETQ SEPARATOR2 '"--------"])
(LAFITE-DISPLAY
[LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* SCB%: "26-Mar-86 10:44")
(COND
((EQ KEY 'LEFT)
(\LAFITE.DISPLAY WINDOW MAILFOLDER ITEM MENU KEY))
((EQ KEY '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 'LENGTH)
LENGTH)
then (SETFILEINFO FILE '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 '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 '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 '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 'ERROR)
(RETURN))
(if (EQ '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 'OUTPUT))
(* Protect against the user typing an interrupt char while we're writing to the
mailfolder.)
[RESETSAVE NIL `(AND RESETSTATE (LAFITE-TRUNCATE-FILE
',(fetch (MAILFOLDER
VERSIONLESSFOLDERNAME)
of MAILFOLDER)
',(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
'ERASE)
(LA.SHOW.SELECTION MAILFOLDER MSG-DESC '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 '{NODIRCORE} '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 'ERROR))
(if *DONT-UPDATE-HEADERS-FLAG*
then (RETURN P2))
(SETQ END-OF-HEADER (CADR (ASSOC 'EOF MSG-HEADER-PARSE)))
(if (NULL (ASSOC '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 1987))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1217 16647 (INSTALL-UNDIGESTIFY 1227 . 3240) (LAFITE-DISPLAY 3242 . 3541) (
LAFITE-TRUNCATE-FILE 3543 . 3954) (LAFITE-UNDIGESTIFY 3956 . 13612) (MOVE-TO-EOL 13614 . 14074) (
OPEN-SPACE-IN-FILE 14076 . 14578) (PARSE-AND-MAYBE-MERGE-HEADER 14580 . 15800) (SKIP-EOLS 15802 .
16113) (BACKUP-PTR 16115 . 16277) (TEDIT.FIND.NOT.CASELESS 16279 . 16645)))))
STOP