(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)


(FILECREATED "24-Sep-2023 14:26:57" {WMEDLEY}<lispusers>UNDIGESTIFY.;3
 17040  

      :EDIT-BY rmk

      :CHANGES-TO (VARS UNDIGESTIFYCOMS)
                  (FNS OPEN-SPACE-IN-FILE)

      :PREVIOUS-DATE "29-Jul-87 08:47:18" {WMEDLEY}<lispusers>UNDIGESTIFY.;1)


(* ; "
Copyright (c) 1986-1987 by Xerox Corporation.
")

(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 (FROM library/LAFITE)
                                                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)
                             (* ; "Edited 24-Sep-2023 14:25 by rmk")

                                                             (* 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.")


         (* Open a space in file starting at POSITION for length NCHARS by sliding the 

         rest of the file down.)


    (LET [(TEMP (OPENSTREAM '{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 (FROM
 library/LAFITE)
       LAFITEDECLS)
)

(INSTALL-UNDIGESTIFY
)
(PUTPROPS UNDIGESTIFY COPYRIGHT ("Xerox Corporation" 1986 1987))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1183 16831 (INSTALL-UNDIGESTIFY 1193 . 3206) (LAFITE-DISPLAY 3208 . 3507) (
LAFITE-TRUNCATE-FILE 3509 . 3920) (LAFITE-UNDIGESTIFY 3922 . 13578) (MOVE-TO-EOL 13580 . 14040) (
OPEN-SPACE-IN-FILE 14042 . 14762) (PARSE-AND-MAYBE-MERGE-HEADER 14764 . 15984) (SKIP-EOLS 15986 . 
16297) (BACKUP-PTR 16299 . 16461) (TEDIT.FIND.NOT.CASELESS 16463 . 16829)))))
STOP