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


(FILECREATED "23-Feb-2024 23:58:34" {WMEDLEY}<library>lafite>LAFITE-HAX.;1
 9138   

      :EDIT-BY rmk

      :PREVIOUS-DATE "26-Feb-93 14:36:38" {WMEDLEY}<library>lafite>LAFITEHAX.;1)


(PRETTYCOMPRINT LAFITE-HAXCOMS)

(RPAQQ LAFITE-HAXCOMS

       [[COMS                                                (* ; "New header parser")

              (FNS LAFITE.NEW.PARSE.HEADER LAFITE.HANDLE.ORIGINAL.FIELD INIT.NEW.PARSE.HANDLER 
                   LAFITE.COMPUTE.CACHED.VARS)
              (INITVARS (*LAFITE-MAX-FIELD-WIDTH* 100)
                     (*LAFITE-PARSE-HEADER-STRING-RESOURCE*))
              (GLOBALVARS *LAFITE-MAX-FIELD-WIDTH* *LAFITE-PARSE-HEADER-STRING-RESOURCE*)
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INIT.NEW.PARSE.HANDLER]
        (COMS                                                (* ; 

                                                            "automatically handle internet addresses")

              (FNS \NSMAIL.PARSE1))
        (COMS (FNS LAFITE.TOGGLE.SERVER.TRACE)
              (APPENDVARS (LAFITESUBQUITMENUITEMS ("Server trace" 'LAFITE.TOGGLE.SERVER.TRACE 
                                                         "Change setting of *NSMAIL-TRACE-SERVERS*"))
                     )
              (VARS (LAFITESUBQUITMENU])



(* ; "New header parser")


(DEFINEQ

(LAFITE.NEW.PARSE.HEADER

(LAMBDA (STREAM PARSETABLE START END ONCEONLY CHECKEOF) (* ; "Edited  3-Jun-92 17:30 by bvm") (PROG ((FIELD (OR *LAFITE-PARSE-HEADER-STRING-RESOURCE* (SETQ *LAFITE-PARSE-HEADER-STRING-RESOURCE* (ALLOCSTRING *LAFITE-MAX-FIELD-WIDTH*)))) PARSERESULT PARSEBEGIN CH I PATLEN) (DECLARE (SPECVARS PARSETABLE PARSERESULT PARSEBEGIN)) (* ; "For Parse result functions to access") (if START then (SETFILEPTR STREAM START)) TOP (SETQ PARSEBEGIN (GETFILEPTR STREAM)) (SETQ I 0) (do (SELCHARQ (SETQ CH (READCCODE STREAM)) ((CR TAB SPACE NIL) (* ; "Whitespace before a colon is illegal (or if it's a cr at start of line, it's the official end of header)") (if CHECKEOF then (push PARSERESULT (LIST (QUOTE EOF) PARSEBEGIN T))) (IF (EQ CH (CHARCODE CR)) THEN (FOR CHOICE IN PARSETABLE WHEN (EQ (CAR CHOICE) (QUOTE %
)) DO (* ; "Kludge for something to call at end of header") (RETURN (CL:FUNCALL (CADR CHOICE) STREAM (CAR CHOICE) 1 (CDDR CHOICE))))) (GO EXIT)) NIL) (if (< I *LAFITE-MAX-FIELD-WIDTH*) then (CL:SETF (CL:CHAR FIELD I) (CL:CODE-CHAR CH)) (add I 1)) (if (EQ CH (CHARCODE ":")) then (for CHOICE in PARSETABLE WHEN (AND (<= (SETQ PATLEN (NCHARS (CAR CHOICE))) I) (STRING-EQUAL FIELD (CAR CHOICE) :END1 PATLEN)) do (LAFITE.SKIP.WHITE.SPACE STREAM) (COND ((OR (EQ (CL:FUNCALL (CADR CHOICE) STREAM FIELD I (CDDR CHOICE)) (QUOTE STOP)) ONCEONLY) (GO EXIT)) (T (GO NEXTLINE)))) (* ;; "Get here if parse of current line failed") (LA.SKIP.TO.EOL STREAM CH) (GO NEXTLINE))) NEXTLINE (COND ((COND (END (< (GETFILEPTR STREAM) END)) (T (NOT (\EOFP STREAM)))) (GO TOP))) EXIT (replace CHARSET of STREAM with 0) (* ; "Don't let any temporary change in charset affect future operations.  This is not a call to CHARSET because of stupid bug that causes it to write a charset change!!!") (RETURN PARSERESULT)))
)

(LAFITE.HANDLE.ORIGINAL.FIELD

(LAMBDA (STREAM FIELD FIELDLEN IGNORE) (DECLARE (USEDFREE PARSERESULT PARSEBEGIN PARSETABLE)) (* ; "Edited  3-Jun-92 17:51 by bvm") (* ;; "Called when we parsed a header starting %"Original-xxx:...%"  We want to hide the %"Original-%" part, and also hide the matching %"xxx:%" field that (we assume) occurs later") (LA.SKIP.TO.EOL STREAM) (push PARSERESULT (LIST PARSEBEGIN (+ PARSEBEGIN (CONSTANT (NCHARS "Original-"))))) (push PARSETABLE (LIST (CL:SUBSEQ FIELD (CONSTANT (NCHARS "Original-")) FIELDLEN) (FUNCTION LAFITE.EAT.UNDESIRABLE.FIELD))) (* ; "Note that we have to COPY the characters of field, since that string is volatile") NIL)
)

(INIT.NEW.PARSE.HANDLER

(LAMBDA NIL (* ; "Edited  3-Jun-92 17:42 by bvm") (FOR FN IN (QUOTE (\LAFITE.APPEND.MESSAGE.BODY MESSAGEDISPLAYER)) DO (CHANGENAME FN (QUOTE LAFITE.PARSE.HEADER) (QUOTE LAFITE.NEW.PARSE.HEADER))) (LAFITE.COMPUTE.CACHED.VARS))
)

(LAFITE.COMPUTE.CACHED.VARS

(LAMBDA NIL (* ; "Edited  3-Jun-92 17:46 by bvm") (* ;; "Clears or recomputes all cached information that is based on some possibly user-settable variable.") (SETQ \LAFITE.DISPLAY.COMMANDS (APPEND (for CMD in (fetch (MENU ITEMS) of TEDIT.DEFAULT.MENU) when (CL:MEMBER (if (LISTP CMD) then (CAR CMD) else CMD) (QUOTE ("put" "find" "Expanded Menu")) :TEST (QUOTE STRING-EQUAL)) collect CMD) (for CMD in LAFITE.EXTRA.DISPLAY.COMMANDS collect (if (STRING-EQUAL (CAR CMD) "looks") then (* ; "Add subcommands, so user can easily add more functions to do Looks.") (LIST (CAR CMD) (CADR CMD) (CADDR CMD) (CONS (QUOTE SUBITEMS) (APPEND (CDR (CADDDR CMD)) LAFITE.LOOKS.SUBCOMMANDS))) else CMD)))) (for USERVAR in (QUOTE (LAFITE.DONT.DISPLAY.HEADERS LAFITE.DONT.FORWARD.HEADERS LAFITE.DONT.HARDCOPY.HEADERS)) as IVAR in (QUOTE (\LAPARSE.DONT.DISPLAY.HEADERS \LAPARSE.DONT.FORWARD.HEADERS \LAPARSE.DONT.HARDCOPY.HEADERS)) do (* ; "Make parse tables out of user vars that list fields to omit from headers") (SET IVAR (AND (EVALV USERVAR) (for FIELD in (EVALV USERVAR) collect (if (STRING-EQUAL FIELD "GV") then (* ; "Kludge!  Designed to eat GVGV nonsense that comes AFTER the header") (LIST (QUOTE %
) (FUNCTION LAFITE.EAT.GVGV)) ELSEIF (EQ FIELD :ORIGINAL) THEN (LIST "Original-" (FUNCTION LAFITE.HANDLE.ORIGINAL.FIELD)) else (LIST FIELD (FUNCTION LAFITE.EAT.UNDESIRABLE.FIELD))))))) (for VAR in LAFITEMENUVARS do (* ; "Clear cached menus") (SET VAR NIL)) (for FOLDER in \ACTIVELAFITEFOLDERS do (for W in (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER) when (WINDOWP W) do (WINDOWPROP W (QUOTE TEDIT.MENU.COMMANDS) \LAFITE.DISPLAY.COMMANDS) (WINDOWPROP W (QUOTE TEDIT.MENU) NIL))) (LET ((OLDABBREVS \LAFITE.PSEUDO.DEVICES) (NEWABBREVS (DREMOVE NIL (for PAIR in LAFITE.HOST.ABBREVS bind FIELDS NAMES collect (if (AND (for STR in (SETQ NAMES (if (LISTP (SETQ NAMES (CAR PAIR))) then (APPEND NAMES) else (LIST NAMES))) always (AND (STRINGP STR) (EQ (NTHCHARCODE STR -1) (CHARCODE ":")))) (for TAIL on (SETQ FIELDS (UNPACKFILENAME.STRING (CADR PAIR))) by (CDDR TAIL) always (FMEMB (CAR TAIL) (QUOTE (HOST DIRECTORY DEVICE))))) then (* ; "CAR is list of pseudo-devices (must be strings ending in colon), CDR is unpacked fields") (CONS NAMES FIELDS) else (PRINTOUT PROMPTWINDOW T "Bad host abbreviation: " PAIR) NIL))))) (if (NOT (PROG1 (EQUAL (CDR \LAFITE.PSEUDO.DEVICES) NEWABBREVS) (SETQ \LAFITE.PSEUDO.DEVICES (AND NEWABBREVS (CONS (CONS NIL (fetch UNPACKEDHOST&DIR of \LAFITEDEFAULTHOST&DIR)) NEWABBREVS))))) then (\LAFITE.RECOMPUTE.FOLDER.NAMES OLDABBREVS))) (* ;; "Finally, reauthenticate user, in case there is any mode-specific caching we care about.") (LAFITECLEARCACHE))
)
)

(RPAQ? *LAFITE-MAX-FIELD-WIDTH*
 100)

(RPAQ? *LAFITE-PARSE-HEADER-STRING-RESOURCE*
 )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS *LAFITE-MAX-FIELD-WIDTH* *LAFITE-PARSE-HEADER-STRING-RESOURCE*)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(INIT.NEW.PARSE.HANDLER
)
)



(* ; "automatically handle internet addresses")


(DEFINEQ

(\NSMAIL.PARSE1

(LAMBDA (FIELD DEFAULTDOMAIN EDITWINDOW) (* ; "Edited 26-Feb-93 14:34 by bvm") (COND (FIELD (bind ADDR (START _ 1) COMMA DOT when (PROGN (SETQ ADDR (SUBSTRING FIELD START (AND (SETQ COMMA (STRPOS (QUOTE %,) FIELD START)) (SUB1 COMMA)))) (do (* ; "Strip leading blanks") (SELCHARQ (CHCON1 ADDR) ((SPACE TAB) (GNC ADDR)) (RETURN))) (do (* ; "Strip trailing blanks") (SELCHARQ (NTHCHARCODE ADDR -1) ((SPACE TAB) (GLC ADDR)) (RETURN))) (NEQ (NCHARS ADDR) 0)) collect (if (AND (STRPOS (QUOTE @) ADDR) (NOT (STRPOS (QUOTE %:) ADDR)) (EQ DEFAULTDOMAIN (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*)) (SETQ DOT (STRPOS (QUOTE %.) ADDR NIL NIL NIL NIL NIL T))) then (* ;; "It's an Internet address--turn the last dot into a colon.  Don't do this if we're not being called from the places that parse with respect to the user's own name.  E.g., when building an answer form, there are often names that are abbreviated relative to the message sender's name.") (create NSNAME NSOBJECT _ (SUBSTRING ADDR 1 (SUB1 DOT)) NSDOMAIN _ (SUBSTRING ADDR (ADD1 DOT)) NSORGANIZATION _ "Xerox") else (PARSE.NSNAME ADDR NIL DEFAULTDOMAIN)) repeatwhile (COND (COMMA (SETQ START (ADD1 COMMA))))))))
)
)
(DEFINEQ

(LAFITE.TOGGLE.SERVER.TRACE

(LAMBDA NIL (* ; "Edited 24-Jul-92 15:14 by bvm") (LET ((CHOICE (MENU (create MENU ITEMS _ (QUOTE (("Quiet" 0 "Don't report server") ("Report" T "Just report server in prompt window") ("Require Confirmation" :ASK "Require approval for posting server choice"))) CENTERFLG _ T TITLE _ "Trace Posting Server?")))) (if CHOICE then (PRINTOUT PROMPTWINDOW T "*NSMAIL-TRACE-SERVERS* = " (SETQ *NSMAIL-TRACE-SERVERS* (AND (NEQ CHOICE 0) CHOICE))))))
)
)

(APPENDTOVAR LAFITESUBQUITMENUITEMS
 ("Server trace" 'LAFITE.TOGGLE.SERVER.TRACE 
                                           "Change setting of *NSMAIL-TRACE-SERVERS*"))

(RPAQQ LAFITESUBQUITMENU
 NIL)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1396 6868 (LAFITE.NEW.PARSE.HEADER 1406 . 3227) (LAFITE.HANDLE.ORIGINAL.FIELD 3229 . 
3905) (INIT.NEW.PARSE.HANDLER 3907 . 4162) (LAFITE.COMPUTE.CACHED.VARS 4164 . 6866)) (7198 8418 (
\NSMAIL.PARSE1 7208 . 8416)) (8419 8906 (LAFITE.TOGGLE.SERVER.TRACE 8429 . 8904)))))
STOP