From f58936e76266d050f04ee0e0ec5ca1ee9fe480c6 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Wed, 29 Sep 2021 10:11:31 -0700 Subject: [PATCH 1/8] PRINTFN: Fix typo, add comments --- sources/PRINTFN | 56 +++++++++++++++++++++++++------------------ sources/PRINTFN.LCOM | Bin 5304 -> 5336 bytes 2 files changed, 33 insertions(+), 23 deletions(-) diff --git a/sources/PRINTFN b/sources/PRINTFN index 093440e2..586b23dd 100644 --- a/sources/PRINTFN +++ b/sources/PRINTFN @@ -1,8 +1,11 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS) -(FILECREATED " 8-Aug-2021 15:15:00"  -{DSK}kaplan>Local>medley3.5>git-medley>sources>PRINTFN.;18 13138 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - previous date%: " 8-Aug-2021 14:52:38" +(FILECREATED "28-Sep-2021 23:52:49"  +{DSK}kaplan>Local>medley3.5>git-medley>sources>PRINTFN.;24 13993 + + changes to%: (FNS PRINTFNDEF PFCOPYBYTES) + + previous date%: " 8-Aug-2021 15:15:00" {DSK}kaplan>Local>medley3.5>git-medley>sources>PRINTFN.;17) @@ -109,7 +112,7 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation. (T (printout TOFILE FN " not found on " LOC "." T]) (PRINTFNDEF - [LAMBDA (SRCFIL DSTFIL START END TYPE) (* bvm%: " 9-Sep-86 15:54") + [LAMBDA (SRCFIL DSTFIL START END TYPE) (* ; "Edited 28-Sep-2021 23:52 by rmk:") (RESETLST (PROG (TEM) [COND @@ -128,10 +131,15 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation. DSTFIL T) (PRIN1 "} " DSTFIL)) + + (* ;; "RMK: Originally the last test was (EQ TYPE 'MAC). I think this was a typo for MAP, since that argument is set to MAP in FINDFNDEF. If the typo is fixed, we would end up in the COPYBYTES clause, which we don't generally want. So changed it also to a NEQ.") + + (* ;; "PFDEFAULT is passed as the TYPE argument on the call from COPYALLBYTES, basically to force COPYBYTES and not do the format and font translations. It defaults to NIL, not COPYBYTES. I don't understand what this is trying to control. Note that the last argument of PFCOPYBYTES (PFDEFAULT here) is ignored.") + (COND ((OR (NOT (DISPLAYP DSTFIL)) (EQ PFDEFAULT 'COPYBYTES) - (EQ TYPE 'MAC)) + (NEQ TYPE 'MAP)) (COPYBYTES SRCFIL DSTFIL START END)) (T (PFCOPYBYTES SRCFIL DSTFIL START END PFDEFAULT))) (TERPRI DSTFIL))]) @@ -160,21 +168,23 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation. (T FULL]) (PFCOPYBYTES - [LAMBDA (SRCFIL DSTFIL START END FLG) (* ; "Edited 8-Aug-2021 14:51 by rmk:") - (* ; "Edited 24-Mar-93 14:16 by rmk:") - (* lmm "28-Sep-86 14:38") + [LAMBDA (SRCFIL DSTFIL START END FLG) (* ; "Edited 28-Sep-2021 23:35 by rmk:") + (* ; "Edited 24-Mar-93 14:16 by rmk:") + (* lmm "28-Sep-86 14:38") - (* ;; " copy from SRCFIL to DSTFIL, paying attention to font changes. Other stuff about truncating lines gone away. Interprets all possible EOL conventions as EOL. Has to call \INCHAR-\INCCODE macros in order to keep track of character count--READDCODE doesn't do that.") + (* ;; "RMK: What does FLG do? It isn't referenced. It seems to be passed as the value of PFDEFAULT from PRINTFNDEF, and that variable is initialized to NIL. Remove both, eventually?") - (* ;; "If END is NIL and START is given, then START is the number of characters to copy from the current file position. Otherwise, copy to the end of the file.") + (* ;; " copy from SRCFIL to DSTFIL, paying attention to font changes. Other stuff about truncating lines gone away. Interprets all possible EOL conventions as EOL. Has to call \INCHAR-\INCCODE macros in order to keep track of character count--READDCODE doesn't do that.") + + (* ;; "If END is NIL and START is given, then START is the number of characters to copy from the current file position. Otherwise, copy to the end of the file.") (DECLARE (GLOBALVARS CHANGECHAR COMMENTFLG **COMMENT**FLG)) (RESETLST (PROG ((SSTRM (\INSTREAMARG SRCFIL)) (DSTRM (\OUTSTREAMARG DSTFIL)) FONTARRAY CHARCODE %#CHARS MAXFONT) - (DECLARE (SPECVARS . T)) (* ; - "In particular, #CHARS must be a specvar for \INCCODE") + (DECLARE (SPECVARS . T)) (* ; + "In particular, #CHARS must be a specvar for \INCCODE") (COND ((IMAGESTREAMP DSTRM) (SETQ FONTARRAY (FONTMAPARRAY)) @@ -187,7 +197,7 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation. [SETQ %#CHARS (COND (END (SETFILEPTR SSTRM START) - (* ;; "Doesn't call \SETFILEPTR cause START has to be checked") + (* ;; "Doesn't call \SETFILEPTR cause START has to be checked") (IDIFFERENCE (COND ((EQ END -1) @@ -195,26 +205,26 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation. (T END)) START)) (START) - (T (* ; - "Copy everything from here to the end-of-file") + (T (* ; + "Copy everything from here to the end-of-file") (SETQ START (GETFILEPTR SSTRM)) (IDIFFERENCE (GETEOFPTR SSTRM) (GETFILEPTR SSTRM] (COND ((ILEQ %#CHARS 0) - (RETURN T))) (* ; "Nothing to do") + (RETURN T))) (* ; "Nothing to do") LP (COND ((ILEQ %#CHARS 0) (CL:WHEN (AND (EQ START 0) - (EOFP SSTRM)) (* ; "We copied the whole file") + (EOFP SSTRM)) (* ; "We copied the whole file") (TERPRI DSTRM)) (RETURN T))) (SETQ CHARCODE (\INCCODE.EOLC SSTRM ANY.EOLC '%#CHARS %#CHARS)) (IF (EQ CHARCODE (CONSTANT (CHARCODE.DECODE FONTESCAPECHAR))) THEN - (* ;; - "No EOL check on font character, otherwise we would be limited to 9 fonts") + (* ;; + "No EOL check on font character, otherwise we would be limited to 9 fonts") (SETQ CHARCODE (\INCCODE SSTRM '%#CHARS %#CHARS)) (CL:WHEN (AND (IGEQ MAXFONT CHARCODE) @@ -257,7 +267,7 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation. (COND ((AND WIDTH (IGREATERP (add HPOS WIDTH) RMAR)) - (* past RIGHT margin, force eol) + (* past RIGHT margin, force eol) (TERPRI DSTRM) (SETQ HPOS WIDTH))) (\OUTCHAR DSTRM CC] @@ -285,7 +295,7 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation. ) (PUTPROPS PRINTFN COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1999 2018 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1097 11016 (PF 1107 . 3802) (PF* 3804 . 4098) (PMORE 4100 . 4419) (PRINTFN 4421 . 5012) - (PRINTFNDEF 5014 . 6131) (FINDFNDEF 6133 . 7157) (PFCOPYBYTES 7159 . 10766) (DISPLAYP 10768 . 11014)) + (FILEMAP (NIL (1134 11871 (PF 1144 . 3839) (PF* 3841 . 4135) (PMORE 4137 . 4456) (PRINTFN 4458 . 5049) + (PRINTFNDEF 5051 . 6790) (FINDFNDEF 6792 . 7816) (PFCOPYBYTES 7818 . 11621) (DISPLAYP 11623 . 11869)) ))) STOP diff --git a/sources/PRINTFN.LCOM b/sources/PRINTFN.LCOM index da21f6928db39699a14b6b5d5f14e94cf4093e5f..3fc6dc26ff190ba76229d33c0c26dcd8f34bfb2b 100644 GIT binary patch delta 286 zcmdm?c|&u8o2n)kmxi0CkE?T#t7C|(i-MAog>GetBZn?f`zVQX}YeFfsvtt zp{W%JSxn3hsyDRI#FR9&GBi+9NGeKA&d)8#%t=jA;7YA1C@NO9Qpn3M$;ix0SIEp$ zP;v|P@lilFSWiz+Ng*Y%1gHVSLZF#uN*JyZ#c-AZ(B{eS867w*6u1nH4UH`(A7hkf fH?cA`vNE>V{D$!pJLAmB_c`w~I&a?3CCLQ<-+n^B From 388d54b7133248149bc13836e735366a52569a35 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Wed, 29 Sep 2021 22:23:45 -0700 Subject: [PATCH 2/8] TEDITSCREEN: Cleanup \DISPLAYLINE Test argument validity at top so ffetch can be used consistently. Remove unused variables, and move some other variable bindings to their proper scope --- library/TEDITSCREEN | 421 +++++++++++++++++++-------------------- library/TEDITSCREEN.LCOM | Bin 35927 -> 34908 bytes 2 files changed, 209 insertions(+), 212 deletions(-) diff --git a/library/TEDITSCREEN b/library/TEDITSCREEN index 772d9832..7ea78f69 100644 --- a/library/TEDITSCREEN +++ b/library/TEDITSCREEN @@ -1,13 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "21-Sep-2021 12:53:40"  -{DSK}kaplan>Local>medley3.5>git-medley>library>TEDITSCREEN.;4 214736 - changes to%: (MACROS MI-TEDIT.BLTCHAR) - (VARS TEDITSCREENCOMS) - (FNS \MAIKO.DISPLAYLINE \DISPLAYLINE) +(FILECREATED "29-Sep-2021 22:03:57"  +{DSK}kaplan>Local>medley3.5>git-medley>library>TEDITSCREEN.;8 214517 - previous date%: "30-Apr-2021 14:42:15" -{DSK}kaplan>Local>medley3.5>git-medley>library>TEDITSCREEN.;1) + changes to%: (FNS \DISPLAYLINE) + + previous date%: "21-Sep-2021 12:53:40" +{DSK}kaplan>Local>medley3.5>git-medley>library>TEDITSCREEN.;7) (* ; " @@ -1094,247 +1093,245 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation. (DEFINEQ (\DISPLAYLINE - [LAMBDA (TEXTOBJ LINE WINDOW) (* ; "Edited 21-Sep-2021 12:47 by rmk:") + [LAMBDA (TEXTOBJ LINE WINDOW) (* ; "Edited 28-Sep-2021 15:00 by rmk:") (* ;; "Display the line of text LINE in the edit window where it belongs.") - (PROG ((CH 0) - (CHLIST (fetch (THISLINE CHARS) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ))) - (WLIST (fetch (THISLINE WIDTHS) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ))) - (LOOKS (fetch (THISLINE LOOKS) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ))) - (WINDOWDS (WINDOWPROP (OR WINDOW (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ))) - 'DSP)) - (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) - (THISLINE (fetch (TEXTOBJ THISLINE) of TEXTOBJ)) - (TERMSA (fetch (TEXTOBJ TXTTERMSA) of TEXTOBJ)) - (STREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) - (OLDCACHE (fetch LCBITMAP of (fetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ))) - (DS (fetch (TEXTOBJ DISPLAYCACHEDS) of TEXTOBJ)) - (HCPYDS (fetch (TEXTOBJ DISPLAYHCPYDS) of TEXTOBJ)) - (HARDCOPYMODE (fetch (FMTSPEC FMTHARDCOPY) of (fetch (LINEDESCRIPTOR LFMTSPEC) - of LINE))) - LOOKSTARTX CACHE \PCHARSLEFT \PSTRING \PFILE FONT OFONT OLOOKS XOFFSET CLIPLEFT CLIPRIGHT - DISPLAYDATA DDPILOTBBT DDWIDTHCACHE DDOFFSETCACHE CURY LHEIGHT SCALE) - [SETQ LHEIGHT (COND - ((fetch (LINEDESCRIPTOR PREVLINE) of LINE) + (* ;; "Validate the incoming arguments so ffetch can be used consistently for all their field extractions.") + + (\DTEST TEXTOBJ 'TEXTOBJ) + (\DTEST LINE 'LINEDESCRIPTOR) + (LET ((LOOKS (ffetch (THISLINE LOOKS) of (ffetch (TEXTOBJ THISLINE) of TEXTOBJ))) + (WINDOWDS (WINDOWPROP (OR WINDOW (CAR (ffetch (TEXTOBJ \WINDOW) of TEXTOBJ))) + 'DSP)) + (THISLINE (\DTEST (ffetch (TEXTOBJ THISLINE) of TEXTOBJ) + 'THISLINE)) + (OLDCACHE (fetch (LINECACHE LCBITMAP) of (ffetch (TEXTOBJ DISPLAYCACHE) + of TEXTOBJ))) + (DS (ffetch (TEXTOBJ DISPLAYCACHEDS) of TEXTOBJ)) + (HCPYDS (ffetch (TEXTOBJ DISPLAYHCPYDS) of TEXTOBJ)) + (HARDCOPYMODE (fetch (FMTSPEC FMTHARDCOPY) of (ffetch (LINEDESCRIPTOR LFMTSPEC) + of LINE))) + CACHE OFONT OLOOKS XOFFSET CLIPLEFT CLIPRIGHT DISPLAYDATA DDPILOTBBT DDWIDTHCACHE + DDOFFSETCACHE CURY LHEIGHT SCALE) + [SETQ LHEIGHT (COND + ((ffetch (LINEDESCRIPTOR PREVLINE) of LINE) (* ;  "So if theres a base-to-base measure, we clear everything right.") - (IMAX (IDIFFERENCE (fetch (LINEDESCRIPTOR YBOT) - of (fetch (LINEDESCRIPTOR PREVLINE) - of LINE)) - (fetch (LINEDESCRIPTOR YBOT) of LINE)) - (fetch (LINEDESCRIPTOR LHEIGHT) of LINE))) - (T (fetch (LINEDESCRIPTOR LHEIGHT) of LINE] - (COND - (HARDCOPYMODE (* ; + (IMAX (IDIFFERENCE (ffetch (LINEDESCRIPTOR YBOT) + of (ffetch (LINEDESCRIPTOR PREVLINE) + of LINE)) + (ffetch (LINEDESCRIPTOR YBOT) of LINE)) + (ffetch (LINEDESCRIPTOR LHEIGHT) of LINE))) + (T (ffetch (LINEDESCRIPTOR LHEIGHT) of LINE] + (SETQ SCALE (COND + (HARDCOPYMODE (* ;  "This is a hardcopy-mode line. Scale things.") - (* ; "(SETQ DS HCPYDS)") - (SETQ SCALE (DSPSCALE NIL HCPYDS))) - (T (SETQ SCALE 1))) - (SETQ CACHE (\TEDIT.LINECACHE (fetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ) - (COND - (HARDCOPYMODE (FIXR (FQUOTIENT (fetch (LINEDESCRIPTOR RIGHTMARGIN + (DSPSCALE NIL HCPYDS)) + (T 1))) + (SETQ CACHE (\TEDIT.LINECACHE (ffetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ) + (COND + (HARDCOPYMODE (FIXR (FQUOTIENT (ffetch (LINEDESCRIPTOR RIGHTMARGIN ) of LINE) - SCALE))) - (T (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE))) - LHEIGHT)) - (COND - ((NEQ CACHE OLDCACHE) (* ; + SCALE))) + (T (ffetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE))) + LHEIGHT)) + (COND + ((NEQ CACHE OLDCACHE) (* ;  "We changed the bitmaps because this line was bigger--update the displaystream, too") - (DSPDESTINATION CACHE DS) - (DSPCLIPPINGREGION (create REGION - LEFT _ 0 - BOTTOM _ 0 - WIDTH _ (fetch BITMAPWIDTH of CACHE) - HEIGHT _ (fetch BITMAPHEIGHT of CACHE)) - DS))) - (BITBLT NIL 0 0 CACHE 0 0 NIL NIL 'TEXTURE 'REPLACE WHITESHADE) + (DSPDESTINATION CACHE DS) + (DSPCLIPPINGREGION (create REGION + LEFT _ 0 + BOTTOM _ 0 + WIDTH _ (fetch BITMAPWIDTH of CACHE) + HEIGHT _ (fetch BITMAPHEIGHT of CACHE)) + DS))) + (BITBLT NIL 0 0 CACHE 0 0 NIL NIL 'TEXTURE 'REPLACE WHITESHADE) (* ; "Clear the line cache") - (COND - (HARDCOPYMODE (* ; - "This is a hardcopy-mode line. Scale things.") - (* ; "(SETQ DS HCPYDS)") - (SETQ SCALE (DSPSCALE NIL HCPYDS))) - (T (SETQ SCALE 1))) - [COND - ((AND (NOT (ZEROP (fetch (LINEDESCRIPTOR CHAR1) of LINE))) - (ILEQ (fetch (LINEDESCRIPTOR CHAR1) of LINE) - TEXTLEN) - (IGEQ (fetch (LINEDESCRIPTOR YBOT) of LINE) - (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ))) + [COND + ((AND (NOT (ZEROP (fetch (LINEDESCRIPTOR CHAR1) of LINE))) + (ILEQ (ffetch (LINEDESCRIPTOR CHAR1) of LINE) + (ffetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (IGEQ (ffetch (LINEDESCRIPTOR YBOT) of LINE) + (ffetch (TEXTOBJ WBOTTOM) of TEXTOBJ))) - (* ;; "Only display the line of it contains text (CHAR1 > 0), appears before the end of the test, and is on-screen.") + (* ;; "Only display the line of it contains text (CHAR1 > 0), appears before the end of the test, and is on-screen.") - (COND - ((NEQ (fetch (THISLINE DESC) of THISLINE) - LINE) (* ; + (COND + ((NEQ (fetch (THISLINE DESC) of THISLINE) + LINE) (* ;  "No image cache -- re-format and display") - (\FORMATLINE TEXTOBJ NIL (fetch (LINEDESCRIPTOR CHAR1) of LINE) - LINE))) - (MOVETO (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE) - (fetch (LINEDESCRIPTOR DESCENT) of LINE) - DS) - (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DS)) - (SETQ DDPILOTBBT (ffetch DDPILOTBBT of DISPLAYDATA)) - (SETQ XOFFSET (fetch DDXOFFSET of DISPLAYDATA)) + (\FORMATLINE TEXTOBJ NIL (ffetch (LINEDESCRIPTOR CHAR1) of LINE) + LINE))) + (MOVETO (ffetch (LINEDESCRIPTOR LEFTMARGIN) of LINE) + (ffetch (LINEDESCRIPTOR DESCENT) of LINE) + DS) + (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DS)) + (SETQ DDPILOTBBT (ffetch DDPILOTBBT of DISPLAYDATA)) + (SETQ XOFFSET (fetch DDXOFFSET of DISPLAYDATA)) - (* ;; "The X position of the left edge of the window, since \TEDIT.BLTCHAR works on the screen bitmap itself.") + (* ;; "The X position of the left edge of the window, since \TEDIT.BLTCHAR works on the screen bitmap itself.") - (SETQ CLIPLEFT (fetch DDClippingLeft of DISPLAYDATA)) + (SETQ CLIPLEFT (fetch DDClippingLeft of DISPLAYDATA)) (* ;  "The left and right edges of the clipping region for the text display window.") - (SETQ CLIPRIGHT (fetch DDClippingRight of DISPLAYDATA)) - (SETQ OFONT (DSPFONT (fetch CLFONT of (SETQ OLOOKS (\EDITELT LOOKS 0))) - DS)) (* ; "The starting font") - (SETQ DDWIDTHCACHE (ffetch DDWIDTHSCACHE of DISPLAYDATA)) + (SETQ CLIPRIGHT (fetch DDClippingRight of DISPLAYDATA)) + (SETQ OFONT (DSPFONT (fetch CLFONT of (SETQ OLOOKS (\EDITELT LOOKS 0))) + DS)) (* ; "The starting font") + (SETQ DDWIDTHCACHE (ffetch DDWIDTHSCACHE of DISPLAYDATA)) (* ;  "Cache the character-image widths") - (SETQ DDOFFSETCACHE (ffetch DDOFFSETSCACHE of DISPLAYDATA)) + (SETQ DDOFFSETCACHE (ffetch DDOFFSETSCACHE of DISPLAYDATA)) (* ;  "And the offset-into-strike-bitmap array") - (SETQ LOOKSTARTX (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE)) (* ; - "Starting X position for the current-looks text.") - (AND (fetch CLOFFSET of OLOOKS) - (RELMOVETO 0 (FIXR (FTIMES SCALE (fetch CLOFFSET of OLOOKS))) - DS)) (* ; + "LOOKSTARTX: Starting X position for the current-looks text.") + (AND (fetch CLOFFSET of OLOOKS) + (RELMOVETO 0 (FIXR (FTIMES SCALE (fetch CLOFFSET of OLOOKS))) + DS)) (* ;  "Any sub- or superscripting at start of line") - (bind (LOOKNO _ 1) - DX - (TX _ (IPLUS XOFFSET (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE))) - for I from 0 to (fetch (THISLINE LEN) of THISLINE) - do + (bind (LOOKNO _ 1) + DX CH (CHLIST _ (fetch (THISLINE CHARS) of (ffetch (TEXTOBJ THISLINE) + of TEXTOBJ))) + (WLIST _ (fetch (THISLINE WIDTHS) of (ffetch (TEXTOBJ THISLINE) + of TEXTOBJ))) + (TX _ (IPLUS XOFFSET (ffetch (LINEDESCRIPTOR LEFTMARGIN) of LINE))) + (TERMSA _ (ffetch (TEXTOBJ TXTTERMSA) of TEXTOBJ)) + (LOOKSTARTX _ (ffetch (LINEDESCRIPTOR LEFTMARGIN) of LINE)) for + I + from 0 to (ffetch (THISLINE LEN) of THISLINE) + do - (* ;; "Display the line character by character") + (* ;; "Display the line character by character") - (SETQ CH (\EDITELT CHLIST I)) (* ; + (SETQ CH (\EDITELT CHLIST I)) (* ;  "Grab the character (or IMAGEOBJ) to display") - (SETQ DX (\EDITELT WLIST I)) (* ; "And its width") - [SELECTC CH - (LMInvisibleRun (* ; + (SETQ DX (\EDITELT WLIST I)) (* ; "And its width") + [SELECTC CH + (LMInvisibleRun (* ;  "An INVISIBLE run -- skip it, and skip over the char count") - (add LOOKNO 1)) - (LMLooksChange (* ; "A LOOKS change") - (replace DDXPOSITION of DISPLAYDATA - with (IDIFFERENCE TX XOFFSET)) + (add LOOKNO 1)) + (LMLooksChange (* ; "A LOOKS change") + (replace DDXPOSITION of DISPLAYDATA + with (IDIFFERENCE TX XOFFSET)) (* ;  "Make the displaystream reflect our current X position") - (TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS - (fetch (LINEDESCRIPTOR DESCENT) of LINE)) + (TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS + (ffetch (LINEDESCRIPTOR DESCENT) of LINE)) (* ;  "Make any necessary changes to the preceding characters (underline, strike-out &c)") - (DSPFONT (fetch CLFONT of (SETQ OLOOKS - (\EDITELT LOOKS LOOKNO)) - ) - DS) (* ; "Set the new font") - (add LOOKNO 1) (* ; "Grab the next set of char looks") - (AND (fetch CLOFFSET of OLOOKS) - (RELMOVETO 0 (fetch CLOFFSET of OLOOKS) - DS)) (* ; "Account for super/subscripting") - (SETQ LOOKSTARTX (IDIFFERENCE TX XOFFSET)) + (DSPFONT (fetch CLFONT of (SETQ OLOOKS + (\EDITELT LOOKS LOOKNO))) + DS) (* ; "Set the new font") + (add LOOKNO 1) (* ; "Grab the next set of char looks") + (AND (fetch CLOFFSET of OLOOKS) + (RELMOVETO 0 (fetch CLOFFSET of OLOOKS) + DS)) (* ; "Account for super/subscripting") + (SETQ LOOKSTARTX (IDIFFERENCE TX XOFFSET)) (* ;  "Remember the starting Xpos for possible later underlining &c") - ) - ((CHARCODE (TAB %#^I)) (* ; + ) + ((CHARCODE (TAB %#^I)) (* ;  "TAB: use the width from the cache to decide the right formatting.") - [COND - ((OR (IEQP CH (CHARCODE %#^I)) - (fetch CLLEADER of OLOOKS) - (EQ (fetch CLUSERINFO of OLOOKS) - 'DOTTEDLEADER)) - (LET* [[LEADERFONT (COND - (HARDCOPYMODE (FONTCOPY (fetch CLFONT - of OLOOKS) - 'DEVICE HCPYDS)) - (T (fetch CLFONT of OLOOKS] - (DOTWIDTH (CHARWIDTH (CHARCODE %.) - LEADERFONT)) - (TTX (IPLUS TX DOTWIDTH (IDIFFERENCE DOTWIDTH - (IREMAINDER TX DOTWIDTH] - (while (ILEQ TTX (IPLUS TX DX)) - do (COND - (HARDCOPYMODE - (MI-TEDIT.BLTCHAR (CHARCODE %.) - DS - (FIXR (FQUOTIENT (IDIFFERENCE TTX - DOTWIDTH) - SCALE)) - DISPLAYDATA DDPILOTBBT CLIPRIGHT)) - ((OR TERMSA HARDCOPYMODE) + [COND + ((OR (IEQP CH (CHARCODE %#^I)) + (fetch CLLEADER of OLOOKS) + (EQ (fetch CLUSERINFO of OLOOKS) + 'DOTTEDLEADER)) + (LET* [[LEADERFONT (COND + (HARDCOPYMODE (FONTCOPY (fetch CLFONT + of OLOOKS) + 'DEVICE HCPYDS)) + (T (fetch CLFONT of OLOOKS] + (DOTWIDTH (CHARWIDTH (CHARCODE %.) + LEADERFONT)) + (TTX (IPLUS TX DOTWIDTH (IDIFFERENCE DOTWIDTH + (IREMAINDER TX DOTWIDTH] + (while (ILEQ TTX (IPLUS TX DX)) + do (COND + (HARDCOPYMODE (MI-TEDIT.BLTCHAR + (CHARCODE %.) + DS + (FIXR (FQUOTIENT (IDIFFERENCE + TTX DOTWIDTH) + SCALE)) + DISPLAYDATA DDPILOTBBT CLIPRIGHT + )) + ((OR TERMSA HARDCOPYMODE) (* ;  "Using special instrns from TERMSA") - (\DSPPRINTCHAR DS (CHARCODE %.))) - (T (* ; "Native charcodes") - (MI-TEDIT.BLTCHAR (CHARCODE %.) - DS - (IDIFFERENCE TTX DOTWIDTH) - DISPLAYDATA DDPILOTBBT CLIPRIGHT))) - (add TTX DOTWIDTH]) - ((CHARCODE (EOL LF CR)) (* ; "It's a CR") - NIL) - (NIL (* ; "NIL signifies a character we've suppressed as part of line formatting (e.g., a discretionary hyphen we didn't use to break the line). Show it as a thin black line.") - (BLTSHADE BLACKSHADE DS TX 0 1 100 'PAINT)) - (COND - [(SMALLP CH) (* ; + (\DSPPRINTCHAR DS (CHARCODE %.))) + (T (* ; "Native charcodes") + (MI-TEDIT.BLTCHAR (CHARCODE %.) + DS + (IDIFFERENCE TTX DOTWIDTH) + DISPLAYDATA DDPILOTBBT CLIPRIGHT))) + (add TTX DOTWIDTH]) + ((CHARCODE (EOL LF CR)) (* ; "It's a CR") + NIL) + (NIL (* ; "NIL signifies a character we've suppressed as part of line formatting (e.g., a discretionary hyphen we didn't use to break the line). Show it as a thin black line.") + (BLTSHADE BLACKSHADE DS TX 0 1 100 'PAINT)) + (COND + [(SMALLP CH) (* ;  "Normal character -- just display it.") - (COND - (HARDCOPYMODE (MI-TEDIT.BLTCHAR CH DS (FIXR (FQUOTIENT TX SCALE)) - DISPLAYDATA DDPILOTBBT CLIPRIGHT)) - ((OR TERMSA HARDCOPYMODE) (* ; + (COND + (HARDCOPYMODE (MI-TEDIT.BLTCHAR CH DS (FIXR (FQUOTIENT TX SCALE)) + DISPLAYDATA DDPILOTBBT CLIPRIGHT)) + ((OR TERMSA HARDCOPYMODE) (* ;  "Using special instrns from TERMSA") - (\DSPPRINTCHAR DS CH)) - (T (* ; "Native charcodes") - (MI-TEDIT.BLTCHAR CH DS TX DISPLAYDATA DDPILOTBBT CLIPRIGHT] - (T (* ; "CH is an object.") - (MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) - XOFFSET) - (SETQ CURY (DSPYPOSITION NIL DS)) - DS) (* ; + (\DSPPRINTCHAR DS CH)) + (T (* ; "Native charcodes") + (MI-TEDIT.BLTCHAR CH DS TX DISPLAYDATA DDPILOTBBT CLIPRIGHT] + (T (* ; "CH is an object.") + (MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) + XOFFSET) + (SETQ CURY (DSPYPOSITION NIL DS)) + DS) (* ;  "Go to the base line, left edge of the image region.") - (APPLY* (IMAGEOBJPROP CH 'DISPLAYFN) - CH DS 'DISPLAY (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ - )) + (APPLY* (IMAGEOBJPROP CH 'DISPLAYFN) + CH DS 'DISPLAY (ffetch (TEXTOBJ STREAMHINT) of TEXTOBJ + )) (* ;  "Tell him to display himself here.") - (DSPFONT (fetch CLFONT of OLOOKS) - DS) - (MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) - XOFFSET) - CURY DS) (* ; + (DSPFONT (fetch CLFONT of OLOOKS) + DS) + (MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) + XOFFSET) + CURY DS) (* ;  "Move to after the object's image") - ] - (add TX DX) (* ; "Update our X position") - finally (replace DDXPOSITION of DISPLAYDATA - with (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) - XOFFSET)) (* ; + ] + (add TX DX) (* ; "Update our X position") + finally (replace DDXPOSITION of DISPLAYDATA + with (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) + XOFFSET)) (* ;  "Make any necessary looks mods to the last run of characters") - (TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS (fetch (LINEDESCRIPTOR + (TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS (ffetch (LINEDESCRIPTOR DESCENT) - of LINE] - (BITBLT CACHE 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBOT) of LINE) - (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) - LHEIGHT - 'INPUT - 'REPLACE) (* ; + of LINE] + (BITBLT CACHE 0 0 WINDOWDS 0 (ffetch (LINEDESCRIPTOR YBOT) of LINE) + (ffetch (TEXTOBJ WRIGHT) of TEXTOBJ) + LHEIGHT + 'INPUT + 'REPLACE) (* ;  "Paint the cached image on the screen (this lessens flicker during update)") - (COND - ((fetch (FMTSPEC FMTREVISED) of (fetch (LINEDESCRIPTOR LFMTSPEC) - of LINE)) + (COND + ((fetch (FMTSPEC FMTREVISED) of (ffetch (LINEDESCRIPTOR LFMTSPEC) + of LINE)) (* ;  "This paragraph has been revised, so mark it.") - (\TEDIT.MARK.REVISION TEXTOBJ (fetch (LINEDESCRIPTOR LFMTSPEC) of LINE) - WINDOWDS LINE))) - (SELECTQ (fetch (LINEDESCRIPTOR LMARK) of LINE) - (GREY (* ; + (\TEDIT.MARK.REVISION TEXTOBJ (ffetch (LINEDESCRIPTOR LFMTSPEC) of LINE) + WINDOWDS LINE))) + (SELECTQ (ffetch (LINEDESCRIPTOR LMARK) of LINE) + (GREY (* ;  "This line has some property that isn't visible to the user. Tell him to be careful") - (BITBLT NIL 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBASE) of LINE) - 6 6 'TEXTURE 'PAINT 42405)) - (SOLID (* ; + (BITBLT NIL 0 0 WINDOWDS 0 (ffetch (LINEDESCRIPTOR YBASE) of LINE) + 6 6 'TEXTURE 'PAINT 42405)) + (SOLID (* ;  "This line has some property that isn't visible to the user. Tell him to be careful") - (BITBLT NIL 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBASE) of LINE) - 6 6 'TEXTURE 'PAINT BLACKSHADE)) - (BITBLT NIL 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBASE) of LINE) - 6 6 'TEXTURE 'REPLACE WHITESHADE]) + (BITBLT NIL 0 0 WINDOWDS 0 (ffetch (LINEDESCRIPTOR YBASE) of LINE) + 6 6 'TEXTURE 'PAINT BLACKSHADE)) + (BITBLT NIL 0 0 WINDOWDS 0 (ffetch (LINEDESCRIPTOR YBASE) of LINE) + 6 6 'TEXTURE 'REPLACE WHITESHADE]) (\TEDIT.LINECACHE (LAMBDA (CACHE WIDTH HEIGHT) (* jds "21-Apr-84 00:52") @@ -2991,16 +2988,16 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation. (PUTPROPS TEDITSCREEN COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2874 76866 (\FORMATLINE 2884 . 56612) (\TEDIT.NSCHAR.RUN 56614 . 63431) ( -\TEDIT.PURGE.SPACES 63433 . 63891) (\DOFORMATTING 63893 . 76864)) (76867 98847 (\DISPLAYLINE 76877 . -94847) (\TEDIT.LINECACHE 94849 . 95600) (\TEDIT.CREATE.LINECACHE 95602 . 96346) (\TEDIT.BLTCHAR 96348 - . 98845)) (99561 214016 (TEDIT.CR.UPDATESCREEN 99571 . 100822) (TEDIT.DELETELINE 100824 . 101858) ( -TEDIT.INSERT.DISPLAYTEXT 101860 . 117099) (TEDIT.INSERT.UPDATESCREEN 117101 . 123853) ( -TEDIT.UPDATE.SCREEN 123855 . 125073) (\BACKFORMAT 125075 . 129386) (\FILLWINDOW 129388 . 144492) ( -\FIXDLINES 144494 . 151731) (\FIXILINES 151733 . 159708) (\SHOWTEXT 159710 . 162966) ( -\TEDIT.ADJUST.LINES 162968 . 170435) (\TEDIT.CLEAR.SCREEN.BELOW.LINE 170437 . 171167) ( -\TEDIT.CLOSEUPLINES 171169 . 179685) (\TEDIT.COPY.LINEDESCRIPTOR 179687 . 185253) ( -\TEDIT.FIXCHANGEDLINE 185255 . 196434) (\TEDIT.FIXCHANGEDPART 196436 . 208863) (\TEDIT.INSERTLINE -208865 . 209685) (\TEDIT.LINE.LIST 209687 . 210013) (\TEDIT.MARK.LINES.DIRTY 210015 . 211701) ( -\TEDIT.NEXT.LINE.BOTTOM 211703 . 214014))))) + (FILEMAP (NIL (2767 76759 (\FORMATLINE 2777 . 56505) (\TEDIT.NSCHAR.RUN 56507 . 63324) ( +\TEDIT.PURGE.SPACES 63326 . 63784) (\DOFORMATTING 63786 . 76757)) (76760 98628 (\DISPLAYLINE 76770 . +94628) (\TEDIT.LINECACHE 94630 . 95381) (\TEDIT.CREATE.LINECACHE 95383 . 96127) (\TEDIT.BLTCHAR 96129 + . 98626)) (99342 213797 (TEDIT.CR.UPDATESCREEN 99352 . 100603) (TEDIT.DELETELINE 100605 . 101639) ( +TEDIT.INSERT.DISPLAYTEXT 101641 . 116880) (TEDIT.INSERT.UPDATESCREEN 116882 . 123634) ( +TEDIT.UPDATE.SCREEN 123636 . 124854) (\BACKFORMAT 124856 . 129167) (\FILLWINDOW 129169 . 144273) ( +\FIXDLINES 144275 . 151512) (\FIXILINES 151514 . 159489) (\SHOWTEXT 159491 . 162747) ( +\TEDIT.ADJUST.LINES 162749 . 170216) (\TEDIT.CLEAR.SCREEN.BELOW.LINE 170218 . 170948) ( +\TEDIT.CLOSEUPLINES 170950 . 179466) (\TEDIT.COPY.LINEDESCRIPTOR 179468 . 185034) ( +\TEDIT.FIXCHANGEDLINE 185036 . 196215) (\TEDIT.FIXCHANGEDPART 196217 . 208644) (\TEDIT.INSERTLINE +208646 . 209466) (\TEDIT.LINE.LIST 209468 . 209794) (\TEDIT.MARK.LINES.DIRTY 209796 . 211482) ( +\TEDIT.NEXT.LINE.BOTTOM 211484 . 213795))))) STOP diff --git a/library/TEDITSCREEN.LCOM b/library/TEDITSCREEN.LCOM index 55c75801fc38d1321b3fc56a92e56e7f6cdcc2ab..da9f570104616b9dbdf5c8d01770fa460c3d23fa 100644 GIT binary patch delta 3464 zcma)9&2JmW6(=cKbr{RlmsLY?jj^m4wBWG&{UNw1SKOtz)^caDySBtuz# zNe)4PVvAndTngJl(Iz<*4d5m~E~eC+iQck3lLZ+#18LiSmQ)og2z^ zSd&Llx{Nxny#veNVM1V* zum3+Wyw|v-AdVG8Rz|Pyy|(|x?%U{{H(y>um4@x1^25^Q1Ect}qI~pT$-WWtBJ%xh zv&7| z%Al8&@_^|qgis9zD!J|B^;_4`nNL>=g^Ai!0X`c2twl<7cK!3IS~ORDfrz65h>|6n zK8eJsMXnZADF2VjOn109oc+&**_lNxx_r0E~pGTxbp0;16=uy7KP`6 z75k5StuitF>$}0VT4dWFY0(tE_HXJAbf)mii)1-C-`N}+6{*f`;!;(>Y0fT@hWu){8=qptVN|~5Bn3( zA?jLGc~0nOw~}Gg1Cjr+l zeY#(~KRnz|lEeyLI9`By;F}hngOW_2q4i1A!`zqf9ZxbO1&qz*lAG^lsU=BK+riC# zNrE7HFAP8F^xhwS+%Hb`-aqaRk5HDNlPqV8 zS9(>vPA6-&xD4*}r&uSCua2M27O%qlsNh$h!Wa~OZy(+~OA?FiAO5gcwP0C4PDd6m z;Y;}9uQsM0Z=GIxtm3u5*dJKED)sbO3iFmOWa^oP#c|Oz4R=7?Jqa59ll}Sm`F`=` z-ZYGH@iMOU%7nN;YD7il&zJU3PAsf+@Al&NVETI`^nPJ@rucEc@Y~Qn)bk;{glnMv ztxWobzkkO<98JIQh$Qu)g=;jae&G)}i+_&yWeL5T<6%GP|Kr`9$A#m)WcHWS*4JpE zsqNqf453B&T2$>#;v3&TpUq7ndGW`r;mi#5?@6ExFaxv8^q;>-rxyH=segNX=gA>r zcIi2=f>)?-`ZG-&n(_goI#0qe4jW}Lb@*Lc_JAfcezuMB=&8lnM zF+CI8h~-&6r^hMW!4-8rWI2gN4RhOt%L}g27QSQn7-&{Zr3|@m9C|~stfU~brEM5+ ze>g6N8;=#mY!fTUM78Z;&-AHJmX{MVESJRvIn?2HLoB0+A!@;m2iKP0b_|fnGTH$X zaE02b62zAzG}7)C*k2E8O?PR=U=@~~y_6=flBUIqxO!@CA0kYUtEer1*+$QP;`BVHs!Ax6uR$^l5sqLc(7&rw{Q zW*{+YZcS7?J+mMLI4MRPudsPe zW>V9<2vd`-ulsOTXFqqTqlxwk0Fpy(}u`_1eONl``x zLi5i*|NQTn{pPcWV}Ji(>|uE!RdOp%!FTM?DUtnXx>UqO@boaVq zT)>(#w5H}&Bd=-;Wb&NSJ^I(F{E&D$on9b~*B?OU zd1|r?7bb`OX#Xv_{+dBF)yU`;xwZNFz1tgalLv2}&y!TuF8DMclU4T;Ja)tMawRO3 zZT|vEUAO&!aAtsjoLYfa1F%cAfUH+-ca^4#Zs1kywTfGFNc)e;v-6V+x^l_B|CWf@ z$QxQ-H5W+x-^oH!-OMO=QBNJ-(c4n3~rPEKRXJ5r>EdJ;H&Y?+H7^kIA z@!L)OVP%9-uXM|ed&x(=Uv+8u?vr}CGxq0u$%nn|ABfoK3SHcrMNTM6MN={*(bQp{ zDj6Lue~RD17=_lMcxIdZX!?0&HtMH3V{W<8da?K0M(e%a<4*FG)_Z%+-VTxSM|Vz0 zax&r_0;#c+XvlfVj~j>1@p}EN&z(+wqm`yL-ip)76k_t8QjZOv?LD1NUZ6hc%2RYk z;+If&1->_?QLa;wapDS zKufITEKB@biXSZi&W;#iwHHB_ZUMROFF-FOA$Q9?D{P^^}XV2i{O7m_j zK0Z?~umC!VFApalcM?BGNX20%PM4YVa5&tNPU5f6S%|&qB(`K+WfoQh?Y|k;ITLS{ zL3I*88Dhjbw%!;ry12I~k3m-UL7AtVXRW^6#eP1QS7B?MF2C}!=p>wfd5pUIw9>vd zR?;W+l`buzuS=aT|2ybtace!dv*X5|VV6;*DcW6L9$%+rXjPS5g?)cL{>4`#9nx;qzUt8B6%WlzRNb)pyL8|i$gX)ba6|5b z4i{qWIskxhQ=l?{$c#pS*~)-i;hN`wVL=EQfKF;0xq)Q>V@Na?NhUy3tX5MML8;l? zer0M#B`_6~0mO)^D!?aFk5HqSnf+T7QyI0d=(;eVC}tFsITT>n?;P+R!#Xki%c&U- zkQkmJS>QU~sffI0azJAunHdY%@jyK+T^o|OfaZ9drUe8Uco8py!6Jaz4{*(QuCiijIh}EfP7t~^o7Ydv^pnrj z7gjm$)ZjVyN&`6UTd*{;?$&~9z7s<&z;@Nj=!gcex_}B;h=Cz8NMK^N&%HY{Z|KCc zQEM=Okq4`7^6qSejtOYREn-nIq@0<{4dhH@f;k4C3%=`x6m4u~41$o>Kv{sehy|h{oq)pqI80z$x8_}AXAe!qoW^OunaO1js5X$mQFDfoMU%y^ z4UWlGJ;&gu?TaI+XE=0?Vzs)JlL#KC4P_KtOE}@IKK%89{zhv_5=|kps-P+{H;3ad zC^Xf;S`G)Oh${mX$|-mn^xeotS)67XqDSMm49TMHht}cO& Date: Wed, 29 Sep 2021 22:26:11 -0700 Subject: [PATCH 3/8] HARDCOPY: COPY.TEXT.TO.IMAGE had Unicode-incompatible end-of-file shortcut Also used byte and not character-code operation in CRLF check --- sources/HARDCOPY | 121 ++++++++++++++++++++++-------------------- sources/HARDCOPY.LCOM | Bin 47349 -> 47390 bytes 2 files changed, 63 insertions(+), 58 deletions(-) diff --git a/sources/HARDCOPY b/sources/HARDCOPY index 145f90bb..83214787 100644 --- a/sources/HARDCOPY +++ b/sources/HARDCOPY @@ -1,11 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "20-Sep-2021 10:59:58"  -{DSK}kaplan>Local>medley3.5>git-medley>sources>HARDCOPY.;2 103730 - changes to%: (VARS HARDCOPYCOMS) +(FILECREATED "29-Sep-2021 08:53:30"  +{DSK}kaplan>Local>medley3.5>git-medley>sources>HARDCOPY.;5 103898 - previous date%: " 5-May-2021 19:41:55" -{DSK}kaplan>Local>medley3.5>git-medley>sources>HARDCOPY.;1) + changes to%: (FNS COPY.TEXT.TO.IMAGE) + + previous date%: "20-Sep-2021 10:59:58" +{DSK}kaplan>Local>medley3.5>git-medley>sources>HARDCOPY.;3) (* ; " @@ -722,10 +723,10 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. (CLOSEF IMAGESTREAM])]) (COPY.TEXT.TO.IMAGE - [LAMBDA (INFILE IMAGESTREAM FONTS TABS) (* ; "Edited 5-May-2021 19:41 by rmk:") - (* ; "Edited 10-Apr-95 21:23 by rmk:") + [LAMBDA (INFILE IMAGESTREAM FONTS TABS) (* ; "Edited 29-Sep-2021 08:53 by rmk:") + (* ; "Edited 10-Apr-95 21:23 by rmk:") - (* ;; "Copy text to an image stream, obeying PSPOOL control characters") + (* ;; "Copy text to an image stream, obeying PSPOOL control characters") (LET* ((IMAGESTREAM (GETSTREAM IMAGESTREAM 'OUTPUT)) @@ -734,15 +735,19 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. (MAXFONT (ARRAYSIZE FONTARRAY)) (INSTRM (GETSTREAM INFILE 'INPUT)) DEFAULTTAB C FC) - (replace (STREAM ENDOFSTREAMOP) of INSTRM with (FUNCTION ZERO)) + + (* ;; + "RMK: EOS function is NILL, not ZERO. 0 in low-order bits is OK in UNICODE, when we switch") + + (replace (STREAM ENDOFSTREAMOP) of INSTRM with (FUNCTION NILL)) (do (COND - ((AND [EQ 0 (LOGAND 255 (SETQ C (\INCCODE INSTRM] - (EOFP INSTRM)) + ((NULL (SETQ C (\INCCODE INSTRM))) + (replace (STREAM ENDOFSTREAMOP) of INSTRM with NIL) (RETURN)) ((AND RIGHTMAR (> (DSPXPOSITION NIL IMAGESTREAM) - RIGHTMAR)) (* ; - "Not to walk off the right edge of the paper") + RIGHTMAR)) (* ; + "Not to walk off the right edge of the paper") (TERPRI IMAGESTREAM))) (COND ([> C (CONSTANT (APPLY (FUNCTION MAX) @@ -750,16 +755,16 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. (\OUTCHAR IMAGESTREAM C)) (T (SELCHARQ C - (^F (* ; "Font shift") + (^F (* ; "Font shift") - (* ;; - "For FX-XP-9 printer:SETXY interpress command to avoid printer's BUG(Take)") + (* ;; + "For FX-XP-9 printer:SETXY interpress command to avoid printer's BUG(Take)") (DSPXPOSITION (IPLUS (DSPXPOSITION NIL IMAGESTREAM) 1) IMAGESTREAM) [SELCHARQ (SETQ FC (\INCCODE INSTRM)) - (^T (* ; "tab to absolute pos.") + (^T (* ; "tab to absolute pos.") (COND ((EQ 0 (SETQ FC (\INCCODE INSTRM))) (\OUTCHAR IMAGESTREAM (CHARCODE ^F)) @@ -769,7 +774,7 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. (\OUTCHAR IMAGESTREAM FC)) (T - (* ;; "TEXTDEFAULTTABS is a hack, since it depends on the units of the stream. Should really be a property of the stream or imagetype, or defined in terms of standard scale") + (* ;; "TEXTDEFAULTTABS is a hack, since it depends on the units of the stream. Should really be a property of the stream or imagetype, or defined in terms of standard scale") [SETQ FC (IF TABS @@ -787,7 +792,7 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. (NULL (\OUTCHAR IMAGESTREAM (CHARCODE ^F)) (AND (\EOFP INSTRM) (RETURN)) - (\OUTCHAR IMAGESTREAM FC) (* ; "EOS after ^F") + (\OUTCHAR IMAGESTREAM FC) (* ; "EOS after ^F") ) (COND ((AND (>= MAXFONT FC) @@ -797,13 +802,13 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. (T (\OUTCHAR IMAGESTREAM (CHARCODE ^F)) (\OUTCHAR IMAGESTREAM C]) (CR - (* ;; "Assumes that CR and possibly following LF denote a single EOL, independent of the EOL convention and independent of whether the file was opened binary or text. Originally, this function tried to discriminate, treating an LF in a CR-mode file as a line-feed and a CR in an LF file as a carriage-return. But these formatting effects cannot be guaranteed across text-file transfers (which is all that it makes sense to print), so it is silly to take them seriously. Given that just this information can be lost in text-mode file transfers, we make adopt here the 99%% correct solution, which is to treat all instances of CR, CRLF, and LF as end-of-line.") + (* ;; "Assumes that CR and possibly following LF denote a single EOL, independent of the EOL convention and independent of whether the file was opened binary or text. Originally, this function tried to discriminate, treating an LF in a CR-mode file as a line-feed and a CR in an LF file as a carriage-return. But these formatting effects cannot be guaranteed across text-file transfers (which is all that it makes sense to print), so it is silly to take them seriously. Given that just this information can be lost in text-mode file transfers, we make adopt here the 99%% correct solution, which is to treat all instances of CR, CRLF, and LF as end-of-line.") (TERPRI IMAGESTREAM) (COND ((EQ (CHARCODE LF) - (\PEEKBIN INSTRM T)) - (BIN INSTRM)))) + (\PEEKCCODE.NOEOLC INSTRM T)) + (\INCCODE INSTRM)))) (TAB (OR (LET* [(LEFTMARGIN (DSPLEFTMARGIN NIL IMAGESTREAM)) (TAB.WIDTH (TIMES (CHARWIDTH (CHARCODE SPACE) IMAGESTREAM) @@ -815,7 +820,7 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. CURRENT.X) 0 IMAGESTREAM))) (\OUTCHAR IMAGESTREAM C))) - (LF (* ; "See comment at CR") + (LF (* ; "See comment at CR") (TERPRI IMAGESTREAM)) (NULL (AND (EOFP INSTRM) (RETURN)) @@ -1088,39 +1093,39 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. (PUTPROPS HARDCOPY COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1999 2018 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (6176 10360 (HARDCOPY.SOMEHOW 6186 . 7544) (HARDCOPYIMAGEW 7546 . 7698) ( -HARDCOPYIMAGEW.TOFILE 7700 . 8008) (HARDCOPYIMAGEW.TOPRINTER 8010 . 8675) (HARDCOPYREGION.TOFILE 8677 - . 8975) (HARDCOPYREGION.TOPRINTER 8977 . 9599) (COPY.WINDOW.TO.BITMAP 9601 . 10358)) (10432 20982 ( -MakeMenuOfPrinters 10442 . 11667) (PRINTERS.WHENSELECTEDFN 11669 . 13411) (MakeMenuOfImageTypes 13413 - . 13931) (GetNewPrinterFromUser 13933 . 14361) (PopUpWindowAndGetAtom 14363 . 15748) ( -PopUpWindowAndGetList 15750 . 17316) (NewPrinter 17318 . 18266) (GetPrinterName 18268 . 18548) ( -GetImageFile 18550 . 20837) (FetchDefaultPrinter 20839 . 20980)) (21017 21555 ( -ExtensionForPrintFileType 21027 . 21220) (PRINTFILETYPE.FROM.EXTENSION 21222 . 21553)) (21610 37994 ( -DEFAULTPRINTER 21620 . 21780) (CAN.PRINT.DIRECTLY 21782 . 21938) (CONVERT.FILE.TO.TYPE.FOR.PRINTER -21940 . 22984) (EMPRESS 22986 . 23299) (HARDCOPYW 23301 . 26261) (LISTFILES1 26263 . 26436) ( -PRINTER.BITMAPFILE 26438 . 26685) (PRINTER.BITMAPSCALE 26687 . 26952) (PRINTER.SCRATCH.FILE 26954 . -27077) (PRINTERPROP 27079 . 27262) (PRINTERSTATUS 27264 . 27453) (PRINTERTYPE 27455 . 29764) ( -PRINTERNAME 29766 . 30068) (PRINTFILEPROP 30070 . 30261) (PRINTFILETYPE 30263 . 32207) ( -\EXPECTED.FILE.TYPE 32209 . 32991) (SEND.FILE.TO.PRINTER 32993 . 37992)) (37995 42977 (PRINTERDEVICE -38005 . 42975)) (43792 51993 (TEXTTOIMAGEFILE 43802 . 45992) (COPY.TEXT.TO.IMAGE 45994 . 51991)) ( -51994 53129 (\BLTSHADE.GENERICPRINTER 52004 . 53127)) (53257 72009 (MAKEHARDCOPYSTREAM 53267 . 54271) -(UNMAKEHARDCOPYSTREAM 54273 . 54957) (HARDCOPYSTREAMTYPE 54959 . 55238) (\CHARWIDTH.HDCPYDISPLAY 55240 - . 55671) (\DSPFONT.HDCPYDISPLAY 55673 . 57078) (\DSPRIGHTMARGIN.HDCPYDISPLAY 57080 . 57657) ( -\DSPXPOSITION.HDCPYDISPLAY 57659 . 57920) (\DSPYPOSITION.HDCPYDISPLAY 57922 . 58183) ( -\STRINGWIDTH.HDCPYDISPLAY 58185 . 58692) (\STRINGWIDTH.HCPYDISPLAYAUX 58694 . 61026) (\HDCPYBLTCHAR -61028 . 63563) (\HDCPYDISPLAY.FIX.XPOS 63565 . 63985) (\HDCPYDISPLAY.FIX.YPOS 63987 . 64407) ( -\HDCPYDISPLAYINIT 64409 . 65186) (\HDCPYDSPPRINTCHAR 65188 . 67348) (\SLOWHDCPYBLTCHAR 67350 . 70853) -(\CHANGECHARSET.HDCPYDISPLAY 70855 . 72007)) (72731 103028 (MAKEHARDCOPYMODESTREAM 72741 . 74650) ( -UNMAKEHARDCOPYMODESTREAM 74652 . 75730) (\BLTSHADE.HCPYMODE 75732 . 76179) (\BITBLT.HCPYMODE 76181 . -76803) (\BRUSHCONVERT.HCPYMODE 76805 . 77042) (\CHANGECHARSET.HCPYMODE 77044 . 78811) ( -\DASHINGCONVERT.HCPYMODE 78813 . 79076) (\CHARWIDTH.HCPYMODE 79078 . 79365) (\DRAWLINE.HCPYMODE 79367 - . 79679) (\DRAWCURVE.HCPYMODE 79681 . 80110) (\DRAWCIRCLE.HCPYMODE 80112 . 80507) ( -\DRAWELLIPSE.HCPYMODE 80509 . 81021) (\DSPFONT.HCPYMODE 81023 . 82179) (\DSPLEFTMARGIN.HCPYMODE 82181 - . 82765) (\DSPLINEFEED.HCPYMODE 82767 . 83177) (\DSPRIGHTMARGIN.HCPYMODE 83179 . 83808) ( -\DSPSPACEFACTOR.HCPYMODE 83810 . 84331) (\DSPXPOSITION.HCPYMODE 84333 . 84914) (\DSPYPOSITION.HCPYMODE - 84916 . 85321) (\MOVETO.HCPYMODE 85323 . 85475) (\FONTCREATE.HCPYMODE.PRESS 85477 . 86489) ( -\CREATECHARSET.HCPYMODE.PRESS 86491 . 87462) (\FONTCREATE.HCPYMODE.INTERPRESS 87464 . 88498) ( -\CREATECHARSET.HCPYMODE.INTERPRESS 88500 . 89488) (\STRINGWIDTH.HCPYMODE 89490 . 89924) ( -\HCPYMODEBLTCHAR 89926 . 92895) (\HCPYMODEDISPLAYINIT 92897 . 95828) (\HCPYMODEDSPPRINTCHAR 95830 . -98011) (\SLOWHCPYMODEBLTCHAR 98013 . 101527) (\SFFixY.HCPYMODE 101529 . 103026))))) + (FILEMAP (NIL (6182 10366 (HARDCOPY.SOMEHOW 6192 . 7550) (HARDCOPYIMAGEW 7552 . 7704) ( +HARDCOPYIMAGEW.TOFILE 7706 . 8014) (HARDCOPYIMAGEW.TOPRINTER 8016 . 8681) (HARDCOPYREGION.TOFILE 8683 + . 8981) (HARDCOPYREGION.TOPRINTER 8983 . 9605) (COPY.WINDOW.TO.BITMAP 9607 . 10364)) (10438 20988 ( +MakeMenuOfPrinters 10448 . 11673) (PRINTERS.WHENSELECTEDFN 11675 . 13417) (MakeMenuOfImageTypes 13419 + . 13937) (GetNewPrinterFromUser 13939 . 14367) (PopUpWindowAndGetAtom 14369 . 15754) ( +PopUpWindowAndGetList 15756 . 17322) (NewPrinter 17324 . 18272) (GetPrinterName 18274 . 18554) ( +GetImageFile 18556 . 20843) (FetchDefaultPrinter 20845 . 20986)) (21023 21561 ( +ExtensionForPrintFileType 21033 . 21226) (PRINTFILETYPE.FROM.EXTENSION 21228 . 21559)) (21616 38000 ( +DEFAULTPRINTER 21626 . 21786) (CAN.PRINT.DIRECTLY 21788 . 21944) (CONVERT.FILE.TO.TYPE.FOR.PRINTER +21946 . 22990) (EMPRESS 22992 . 23305) (HARDCOPYW 23307 . 26267) (LISTFILES1 26269 . 26442) ( +PRINTER.BITMAPFILE 26444 . 26691) (PRINTER.BITMAPSCALE 26693 . 26958) (PRINTER.SCRATCH.FILE 26960 . +27083) (PRINTERPROP 27085 . 27268) (PRINTERSTATUS 27270 . 27459) (PRINTERTYPE 27461 . 29770) ( +PRINTERNAME 29772 . 30074) (PRINTFILEPROP 30076 . 30267) (PRINTFILETYPE 30269 . 32213) ( +\EXPECTED.FILE.TYPE 32215 . 32997) (SEND.FILE.TO.PRINTER 32999 . 37998)) (38001 42983 (PRINTERDEVICE +38011 . 42981)) (43798 52161 (TEXTTOIMAGEFILE 43808 . 45998) (COPY.TEXT.TO.IMAGE 46000 . 52159)) ( +52162 53297 (\BLTSHADE.GENERICPRINTER 52172 . 53295)) (53425 72177 (MAKEHARDCOPYSTREAM 53435 . 54439) +(UNMAKEHARDCOPYSTREAM 54441 . 55125) (HARDCOPYSTREAMTYPE 55127 . 55406) (\CHARWIDTH.HDCPYDISPLAY 55408 + . 55839) (\DSPFONT.HDCPYDISPLAY 55841 . 57246) (\DSPRIGHTMARGIN.HDCPYDISPLAY 57248 . 57825) ( +\DSPXPOSITION.HDCPYDISPLAY 57827 . 58088) (\DSPYPOSITION.HDCPYDISPLAY 58090 . 58351) ( +\STRINGWIDTH.HDCPYDISPLAY 58353 . 58860) (\STRINGWIDTH.HCPYDISPLAYAUX 58862 . 61194) (\HDCPYBLTCHAR +61196 . 63731) (\HDCPYDISPLAY.FIX.XPOS 63733 . 64153) (\HDCPYDISPLAY.FIX.YPOS 64155 . 64575) ( +\HDCPYDISPLAYINIT 64577 . 65354) (\HDCPYDSPPRINTCHAR 65356 . 67516) (\SLOWHDCPYBLTCHAR 67518 . 71021) +(\CHANGECHARSET.HDCPYDISPLAY 71023 . 72175)) (72899 103196 (MAKEHARDCOPYMODESTREAM 72909 . 74818) ( +UNMAKEHARDCOPYMODESTREAM 74820 . 75898) (\BLTSHADE.HCPYMODE 75900 . 76347) (\BITBLT.HCPYMODE 76349 . +76971) (\BRUSHCONVERT.HCPYMODE 76973 . 77210) (\CHANGECHARSET.HCPYMODE 77212 . 78979) ( +\DASHINGCONVERT.HCPYMODE 78981 . 79244) (\CHARWIDTH.HCPYMODE 79246 . 79533) (\DRAWLINE.HCPYMODE 79535 + . 79847) (\DRAWCURVE.HCPYMODE 79849 . 80278) (\DRAWCIRCLE.HCPYMODE 80280 . 80675) ( +\DRAWELLIPSE.HCPYMODE 80677 . 81189) (\DSPFONT.HCPYMODE 81191 . 82347) (\DSPLEFTMARGIN.HCPYMODE 82349 + . 82933) (\DSPLINEFEED.HCPYMODE 82935 . 83345) (\DSPRIGHTMARGIN.HCPYMODE 83347 . 83976) ( +\DSPSPACEFACTOR.HCPYMODE 83978 . 84499) (\DSPXPOSITION.HCPYMODE 84501 . 85082) (\DSPYPOSITION.HCPYMODE + 85084 . 85489) (\MOVETO.HCPYMODE 85491 . 85643) (\FONTCREATE.HCPYMODE.PRESS 85645 . 86657) ( +\CREATECHARSET.HCPYMODE.PRESS 86659 . 87630) (\FONTCREATE.HCPYMODE.INTERPRESS 87632 . 88666) ( +\CREATECHARSET.HCPYMODE.INTERPRESS 88668 . 89656) (\STRINGWIDTH.HCPYMODE 89658 . 90092) ( +\HCPYMODEBLTCHAR 90094 . 93063) (\HCPYMODEDISPLAYINIT 93065 . 95996) (\HCPYMODEDSPPRINTCHAR 95998 . +98179) (\SLOWHCPYMODEBLTCHAR 98181 . 101695) (\SFFixY.HCPYMODE 101697 . 103194))))) STOP diff --git a/sources/HARDCOPY.LCOM b/sources/HARDCOPY.LCOM index 27e0ec8543a0c72c8fd37e23bf92631da407fefd..8d8981f4c6d0dbeb74a70275878793104595b0f8 100644 GIT binary patch delta 1099 zcma)5zi-n(6s}uTz)}YU6d_df2tSk{Ql0O7j%~pZoJ(wav5oDPB9);u5lu_r3SN_ujpq--loS7~Zrm z%gMaMnH8{X#Bz|pMmj9l(imX{kZw|96124x7HLY@GJTt3m_#v&nt+FE<%QMdTBTYp zfn0u8TU)|;hB(ig5 zcszGXPGSnC>jlLu7pzipJeA)Y!zcqj=#WJiY4Q2ON2wC;7kv309~}~B@yzx3mVHh7 z6qoE}=|TL(M$(OV#NpD{*movw?%CB*xeeU4-R|9Jy?0C1vF3JS*FM>?@Jh#0m78xG ztxeulHd@c)w@$eZeZRB9Pj0^IxiwnHmYUn=y7-rk*6~B+uW$Y5{!mg=6qxg-Bg@VP zpdr*3sBQrB@;=ZEg@^@y-~gri0AQHl_{E(Ibp--e%sOt41)%B_a-l!#d!Z9Ko(pOQ zLp%6ACl}eEYD(M8Sw1RegMuUMDup@6wJa~kKqVOFe8#3a;-u>_k6WN(wMRfjTAu(B z^A_CeUGhZN+M)BF8v)S~FfML72v>{&UqpcgffoQa5V(RG&KO6TV@)4mjx_@9*xl6t zOi3pLCaB(zsu*NI(A5DUBU;-lQxVR6LGAGFcT6GrQ6h?1zQY+Qq5}uhFftw7iC(Yc zi+pB5PEz52@Ku2-2tvm+T^_RNZrTq#i?LkV%7zRG5f$aw3=phA7>SiHLic7t0ho^)aritVmo3Wjh))mzi`|FRaL39QJXeRqO>4b z$jF35@q&D2nLL@OwBT7ceB_eX%Mj*=Lm^%R2AV)qqI`ns+TLJRY;WX z*BjfHvQVw2)hrjc?1#| zQJErGSzoTMm9}B0#_Ol%bAAzwoUi3w?{?m`i)pAgO83gOyW73e93ujow3i?J?N!Z6 zILlagAmjzS&xS{}v&j@;kab+&&RJny9}BC6H%TlZ@IZka!c+~f%zO~m!-E+wS^52S zqw~xb`bXE6L8@ z#kSECXj|o8rjqEqYIPr5&~9}fg>TJLb0X%9a!#W2yiaL$Pi}Pf#tt1kZFSEaA%A^~ zmtTfb8H`}joeT1OJit_SAW#(0-GT>9mLSl5&o_ZFc>pj>arol;`6dEiw{xbW={`t` z1X|I%<+(*OFkJ^E8ABv~)6@b3qzsDEmR<<#oIhjoJY}%x>H6$+6cD*zN)H5E>221$35lo~bS^nbG{xC4=jV)&Kg1xih zN3$4CTQ^3MDMsb~{RD>8@FyMjDdnwb`aDpgLNVa)+6KZ;ythXX?eFo97j)l+4DRnp kGMJ7x7XSl(JNP1 From 1d8fa0301d688ad07864a9d1e60c72e141292c46 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Wed, 29 Sep 2021 22:27:18 -0700 Subject: [PATCH 4/8] TEDIT: TEDIT-SEE treats FORMAT better for plain-text files --- library/TEDIT | 58 +++++++++++++++++++++++++-------------------- library/TEDIT.LCOM | Bin 38866 -> 38913 bytes 2 files changed, 32 insertions(+), 26 deletions(-) diff --git a/library/TEDIT b/library/TEDIT index 8381bd7b..d366eba4 100644 --- a/library/TEDIT +++ b/library/TEDIT @@ -1,10 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "19-Sep-2021 17:08:56" {DSK}kaplan>Local>medley3.5>git-medley>library>TEDIT.;2 141945 - changes to%: (VARS TEDITCOMS) +(FILECREATED "29-Sep-2021 22:16:28"  +{DSK}kaplan>Local>medley3.5>git-medley>library>TEDIT.;11 142247 - previous date%: "19-Apr-2018 12:22:03" -{DSK}kaplan>Local>medley3.5>git-medley>library>TEDIT.;1) + changes to%: (FNS TEDIT-SEE) + + previous date%: "19-Sep-2021 17:08:56" +{DSK}kaplan>Local>medley3.5>git-medley>library>TEDIT.;5) (* ; " @@ -328,12 +330,14 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation. (RETURN PROC]) (TEDIT-SEE - [LAMBDA (FILE WINDOW) (* ; "Edited 19-Sep-2021 09:40 by rmk:") + [LAMBDA (FILE WINDOW FORMAT) (* ; "Edited 29-Sep-2021 22:16 by rmk:") (* ; "Edited 27-Feb-2021 20:07 by rmk:") (* ; "Edited 1-Feb-88 19:00 by bvm:") (* ;; "See FILE in a scrollable READONLY TEDIT window. If FILE is a LISP source file, copy first to a temporary NODIRCORE image file that interpretes the fontchange characters rather than showing black boxes.") + (* ;; "FORMAT for text files defaults to :UTF-8 if present, otherwise *DEFAULT-EXTERNALFORMAT*") + (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET ((SEESTREAM STREAM) ENV TSTREAM) @@ -346,18 +350,20 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation. (* ;; "Lisp source file") - (\EXTERNALFORMAT STREAM ENV) + (SETFILEINFO STREAM 'FORMAT ENV) (SETQ SEESTREAM (OPENTEXTSTREAM)) (COPY.TEXT.TO.IMAGE STREAM SEESTREAM) ELSE (* ;; "Not a Lisp source file and not a Tedit file. If it is not random access, we copy it so we can scroll around.") + (* ;; "Maybe there is a conventional way of finding out the external format of a plain-text stream (an EMACS header?), here we nudge towards :UTF-8 (if it exists).") + + (SETFILEINFO STREAM 'FORMAT (OR FORMAT (FIND-FORMAT :UTF-8) + *DEFAULT-EXTERNALFORMAT*)) (CL:UNLESS (RANDACCESSP STREAM) - [SETQ SEESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW - `([TYPE ,(GETFILEINFO STREAM 'TYPE] - (FORMAT ,(\EXTERNALFORMAT STREAM] - (COPYBYTES STREAM SEESTREAM))) + (SETQ SEESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW)) + (COPYCHARS STREAM SEESTREAM))) [SETQ TSTREAM (TEXTSTREAM (TEDIT SEESTREAM WINDOW NIL '(READONLY T] (WINDOWPROP (WFROMDS TSTREAM) 'TITLE @@ -2229,7 +2235,7 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation. (* ; "TEDIT Support information") -(RPAQQ TEDITSYSTEMDATE "19-Sep-2021 17:08:56") +(RPAQQ TEDITSYSTEMDATE "29-Sep-2021 22:16:28") (RPAQ TEDITSUPPORT "TEditSupport.PA") (DEFINEQ @@ -2255,19 +2261,19 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation. (PUTPROPS TEDIT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1995 1999 2018 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4327 117111 (\TEDIT2 4337 . 7088) (COERCETEXTOBJ 7090 . 15866) (TEDIT 15868 . 20837) ( -TEDIT-SEE 20839 . 22787) (TEDIT.CHARWIDTH 22789 . 24813) (TEDIT.COPY 24815 . 33251) (TEDIT.DELETE -33253 . 33943) (TEDIT.DO.BLUEPENDINGDELETE 33945 . 37012) (TEDIT.INSERT 37014 . 42544) (TEDIT.KILL -42546 . 44103) (TEDIT.MAPLINES 44105 . 45504) (TEDIT.MAPPIECES 45506 . 46462) (TEDIT.MOVE 46464 . -56248) (TEDIT.QUIT 56250 . 58250) (TEDIT.STRINGWIDTH 58252 . 58923) (TEDIT.\INSERT 58925 . 60950) ( -TEXTOBJ 60952 . 62077) (TEXTSTREAM 62079 . 63694) (\TEDIT.INCLUDE 63696 . 67596) (\TEDIT.INSERT.PIECES - 67598 . 77513) (\TEDIT.MOVE.PIECEMAPFN 77515 . 79594) (\TEDIT.OBJECT.SHOWSEL 79596 . 83225) ( -\TEDIT.RESTARTFN 83227 . 85222) (\TEDIT.CHARDELETE 85224 . 89186) (\TEDIT.COPY.PIECEMAPFN 89188 . -92413) (\TEDIT.DELETE 92415 . 99933) (\TEDIT.DIFFUSE.PARALOOKS 99935 . 102699) (\TEDIT.FOREIGN.COPY? -102701 . 106428) (\TEDIT.QUIT 106430 . 109576) (\TEDIT.WORDDELETE 109578 . 114411) (\TEDIT1 114413 . -117109)) (117225 117341 (\CREATE.TEDIT.RESTART.MENU 117235 . 117339)) (117440 121129 (PLCHAIN 117450 - . 117724) (PRINTLINE 117726 . 120490) (SEEFILE 120492 . 121127)) (121170 140813 (TEDIT.INSERT.OBJECT -121180 . 130257) (TEDIT.EDIT.OBJECT 130259 . 132515) (TEDIT.FIND.OBJECT 132517 . 133410) ( -TEDIT.FIND.OBJECT.SUBTREE 133412 . 134218) (TEDIT.PUT.OBJECT 134220 . 135879) (TEDIT.GET.OBJECT 135881 - . 139080) (TEDIT.OBJECT.CHANGED 139082 . 140811)) (141091 141454 (MAKETEDITFORM 141101 . 141452))))) + (FILEMAP (NIL (4329 117413 (\TEDIT2 4339 . 7090) (COERCETEXTOBJ 7092 . 15868) (TEDIT 15870 . 20839) ( +TEDIT-SEE 20841 . 23089) (TEDIT.CHARWIDTH 23091 . 25115) (TEDIT.COPY 25117 . 33553) (TEDIT.DELETE +33555 . 34245) (TEDIT.DO.BLUEPENDINGDELETE 34247 . 37314) (TEDIT.INSERT 37316 . 42846) (TEDIT.KILL +42848 . 44405) (TEDIT.MAPLINES 44407 . 45806) (TEDIT.MAPPIECES 45808 . 46764) (TEDIT.MOVE 46766 . +56550) (TEDIT.QUIT 56552 . 58552) (TEDIT.STRINGWIDTH 58554 . 59225) (TEDIT.\INSERT 59227 . 61252) ( +TEXTOBJ 61254 . 62379) (TEXTSTREAM 62381 . 63996) (\TEDIT.INCLUDE 63998 . 67898) (\TEDIT.INSERT.PIECES + 67900 . 77815) (\TEDIT.MOVE.PIECEMAPFN 77817 . 79896) (\TEDIT.OBJECT.SHOWSEL 79898 . 83527) ( +\TEDIT.RESTARTFN 83529 . 85524) (\TEDIT.CHARDELETE 85526 . 89488) (\TEDIT.COPY.PIECEMAPFN 89490 . +92715) (\TEDIT.DELETE 92717 . 100235) (\TEDIT.DIFFUSE.PARALOOKS 100237 . 103001) (\TEDIT.FOREIGN.COPY? + 103003 . 106730) (\TEDIT.QUIT 106732 . 109878) (\TEDIT.WORDDELETE 109880 . 114713) (\TEDIT1 114715 . +117411)) (117527 117643 (\CREATE.TEDIT.RESTART.MENU 117537 . 117641)) (117742 121431 (PLCHAIN 117752 + . 118026) (PRINTLINE 118028 . 120792) (SEEFILE 120794 . 121429)) (121472 141115 (TEDIT.INSERT.OBJECT +121482 . 130559) (TEDIT.EDIT.OBJECT 130561 . 132817) (TEDIT.FIND.OBJECT 132819 . 133712) ( +TEDIT.FIND.OBJECT.SUBTREE 133714 . 134520) (TEDIT.PUT.OBJECT 134522 . 136181) (TEDIT.GET.OBJECT 136183 + . 139382) (TEDIT.OBJECT.CHANGED 139384 . 141113)) (141393 141756 (MAKETEDITFORM 141403 . 141754))))) STOP diff --git a/library/TEDIT.LCOM b/library/TEDIT.LCOM index 15e0271ee956f6f254ef2084fd52fde60a88c548..419aa50db9ed8b1e62c8ae265f02f9baac9f840f 100644 GIT binary patch delta 800 zcma)4U279T6wN01U;x#!+{{yG2lOa6W9R&mV_LguE- z5zIq{S}N}ysI*QAD7A@hQ*-z%Ss|nmfawBLmQsg^3)jqE?a-2TD?;JkN8Ib&5E9QI!94W1uiXZyG(@d}yCm>725 zw3~Vb#Vl6tDb3Nf{JX_Rew?-)0Uu2`QW%kzj+)1OrxOa5Z3>n~PB>-NBxs-;L|)vj zBKN&;DW~won|XdYC)a3qdTxEa!TaNfU?Katw8Yk@H*t1#@;c$36*d;elpizK)d_U5 zO~7xwRh*Do-78srIXE@&u)PrmT!0ud(M}jfPMd+~8j_Bf=9Q#z0@AeL#*r(9k)}4s zY?$c!Y25ZWNQ27SZ3-@Af7>9`n3fWRQ0bg(xh*G^w7P~kVUeUY#ypcEbt2DkUB-C= zqY2K$cua!GkD(jzWqH(DRW&`kTPm%ZlL&L4$*fgc5UrC7L9{WCJO(|Z z68CCZubN;rKXh6YG;LmWfq-iMRhXE7)5e^25|?^@`tj!7z5&7)0R>Be%l4)Tq8C#z zNp4Y%h;{)b*kGa!IRC4NHT}e834M*bgpw#Ab4uZ4|8RG70?$VikWm0VEm!m+zHa)o g(z=coVo)I0C;eQxEfr=zDxaq1f35fI^urtJH>(D|!vFvP From d6173b52693afafd503e6efc7ad02e2def9f6b9b Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Thu, 30 Sep 2021 13:39:10 -0700 Subject: [PATCH 5/8] Revert "HARDCOPY: COPY.TEXT.TO.IMAGE had Unicode-incompatible end-of-file shortcut" This reverts commit 65a2d8000ebc061714bb7cf3562f55bde142f546. --- sources/HARDCOPY | 121 ++++++++++++++++++++---------------------- sources/HARDCOPY.LCOM | Bin 47390 -> 47349 bytes 2 files changed, 58 insertions(+), 63 deletions(-) diff --git a/sources/HARDCOPY b/sources/HARDCOPY index 83214787..145f90bb 100644 --- a/sources/HARDCOPY +++ b/sources/HARDCOPY @@ -1,12 +1,11 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "20-Sep-2021 10:59:58"  +{DSK}kaplan>Local>medley3.5>git-medley>sources>HARDCOPY.;2 103730 -(FILECREATED "29-Sep-2021 08:53:30"  -{DSK}kaplan>Local>medley3.5>git-medley>sources>HARDCOPY.;5 103898 + changes to%: (VARS HARDCOPYCOMS) - changes to%: (FNS COPY.TEXT.TO.IMAGE) - - previous date%: "20-Sep-2021 10:59:58" -{DSK}kaplan>Local>medley3.5>git-medley>sources>HARDCOPY.;3) + previous date%: " 5-May-2021 19:41:55" +{DSK}kaplan>Local>medley3.5>git-medley>sources>HARDCOPY.;1) (* ; " @@ -723,10 +722,10 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. (CLOSEF IMAGESTREAM])]) (COPY.TEXT.TO.IMAGE - [LAMBDA (INFILE IMAGESTREAM FONTS TABS) (* ; "Edited 29-Sep-2021 08:53 by rmk:") - (* ; "Edited 10-Apr-95 21:23 by rmk:") + [LAMBDA (INFILE IMAGESTREAM FONTS TABS) (* ; "Edited 5-May-2021 19:41 by rmk:") + (* ; "Edited 10-Apr-95 21:23 by rmk:") - (* ;; "Copy text to an image stream, obeying PSPOOL control characters") + (* ;; "Copy text to an image stream, obeying PSPOOL control characters") (LET* ((IMAGESTREAM (GETSTREAM IMAGESTREAM 'OUTPUT)) @@ -735,19 +734,15 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. (MAXFONT (ARRAYSIZE FONTARRAY)) (INSTRM (GETSTREAM INFILE 'INPUT)) DEFAULTTAB C FC) - - (* ;; - "RMK: EOS function is NILL, not ZERO. 0 in low-order bits is OK in UNICODE, when we switch") - - (replace (STREAM ENDOFSTREAMOP) of INSTRM with (FUNCTION NILL)) + (replace (STREAM ENDOFSTREAMOP) of INSTRM with (FUNCTION ZERO)) (do (COND - ((NULL (SETQ C (\INCCODE INSTRM))) - (replace (STREAM ENDOFSTREAMOP) of INSTRM with NIL) + ((AND [EQ 0 (LOGAND 255 (SETQ C (\INCCODE INSTRM] + (EOFP INSTRM)) (RETURN)) ((AND RIGHTMAR (> (DSPXPOSITION NIL IMAGESTREAM) - RIGHTMAR)) (* ; - "Not to walk off the right edge of the paper") + RIGHTMAR)) (* ; + "Not to walk off the right edge of the paper") (TERPRI IMAGESTREAM))) (COND ([> C (CONSTANT (APPLY (FUNCTION MAX) @@ -755,16 +750,16 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. (\OUTCHAR IMAGESTREAM C)) (T (SELCHARQ C - (^F (* ; "Font shift") + (^F (* ; "Font shift") - (* ;; - "For FX-XP-9 printer:SETXY interpress command to avoid printer's BUG(Take)") + (* ;; + "For FX-XP-9 printer:SETXY interpress command to avoid printer's BUG(Take)") (DSPXPOSITION (IPLUS (DSPXPOSITION NIL IMAGESTREAM) 1) IMAGESTREAM) [SELCHARQ (SETQ FC (\INCCODE INSTRM)) - (^T (* ; "tab to absolute pos.") + (^T (* ; "tab to absolute pos.") (COND ((EQ 0 (SETQ FC (\INCCODE INSTRM))) (\OUTCHAR IMAGESTREAM (CHARCODE ^F)) @@ -774,7 +769,7 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. (\OUTCHAR IMAGESTREAM FC)) (T - (* ;; "TEXTDEFAULTTABS is a hack, since it depends on the units of the stream. Should really be a property of the stream or imagetype, or defined in terms of standard scale") + (* ;; "TEXTDEFAULTTABS is a hack, since it depends on the units of the stream. Should really be a property of the stream or imagetype, or defined in terms of standard scale") [SETQ FC (IF TABS @@ -792,7 +787,7 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. (NULL (\OUTCHAR IMAGESTREAM (CHARCODE ^F)) (AND (\EOFP INSTRM) (RETURN)) - (\OUTCHAR IMAGESTREAM FC) (* ; "EOS after ^F") + (\OUTCHAR IMAGESTREAM FC) (* ; "EOS after ^F") ) (COND ((AND (>= MAXFONT FC) @@ -802,13 +797,13 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. (T (\OUTCHAR IMAGESTREAM (CHARCODE ^F)) (\OUTCHAR IMAGESTREAM C]) (CR - (* ;; "Assumes that CR and possibly following LF denote a single EOL, independent of the EOL convention and independent of whether the file was opened binary or text. Originally, this function tried to discriminate, treating an LF in a CR-mode file as a line-feed and a CR in an LF file as a carriage-return. But these formatting effects cannot be guaranteed across text-file transfers (which is all that it makes sense to print), so it is silly to take them seriously. Given that just this information can be lost in text-mode file transfers, we make adopt here the 99%% correct solution, which is to treat all instances of CR, CRLF, and LF as end-of-line.") + (* ;; "Assumes that CR and possibly following LF denote a single EOL, independent of the EOL convention and independent of whether the file was opened binary or text. Originally, this function tried to discriminate, treating an LF in a CR-mode file as a line-feed and a CR in an LF file as a carriage-return. But these formatting effects cannot be guaranteed across text-file transfers (which is all that it makes sense to print), so it is silly to take them seriously. Given that just this information can be lost in text-mode file transfers, we make adopt here the 99%% correct solution, which is to treat all instances of CR, CRLF, and LF as end-of-line.") (TERPRI IMAGESTREAM) (COND ((EQ (CHARCODE LF) - (\PEEKCCODE.NOEOLC INSTRM T)) - (\INCCODE INSTRM)))) + (\PEEKBIN INSTRM T)) + (BIN INSTRM)))) (TAB (OR (LET* [(LEFTMARGIN (DSPLEFTMARGIN NIL IMAGESTREAM)) (TAB.WIDTH (TIMES (CHARWIDTH (CHARCODE SPACE) IMAGESTREAM) @@ -820,7 +815,7 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. CURRENT.X) 0 IMAGESTREAM))) (\OUTCHAR IMAGESTREAM C))) - (LF (* ; "See comment at CR") + (LF (* ; "See comment at CR") (TERPRI IMAGESTREAM)) (NULL (AND (EOFP INSTRM) (RETURN)) @@ -1093,39 +1088,39 @@ Copyright (c) 1984-1993, 1999, 2018, 2021 by Venue & Xerox Corporation. (PUTPROPS HARDCOPY COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1999 2018 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (6182 10366 (HARDCOPY.SOMEHOW 6192 . 7550) (HARDCOPYIMAGEW 7552 . 7704) ( -HARDCOPYIMAGEW.TOFILE 7706 . 8014) (HARDCOPYIMAGEW.TOPRINTER 8016 . 8681) (HARDCOPYREGION.TOFILE 8683 - . 8981) (HARDCOPYREGION.TOPRINTER 8983 . 9605) (COPY.WINDOW.TO.BITMAP 9607 . 10364)) (10438 20988 ( -MakeMenuOfPrinters 10448 . 11673) (PRINTERS.WHENSELECTEDFN 11675 . 13417) (MakeMenuOfImageTypes 13419 - . 13937) (GetNewPrinterFromUser 13939 . 14367) (PopUpWindowAndGetAtom 14369 . 15754) ( -PopUpWindowAndGetList 15756 . 17322) (NewPrinter 17324 . 18272) (GetPrinterName 18274 . 18554) ( -GetImageFile 18556 . 20843) (FetchDefaultPrinter 20845 . 20986)) (21023 21561 ( -ExtensionForPrintFileType 21033 . 21226) (PRINTFILETYPE.FROM.EXTENSION 21228 . 21559)) (21616 38000 ( -DEFAULTPRINTER 21626 . 21786) (CAN.PRINT.DIRECTLY 21788 . 21944) (CONVERT.FILE.TO.TYPE.FOR.PRINTER -21946 . 22990) (EMPRESS 22992 . 23305) (HARDCOPYW 23307 . 26267) (LISTFILES1 26269 . 26442) ( -PRINTER.BITMAPFILE 26444 . 26691) (PRINTER.BITMAPSCALE 26693 . 26958) (PRINTER.SCRATCH.FILE 26960 . -27083) (PRINTERPROP 27085 . 27268) (PRINTERSTATUS 27270 . 27459) (PRINTERTYPE 27461 . 29770) ( -PRINTERNAME 29772 . 30074) (PRINTFILEPROP 30076 . 30267) (PRINTFILETYPE 30269 . 32213) ( -\EXPECTED.FILE.TYPE 32215 . 32997) (SEND.FILE.TO.PRINTER 32999 . 37998)) (38001 42983 (PRINTERDEVICE -38011 . 42981)) (43798 52161 (TEXTTOIMAGEFILE 43808 . 45998) (COPY.TEXT.TO.IMAGE 46000 . 52159)) ( -52162 53297 (\BLTSHADE.GENERICPRINTER 52172 . 53295)) (53425 72177 (MAKEHARDCOPYSTREAM 53435 . 54439) -(UNMAKEHARDCOPYSTREAM 54441 . 55125) (HARDCOPYSTREAMTYPE 55127 . 55406) (\CHARWIDTH.HDCPYDISPLAY 55408 - . 55839) (\DSPFONT.HDCPYDISPLAY 55841 . 57246) (\DSPRIGHTMARGIN.HDCPYDISPLAY 57248 . 57825) ( -\DSPXPOSITION.HDCPYDISPLAY 57827 . 58088) (\DSPYPOSITION.HDCPYDISPLAY 58090 . 58351) ( -\STRINGWIDTH.HDCPYDISPLAY 58353 . 58860) (\STRINGWIDTH.HCPYDISPLAYAUX 58862 . 61194) (\HDCPYBLTCHAR -61196 . 63731) (\HDCPYDISPLAY.FIX.XPOS 63733 . 64153) (\HDCPYDISPLAY.FIX.YPOS 64155 . 64575) ( -\HDCPYDISPLAYINIT 64577 . 65354) (\HDCPYDSPPRINTCHAR 65356 . 67516) (\SLOWHDCPYBLTCHAR 67518 . 71021) -(\CHANGECHARSET.HDCPYDISPLAY 71023 . 72175)) (72899 103196 (MAKEHARDCOPYMODESTREAM 72909 . 74818) ( -UNMAKEHARDCOPYMODESTREAM 74820 . 75898) (\BLTSHADE.HCPYMODE 75900 . 76347) (\BITBLT.HCPYMODE 76349 . -76971) (\BRUSHCONVERT.HCPYMODE 76973 . 77210) (\CHANGECHARSET.HCPYMODE 77212 . 78979) ( -\DASHINGCONVERT.HCPYMODE 78981 . 79244) (\CHARWIDTH.HCPYMODE 79246 . 79533) (\DRAWLINE.HCPYMODE 79535 - . 79847) (\DRAWCURVE.HCPYMODE 79849 . 80278) (\DRAWCIRCLE.HCPYMODE 80280 . 80675) ( -\DRAWELLIPSE.HCPYMODE 80677 . 81189) (\DSPFONT.HCPYMODE 81191 . 82347) (\DSPLEFTMARGIN.HCPYMODE 82349 - . 82933) (\DSPLINEFEED.HCPYMODE 82935 . 83345) (\DSPRIGHTMARGIN.HCPYMODE 83347 . 83976) ( -\DSPSPACEFACTOR.HCPYMODE 83978 . 84499) (\DSPXPOSITION.HCPYMODE 84501 . 85082) (\DSPYPOSITION.HCPYMODE - 85084 . 85489) (\MOVETO.HCPYMODE 85491 . 85643) (\FONTCREATE.HCPYMODE.PRESS 85645 . 86657) ( -\CREATECHARSET.HCPYMODE.PRESS 86659 . 87630) (\FONTCREATE.HCPYMODE.INTERPRESS 87632 . 88666) ( -\CREATECHARSET.HCPYMODE.INTERPRESS 88668 . 89656) (\STRINGWIDTH.HCPYMODE 89658 . 90092) ( -\HCPYMODEBLTCHAR 90094 . 93063) (\HCPYMODEDISPLAYINIT 93065 . 95996) (\HCPYMODEDSPPRINTCHAR 95998 . -98179) (\SLOWHCPYMODEBLTCHAR 98181 . 101695) (\SFFixY.HCPYMODE 101697 . 103194))))) + (FILEMAP (NIL (6176 10360 (HARDCOPY.SOMEHOW 6186 . 7544) (HARDCOPYIMAGEW 7546 . 7698) ( +HARDCOPYIMAGEW.TOFILE 7700 . 8008) (HARDCOPYIMAGEW.TOPRINTER 8010 . 8675) (HARDCOPYREGION.TOFILE 8677 + . 8975) (HARDCOPYREGION.TOPRINTER 8977 . 9599) (COPY.WINDOW.TO.BITMAP 9601 . 10358)) (10432 20982 ( +MakeMenuOfPrinters 10442 . 11667) (PRINTERS.WHENSELECTEDFN 11669 . 13411) (MakeMenuOfImageTypes 13413 + . 13931) (GetNewPrinterFromUser 13933 . 14361) (PopUpWindowAndGetAtom 14363 . 15748) ( +PopUpWindowAndGetList 15750 . 17316) (NewPrinter 17318 . 18266) (GetPrinterName 18268 . 18548) ( +GetImageFile 18550 . 20837) (FetchDefaultPrinter 20839 . 20980)) (21017 21555 ( +ExtensionForPrintFileType 21027 . 21220) (PRINTFILETYPE.FROM.EXTENSION 21222 . 21553)) (21610 37994 ( +DEFAULTPRINTER 21620 . 21780) (CAN.PRINT.DIRECTLY 21782 . 21938) (CONVERT.FILE.TO.TYPE.FOR.PRINTER +21940 . 22984) (EMPRESS 22986 . 23299) (HARDCOPYW 23301 . 26261) (LISTFILES1 26263 . 26436) ( +PRINTER.BITMAPFILE 26438 . 26685) (PRINTER.BITMAPSCALE 26687 . 26952) (PRINTER.SCRATCH.FILE 26954 . +27077) (PRINTERPROP 27079 . 27262) (PRINTERSTATUS 27264 . 27453) (PRINTERTYPE 27455 . 29764) ( +PRINTERNAME 29766 . 30068) (PRINTFILEPROP 30070 . 30261) (PRINTFILETYPE 30263 . 32207) ( +\EXPECTED.FILE.TYPE 32209 . 32991) (SEND.FILE.TO.PRINTER 32993 . 37992)) (37995 42977 (PRINTERDEVICE +38005 . 42975)) (43792 51993 (TEXTTOIMAGEFILE 43802 . 45992) (COPY.TEXT.TO.IMAGE 45994 . 51991)) ( +51994 53129 (\BLTSHADE.GENERICPRINTER 52004 . 53127)) (53257 72009 (MAKEHARDCOPYSTREAM 53267 . 54271) +(UNMAKEHARDCOPYSTREAM 54273 . 54957) (HARDCOPYSTREAMTYPE 54959 . 55238) (\CHARWIDTH.HDCPYDISPLAY 55240 + . 55671) (\DSPFONT.HDCPYDISPLAY 55673 . 57078) (\DSPRIGHTMARGIN.HDCPYDISPLAY 57080 . 57657) ( +\DSPXPOSITION.HDCPYDISPLAY 57659 . 57920) (\DSPYPOSITION.HDCPYDISPLAY 57922 . 58183) ( +\STRINGWIDTH.HDCPYDISPLAY 58185 . 58692) (\STRINGWIDTH.HCPYDISPLAYAUX 58694 . 61026) (\HDCPYBLTCHAR +61028 . 63563) (\HDCPYDISPLAY.FIX.XPOS 63565 . 63985) (\HDCPYDISPLAY.FIX.YPOS 63987 . 64407) ( +\HDCPYDISPLAYINIT 64409 . 65186) (\HDCPYDSPPRINTCHAR 65188 . 67348) (\SLOWHDCPYBLTCHAR 67350 . 70853) +(\CHANGECHARSET.HDCPYDISPLAY 70855 . 72007)) (72731 103028 (MAKEHARDCOPYMODESTREAM 72741 . 74650) ( +UNMAKEHARDCOPYMODESTREAM 74652 . 75730) (\BLTSHADE.HCPYMODE 75732 . 76179) (\BITBLT.HCPYMODE 76181 . +76803) (\BRUSHCONVERT.HCPYMODE 76805 . 77042) (\CHANGECHARSET.HCPYMODE 77044 . 78811) ( +\DASHINGCONVERT.HCPYMODE 78813 . 79076) (\CHARWIDTH.HCPYMODE 79078 . 79365) (\DRAWLINE.HCPYMODE 79367 + . 79679) (\DRAWCURVE.HCPYMODE 79681 . 80110) (\DRAWCIRCLE.HCPYMODE 80112 . 80507) ( +\DRAWELLIPSE.HCPYMODE 80509 . 81021) (\DSPFONT.HCPYMODE 81023 . 82179) (\DSPLEFTMARGIN.HCPYMODE 82181 + . 82765) (\DSPLINEFEED.HCPYMODE 82767 . 83177) (\DSPRIGHTMARGIN.HCPYMODE 83179 . 83808) ( +\DSPSPACEFACTOR.HCPYMODE 83810 . 84331) (\DSPXPOSITION.HCPYMODE 84333 . 84914) (\DSPYPOSITION.HCPYMODE + 84916 . 85321) (\MOVETO.HCPYMODE 85323 . 85475) (\FONTCREATE.HCPYMODE.PRESS 85477 . 86489) ( +\CREATECHARSET.HCPYMODE.PRESS 86491 . 87462) (\FONTCREATE.HCPYMODE.INTERPRESS 87464 . 88498) ( +\CREATECHARSET.HCPYMODE.INTERPRESS 88500 . 89488) (\STRINGWIDTH.HCPYMODE 89490 . 89924) ( +\HCPYMODEBLTCHAR 89926 . 92895) (\HCPYMODEDISPLAYINIT 92897 . 95828) (\HCPYMODEDSPPRINTCHAR 95830 . +98011) (\SLOWHCPYMODEBLTCHAR 98013 . 101527) (\SFFixY.HCPYMODE 101529 . 103026))))) STOP diff --git a/sources/HARDCOPY.LCOM b/sources/HARDCOPY.LCOM index 8d8981f4c6d0dbeb74a70275878793104595b0f8..27e0ec8543a0c72c8fd37e23bf92631da407fefd 100644 GIT binary patch delta 1085 zcmZuwzi-n(6t0UvB9NgHYE>c7t0ho^)aritVmo3Wjh))mzi`|FRaL39QJXeRqO>4b z$jF35@q&D2nLL@OwBT7ceB_eX%Mj*=Lm^%R2AV)qqI`ns+TLJRY;WX z*BjfHvQVw2)hrjc?1#| zQJErGSzoTMm9}B0#_Ol%bAAzwoUi3w?{?m`i)pAgO83gOyW73e93ujow3i?J?N!Z6 zILlagAmjzS&xS{}v&j@;kab+&&RJny9}BC6H%TlZ@IZka!c+~f%zO~m!-E+wS^52S zqw~xb`bXE6L8@ z#kSECXj|o8rjqEqYIPr5&~9}fg>TJLb0X%9a!#W2yiaL$Pi}Pf#tt1kZFSEaA%A^~ zmtTfb8H`}joeT1OJit_SAW#(0-GT>9mLSl5&o_ZFc>pj>arol;`6dEiw{xbW={`t` z1X|I%<+(*OFkJ^E8ABv~)6@b3qzsDEmR<<#oIhjoJY}%x>H6$+6cD*zN)H5E>221$35lo~bS^nbG{xC4=jV)&Kg1xih zN3$4CTQ^3MDMsb~{RD>8@FyMjDdnwb`aDpgLNVa)+6KZ;ythXX?eFo97j)l+4DRnp kGMJ7x7XSl(JNP1 delta 1099 zcma)5zi-n(6s}uTz)}YU6d_df2tSk{Ql0O7j%~pZoJ(wav5oDPB9);u5lu_r3SN_ujpq--loS7~Zrm z%gMaMnH8{X#Bz|pMmj9l(imX{kZw|96124x7HLY@GJTt3m_#v&nt+FE<%QMdTBTYp zfn0u8TU)|;hB(ig5 zcszGXPGSnC>jlLu7pzipJeA)Y!zcqj=#WJiY4Q2ON2wC;7kv309~}~B@yzx3mVHh7 z6qoE}=|TL(M$(OV#NpD{*movw?%CB*xeeU4-R|9Jy?0C1vF3JS*FM>?@Jh#0m78xG ztxeulHd@c)w@$eZeZRB9Pj0^IxiwnHmYUn=y7-rk*6~B+uW$Y5{!mg=6qxg-Bg@VP zpdr*3sBQrB@;=ZEg@^@y-~gri0AQHl_{E(Ibp--e%sOt41)%B_a-l!#d!Z9Ko(pOQ zLp%6ACl}eEYD(M8Sw1RegMuUMDup@6wJa~kKqVOFe8#3a;-u>_k6WN(wMRfjTAu(B z^A_CeUGhZN+M)BF8v)S~FfML72v>{&UqpcgffoQa5V(RG&KO6TV@)4mjx_@9*xl6t zOi3pLCaB(zsu*NI(A5DUBU;-lQxVR6LGAGFcT6GrQ6h?1zQY+Qq5}uhFftw7iC(Yc zi+pB5PEz52@Ku2-2tvm+T^_RNZrTq#i?LkV%7zRG5f$aw3=phA7>SiHLi Date: Thu, 30 Sep 2021 23:16:45 -0700 Subject: [PATCH 6/8] Convert LAFITE files to LF They missed the previous global conversion since they were in a subdirectory. The only actual change is in LAFITETEDIT, it had the wrong name for the TEDITDCL file --- library/UNIXMAIL | 1211 +++++++++++- library/UNIXMAIL.DFASL | Bin 23363 -> 23415 bytes library/lafite/LAFITE | 89 +- library/lafite/LAFITE.LCOM | Bin 47728 -> 47708 bytes library/lafite/LAFITEBROWSE | 2468 +++++++++++++++++++++++-- library/lafite/LAFITEBROWSE.LCOM | Bin 52417 -> 52450 bytes library/lafite/LAFITECOMMANDS | 2730 ++++++++++++++++++++++++++-- library/lafite/LAFITECOMMANDS.LCOM | Bin 59039 -> 59029 bytes library/lafite/LAFITEFIND | 138 +- library/lafite/LAFITEFIND.LCOM | Bin 10029 -> 10000 bytes library/lafite/LAFITEMAIL | 1994 ++++++++++++++++++-- library/lafite/LAFITEMAIL.LCOM | Bin 41885 -> 41777 bytes library/lafite/LAFITESEND | 1906 +++++++++++++++++-- library/lafite/LAFITESEND.LCOM | Bin 45081 -> 45076 bytes library/lafite/LAFITESORT | 353 +++- library/lafite/LAFITESORT.LCOM | Bin 7028 -> 7129 bytes library/lafite/LAFITETEDIT | 32 +- library/lafite/LAFITETEDIT.LCOM | Bin 3195 -> 3555 bytes library/lafite/MAILSCAVENGE | 665 ++++++- library/lafite/MAILSCAVENGE.LCOM | Bin 11937 -> 11961 bytes 20 files changed, 10820 insertions(+), 766 deletions(-) diff --git a/library/UNIXMAIL b/library/UNIXMAIL index 7e98a652..dbeea409 100644 --- a/library/UNIXMAIL +++ b/library/UNIXMAIL @@ -1,10 +1,519 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "10-Feb-2000 12:03:28" |{DSK}medley3.5>library>unixmail.;42| 82019 |changes| |to:| (FNS UNIXSPOOL.OPENMAILBOX) |previous| |date:| " 6-Jul-99 15:22:12" |{DSK}medley3.5>library>unixmail.;41|) ; Copyright (c) 1989, 1990, 1991, 1992, 1997, 1999, 1920 by ENVOS Corporation. All rights reserved. (PRETTYCOMPRINT UNIXMAILCOMS) (RPAQQ UNIXMAILCOMS ((DECLARE\: DOEVAL@COMPILE DONTCOPY (FILES (SOURCE) LAFITEDECLS NSMAIL) (RECORDS UNIXMAILBOX UNIXMAILFILEINFO UNIXMAILPARSE)) (ALISTS (LAFITEMODELST UNIX)) (* |;;| "JDS 4/6/97: CHANGE TRANSMIT SMTP INTERACTION TO put <> around mail-from name, which SMTP seems to require.") (* |;;| "These variables control how mail is sent and received. UNIXMAIL.SEND.MODE controls whether the SMTP stream is opened via process-stream (PROCESS) or TCP socket (TCP). UNIXMAIL.RECEIVE.MODE controls whether mail is received through the Berkeley mailer (MAILER) or by reading the spool file directly (SPOOL). PROCESS and MAILER can only be done under an emulator; TCP and SPOOL will also work on D-machines (but may need other library packages like TCP or NFS).") (INITVARS (UNIXMAIL.SEND.MODE 'PROCESS) (UNIXMAIL.RECEIVE.MODE 'SPOOL)) (* |;;| "List used by \\UNIXMAIL.AUTHENTICATE to construct the MAILSERVEROPS list") (VARS UNIXMAIL.MSOPS.LIST) (* |;;| "These variables control filenames, hostnames, etc. They default to NIL, meaning they are not used or the mailer will try and figure them out itself") (INITVARS UNIXMAIL.SEND.HOST UNIXMAIL.DOMAIN.NAME (UNIXMAIL.SEND.PROCESS '( "/usr/bin/mconnect" "/usr/etc/mconnect" )) (UNIXMAIL.RECEIVE.PROCESS "/usr/ucb/mail -N") UNIXMAIL.SPOOL.FILE (UNIXMAIL.DONT.RECEIVE.STATUS "") (UNIXMAIL.WRAP.LINES T) (UNIXMAIL.WRAP-LIMIT 72) (UNIXMAIL.TABWIDTH 8)) (* |;;| "Functions used to receive mail") (FNS UNIX.POLLNEWMAIL UNIX.NEXTMESSAGE UNIXMAILER.OPENMAILBOX UNIXMAILER.RETRIEVEMESSAGE UNIXMAILER.CLOSEMAILBOX UNIXSPOOL.OPENMAILBOX UNIXSPOOL.RETRIEVEMESSAGE UNIXSPOOL.CLOSEMAILBOX) (* |;;| "Functions used to send mail") (FNS UNIX.FLUSH.STREAM UNIX.RETRIEVE.LINE \\UNIXMAIL.SEND \\UNIXMAIL.SEND.WRAPLINES \\SMTP-DUMP \\UNIXMAIL.SEND.PARSE \\UNIXMAIL.CHECK.ABORT \\UNIXMAIL.MUNG.RECIPIENTS \\UNIXMAIL.SMTP \\UNIXMAIL.SMTP.FLUSH \\UNIXMAIL.CHANGE.MODE) (* |;;| "This returns multiple-values, so it's a CL:LAMBDA (what the heck).") (FUNCTIONS \\UNIXMAIL.SMTP.TCP.STREAMS) (* |;;| "Other functions Lafite uses and needs Unix equivalents for") (FNS \\UNIXMAIL.AUTHENTICATE \\UNIXMAIL.LOGIN \\UNIXMAIL.PARSENAMES \\UNIXMAIL.MAKEANSWERFORM \\UNIXMAIL.MESSAGE.FROM.SELF.P \\UNIXMAIL.MESSAGE.P \\UNIXMAIL.REALADDRESS \\UNIXMAIL.FQNAME \\UNIXMAIL.FIXMICROSOFT) (* |;;| "This is a stub needed by the TEdit-uuencode strategy; if we ever decide on a reasonable way to do this and make it part of Lafite, this may go away") (P (MOVD? 'NILL 'UNIX.UUDECODE.IF.NEEDED)) (* |;;| "Hack to install easy interface for line wrapping. I should really put line-wrapping into Lafite as a whole.") (P (CL:WHEN (CAR (NLSETQ (EDITE LAFITESENDINGMENUITEMS '(F \\SENDMSG.CHANGE.MODE)))) (* |;;| "The CONS below insures that Lafite notices you've changed LAFITESENDINGMENUITEMS, so the menu will get updated.") (SETQ LAFITESENDINGMENUITEMS (EDITE (CONS (CAR LAFITESENDINGMENUITEMS) (CDR LAFITESENDINGMENUITEMS)) '(CHANGE \\SENDMSG.CHANGE.MODE TO \\UNIXMAIL.CHANGE.MODE))))) (PROP FILETYPE UNIXMAIL))) (DECLARE\: DOEVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) LAFITEDECLS NSMAIL) (DECLARE\: EVAL@COMPILE (RECORD UNIXMAILBOX (UMSTREAM UMNUMBERS UMNEXT UMLOCKSTREAM)) (RECORD UNIXMAILFILEINFO (UMFNAME UMFTIME)) (RECORD UNIXMAILPARSE (UNIXMAILSUBJECT UNIXFROM UNIXTO UNIXOTHER FORMATTED? UNIXBODY)) ) ) (ADDTOVAR LAFITEMODELST (UNIX 3 \\UNIXMAIL.SEND.PARSE \\UNIXMAIL.SEND \\UNIXMAIL.MAKEANSWERFORM \\UNIXMAIL.AUTHENTICATE \\UNIXMAIL.MESSAGE.P \\UNIXMAIL.MESSAGE.FROM.SELF.P \\UNIXMAIL.LOGIN)) (* |;;| "JDS 4/6/97: CHANGE TRANSMIT SMTP INTERACTION TO put <> around mail-from name, which SMTP seems to require." ) (* |;;| "These variables control how mail is sent and received. UNIXMAIL.SEND.MODE controls whether the SMTP stream is opened via process-stream (PROCESS) or TCP socket (TCP). UNIXMAIL.RECEIVE.MODE controls whether mail is received through the Berkeley mailer (MAILER) or by reading the spool file directly (SPOOL). PROCESS and MAILER can only be done under an emulator; TCP and SPOOL will also work on D-machines (but may need other library packages like TCP or NFS)." ) (RPAQ? UNIXMAIL.SEND.MODE 'PROCESS) (RPAQ? UNIXMAIL.RECEIVE.MODE 'SPOOL) (* |;;| "List used by \\UNIXMAIL.AUTHENTICATE to construct the MAILSERVEROPS list") (RPAQQ UNIXMAIL.MSOPS.LIST ((MAILER UNIX.POLLNEWMAIL UNIXMAILER.OPENMAILBOX UNIX.NEXTMESSAGE UNIXMAILER.RETRIEVEMESSAGE UNIXMAILER.CLOSEMAILBOX) (SPOOL UNIX.POLLNEWMAIL UNIXSPOOL.OPENMAILBOX UNIX.NEXTMESSAGE UNIXSPOOL.RETRIEVEMESSAGE UNIXSPOOL.CLOSEMAILBOX))) (* |;;| "These variables control filenames, hostnames, etc. They default to NIL, meaning they are not used or the mailer will try and figure them out itself" ) (RPAQ? UNIXMAIL.SEND.HOST NIL) (RPAQ? UNIXMAIL.DOMAIN.NAME NIL) (RPAQ? UNIXMAIL.SEND.PROCESS '("/usr/bin/mconnect" "/usr/etc/mconnect")) (RPAQ? UNIXMAIL.RECEIVE.PROCESS "/usr/ucb/mail -N") (RPAQ? UNIXMAIL.SPOOL.FILE NIL) (RPAQ? UNIXMAIL.DONT.RECEIVE.STATUS "") (RPAQ? UNIXMAIL.WRAP.LINES T) (RPAQ? UNIXMAIL.WRAP-LIMIT 72) (RPAQ? UNIXMAIL.TABWIDTH 8) (* |;;| "Functions used to receive mail") (DEFINEQ (UNIX.POLLNEWMAIL (LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER) (* \; "Edited 19-May-99 10:34 by rmk:") (* \; "Edited 24-Oct-90 00:04 by jrb:") (* |;;| "We have mail iff our mail spool file (either the value of UNIXMAIL.SPOOL.FILE or /usr/spool/mail/) exists and its date is later than the last time we got our Unix mail. In relentlessly hackish use of the existing MAILSERVER structure, MAILPORT holds a UNIXMAILFILEINFO which remembers the name of our mail file and when we last looked at it.") (LET (X (FILEINFO (OR (|fetch| (MAILSERVER MAILPORT) |of| MAILSERVER) (|replace| (MAILSERVER MAILPORT) |of| MAILSERVER |with| (|create| UNIXMAILFILEINFO UMFNAME _ (OR UNIXMAIL.SPOOL.FILE (CL:CONCATENATE 'STRING "{UNIX}/usr/spool/mail/" (|fetch| (LAFITEMODEDATA SHORTUSERNAME) |of| *LAFITE-MODE-DATA*))) UMFTIME _ 0))))) (AND (CL:PROBE-FILE (|fetch| (UNIXMAILFILEINFO UMFNAME) |of| FILEINFO)) (SETQ X (GETFILEINFO (|fetch| (UNIXMAILFILEINFO UMFNAME) |of| FILEINFO) 'LENGTH)) (IGREATERP X 0) (SETQ X (GETFILEINFO (|fetch| (UNIXMAILFILEINFO UMFNAME) |of| FILEINFO) 'IWRITEDATE)) (IGREATERP X (|fetch| (UNIXMAILFILEINFO UMFTIME) |of| FILEINFO)))))) (UNIX.NEXTMESSAGE (LAMBDA (MAILBOX) (* \; "Edited 5-Jan-89 18:18 by bane") (CAR (|fetch| UMNEXT |of| MAILBOX)))) (UNIXMAILER.OPENMAILBOX (LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER)(* \; "Edited 15-Oct-90 20:31 by jrb:") (* |;;| "A Unix \"mailbox\" is a process-stream talking to /usr/ucb/mail ") (|if| (OR (|fetch| (MAILSERVER NEWMAILP) |of| MAILSERVER) (UNIX.POLLNEWMAIL ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER)) |then| (LET* ((MSTREAM (CREATE-PROCESS-STREAM UNIXMAIL.RECEIVE.PROCESS)) (UMBOX (|create| UNIXMAILBOX UMSTREAM _ MSTREAM UMNUMBERS _ NIL UMNEXT _ NIL)) NUMBERS) (* |;;| "Get it in condition to be talked to") (CL:FORMAT MSTREAM "set screen=10000~%set prompt= ~%") (BLOCK 1000) (UNIX.FLUSH.STREAM MSTREAM) (* |;;| "OK, get it to print the headers followed by a line with a strange character on it (char code 254)") (CL:FORMAT MSTREAM "h~%echo ") (PRINTCCODE 254 MSTREAM) (PRINTCCODE (CHARCODE NEWLINE) MSTREAM) (* |;;|  "Before we really get rolling, scream if UNIXMAIL.DONT.RECEIVE.STATUS isn't a string") (OR (STRINGP UNIXMAIL.DONT.RECEIVE.STATUS) (ERROR "UNIXMAIL.DONT.RECEIVE.STATUS isn't a string" UNIXMAIL.DONT.RECEIVE.STATUS)) (* |;;| "Headers look like this:") (* |;;| " other junk like size, subject...") (|until| (EQ (READCCODE MSTREAM) 254) |do| (|if| (NULL (STRPOS (CL:READ-CHAR MSTREAM ) UNIXMAIL.DONT.RECEIVE.STATUS )) |then| (|push| NUMBERS (READ MSTREAM))) (UNIX.FLUSH.STREAM MSTREAM (CHARCODE NEWLINE )) |finally| (UNIX.FLUSH.STREAM MSTREAM (CHARCODE NEWLINE))) (|if| NUMBERS |then| (SETQ NUMBERS (DREVERSE NUMBERS)) (|replace| UMNUMBERS |of| UMBOX |with| NUMBERS) (|replace| UMNEXT |of| UMBOX |with| NUMBERS) (|create| OPENEDMAILBOX MAILBOX _ UMBOX PROPERTIES _ (LIST '\#OFMESSAGES (LENGTH NUMBERS))) |else| (CL:FORMAT MSTREAM "x~%") (* \; "Empty; close the mail process") (* \;  "and remember that we've checked on the mailbox.") (* \;  "HACK! Depends on \\LAFITE.RETRIEVEMESSAGES binding of MAILSERVER") (|replace| (UNIXMAILFILEINFO UMFTIME) |of| (|fetch| (MAILSERVER MAILPORT) |of| MAILSERVER) |with| (IDATE)) 'EMPTY)) |else| 'EMPTY))) (UNIXMAILER.RETRIEVEMESSAGE (LAMBDA (MAILBOX MSGOUTFILE) (* \; "Edited 5-Sep-90 22:58 by jrb:") (LET ((MSTREAM (|fetch| UMSTREAM |of| MAILBOX)) (OUTSTART (GETFILEPTR MSGOUTFILE))) (* |;;| "The UMCOUNT in the MAILBOX is the number of the message we're about to read in. The echo command below makes the message text be followed by a line starting with the character 254; you'll never see that in a message that has gone over an SMTP channel (guaranteed 7-bit chars).") (CL:FORMAT MSTREAM "p ~d~%echo " (|pop| (|fetch| UMNEXT |of| MAILBOX))) (PRINTCCODE 254 MSTREAM) (PRINTCCODE (CHARCODE NEWLINE) MSTREAM) (UNIX.FLUSH.STREAM MSTREAM (CHARCODE NEWLINE)) (* \; "Throw away \"Message 1:\" line") (|while| (UNIX.RETRIEVE.LINE MSTREAM MSGOUTFILE) |do| NIL) (* |;;|  "This could use a little error-handling, of course... perhaps a LOT of error handling.") (* |;;| "Check out the tail of the message and uudecode it if it's an encoded message") (UNIX.UUDECODE.IF.NEEDED MSGOUTFILE OUTSTART)))) (UNIXMAILER.CLOSEMAILBOX (LAMBDA (MAILBOX FLUSH?) (* \; "Edited 5-Sep-90 23:01 by jrb:") (LET ((MSTREAM (|fetch| UMSTREAM |of| MAILBOX))) (* |;;| "If FLUSH?, first clean out the mailbox") (|if| FLUSH? |then| (CL:FORMAT MSTREAM "d~{ ~D~}~%" (|fetch| UMNUMBERS |of| MAILBOX))) (* |;;| "Then close it up") (CL:FORMAT MSTREAM "q~%") (CLOSEF MSTREAM) (* |;;|  "Twiddle a second to let the mailer run, then remember what time we closed the mailbox") (BLOCK 1000) (* |;;| "HACK! Depends on \\LAFITE.RETRIEVEMESSAGES binding of MAILSERVER") (|replace| (UNIXMAILFILEINFO UMFTIME) |of| (|fetch| (MAILSERVER MAILPORT) |of| MAILSERVER) |with| (IDATE ))))) (UNIXSPOOL.OPENMAILBOX (LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER) (* \;  "Edited 10-Feb-2000 12:03 by rmk:") (* \;  "Edited 10-Feb-2000 12:02 by rmk:") (* \; "Edited 11-Mar-99 16:09 by rmk:") (* \; "Edited 11-Mar-99 16:08 by rmk:") (IF (OR (FETCH (MAILSERVER NEWMAILP) OF MAILSERVER) (UNIX.POLLNEWMAIL ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER)) THEN (LET (MSTREAM UMBOX NUMBERS LOCKSTREAM) (BIND WRITEDATE (LOCKFILE _ (PACK* "{UNIX}" UNIXMAIL.SPOOL.FILE ".lock")) (TRYNUM _ 0) UNTIL (NLSETQ (SETQ LOCKSTREAM (OPEN LOCKFILE :DIRECTION :OUTPUT :IF-EXISTS :ERROR))) DO (IF (NULL (SETQ WRITEDATE (CAR (NLSETQ (GETFILEINFO LOCKFILE 'IWRITEDATE))))) THEN (* |;;|  "Error on writedate means file doesn't exist, go around immediately to acquire the lock.") (SETQ TRYNUM 0) ELSEIF (IGREATERP (- (IDATE) WRITEDATE) 300) THEN (* \; "Delete and try again") (SETQ TRYNUM 0) (DELFILE LOCKFILE) ELSE (ADD TRYNUM 1) (* \;  "File still exists and was recently modified; wait and try again") (CL:WHEN (EQ TRYNUM 4) (LAB.PROMPTPRINT MAILFOLDER "Unix mailbox file is locked, can't open") (ERROR!)) (DISMISS (TIMES TRYNUM 5000)))) (PRINTOUT LOCKSTREAM "0") (CLOSEF LOCKSTREAM) (* \;  "Close the lock file but use the closed stream later for the DELFILE.") (* |;;|  "Note: The THROUGH must come before the EOL, otherwise the file reverts back to CR.") (SETQ MSTREAM (OPENSTREAM (FETCH (UNIXMAILFILEINFO UMFNAME) OF (FETCH (MAILSERVER MAILPORT) OF MAILSERVER)) 'INPUT NIL '((TYPE TEXT) (EXTERNALFORMAT :THROUGH) (EOL LF)))) (SETQ UMBOX (CREATE UNIXMAILBOX UMSTREAM _ MSTREAM UMNUMBERS _ NIL UMNEXT _ NIL UMLOCKSTREAM _ LOCKSTREAM)) (* |;;| "Merrily scan the spool file remembering where all the messages start; there had better be at least one. All messages in Unix spool files start with the character sequence \"(OR beginning-of-file Newline)From \"; this sequence is guaranteed to occur nowhere else but at the start of messages.") (IF (ZEROP (FILEPOS "From " MSTREAM)) THEN (PUSH NUMBERS 0) (* |;;| "The (CONCAT...) stuff below is to avoid having a string with a LF character in it; the file package/reader/printer have been known to EOL-translate such characters in strings inappropriately.") (BIND POS WHILE (SETQ POS (FILEPOS (CONSTANT (CONCAT (CHARACTER (CHARCODE LF)) "From ")) MSTREAM)) DO (PUSH NUMBERS (ADD1 POS)) (READCCODE MSTREAM)) (SETQ NUMBERS (DREVERSE NUMBERS)) (REPLACE UMNUMBERS OF UMBOX WITH NUMBERS) (REPLACE UMNEXT OF UMBOX WITH NUMBERS) (SETFILEPTR MSTREAM 0) (CREATE OPENEDMAILBOX MAILBOX _ UMBOX PROPERTIES _ (LIST '\#OFMESSAGES (LENGTH NUMBERS))) ELSE (CL:UNLESS (ZEROP (GETEOFPTR MSTREAM)) (LAB.PROMPTPRINT MAILFOLDER "Mail spool file is not in Unix format: " (FETCH (UNIXMAILFILEINFO UMFNAME) OF (FETCH (MAILSERVER MAILPORT) OF MAILSERVER )) ": ")) (CLOSEF MSTREAM) 'EMPTY)) ELSE 'EMPTY))) (UNIXSPOOL.RETRIEVEMESSAGE (LAMBDA (MAILBOX MSGOUTFILE) (* \; "Edited 10-Mar-99 08:59 by rmk:") (* \; "Edited 10-Mar-99 08:57 by rmk:") (* \; "Edited 10-Mar-99 08:55 by rmk:") (* \; "Edited 10-Mar-99 08:54 by rmk:") (* \; "Edited 10-Mar-99 08:44 by rmk:") (* \; "Edited 26-Feb-99 11:25 by rmk:") (LET ((MSTREAM (|fetch| UMSTREAM |of| MAILBOX)) (OUTSTART (GETFILEPTR MSGOUTFILE))) (* |;;| "The numbers in the UMNEXT of the mailbox are file positions in the spool file of the start of each message, so to get a message, just COPYCHARS from the start of the current message to the start of the next one.") (* |;;| "") (* |;;| "NOTE, however, that a message in a Unix mailbox begins with a \"From \" line which should not be copied.") (LET ((MSTART (|pop| (|fetch| UMNEXT |of| MAILBOX))) (MEND (OR (CAR (|fetch| UMNEXT |of| MAILBOX)) (GETEOFPTR MSTREAM)))) (* |;;| "Confirm and skip the From line.") (CL:UNLESS (EQ (CHARCODE F) (READCCODE MSTREAM)) (ERROR "Not a valid Unix mail-spool file" (FULLNAME MSTREAM))) (UNTIL (MEMB (BIN MSTREAM) (CHARCODE (LF CR)))) (COPYCHARS MSTREAM MSGOUTFILE (GETFILEPTR MSTREAM) MEND)) (* |;;|  "This could use a little error-handling, of course... perhaps a LOT of error handling.") (* |;;| "Check out the tail of the message and uudecode it if it's an encoded message") (UNIX.UUDECODE.IF.NEEDED MSGOUTFILE OUTSTART)))) (UNIXSPOOL.CLOSEMAILBOX (LAMBDA (MAILBOX FLUSH?) (* \; "Edited 10-Mar-99 08:45 by rmk:") (* \; "Edited 15-Oct-90 20:46 by jrb:") (LET ((MSTREAM (|fetch| UMSTREAM |of| MAILBOX))) (* |;;| "If FLUSH?, nuke the spool file") (|if| FLUSH? |then| (SETFILEINFO (|fetch| (UNIXMAILFILEINFO UMFNAME) |of| (|fetch| (MAILSERVER MAILPORT) |of| MAILSERVER) ) 'LENGTH 0) (* |;;| "HACK! Depends on \\LAFITE.RETRIEVEMESSAGES binding of MAILSERVER") (|replace| (UNIXMAILFILEINFO UMFTIME) |of| (|fetch| (MAILSERVER MAILPORT) |of| MAILSERVER) |with| (IDATE))) (* |;;| " In any event, close the mailbox stream") (CLOSEF MSTREAM) (DELFILE (FULLNAME (FETCH UMLOCKSTREAM OF MAILBOX)))))) ) (* |;;| "Functions used to send mail") (DEFINEQ (UNIX.FLUSH.STREAM (LAMBDA (STREAM CHAR) (* \; "Edited 13-Sep-90 15:58 by jrb:") (* |;;| "Just vacuum out the stream until you see CHAR (if it's NIL, read until EOF)") (* |;;| "If CHAR is supplied, stream must not be at EOF") (|if| CHAR |then| (|until| (OR (NOT (READP STREAM)) (EQ (READCCODE STREAM) CHAR)) |do| NIL) |else| (|until| (NOT (READP STREAM)) |do| (READCCODE STREAM))) STREAM)) (UNIX.RETRIEVE.LINE (LAMBDA (MSTREAM MSGOUTFILE) (* \; "Edited 18-Sep-89 14:39 by jrb:") (* |;;| "Copies a line of text from MSTREAM to MSGOUTFILE except if that line starts with a strange character (charcode 254; see UNIX.RETRIEVEMESSAGE). Returns NIL on seeing such a line") (BLOCK) (* \;  "This looks like a good place...") (LET ((CHAR (READCCODE MSTREAM))) (|if| (EQ CHAR 254) |then| (SETQ CHAR NIL)) (* |;;| "When we get here, if CHAR is non-NIL, it needs to be printed to MSGOUTFILE") (|if| CHAR |then| (PRINTCCODE CHAR MSGOUTFILE) (|until| (EQ CHAR (CHARCODE NEWLINE)) |do| (PRINTCCODE (SETQ CHAR (READCCODE MSTREAM )) MSGOUTFILE)) T)))) (\\UNIXMAIL.SEND - (LAMBDA (MSG PARSE EDITORWINDOW ABORTWINDOW) (* \; "Edited 4-Jul-99 21:26 by rmk:") - (* \; "Edited 2-Apr-99 15:44 by rmk:") - (* \; - "Edited 6-Apr-97 17:27 by sybalsky:mv:envos") +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) +(FILECREATED "30-Sep-2021 16:06:26"  +|{DSK}kaplan>Local>medley3.5>git-medley>library>UNIXMAIL.;2| 82866 - (* |;;| "The strategy here is to talk to an SMTP server and throw the message at it.") + |changes| |to:| (VARS UNIXMAILCOMS) + (FNS UNIX.POLLNEWMAIL UNIX.NEXTMESSAGE UNIXMAILER.OPENMAILBOX + UNIXMAILER.RETRIEVEMESSAGE UNIXMAILER.CLOSEMAILBOX UNIXSPOOL.OPENMAILBOX + UNIXSPOOL.RETRIEVEMESSAGE UNIXSPOOL.CLOSEMAILBOX UNIX.FLUSH.STREAM + UNIX.RETRIEVE.LINE \\UNIXMAIL.SEND \\UNIXMAIL.SEND.WRAPLINES \\SMTP-DUMP + \\UNIXMAIL.SEND.PARSE \\UNIXMAIL.CHECK.ABORT \\UNIXMAIL.MUNG.RECIPIENTS + \\UNIXMAIL.SMTP \\UNIXMAIL.SMTP.FLUSH \\UNIXMAIL.CHANGE.MODE + \\UNIXMAIL.AUTHENTICATE \\UNIXMAIL.LOGIN \\UNIXMAIL.PARSENAMES + \\UNIXMAIL.MAKEANSWERFORM \\UNIXMAIL.MESSAGE.FROM.SELF.P + \\UNIXMAIL.MESSAGE.P \\UNIXMAIL.REALADDRESS \\UNIXMAIL.FQNAME + \\UNIXMAIL.FIXMICROSOFT) + + |previous| |date:| "10-Feb-2000 12:03:28" |{DSK}medley3.5>library>unixmail.;42|) + + +; Copyright (c) 1989-1992, 1997, 1999, 1920, 2021 by ENVOS Corporation. + +(PRETTYCOMPRINT UNIXMAILCOMS) + +(RPAQQ UNIXMAILCOMS + ((DECLARE\: DOEVAL@COMPILE DONTCOPY (FILES (SOURCE) + LAFITEDECLS NSMAIL) + (RECORDS UNIXMAILBOX UNIXMAILFILEINFO UNIXMAILPARSE)) + (ALISTS (LAFITEMODELST UNIX)) + + (* |;;| "JDS 4/6/97: CHANGE TRANSMIT SMTP INTERACTION TO put <> around mail-from name, which SMTP seems to require.") + + + (* |;;| "These variables control how mail is sent and received. UNIXMAIL.SEND.MODE controls whether the SMTP stream is opened via process-stream (PROCESS) or TCP socket (TCP). UNIXMAIL.RECEIVE.MODE controls whether mail is received through the Berkeley mailer (MAILER) or by reading the spool file directly (SPOOL). PROCESS and MAILER can only be done under an emulator; TCP and SPOOL will also work on D-machines (but may need other library packages like TCP or NFS).") + + (INITVARS (UNIXMAIL.SEND.MODE 'PROCESS) + (UNIXMAIL.RECEIVE.MODE 'SPOOL)) + + (* |;;| "List used by \\UNIXMAIL.AUTHENTICATE to construct the MAILSERVEROPS list") + + (VARS UNIXMAIL.MSOPS.LIST) + + (* |;;| "These variables control filenames, hostnames, etc. They default to NIL, meaning they are not used or the mailer will try and figure them out itself") + + (INITVARS UNIXMAIL.SEND.HOST UNIXMAIL.DOMAIN.NAME (UNIXMAIL.SEND.PROCESS '( + "/usr/bin/mconnect" + + "/usr/etc/mconnect" + )) + (UNIXMAIL.RECEIVE.PROCESS "/usr/ucb/mail -N") + UNIXMAIL.SPOOL.FILE + (UNIXMAIL.DONT.RECEIVE.STATUS "") + (UNIXMAIL.WRAP.LINES T) + (UNIXMAIL.WRAP-LIMIT 72) + (UNIXMAIL.TABWIDTH 8)) + + (* |;;| "Functions used to receive mail") + + (FNS UNIX.POLLNEWMAIL UNIX.NEXTMESSAGE UNIXMAILER.OPENMAILBOX UNIXMAILER.RETRIEVEMESSAGE + UNIXMAILER.CLOSEMAILBOX UNIXSPOOL.OPENMAILBOX UNIXSPOOL.RETRIEVEMESSAGE + UNIXSPOOL.CLOSEMAILBOX) + + (* |;;| "Functions used to send mail") + + (FNS UNIX.FLUSH.STREAM UNIX.RETRIEVE.LINE \\UNIXMAIL.SEND \\UNIXMAIL.SEND.WRAPLINES + \\SMTP-DUMP \\UNIXMAIL.SEND.PARSE \\UNIXMAIL.CHECK.ABORT \\UNIXMAIL.MUNG.RECIPIENTS + \\UNIXMAIL.SMTP \\UNIXMAIL.SMTP.FLUSH \\UNIXMAIL.CHANGE.MODE) + + (* |;;| "This returns multiple-values, so it's a CL:LAMBDA (what the heck).") + + (FUNCTIONS \\UNIXMAIL.SMTP.TCP.STREAMS) + + (* |;;| "Other functions Lafite uses and needs Unix equivalents for") + + (FNS \\UNIXMAIL.AUTHENTICATE \\UNIXMAIL.LOGIN \\UNIXMAIL.PARSENAMES \\UNIXMAIL.MAKEANSWERFORM + \\UNIXMAIL.MESSAGE.FROM.SELF.P \\UNIXMAIL.MESSAGE.P \\UNIXMAIL.REALADDRESS + \\UNIXMAIL.FQNAME \\UNIXMAIL.FIXMICROSOFT) + + (* |;;| "This is a stub needed by the TEdit-uuencode strategy; if we ever decide on a reasonable way to do this and make it part of Lafite, this may go away") + + (P (MOVD? 'NILL 'UNIX.UUDECODE.IF.NEEDED)) + + (* |;;| "Hack to install easy interface for line wrapping. I should really put line-wrapping into Lafite as a whole.") + + (P (CL:WHEN (CAR (NLSETQ (EDITE LAFITESENDINGMENUITEMS '(F \\SENDMSG.CHANGE.MODE)))) + + (* |;;| "The CONS below insures that Lafite notices you've changed LAFITESENDINGMENUITEMS, so the menu will get updated.") + + (SETQ LAFITESENDINGMENUITEMS (EDITE (CONS (CAR LAFITESENDINGMENUITEMS) + (CDR LAFITESENDINGMENUITEMS)) + '(CHANGE \\SENDMSG.CHANGE.MODE TO + \\UNIXMAIL.CHANGE.MODE))))) + (PROP FILETYPE UNIXMAIL))) +(DECLARE\: DOEVAL@COMPILE DONTCOPY + +(FILESLOAD (SOURCE) + LAFITEDECLS NSMAIL) + +(DECLARE\: EVAL@COMPILE + +(RECORD UNIXMAILBOX (UMSTREAM UMNUMBERS UMNEXT UMLOCKSTREAM)) + +(RECORD UNIXMAILFILEINFO (UMFNAME UMFTIME)) + +(RECORD UNIXMAILPARSE (UNIXMAILSUBJECT UNIXFROM UNIXTO UNIXOTHER FORMATTED? UNIXBODY)) +) +) + +(ADDTOVAR LAFITEMODELST (UNIX 3 \\UNIXMAIL.SEND.PARSE \\UNIXMAIL.SEND \\UNIXMAIL.MAKEANSWERFORM + \\UNIXMAIL.AUTHENTICATE \\UNIXMAIL.MESSAGE.P + \\UNIXMAIL.MESSAGE.FROM.SELF.P \\UNIXMAIL.LOGIN)) + + + +(* |;;| +"JDS 4/6/97: CHANGE TRANSMIT SMTP INTERACTION TO put <> around mail-from name, which SMTP seems to require." +) + + + + +(* |;;| +"These variables control how mail is sent and received. UNIXMAIL.SEND.MODE controls whether the SMTP stream is opened via process-stream (PROCESS) or TCP socket (TCP). UNIXMAIL.RECEIVE.MODE controls whether mail is received through the Berkeley mailer (MAILER) or by reading the spool file directly (SPOOL). PROCESS and MAILER can only be done under an emulator; TCP and SPOOL will also work on D-machines (but may need other library packages like TCP or NFS)." +) + + +(RPAQ? UNIXMAIL.SEND.MODE 'PROCESS) + +(RPAQ? UNIXMAIL.RECEIVE.MODE 'SPOOL) + + + +(* |;;| "List used by \\UNIXMAIL.AUTHENTICATE to construct the MAILSERVEROPS list") + + +(RPAQQ UNIXMAIL.MSOPS.LIST ((MAILER UNIX.POLLNEWMAIL UNIXMAILER.OPENMAILBOX UNIX.NEXTMESSAGE + UNIXMAILER.RETRIEVEMESSAGE UNIXMAILER.CLOSEMAILBOX) + (SPOOL UNIX.POLLNEWMAIL UNIXSPOOL.OPENMAILBOX UNIX.NEXTMESSAGE + UNIXSPOOL.RETRIEVEMESSAGE UNIXSPOOL.CLOSEMAILBOX))) + + + +(* |;;| +"These variables control filenames, hostnames, etc. They default to NIL, meaning they are not used or the mailer will try and figure them out itself" +) + + +(RPAQ? UNIXMAIL.SEND.HOST NIL) + +(RPAQ? UNIXMAIL.DOMAIN.NAME NIL) + +(RPAQ? UNIXMAIL.SEND.PROCESS '("/usr/bin/mconnect" "/usr/etc/mconnect")) + +(RPAQ? UNIXMAIL.RECEIVE.PROCESS "/usr/ucb/mail -N") + +(RPAQ? UNIXMAIL.SPOOL.FILE NIL) + +(RPAQ? UNIXMAIL.DONT.RECEIVE.STATUS "") + +(RPAQ? UNIXMAIL.WRAP.LINES T) + +(RPAQ? UNIXMAIL.WRAP-LIMIT 72) + +(RPAQ? UNIXMAIL.TABWIDTH 8) + + + +(* |;;| "Functions used to receive mail") + +(DEFINEQ + +(UNIX.POLLNEWMAIL + (LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER)(* \; "Edited 19-May-99 10:34 by rmk:") + (* \; "Edited 24-Oct-90 00:04 by jrb:") + + (* |;;| "We have mail iff our mail spool file (either the value of UNIXMAIL.SPOOL.FILE or /usr/spool/mail/) exists and its date is later than the last time we got our Unix mail. In relentlessly hackish use of the existing MAILSERVER structure, MAILPORT holds a UNIXMAILFILEINFO which remembers the name of our mail file and when we last looked at it.") + + (LET (X (FILEINFO (OR (|fetch| (MAILSERVER MAILPORT) |of| MAILSERVER) + (|replace| (MAILSERVER MAILPORT) |of| MAILSERVER + |with| (|create| UNIXMAILFILEINFO + UMFNAME _ (OR UNIXMAIL.SPOOL.FILE + (CL:CONCATENATE 'STRING + "{UNIX}/usr/spool/mail/" + (|fetch| (LAFITEMODEDATA + SHORTUSERNAME) + |of| *LAFITE-MODE-DATA*))) + UMFTIME _ 0))))) + (AND (CL:PROBE-FILE (|fetch| (UNIXMAILFILEINFO UMFNAME) |of| FILEINFO)) + (SETQ X (GETFILEINFO (|fetch| (UNIXMAILFILEINFO UMFNAME) |of| FILEINFO) + 'LENGTH)) + (IGREATERP X 0) + (SETQ X (GETFILEINFO (|fetch| (UNIXMAILFILEINFO UMFNAME) |of| FILEINFO) + 'IWRITEDATE)) + (IGREATERP X (|fetch| (UNIXMAILFILEINFO UMFTIME) |of| FILEINFO)))))) + +(UNIX.NEXTMESSAGE + (LAMBDA (MAILBOX) (* \; "Edited 5-Jan-89 18:18 by bane") + (CAR (|fetch| UMNEXT |of| MAILBOX)))) + +(UNIXMAILER.OPENMAILBOX + (LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER)(* \; "Edited 15-Oct-90 20:31 by jrb:") + + (* |;;| "A Unix \"mailbox\" is a process-stream talking to /usr/ucb/mail ") + + (|if| (OR (|fetch| (MAILSERVER NEWMAILP) |of| MAILSERVER) + (UNIX.POLLNEWMAIL ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER)) + |then| (LET* ((MSTREAM (CREATE-PROCESS-STREAM UNIXMAIL.RECEIVE.PROCESS)) + (UMBOX (|create| UNIXMAILBOX + UMSTREAM _ MSTREAM + UMNUMBERS _ NIL + UMNEXT _ NIL)) + NUMBERS) + + (* |;;| "Get it in condition to be talked to") + + (CL:FORMAT MSTREAM "set screen=10000~%set prompt= ~%") + (BLOCK 1000) + (UNIX.FLUSH.STREAM MSTREAM) + + (* |;;| +"OK, get it to print the headers followed by a line with a strange character on it (char code 254)") + + (CL:FORMAT MSTREAM "h~%echo ") + (PRINTCCODE 254 MSTREAM) + (PRINTCCODE (CHARCODE NEWLINE) + MSTREAM) + + (* |;;| + "Before we really get rolling, scream if UNIXMAIL.DONT.RECEIVE.STATUS isn't a string") + + (OR (STRINGP UNIXMAIL.DONT.RECEIVE.STATUS) + (ERROR "UNIXMAIL.DONT.RECEIVE.STATUS isn't a string" + UNIXMAIL.DONT.RECEIVE.STATUS)) + + (* |;;| "Headers look like this:") + + (* |;;| " other junk like size, subject...") + + (|until| (EQ (READCCODE MSTREAM) + 254) |do| (|if| (NULL (STRPOS (CL:READ-CHAR MSTREAM + ) + + UNIXMAIL.DONT.RECEIVE.STATUS + )) + |then| (|push| NUMBERS + (READ MSTREAM))) + (UNIX.FLUSH.STREAM MSTREAM (CHARCODE NEWLINE + )) + |finally| (UNIX.FLUSH.STREAM MSTREAM (CHARCODE NEWLINE))) + (|if| NUMBERS + |then| (SETQ NUMBERS (DREVERSE NUMBERS)) + (|replace| UMNUMBERS |of| UMBOX |with| NUMBERS) + (|replace| UMNEXT |of| UMBOX |with| NUMBERS) + (|create| OPENEDMAILBOX + MAILBOX _ UMBOX + PROPERTIES _ (LIST '\#OFMESSAGES (LENGTH NUMBERS))) + |else| (CL:FORMAT MSTREAM "x~%") + (* \; "Empty; close the mail process") + (* \; + "and remember that we've checked on the mailbox.") + (* \; + "HACK! Depends on \\LAFITE.RETRIEVEMESSAGES binding of MAILSERVER") + (|replace| (UNIXMAILFILEINFO UMFTIME) |of| + (|fetch| (MAILSERVER + MAILPORT) + |of| MAILSERVER) + |with| (IDATE)) + 'EMPTY)) + |else| 'EMPTY))) + +(UNIXMAILER.RETRIEVEMESSAGE + (LAMBDA (MAILBOX MSGOUTFILE) (* \; "Edited 5-Sep-90 22:58 by jrb:") + (LET ((MSTREAM (|fetch| UMSTREAM |of| MAILBOX)) + (OUTSTART (GETFILEPTR MSGOUTFILE))) + + (* |;;| "The UMCOUNT in the MAILBOX is the number of the message we're about to read in. The echo command below makes the message text be followed by a line starting with the character 254; you'll never see that in a message that has gone over an SMTP channel (guaranteed 7-bit chars).") + + (CL:FORMAT MSTREAM "p ~d~%echo " (|pop| (|fetch| UMNEXT |of| MAILBOX))) + (PRINTCCODE 254 MSTREAM) + (PRINTCCODE (CHARCODE NEWLINE) + MSTREAM) + (UNIX.FLUSH.STREAM MSTREAM (CHARCODE NEWLINE)) (* \; "Throw away \"Message 1:\" line") + (|while| (UNIX.RETRIEVE.LINE MSTREAM MSGOUTFILE) |do| NIL) + + (* |;;| + "This could use a little error-handling, of course... perhaps a LOT of error handling.") + + (* |;;| "Check out the tail of the message and uudecode it if it's an encoded message") + + (UNIX.UUDECODE.IF.NEEDED MSGOUTFILE OUTSTART)))) + +(UNIXMAILER.CLOSEMAILBOX + (LAMBDA (MAILBOX FLUSH?) (* \; "Edited 5-Sep-90 23:01 by jrb:") + (LET ((MSTREAM (|fetch| UMSTREAM |of| MAILBOX))) + + (* |;;| "If FLUSH?, first clean out the mailbox") + + (|if| FLUSH? + |then| (CL:FORMAT MSTREAM "d~{ ~D~}~%" (|fetch| UMNUMBERS |of| MAILBOX))) + + (* |;;| "Then close it up") + + (CL:FORMAT MSTREAM "q~%") + (CLOSEF MSTREAM) + + (* |;;| + "Twiddle a second to let the mailer run, then remember what time we closed the mailbox") + + (BLOCK 1000) + + (* |;;| "HACK! Depends on \\LAFITE.RETRIEVEMESSAGES binding of MAILSERVER") + + (|replace| (UNIXMAILFILEINFO UMFTIME) |of| (|fetch| (MAILSERVER MAILPORT) + |of| MAILSERVER) |with| (IDATE + ))))) + +(UNIXSPOOL.OPENMAILBOX + (LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER) + (* \; "Edited 10-Feb-2000 12:03 by rmk:") + (* \; "Edited 10-Feb-2000 12:02 by rmk:") + (* \; "Edited 11-Mar-99 16:09 by rmk:") + (* \; "Edited 11-Mar-99 16:08 by rmk:") + (IF (OR (FETCH (MAILSERVER NEWMAILP) OF MAILSERVER) + (UNIX.POLLNEWMAIL ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER)) + THEN (LET (MSTREAM UMBOX NUMBERS LOCKSTREAM) + (BIND WRITEDATE (LOCKFILE _ (PACK* "{UNIX}" UNIXMAIL.SPOOL.FILE ".lock")) + (TRYNUM _ 0) UNTIL (NLSETQ (SETQ LOCKSTREAM + (OPEN LOCKFILE :DIRECTION :OUTPUT + :IF-EXISTS :ERROR))) + DO (IF (NULL (SETQ WRITEDATE (CAR (NLSETQ (GETFILEINFO LOCKFILE + 'IWRITEDATE))))) + THEN + + (* |;;| + "Error on writedate means file doesn't exist, go around immediately to acquire the lock.") + + (SETQ TRYNUM 0) + ELSEIF (IGREATERP (- (IDATE) + WRITEDATE) + 300) + THEN (* \; "Delete and try again") + (SETQ TRYNUM 0) + (DELFILE LOCKFILE) + ELSE (ADD TRYNUM 1) + (* \; + "File still exists and was recently modified; wait and try again") + (CL:WHEN (EQ TRYNUM 4) + (LAB.PROMPTPRINT MAILFOLDER + "Unix mailbox file is locked, can't open") + (ERROR!)) + (DISMISS (TIMES TRYNUM 5000)))) + (PRINTOUT LOCKSTREAM "0") + (CLOSEF LOCKSTREAM) (* \; + "Close the lock file but use the closed stream later for the DELFILE.") + + (* |;;| + "Note: The THROUGH must come before the EOL, otherwise the file reverts back to CR.") + + (SETQ MSTREAM (OPENSTREAM (FETCH (UNIXMAILFILEINFO UMFNAME) + OF (FETCH (MAILSERVER MAILPORT) + OF MAILSERVER)) + 'INPUT NIL '((TYPE TEXT) + (EXTERNALFORMAT :THROUGH) + (EOL LF)))) + (SETQ UMBOX + (CREATE UNIXMAILBOX + UMSTREAM _ MSTREAM + UMNUMBERS _ NIL + UMNEXT _ NIL + UMLOCKSTREAM _ LOCKSTREAM)) + + (* |;;| "Merrily scan the spool file remembering where all the messages start; there had better be at least one. All messages in Unix spool files start with the character sequence \"(OR beginning-of-file Newline)From \"; this sequence is guaranteed to occur nowhere else but at the start of messages.") + + (IF (ZEROP (FILEPOS "From " MSTREAM)) + THEN (PUSH NUMBERS 0) + + (* |;;| "The (CONCAT...) stuff below is to avoid having a string with a LF character in it; the file package/reader/printer have been known to EOL-translate such characters in strings inappropriately.") + + (BIND POS WHILE (SETQ POS + (FILEPOS (CONSTANT + (CONCAT (CHARACTER (CHARCODE + LF)) + "From ")) + MSTREAM)) + DO (PUSH NUMBERS (ADD1 POS)) + (READCCODE MSTREAM)) + (SETQ NUMBERS (DREVERSE NUMBERS)) + (REPLACE UMNUMBERS OF UMBOX WITH NUMBERS) + (REPLACE UMNEXT OF UMBOX WITH NUMBERS) + (SETFILEPTR MSTREAM 0) + (CREATE OPENEDMAILBOX + MAILBOX _ UMBOX + PROPERTIES _ (LIST '\#OFMESSAGES (LENGTH NUMBERS))) + ELSE (CL:UNLESS (ZEROP (GETEOFPTR MSTREAM)) + (LAB.PROMPTPRINT MAILFOLDER + "Mail spool file is not in Unix format: " + (FETCH (UNIXMAILFILEINFO UMFNAME) + OF (FETCH (MAILSERVER MAILPORT) OF + MAILSERVER + )) + ": ")) + (CLOSEF MSTREAM) + 'EMPTY)) + ELSE 'EMPTY))) + +(UNIXSPOOL.RETRIEVEMESSAGE + (LAMBDA (MAILBOX MSGOUTFILE) (* \; "Edited 10-Mar-99 08:59 by rmk:") + (* \; "Edited 10-Mar-99 08:57 by rmk:") + (* \; "Edited 10-Mar-99 08:55 by rmk:") + (* \; "Edited 10-Mar-99 08:54 by rmk:") + (* \; "Edited 10-Mar-99 08:44 by rmk:") + (* \; "Edited 26-Feb-99 11:25 by rmk:") + (LET ((MSTREAM (|fetch| UMSTREAM |of| MAILBOX)) + (OUTSTART (GETFILEPTR MSGOUTFILE))) + + (* |;;| "The numbers in the UMNEXT of the mailbox are file positions in the spool file of the start of each message, so to get a message, just COPYCHARS from the start of the current message to the start of the next one.") + + (* |;;| "") + + (* |;;| "NOTE, however, that a message in a Unix mailbox begins with a \"From \" line which should not be copied.") + + (LET ((MSTART (|pop| (|fetch| UMNEXT |of| MAILBOX))) + (MEND (OR (CAR (|fetch| UMNEXT |of| MAILBOX)) + (GETEOFPTR MSTREAM)))) + + (* |;;| "Confirm and skip the From line.") + + (CL:UNLESS (EQ (CHARCODE F) + (READCCODE MSTREAM)) + (ERROR "Not a valid Unix mail-spool file" (FULLNAME MSTREAM))) + (UNTIL (MEMB (BIN MSTREAM) + (CHARCODE (LF CR)))) + (COPYCHARS MSTREAM MSGOUTFILE (GETFILEPTR MSTREAM) + MEND)) + + (* |;;| + "This could use a little error-handling, of course... perhaps a LOT of error handling.") + + (* |;;| "Check out the tail of the message and uudecode it if it's an encoded message") + + (UNIX.UUDECODE.IF.NEEDED MSGOUTFILE OUTSTART)))) + +(UNIXSPOOL.CLOSEMAILBOX + (LAMBDA (MAILBOX FLUSH?) (* \; "Edited 10-Mar-99 08:45 by rmk:") + (* \; "Edited 15-Oct-90 20:46 by jrb:") + (LET ((MSTREAM (|fetch| UMSTREAM |of| MAILBOX))) + + (* |;;| "If FLUSH?, nuke the spool file") + + (|if| FLUSH? + |then| (SETFILEINFO (|fetch| (UNIXMAILFILEINFO UMFNAME) + |of| (|fetch| (MAILSERVER MAILPORT) |of| + MAILSERVER) + ) + 'LENGTH 0) + + (* |;;| "HACK! Depends on \\LAFITE.RETRIEVEMESSAGES binding of MAILSERVER") + + (|replace| (UNIXMAILFILEINFO UMFTIME) |of| (|fetch| (MAILSERVER + MAILPORT) + |of| MAILSERVER) + |with| (IDATE))) + + (* |;;| " In any event, close the mailbox stream") + + (CLOSEF MSTREAM) + (DELFILE (FULLNAME (FETCH UMLOCKSTREAM OF MAILBOX)))))) +) + + + +(* |;;| "Functions used to send mail") + +(DEFINEQ + +(UNIX.FLUSH.STREAM + (LAMBDA (STREAM CHAR) (* \; "Edited 13-Sep-90 15:58 by jrb:") + + (* |;;| "Just vacuum out the stream until you see CHAR (if it's NIL, read until EOF)") + + (* |;;| "If CHAR is supplied, stream must not be at EOF") + + (|if| CHAR + |then| (|until| (OR (NOT (READP STREAM)) + (EQ (READCCODE STREAM) + CHAR)) |do| NIL) + |else| (|until| (NOT (READP STREAM)) |do| (READCCODE STREAM))) + STREAM)) + +(UNIX.RETRIEVE.LINE + (LAMBDA (MSTREAM MSGOUTFILE) (* \; "Edited 18-Sep-89 14:39 by jrb:") + + (* |;;| "Copies a line of text from MSTREAM to MSGOUTFILE except if that line starts with a strange character (charcode 254; see UNIX.RETRIEVEMESSAGE). Returns NIL on seeing such a line") + + (BLOCK) (* \; + "This looks like a good place...") + (LET ((CHAR (READCCODE MSTREAM))) + (|if| (EQ CHAR 254) + |then| (SETQ CHAR NIL)) + + (* |;;| "When we get here, if CHAR is non-NIL, it needs to be printed to MSGOUTFILE") + + (|if| CHAR + |then| (PRINTCCODE CHAR MSGOUTFILE) + (|until| (EQ CHAR (CHARCODE NEWLINE)) |do| (PRINTCCODE (SETQ CHAR + (READCCODE MSTREAM + )) + MSGOUTFILE)) + T)))) + +(\\UNIXMAIL.SEND + (LAMBDA (MSG PARSE EDITORWINDOW ABORTWINDOW) (* \; "Edited 4-Jul-99 21:26 by rmk:") + (* \; "Edited 2-Apr-99 15:44 by rmk:") + (* \; + "Edited 6-Apr-97 17:27 by sybalsky:mv:envos") + + (* |;;| "The strategy here is to talk to an SMTP server and throw the message at it.") (|if| (AND (TEDIT.FORMATTEDFILEP MSG) (EQ (|fetch| (UNIXMAILPARSE FORMATTED?) |of| PARSE) @@ -31,14 +540,14 @@ (CL:FLET ((GIVE-UP-AND-DIE (&REST WHY) - (* |;;| "Close up the SMTP streams, send up a flare for the user and return NIL") + (* |;;| "Close up the SMTP streams, send up a flare for the user and return NIL") (IGNORE-ERRORS (CLOSEF SMIN) (CLOSEF SMOUT)) (\\LAFITE.SEND.FAIL EDITORWINDOW (CL:APPLY #'CL:FORMAT NIL WHY)) NIL)) - (* |;;| "Get the connection ready to talk to") + (* |;;| "Get the connection ready to talk to") (|for| I |from| 1 |to| 5 |while| (SETQ RESULT (\\UNIXMAIL.SMTP.FLUSH SMIN)) |do| NIL) @@ -52,13 +561,13 @@ (LENGTH RECIPIENTS))) (|if| (SETQ RESULT (CL:CATCH 'SMTP-LOST - (* |;;| "First, announce who we are") + (* |;;| "First, announce who we are") (\\UNIXMAIL.SMTP SMIN SMOUT (CL:FORMAT NIL "HELO ~a~%" (UNIX-GETPARM "HOSTNAME" ))) - (* |;;| "Then send who it's from") + (* |;;| "Then send who it's from") (\\UNIXMAIL.SMTP SMIN SMOUT (CL:FORMAT NIL "MAIL FROM: <~a>~%" @@ -71,22 +580,22 @@ *LAFITE-MODE-DATA* )))) - (* |;;| "Then the recipients") + (* |;;| "Then the recipients") (|for| R |in| RECIPIENTS |do| (\\UNIXMAIL.SMTP SMIN SMOUT (CL:FORMAT NIL "RCPT TO: <~a>~%" R))) - (* |;;| "Print a '.' to show we're this far") + (* |;;| "Print a '.' to show we're this far") (AND PWINDOW (|printout| PWINDOW '\.)) - (* |;;| - "Then the message itself; the SMTP response here is a 300-range number meaning \"Lay it on me\"") + (* |;;| + "Then the message itself; the SMTP response here is a 300-range number meaning \"Lay it on me\"") (\\UNIXMAIL.SMTP SMIN SMOUT "DATA~%" 300 399) - (* |;;| "First hose out the other fields") + (* |;;| "First hose out the other fields") (CL:FORMAT SMOUT "From: ~a~%" (\\UNIXMAIL.FQNAME (|fetch| (LAFITEMODEDATA @@ -107,7 +616,7 @@ |of| PARSE))) (TERPRI SMOUT)) - (* |;;| "Print a '.' to show we're this far") + (* |;;| "Print a '.' to show we're this far") (AND PWINDOW (|printout| PWINDOW '\.)) (|if| (TEDIT.FORMATTEDFILEP MSG) @@ -117,8 +626,8 @@ "UNIX mode can't send raw TEdit; try TEdit-UUencoded" )) (TEDIT-UUENCODE - (* |;;| - "Nuke the header in a copy of the msg") + (* |;;| + "Nuke the header in a copy of the msg") (SETQ MSG (COPYTEXTSTREAM MSG)) (TEDIT.DELETE MSG 1 (|fetch| @@ -127,7 +636,7 @@ |of| PARSE)) (UNIX.TEDIT-UUENCODE.MESSAGE MSG SMOUT)) (NIL - (* |;;| "Strip TEdit formatting") + (* |;;| "Strip TEdit formatting") (\\SMTP-DUMP (LAFITE.MAKE.PLAIN.TEXTSTREAM @@ -146,7 +655,7 @@ SMOUT) (\\UNIXMAIL.SMTP SMIN SMOUT "~%.~%") - (* |;;| "Print a '.' to show we're this far") + (* |;;| "Print a '.' to show we're this far") (AND PWINDOW (|printout| PWINDOW '\.)) (\\UNIXMAIL.SMTP SMIN SMOUT "QUIT~%") @@ -157,9 +666,11 @@ |else| (\\UNIXMAIL.CHECK.ABORT ABORTWINDOW SMIN SMOUT) (IGNORE-ERRORS (CLOSEF SMIN) (CLOSEF SMOUT)) - (LENGTH RECIPIENTS))))))))) (\\UNIXMAIL.SEND.WRAPLINES - (LAMBDA (INSTREAM OUTSTREAM) (* \; "Edited 4-Jul-99 21:14 by rmk:") - (* \; "Edited 4-Jul-99 21:11 by rmk:") + (LENGTH RECIPIENTS))))))))) + +(\\UNIXMAIL.SEND.WRAPLINES + (LAMBDA (INSTREAM OUTSTREAM) (* \; "Edited 4-Jul-99 21:14 by rmk:") + (* \; "Edited 4-Jul-99 21:11 by rmk:") (LET ((BUF (CL:MAKE-ARRAY (IPLUS UNIXMAIL.WRAP-LIMIT 8) :ELEMENT-TYPE 'CL:CHARACTER)) @@ -215,11 +726,13 @@ (CL:CHAR BUF BPTR))) (SETQ BPTR C BLENGTH C LASTWS NIL) |else| (DUMP-BUFFER) - (SETQ LASTWS NIL))) |finally| (DUMP-BUFFER)))))) (\\SMTP-DUMP - (LAMBDA (INSTREAM OUTSTREAM) (* \; "Edited 4-Jul-99 21:20 by rmk:") - (* \; "Edited 4-Jul-99 21:17 by rmk:") + (SETQ LASTWS NIL))) |finally| (DUMP-BUFFER)))))) - (* |;;| "In both wrapped and unwrapped cases, we have to treat specially lines beginning with '.': the '.' must be doubled when talking to the SMTP server.") +(\\SMTP-DUMP + (LAMBDA (INSTREAM OUTSTREAM) (* \; "Edited 4-Jul-99 21:20 by rmk:") + (* \; "Edited 4-Jul-99 21:17 by rmk:") + + (* |;;| "In both wrapped and unwrapped cases, we have to treat specially lines beginning with '.': the '.' must be doubled when talking to the SMTP server.") (|if| UNIXMAIL.WRAP.LINES |then| (\\UNIXMAIL.SEND.WRAPLINES INSTREAM OUTSTREAM) @@ -232,4 +745,646 @@ (PRIN1 ".." OUTSTREAM) (SETQ STARTC (IPLUS ENDC 2)) FINALLY (COPYCHARS INSTREAM OUTSTREAM STARTC (GETEOFPTR - INSTREAM))))))) (\\UNIXMAIL.SEND.PARSE (LAMBDA (MSG EDITORWINDOW) (* \; "Edited 30-Jun-99 23:54 by rmk:") (* \; "Edited 28-Feb-99 19:27 by rmk:") (* \; "Edited 26-Feb-99 23:59 by rmk:") (* \; "Edited 20-Sep-91 16:59 by jrb:") (* |;;| "Do some obvious checks here and build a \\UNIXMAILPARSE for UNIXMAIL.SEND to munch on") (PROG ((MSGFIELDS (\\LAFITE.PREPARE.SEND MSG EDITORWINDOW)) SENDINGFORMAT HEADEREOF FROMFIELD RECIPIENTS OTHERSTUFF SUBJECT) (|if| MSGFIELDS |then| (|if| (EQ (CAAR MSGFIELDS) 'EOF) |then| (SETQ HEADEREOF (CADR (|pop| MSGFIELDS)))) (|for| PAIR |in| MSGFIELDS |do| (SELECTQ (CAR PAIR) (|Date| (\\SENDMESSAGEFAIL EDITORWINDOW "User-supplied Date not allowed")) (|Sender| (\\SENDMESSAGEFAIL EDITORWINDOW "User-supplied Sender not allowed")) ((TO T\o |cc|) (SETQ RECIPIENTS (NCONC RECIPIENTS (\\UNIXMAIL.PARSENAMES (CDR PAIR)))) (|push| OTHERSTUFF PAIR)) (|From| (SETQ FROMFIELD (\\UNIXMAIL.PARSENAMES (CDR PAIR))) (|push| OTHERSTUFF PAIR)) (|Format| (SETQ SENDINGFORMAT (CADR PAIR))) (|Subject| (SETQ SUBJECT (CADR PAIR)) (|push| OTHERSTUFF PAIR)) (|push| OTHERSTUFF PAIR))) (|if| (NULL RECIPIENTS) |then| (\\SENDMESSAGEFAIL EDITORWINDOW "No recipients!") (RETURN NIL)) (|if| (NULL SENDINGFORMAT) |then| (SETQ SENDINGFORMAT (OR (\\LAFITE.CHOOSE.MSG.FORMAT MSG HEADEREOF EDITORWINDOW) (RETURN)))) (RETURN (|create| UNIXMAILPARSE UNIXMAILSUBJECT _ SUBJECT UNIXFROM _ FROMFIELD UNIXTO _ RECIPIENTS UNIXOTHER _ OTHERSTUFF UNIXBODY _ HEADEREOF FORMATTED? _ (SELECTQ SENDINGFORMAT ((NIL TEXT) NIL) SENDINGFORMAT))))))) (\\UNIXMAIL.CHECK.ABORT (LAMBDA (ABORTWINDOW SMIN SMOUT) (* \; "Edited 2-Apr-99 14:37 by rmk:") (* \; "Edited 2-Apr-99 14:36 by rmk:") (* \; "Edited 2-Apr-99 13:52 by rmk:") (* \; "Edited 2-Apr-99 12:31 by rmk:") (* \;  "Perhaps the Abort button was pushed?") (BLOCK) (CL:WHEN (AND ABORTWINDOW (WINDOWPROP ABORTWINDOW 'ABORT)) (CL:WHEN SMIN (IGNORE-ERRORS (CLOSEF SMIN) (CLOSEF SMOUT))) (ERROR!)))) (\\UNIXMAIL.MUNG.RECIPIENTS (LAMBDA (RECIPIENTS) (* \; "Edited 11-Mar-99 16:38 by rmk:") (* |;;| "Coerces addresses from XNS formats to Internet formats, needed for answering messages that arrived via XNS.") (FOR R COLPOS IN RECIPIENTS COLLECT (IF (NOT (SETQ COLPOS (STRPOS ":" R))) THEN (* |;;|  "Either a vanilla name or an Internet address, mailer will handle it") (IF (STRPOS ".XEROX" R -6 NIL T NIL UPPERCASEARRAY) THEN (* \;  "domain was stripped out of unix address") (SETQ R (CONCAT R ".com"))) ELSEIF (STRPOS "@" R) THEN (* |;;| "A converted internet address, fix up last domain. foo@fum.fie:Xerox, foo@fum.fie:SMTP:Xerox, foo@fum:fie all go to foo@fum.fie") (IF (STRPOS ":XEROX" R -6 NIL T NIL UPPERCASEARRAY) THEN (* |;;| "Strip Xerox") (SETQ R (SUBSTRING R 1 -7)) (IF (IGREATERP COLPOS (NCHARS R)) ELSEIF (STRPOS ":SMTP" R -5 T NIL UPPERCASEARRAY) THEN (* |;;| "Another colon, followed by SMTP") (SETQ R (SUBSTRING R 1 -6)) ELSE (* |;;| "Another colon not followed by SMTP") (RPLCHARCODE R COLPOS (CHARCODE \.))) ELSE (* |;;| "No Xerox, last segment is domain") (RPLCHARCODE R COLPOS (CHARCODE \.))) ELSE (* |;;|  "A pure NS address: foo:bar:bas -> foo.bar@baz.xerox.com, foo:bar:xerox -> foo.bar@xerox.com") (LET ((FOO (SUBSTRING R 1 (SUB1 COLPOS))) (BAR (SUBSTRING R (ADD1 COLPOS) (SUB1 (OR (SETQ COLPOS (STRPOS ":" R (ADD1 COLPOS))) 0)))) (BAZ (AND COLPOS (SUBSTRING R (ADD1 COLPOS))))) (* |;;| "Spaces in FOO and BAR go to underscore") (FOR I C FROM 1 WHILE (SETQ C (NTHCHARCODE FOO I)) WHEN (EQ C (CHARCODE SPACE)) DO (RPLCHARCODE FOO I (CHARCODE _))) (CL:WHEN BAR (FOR I C FROM 1 WHILE (SETQ C (NTHCHARCODE BAR I)) WHEN (EQ C (CHARCODE SPACE)) DO (RPLCHARCODE BAR I (CHARCODE _)))) (* |;;| "Spaces in BAZ disappear") (CL:WHEN (AND BAZ (STRPOS " " BAZ)) (FOR I C (NEWI _ 1) (NEWBAZ _ (ALLOCSTRING (NCHARS BAZ))) FROM 1 WHILE (SETQ C (NTHCHARCODE BAZ I)) UNLESS (EQ C (CHARCODE SPACE)) DO (RPLCHARCODE NEWBAZ NEWI C) (ADD NEWI 1) FINALLY (SETQ BAZ (SUBSTRING NEWBAZ 1 (SUB1 NEWI) (CONSTANT (CONCAT)) )))) (IF (STREQUAL (L-CASE BAZ) "xerox") THEN (SETQ BAZ NIL)) (SETQ R (IF BAZ THEN (CONCAT FOO "." BAR "@" BAZ ".xerox.com") ELSE (CONCAT FOO "." BAR "@xerox.com"))))) R))) (\\UNIXMAIL.SMTP (LAMBDA (SIN SOUT STRING LO HI) (* \;  "Edited 6-Apr-97 17:30 by sybalsky:mv:envos") (* |;;| "Very dumb protocol handler; shows STRING to STREAM and reads the response number, returning T or NIL depending on the range of the result. Currently we only accept 200-range answers (completions)") (LET (RESULT) (CL:FORMAT SOUT STRING) (FORCEOUTPUT SOUT) (|if| (SETQ RESULT (\\UNIXMAIL.SMTP.FLUSH SIN LO HI)) |then| (CL:THROW 'SMTP-LOST RESULT))))) (\\UNIXMAIL.SMTP.FLUSH (LAMBDA (STREAM LO HI) (* \; "Edited 6-Jul-99 15:16 by rmk:") (* \; "Edited 4-Jul-99 12:55 by rmk:") (* \;  "Edited 8-Mar-99 13:08 by N.H.Briggs") (* |;;|  "STREAM is about to throw an SMTP exchange at us; get the number and shake hands appropriately") (LET (RESULT ERRORTYPE CHAR) (* |;;| "Flush any continuation result codes") (|while| (EQUAL "-" (SUBSTRING (FOR RPT FROM 1 TO 10 DO (* |;;| "Try again 10 times on end-of-file error, hoping that the error comes from a timing glitch. Both RESULT and the value of the loop will be NIL for any other kind of error and for the 10th end-of-file, which will be reported as the error type.") (CL:MULTIPLE-VALUE-SETQ (RESULT ERRORTYPE) (IGNORE-ERRORS (RATOM STREAM))) (CL:WHEN RESULT (RETURN RESULT)) REPEATWHILE (EQ 'END-OF-FILE (TYPENAME ERRORTYPE)) ) 4 4)) DO (UNIX.FLUSH.STREAM STREAM (CHARCODE NEWLINE) )) (|if| (NOT (SMALLP RESULT)) |then| (UNIX.FLUSH.STREAM STREAM (CHARCODE NEWLINE)) (CL:FORMAT NIL "Not an SMTP number:~S" (OR ERRORTYPE RESULT)) |else| (|if| (OR (IGREATERP RESULT (OR HI 299)) (ILESSP RESULT (OR LO 200))) |then| (SETQ RESULT (CL:FORMAT NIL "~a: " RESULT)) (|until| (OR (NOT (READP STREAM)) (EQ (SETQ CHAR (READCCODE STREAM)) (CHARCODE NEWLINE))) |do| (SETQ RESULT (CONCAT RESULT (CHARACTER CHAR)))) RESULT |else| (UNIX.FLUSH.STREAM STREAM (CHARCODE NEWLINE)) NIL))))) (\\UNIXMAIL.CHANGE.MODE (LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (SELECTQ (MENU (|create| MENU TITLE _ "Mail mode" ITEMS _ `(("Change Mode" '\\SENDMSG.CHANGE.MODE "Change the mail protocol used to send this message") (,(|if| UNIXMAIL.WRAP.LINES |then| "Line wrap Off" |else| "Line wrap On") 'UNIXMAIL.WRAP.LINES ,(|if| UNIXMAIL.WRAP.LINES |then| "Send message as is" |else| "Insert newlines to make message lines shorter than UNIXMAIL.WRAP-LIMIT" ))))) (\\SENDMSG.CHANGE.MODE (\\SENDMSG.CHANGE.MODE WINDOW TEXTSTREAM MENU ITEM)) (UNIXMAIL.WRAP.LINES (SETQ UNIXMAIL.WRAP.LINES (NOT UNIXMAIL.WRAP.LINES)) (\\SENDMESSAGE.PROMPT WINDOW (|if| UNIXMAIL.WRAP.LINES |then| "Line wrapping is on" |else| "Line wrapping is off"))) NIL) (* |;;| "Exit with error so that the window is restored to previous state") (ERROR!))) ) (* |;;| "This returns multiple-values, so it's a CL:LAMBDA (what the heck).") (CL:DEFUN \\UNIXMAIL.SMTP.TCP.STREAMS () (* \; "Edited 27-Feb-99 13:55 by rmk:") (* |;;| "Opens two streams representing the input and output streams of an SMTP TCP connection. On failure return NIL and a string describing the failure.") (SELECTQ UNIXMAIL.SEND.MODE (PROCESS (|if| (EQ (MACHINETYPE) 'MAIKO) |then| (* |;;| "UNIXMAIL.SEND.PROCESS can be a list of possibilities because the process may be in different places in different operating systems (e.g. solaris vs. sunos). If the first one doesn't exist at this time, we search the remaining ones and move the first one we find to the beginning of the list for next time. This could be done as an AFTERSYSOUTFORMS, but easy enough just to do it here.") (LET ((S (CREATE-PROCESS-STREAM (CONCAT (IF (NLISTP UNIXMAIL.SEND.PROCESS) THEN UNIXMAIL.SEND.PROCESS ELSEIF (INFILEP (PACKFILENAME 'HOST 'DSK 'BODY (CAR UNIXMAIL.SEND.PROCESS))) THEN (CAR UNIXMAIL.SEND.PROCESS) ELSE (FOR P IN (CDR UNIXMAIL.SEND.PROCESS) WHEN (INFILEP (PACKFILENAME 'HOST 'DSK 'BODY P)) DO (SETQ UNIXMAIL.SEND.PROCESS (CONS P (DREMOVE P UNIXMAIL.SEND.PROCESS) )) (RETURN P))) (IF UNIXMAIL.SEND.HOST THEN (CONCAT " " UNIXMAIL.SEND.HOST) ELSE ""))))) (CL:VALUES S S)) |else| (CL:VALUES NIL "this MACHINETYPE can't do Unix process-streams; change UNIXMAIL.SEND.MODE" ))) (SOCKET (|if| (EQ (MACHINETYPE) 'MAIKO) |then| (LET ((S (OPENTCPSTREAM (OR UNIXMAIL.SEND.HOST (UNIX-GETPARM "HOSTNAME" )) 25))) (CL:VALUES S S)) |else| (LET ((S (TCP.OPEN UNIXMAIL.SEND.HOST 25 NIL 'ACTIVE 'INPUT T))) (|if| S |then| (CL:VALUES S (TCP.OTHER.STREAM S)) |else| (CL:VALUES NIL "TCP.OPEN failed; check your Lisp TCP configuration" ))))) (ERROR "Unrecognized UNIXMAIL.SEND.MODE:" UNIXMAIL.SEND.MODE))) (* |;;| "Other functions Lafite uses and needs Unix equivalents for") (DEFINEQ (\\UNIXMAIL.AUTHENTICATE (LAMBDA NIL (* \; "Edited 2-Apr-99 15:33 by rmk:") (* \; "Edited 2-Apr-99 15:25 by rmk:") (* \;  "Edited 10-Mar-99 18:00 by N.H.Briggs") (* |;;| "No authentication really necessary (we're depending on underlying Unix to keep us from doing illegal things), so just return an appropriate LAFITEMODEDATA") (* |;;| "Unfortunately, all the various versions of the username have to be the short one, because Lafite insists they all be acceptable mailing addresses, in particular FULLUSERNAME... *sigh*...") (LET ((FQNAME (\\UNIXMAIL.FQNAME (UNIX-USERNAME)))) (|create| LAFITEMODEDATA LAFITEOPS _ (FASSOC 'UNIX LAFITEMODELST) FULLUSERNAME _ (CONCAT (UNIX-FULLNAME) " <" FQNAME ">") UNPACKEDUSERNAME _ FQNAME SHORTUSERNAME _ (UNIX-USERNAME) MAILSERVERS _ (LIST (|create| MAILSERVER MAILSERVERNAME _ "Unix mail" MAILSERVEROPS _ (OR (CDR (FASSOC UNIXMAIL.RECEIVE.MODE UNIXMAIL.MSOPS.LIST)) (ERROR "Not a known Unix mail receive mode" UNIXMAIL.RECEIVE.MODE)))))))) (\\UNIXMAIL.LOGIN (LAMBDA NIL (* \; "Edited 4-Jan-89 13:29 by bane") (|if| (EQ (MACHINETYPE) 'MAIKO) |then| (\\LAFITE.GET.USER.DATA 'UNIX NIL T) (\\LAFITE.WAKE.WATCHER) |else| (PROMPTPRINT "No Unix mode; this isn't Maiko")))) (\\UNIXMAIL.PARSENAMES (LAMBDA (FIELD) (* \; "Edited 7-Mar-99 23:31 by rmk:") (* \; "Edited 7-Mar-99 23:28 by rmk:") (* \; "Edited 4-Jan-89 15:41 by bane") (* |;;|  "Just returns a list of the unquoted, unparenthesized comma-seperated fields in this string") (FOR F RESULT INSIDE FIELD DO (FOR I C SEGMENT (START _ 1) FROM 1 DO (SELCHARQ (SETQ C (NTHCHARCODE F I)) ((\, NIL) (SETQ SEGMENT (CL:STRING-TRIM " " (SUBSTRING F START (SUB1 I)))) (PUSH RESULT (\\UNIXMAIL.FIXMICROSOFT SEGMENT)) (CL:UNLESS C (RETURN)) (SETQ START (ADD1 I))) (\" (FOR OLD I FROM (ADD1 I) BY 1 WHILE (SETQ C (NTHCHARCODE F I)) WHEN (EQ C (CHARCODE \")) DO (RETURN I) FINALLY (* \; "ran off the end") (SETQ I (SUB1 I)))) (\( (FOR OLD I (PDEPTH _ 1) FROM (ADD1 I) BY 1 WHILE (SETQ C (NTHCHARCODE F I)) DO (SELCHARQ C (\( (ADD PDEPTH 1)) (\) (IF (EQ PDEPTH 1) THEN (RETURN I) ELSE (ADD PDEPTH -1))) NIL) FINALLY (* \; "ran off the end") (SETQ I (SUB1 I)))) NIL)) FINALLY (RETURN (\\UNIXMAIL.MUNG.RECIPIENTS (DREVERSE RESULT)))))) (\\UNIXMAIL.MAKEANSWERFORM (LAMBDA (MSGDESCRIPTORS MAILFOLDER) (* \; "Edited 11-Oct-91 09:13 by jrb:") (* |;;| " Code borrowed liberally from GV.MAKEANSWERFORM") (LET ((MSGFIELDS (\\LAFITE.PARSE.MESSAGE MAILFOLDER (OR (CAR (LISTP MSGDESCRIPTORS)) MSGDESCRIPTORS))) SUBJECT FROM DATE SENDER REPLYTO TO CC OLDFROM NEWTO NEWCC) (* \; "get the fields from the file") (|for| PAIR |in| MSGFIELDS |do| (SELECTQ (CAR PAIR) (|Subject| (SETQ SUBJECT (CADR PAIR))) (|Sender| (SETQ SENDER (CADR PAIR))) (|From| (SETQ FROM (CADR PAIR))) (|Date| (SETQ DATE (CADR PAIR))) (|Reply-to| (SETQ REPLYTO (CDR PAIR))) ((T\o TO) (SETQ TO (CDR PAIR))) (|cc| (SETQ CC (CDR PAIR))) NIL)) (* |;;| "first parse the strings into recipients. Need to find the sender's registry in order to get the registry defaults correct for its recipients.") (COND (SENDER (* \;  "Sender is a mail address, and has the official registry") (SETQ OLDFROM (\\UNIXMAIL.PARSENAMES SENDER)) (* \;  "Elements are of the form (prettyname gvname . registry)") (|if| FROM |then| (* \; "Now that we have a source of official registry (we hope), parse the From field with reference to it.") (SETQ OLDFROM (\\UNIXMAIL.PARSENAMES FROM)))) (FROM (* \;  "Have to parse the From field before we can get its registry") (SETQ OLDFROM (\\UNIXMAIL.PARSENAMES FROM)))) (|if| (NULL OLDFROM) |then| (LAB.PROMPTPRINT MAILFOLDER T "Warning: message has no FROM field")) (AND TO (SETQ TO (\\UNIXMAIL.PARSENAMES TO))) (AND CC (SETQ CC (\\UNIXMAIL.PARSENAMES CC))) (SETQ NEWTO (OR (AND REPLYTO (SETQ REPLYTO (\\UNIXMAIL.PARSENAMES REPLYTO))) OLDFROM)) (SETQ NEWCC (CL:SET-DIFFERENCE (COND (REPLYTO (* \;  "Reply goes only to this address, so the only cc is to self") (MKLIST (|fetch| (LAFITEMODEDATA SHORTUSERNAME) |of| *LAFITE-MODE-DATA*))) (T (* \; "By default CC everyone who received the original message and to whom we are not directly replying already") (APPEND TO (CL:SET-DIFFERENCE CC TO :TEST #'STRING-EQUAL)))) NEWTO :TEST #'STRING-EQUAL)) (LAFITE.FILL.IN.ANSWER.FORM SUBJECT (|if| (AND (OR (NULL REPLYTO) (EQUAL REPLYTO OLDFROM)) (NULL (CDR NEWCC)) (OR (NULL NEWCC) (STRING-EQUAL (CAR NEWCC) (|fetch| (LAFITEMODEDATA SHORTUSERNAME) |of| *LAFITE-MODE-DATA* )))) |then| (* \; "Replying only to sender (and maybe self), so just say \"your\" instead of \"Joe Bob Smith 's\"") NIL |else| FROM) DATE NEWTO NEWCC #'LA.PRINT.COMMA.LIST)))) (\\UNIXMAIL.MESSAGE.FROM.SELF.P (LAMBDA (MSG) (* \; "Edited 6-Jul-99 15:22 by rmk:") (* \; "Edited 2-Apr-99 15:27 by rmk:") (* \; "Edited 6-Dec-88 15:41 by bane") (* |;;| "For the moment, we send stuff with our SHORTUSERNAME only in the FROM field") (OR (STRING-EQUAL (\\UNIXMAIL.FQNAME (|fetch| (LAFITEMSG FROM) |of| MSG)) (\\UNIXMAIL.FQNAME (|fetch| (LAFITEMODEDATA SHORTUSERNAME) |of| *LAFITE-MODE-DATA* ))) (STRING-EQUAL (\\UNIXMAIL.REALADDRESS (|fetch| (LAFITEMSG FROM) |of| MSG)) (\\UNIXMAIL.FQNAME (|fetch| (LAFITEMODEDATA SHORTUSERNAME) |of| *LAFITE-MODE-DATA* )))))) (\\UNIXMAIL.MESSAGE.P (LAMBDA (MSG) (* \; "Edited 6-Dec-88 15:39 by bane") (* |;;| "We're guessing here; basically if it doesn't look like an NS message, say maybe.") (AND (NOT (STRPOS ":" (|fetch| (LAFITEMSG FROM) |of| MSG))) '?))) (\\UNIXMAIL.REALADDRESS (LAMBDA (R) (* \; "Edited 1-Jul-99 00:00 by rmk:") (* \; "Edited 30-Jun-99 23:57 by rmk:") (* \; "Edited 2-Apr-99 15:30 by rmk:") (* |;;| "Finds the true address inside R. We look for angle brackets outside of double-quotes. If that doesn't work, send the whole string with parenthetic material replaced by white space.") (FOR I C (STARTTEXT _ 1) SEGMENTS FROM 1 WHILE (SETQ C (NTHCHARCODE R I)) DO (SELCHARQ C (< (* |;;| "If we find a top-level angle bracket, we're done") (RETURN (\\UNIXMAIL.FQNAME (CL:STRING-TRIM " " (SUBSTRING R (ADD1 I) (SUB1 (OR (STRPOS ">" R (ADD1 I)) 0))))))) (\" (CL:UNLESS (EQ I STARTTEXT) (PUSH SEGMENTS (LIST 'TEXT STARTTEXT (SUB1 I)))) (PUSH SEGMENTS (LIST 'QUOTES I (FOR OLD I FROM (ADD1 I) BY 1 WHILE (SETQ C (NTHCHARCODE R I)) WHEN (EQ C (CHARCODE \")) DO (RETURN I) FINALLY (* \; "ran off the end") (SETQ I (SUB1 I))))) (SETQ STARTTEXT (ADD1 I))) (\( (CL:UNLESS (EQ I STARTTEXT) (PUSH SEGMENTS (LIST 'TEXT STARTTEXT (SUB1 I)))) (PUSH SEGMENTS (LIST 'PARENS I (FOR OLD I (PDEPTH _ 1) FROM (ADD1 I) BY 1 WHILE (SETQ C (NTHCHARCODE R I)) DO (SELCHARQ C (\( (ADD PDEPTH 1)) (\) (IF (EQ PDEPTH 1) THEN (RETURN I) ELSE (ADD PDEPTH -1))) NIL) FINALLY (* \; "ran off the end") (SETQ I (SUB1 I))))) (SETQ STARTTEXT (ADD1 I))) NIL) FINALLY (RETURN (\\UNIXMAIL.FQNAME (IF (NULL SEGMENTS) THEN R ELSE (CL:STRING-TRIM " " (CONCATLIST (FOR S IN SEGMENTS COLLECT (SELECTQ (CAR S) ((TEXT QUOTES) (SUBSTRING R (CADR S) (CADDR S))) (PARENS " ") R)))))))))) (\\UNIXMAIL.FQNAME (LAMBDA (NAME) (* \; "Edited 2-Apr-99 15:24 by rmk:") (* \; "Edited 2-Apr-99 15:23 by rmk:") (* \; "Edited 2-Apr-99 15:21 by rmk:") (* |;;| "Returns the fully qualified version of name") (IF (OR (STRPOS "@" NAME) (NULL UNIXMAIL.DOMAIN.NAME) (EQ 0 (NCHARS NAME))) THEN NAME ELSE (CONCAT NAME "@" UNIXMAIL.DOMAIN.NAME)))) (\\UNIXMAIL.FIXMICROSOFT (LAMBDA (STRING) (* \; "Edited 7-Mar-99 16:13 by rmk:") (* \; "Edited 7-Mar-99 16:10 by rmk:") (* \; "Edited 7-Mar-99 16:10 by rmk:") (* \; "Edited 7-Mar-99 16:09 by rmk:") (* \; "Edited 7-Mar-99 16:08 by rmk:") (* \; "Edited 7-Mar-99 16:05 by rmk:") (* \; "Edited 7-Mar-99 16:03 by rmk:") (* \; "Edited 7-Mar-99 16:02 by rmk:") (* \; "Edited 7-Mar-99 15:54 by rmk:") (* \; "Edited 7-Mar-99 15:53 by rmk:") (* \; "Edited 7-Mar-99 15:52 by rmk:") (* \; "Edited 7-Mar-99 15:18 by rmk:") (* \; "Edited 7-Mar-99 15:15 by rmk:") (SETQ STRING (CL:STRING-TRIM " " STRING)) (* |;;| "Try to simplify goofy addresses from Microsoft mailer. \"'foo '\" \"\" goes to foo . Foo is quoted if it contains commas") (DO (* \; "Strip leading blanks") (SELCHARQ (CHCON1 STRING) ((SPACE TAB) (GNC STRING)) (RETURN))) (DO (* \; "Strip trailing blanks") (SELCHARQ (NTHCHARCODE STRING -1) ((SPACE TAB) (GLC STRING)) (RETURN))) (LET ((HASQUOTE (EQ (CHARCODE \") (CHCON1 STRING))) SECONDQUOTE FQBRK SQBRK FBRK SBRK QUOTEDSTRING BRKSTRING) (IF (AND HASQUOTE (SETQ SECONDQUOTE (STRPOS "\"" STRING 2)) (SETQ FBRK (STRPOS "<" STRING (ADD1 SECONDQUOTE))) (SETQ SBRK (STRPOS ">" STRING (ADD1 FBRK)))) THEN (SETQ QUOTEDSTRING (CL:STRING-TRIM " " (SUBSTRING STRING 2 (SUB1 SECONDQUOTE) (CONSTANT (CONCAT))))) (SETQ BRKSTRING (CL:STRING-TRIM " " (SUBSTRING STRING (ADD1 FBRK) (SUB1 SBRK) (CONSTANT (CONCAT))))) (CL:UNLESS (STRPOS "@" BRKSTRING) (SETQ BRKSTRING (CONCAT BRKSTRING "@parc.xerox.com"))) (IF (AND (SETQ FQBRK (STRPOS "<" QUOTEDSTRING)) (SETQ SQBRK (STRPOS ">" QUOTEDSTRING (ADD1 FQBRK))) (STRING-EQUAL BRKSTRING (SUBSTRING QUOTEDSTRING (ADD1 FQBRK) (SUB1 SQBRK) (CONSTANT (CONCAT))))) THEN (* |;;| "The quoted string has a bracketed substring that matches the outer string, so that part of the quoted string is redundant.") (CL:WHEN (AND (EQ (CHARCODE \') (CHCON1 QUOTEDSTRING)) (EQ (CHARCODE \') (NTHCHARCODE QUOTEDSTRING -1))) (GNC QUOTEDSTRING) (GLC QUOTEDSTRING) (SETQ QUOTEDSTRING (CL:STRING-TRIM " " QUOTEDSTRING))) (* |;;| "Chop bracket stuff out of quoted string") (SETQ QUOTEDSTRING (CL:STRING-TRIM " " (CONCAT (OR (SUBSTRING QUOTEDSTRING 1 (SUB1 FQBRK) (CONSTANT (CONCAT))) "") (OR (SUBSTRING QUOTEDSTRING (ADD1 SQBRK) -1 (CONSTANT (CONCAT))) "")))) (IF (STRPOS "," QUOTEDSTRING) THEN (CONCAT "\"" QUOTEDSTRING "\" " (SUBSTRING STRING FBRK SBRK )) ELSE (CONCAT QUOTEDSTRING " " (SUBSTRING STRING FBRK SBRK))) ELSEIF (AND (EQ (CHARCODE \') (CHCON1 QUOTEDSTRING)) (EQ (CHARCODE \') (NTHCHARCODE QUOTEDSTRING -1)) (STRING-EQUAL BRKSTRING (SUBSTRING QUOTEDSTRING 2 -2 (CONSTANT (CONCAT))))) THEN (* |;;| "The quoted string is 'foo@parc.xerox.com' and the (possibly extended) bracketed string is the same. We can just return the original bracketed string") (SUBSTRING STRING (ADD1 FBRK) (SUB1 SBRK)) ELSE STRING) ELSE STRING)))) ) (* |;;| "This is a stub needed by the TEdit-uuencode strategy; if we ever decide on a reasonable way to do this and make it part of Lafite, this may go away" ) (MOVD? 'NILL 'UNIX.UUDECODE.IF.NEEDED) (* |;;| "Hack to install easy interface for line wrapping. I should really put line-wrapping into Lafite as a whole." ) (CL:WHEN (CAR (NLSETQ (EDITE LAFITESENDINGMENUITEMS '(F \\SENDMSG.CHANGE.MODE)))) (* |;;| "The CONS below insures that Lafite notices you've changed LAFITESENDINGMENUITEMS, so the menu will get updated.") (SETQ LAFITESENDINGMENUITEMS (EDITE (CONS (CAR LAFITESENDINGMENUITEMS) (CDR LAFITESENDINGMENUITEMS)) '(CHANGE \\SENDMSG.CHANGE.MODE TO \\UNIXMAIL.CHANGE.MODE) ))) (PUTPROPS UNIXMAIL FILETYPE :COMPILE-FILE) (PUTPROPS UNIXMAIL COPYRIGHT ("ENVOS Corporation" 1989 1990 1991 1992 1997 1999 1920)) (DECLARE\: DONTCOPY (FILEMAP (NIL (6942 25397 (UNIX.POLLNEWMAIL 6952 . 8898) (UNIX.NEXTMESSAGE 8900 . 9076) ( UNIXMAILER.OPENMAILBOX 9078 . 13474) (UNIXMAILER.RETRIEVEMESSAGE 13476 . 14683) ( UNIXMAILER.CLOSEMAILBOX 14685 . 15710) (UNIXSPOOL.OPENMAILBOX 15712 . 21987) ( UNIXSPOOL.RETRIEVEMESSAGE 21989 . 24050) (UNIXSPOOL.CLOSEMAILBOX 24052 . 25395)) (25445 55974 ( UNIX.FLUSH.STREAM 25455 . 26036) (UNIX.RETRIEVE.LINE 26038 . 27227) (\\UNIXMAIL.SEND 27229 . 37532) ( \\UNIXMAIL.SEND.WRAPLINES 37534 . 41160) (\\SMTP-DUMP 41162 . 42428) (\\UNIXMAIL.SEND.PARSE 42430 . 45662) (\\UNIXMAIL.CHECK.ABORT 45664 . 46480) (\\UNIXMAIL.MUNG.RECIPIENTS 46482 . 51350) ( \\UNIXMAIL.SMTP 51352 . 51957) (\\UNIXMAIL.SMTP.FLUSH 51959 . 54498) (\\UNIXMAIL.CHANGE.MODE 54500 . 55972)) (59451 81005 (\\UNIXMAIL.AUTHENTICATE 59461 . 61214) (\\UNIXMAIL.LOGIN 61216 . 61561) ( \\UNIXMAIL.PARSENAMES 61563 . 63873) (\\UNIXMAIL.MAKEANSWERFORM 63875 . 68757) ( \\UNIXMAIL.MESSAGE.FROM.SELF.P 68759 . 69880) (\\UNIXMAIL.MESSAGE.P 69882 . 70201) ( \\UNIXMAIL.REALADDRESS 70203 . 74239) (\\UNIXMAIL.FQNAME 74241 . 74838) (\\UNIXMAIL.FIXMICROSOFT 74840 . 81003))))) STOP \ No newline at end of file + INSTREAM))))))) + +(\\UNIXMAIL.SEND.PARSE + (LAMBDA (MSG EDITORWINDOW) (* \; "Edited 30-Jun-99 23:54 by rmk:") + (* \; "Edited 28-Feb-99 19:27 by rmk:") + (* \; "Edited 26-Feb-99 23:59 by rmk:") + (* \; "Edited 20-Sep-91 16:59 by jrb:") + + (* |;;| "Do some obvious checks here and build a \\UNIXMAILPARSE for UNIXMAIL.SEND to munch on") + + (PROG ((MSGFIELDS (\\LAFITE.PREPARE.SEND MSG EDITORWINDOW)) + SENDINGFORMAT HEADEREOF FROMFIELD RECIPIENTS OTHERSTUFF SUBJECT) + (|if| MSGFIELDS + |then| (|if| (EQ (CAAR MSGFIELDS) + 'EOF) + |then| (SETQ HEADEREOF (CADR (|pop| MSGFIELDS)))) + (|for| PAIR |in| MSGFIELDS + |do| (SELECTQ (CAR PAIR) + (|Date| (\\SENDMESSAGEFAIL EDITORWINDOW + "User-supplied Date not allowed")) + (|Sender| (\\SENDMESSAGEFAIL EDITORWINDOW + "User-supplied Sender not allowed")) + ((TO T\o |cc|) + (SETQ RECIPIENTS (NCONC RECIPIENTS (\\UNIXMAIL.PARSENAMES + (CDR PAIR)))) + (|push| OTHERSTUFF PAIR)) + (|From| (SETQ FROMFIELD (\\UNIXMAIL.PARSENAMES (CDR PAIR))) + (|push| OTHERSTUFF PAIR)) + (|Format| (SETQ SENDINGFORMAT (CADR PAIR))) + (|Subject| (SETQ SUBJECT (CADR PAIR)) + (|push| OTHERSTUFF PAIR)) + (|push| OTHERSTUFF PAIR))) + (|if| (NULL RECIPIENTS) + |then| (\\SENDMESSAGEFAIL EDITORWINDOW "No recipients!") + (RETURN NIL)) + (|if| (NULL SENDINGFORMAT) + |then| (SETQ SENDINGFORMAT (OR (\\LAFITE.CHOOSE.MSG.FORMAT MSG HEADEREOF + EDITORWINDOW) + (RETURN)))) + (RETURN (|create| UNIXMAILPARSE + UNIXMAILSUBJECT _ SUBJECT + UNIXFROM _ FROMFIELD + UNIXTO _ RECIPIENTS + UNIXOTHER _ OTHERSTUFF + UNIXBODY _ HEADEREOF + FORMATTED? _ (SELECTQ SENDINGFORMAT + ((NIL TEXT) + NIL) + SENDINGFORMAT))))))) + +(\\UNIXMAIL.CHECK.ABORT + (LAMBDA (ABORTWINDOW SMIN SMOUT) (* \; "Edited 2-Apr-99 14:37 by rmk:") + (* \; "Edited 2-Apr-99 14:36 by rmk:") + (* \; "Edited 2-Apr-99 13:52 by rmk:") + (* \; "Edited 2-Apr-99 12:31 by rmk:") + (* \; + "Perhaps the Abort button was pushed?") + (BLOCK) + (CL:WHEN (AND ABORTWINDOW (WINDOWPROP ABORTWINDOW 'ABORT)) + (CL:WHEN SMIN + (IGNORE-ERRORS (CLOSEF SMIN) + (CLOSEF SMOUT))) + (ERROR!)))) + +(\\UNIXMAIL.MUNG.RECIPIENTS + (LAMBDA (RECIPIENTS) (* \; "Edited 11-Mar-99 16:38 by rmk:") + + (* |;;| "Coerces addresses from XNS formats to Internet formats, needed for answering messages that arrived via XNS.") + + (FOR R COLPOS IN RECIPIENTS + COLLECT (IF (NOT (SETQ COLPOS (STRPOS ":" R))) + THEN + + (* |;;| + "Either a vanilla name or an Internet address, mailer will handle it") + + (IF (STRPOS ".XEROX" R -6 NIL T NIL UPPERCASEARRAY) + THEN (* \; + "domain was stripped out of unix address") + (SETQ R (CONCAT R ".com"))) + ELSEIF (STRPOS "@" R) + THEN + + (* |;;| "A converted internet address, fix up last domain. foo@fum.fie:Xerox, foo@fum.fie:SMTP:Xerox, foo@fum:fie all go to foo@fum.fie") + + (IF (STRPOS ":XEROX" R -6 NIL T NIL UPPERCASEARRAY) + THEN + + (* |;;| "Strip Xerox") + + (SETQ R (SUBSTRING R 1 -7)) + (IF (IGREATERP COLPOS (NCHARS R)) + ELSEIF (STRPOS ":SMTP" R -5 T NIL UPPERCASEARRAY) + THEN + + (* |;;| "Another colon, followed by SMTP") + + (SETQ R (SUBSTRING R 1 -6)) + ELSE + + (* |;;| "Another colon not followed by SMTP") + + (RPLCHARCODE R COLPOS (CHARCODE \.))) + ELSE + + (* |;;| "No Xerox, last segment is domain") + + (RPLCHARCODE R COLPOS (CHARCODE \.))) + ELSE + + (* |;;| + "A pure NS address: foo:bar:bas -> foo.bar@baz.xerox.com, foo:bar:xerox -> foo.bar@xerox.com") + + (LET ((FOO (SUBSTRING R 1 (SUB1 COLPOS))) + (BAR (SUBSTRING R (ADD1 COLPOS) + (SUB1 (OR (SETQ COLPOS (STRPOS ":" R (ADD1 COLPOS))) + 0)))) + (BAZ (AND COLPOS (SUBSTRING R (ADD1 COLPOS))))) + + (* |;;| "Spaces in FOO and BAR go to underscore") + + (FOR I C FROM 1 WHILE (SETQ C (NTHCHARCODE FOO I)) + WHEN (EQ C (CHARCODE SPACE)) DO (RPLCHARCODE FOO I + (CHARCODE _))) + (CL:WHEN BAR + (FOR I C FROM 1 WHILE (SETQ C (NTHCHARCODE BAR I)) + WHEN (EQ C (CHARCODE SPACE)) + DO (RPLCHARCODE BAR I (CHARCODE _)))) + + (* |;;| "Spaces in BAZ disappear") + + (CL:WHEN (AND BAZ (STRPOS " " BAZ)) + (FOR I C (NEWI _ 1) + (NEWBAZ _ (ALLOCSTRING (NCHARS BAZ))) FROM 1 + WHILE (SETQ C (NTHCHARCODE BAZ I)) + UNLESS (EQ C (CHARCODE SPACE)) + DO (RPLCHARCODE NEWBAZ NEWI C) + (ADD NEWI 1) FINALLY (SETQ BAZ + (SUBSTRING NEWBAZ 1 + (SUB1 NEWI) + (CONSTANT (CONCAT)) + )))) + (IF (STREQUAL (L-CASE BAZ) + "xerox") + THEN (SETQ BAZ NIL)) + (SETQ R (IF BAZ + THEN (CONCAT FOO "." BAR "@" BAZ ".xerox.com") + ELSE (CONCAT FOO "." BAR "@xerox.com"))))) + R))) + +(\\UNIXMAIL.SMTP + (LAMBDA (SIN SOUT STRING LO HI) (* \; + "Edited 6-Apr-97 17:30 by sybalsky:mv:envos") + + (* |;;| "Very dumb protocol handler; shows STRING to STREAM and reads the response number, returning T or NIL depending on the range of the result. Currently we only accept 200-range answers (completions)") + + (LET (RESULT) + (CL:FORMAT SOUT STRING) + (FORCEOUTPUT SOUT) + (|if| (SETQ RESULT (\\UNIXMAIL.SMTP.FLUSH SIN LO HI)) + |then| (CL:THROW 'SMTP-LOST RESULT))))) + +(\\UNIXMAIL.SMTP.FLUSH + (LAMBDA (STREAM LO HI) (* \; "Edited 6-Jul-99 15:16 by rmk:") + (* \; "Edited 4-Jul-99 12:55 by rmk:") + (* \; "Edited 8-Mar-99 13:08 by N.H.Briggs") + + (* |;;| + "STREAM is about to throw an SMTP exchange at us; get the number and shake hands appropriately") + + (LET (RESULT ERRORTYPE CHAR) + + (* |;;| "Flush any continuation result codes") + + (|while| (EQUAL "-" (SUBSTRING (FOR RPT FROM 1 TO 10 + DO + + (* |;;| "Try again 10 times on end-of-file error, hoping that the error comes from a timing glitch. Both RESULT and the value of the loop will be NIL for any other kind of error and for the 10th end-of-file, which will be reported as the error type.") + + (CL:MULTIPLE-VALUE-SETQ (RESULT ERRORTYPE) + (IGNORE-ERRORS (RATOM STREAM))) + (CL:WHEN RESULT (RETURN RESULT)) + REPEATWHILE (EQ 'END-OF-FILE (TYPENAME ERRORTYPE)) + ) + 4 4)) DO (UNIX.FLUSH.STREAM STREAM (CHARCODE NEWLINE) + )) + (|if| (NOT (SMALLP RESULT)) + |then| (UNIX.FLUSH.STREAM STREAM (CHARCODE NEWLINE)) + (CL:FORMAT NIL "Not an SMTP number:~S" (OR ERRORTYPE RESULT)) + |else| (|if| (OR (IGREATERP RESULT (OR HI 299)) + (ILESSP RESULT (OR LO 200))) + |then| (SETQ RESULT (CL:FORMAT NIL "~a: " RESULT)) + (|until| (OR (NOT (READP STREAM)) + (EQ (SETQ CHAR (READCCODE STREAM)) + (CHARCODE NEWLINE))) + |do| (SETQ RESULT (CONCAT RESULT (CHARACTER CHAR)))) + RESULT + |else| (UNIX.FLUSH.STREAM STREAM (CHARCODE NEWLINE)) + NIL))))) + +(\\UNIXMAIL.CHANGE.MODE + (LAMBDA (WINDOW TEXTSTREAM MENU ITEM) + (SELECTQ (MENU (|create| MENU + TITLE _ "Mail mode" + ITEMS _ `(("Change Mode" '\\SENDMSG.CHANGE.MODE + "Change the mail protocol used to send this message") + (,(|if| UNIXMAIL.WRAP.LINES + |then| "Line wrap Off" + |else| "Line wrap On") + 'UNIXMAIL.WRAP.LINES + ,(|if| UNIXMAIL.WRAP.LINES + |then| "Send message as is" + |else| + "Insert newlines to make message lines shorter than UNIXMAIL.WRAP-LIMIT" + ))))) + (\\SENDMSG.CHANGE.MODE + (\\SENDMSG.CHANGE.MODE WINDOW TEXTSTREAM MENU ITEM)) + (UNIXMAIL.WRAP.LINES + (SETQ UNIXMAIL.WRAP.LINES (NOT UNIXMAIL.WRAP.LINES)) + (\\SENDMESSAGE.PROMPT WINDOW (|if| UNIXMAIL.WRAP.LINES + |then| "Line wrapping is on" + |else| "Line wrapping is off"))) + NIL) + + (* |;;| "Exit with error so that the window is restored to previous state") + + (ERROR!))) +) + + + +(* |;;| "This returns multiple-values, so it's a CL:LAMBDA (what the heck).") + + +(CL:DEFUN \\UNIXMAIL.SMTP.TCP.STREAMS () (* \; "Edited 27-Feb-99 13:55 by rmk:") + + (* |;;| "Opens two streams representing the input and output streams of an SMTP TCP connection. On failure return NIL and a string describing the failure.") + + (SELECTQ UNIXMAIL.SEND.MODE + (PROCESS (|if| (EQ (MACHINETYPE) + 'MAIKO) + |then| + + (* |;;| "UNIXMAIL.SEND.PROCESS can be a list of possibilities because the process may be in different places in different operating systems (e.g. solaris vs. sunos). If the first one doesn't exist at this time, we search the remaining ones and move the first one we find to the beginning of the list for next time. This could be done as an AFTERSYSOUTFORMS, but easy enough just to do it here.") + + (LET ((S (CREATE-PROCESS-STREAM + (CONCAT (IF (NLISTP UNIXMAIL.SEND.PROCESS) + THEN UNIXMAIL.SEND.PROCESS + ELSEIF (INFILEP (PACKFILENAME 'HOST 'DSK 'BODY + (CAR UNIXMAIL.SEND.PROCESS))) + THEN (CAR UNIXMAIL.SEND.PROCESS) + ELSE (FOR P IN (CDR UNIXMAIL.SEND.PROCESS) + WHEN (INFILEP (PACKFILENAME 'HOST + 'DSK + 'BODY P)) + DO (SETQ UNIXMAIL.SEND.PROCESS + (CONS P (DREMOVE P UNIXMAIL.SEND.PROCESS) + )) + (RETURN P))) + (IF UNIXMAIL.SEND.HOST + THEN (CONCAT " " UNIXMAIL.SEND.HOST) + ELSE ""))))) + (CL:VALUES S S)) + |else| (CL:VALUES NIL + "this MACHINETYPE can't do Unix process-streams; change UNIXMAIL.SEND.MODE" + ))) + (SOCKET (|if| (EQ (MACHINETYPE) + 'MAIKO) + |then| (LET ((S (OPENTCPSTREAM (OR UNIXMAIL.SEND.HOST (UNIX-GETPARM "HOSTNAME" + )) + 25))) + (CL:VALUES S S)) + |else| (LET ((S (TCP.OPEN UNIXMAIL.SEND.HOST 25 NIL 'ACTIVE 'INPUT T))) + (|if| S + |then| (CL:VALUES S (TCP.OTHER.STREAM S)) + |else| (CL:VALUES NIL + "TCP.OPEN failed; check your Lisp TCP configuration" + ))))) + (ERROR "Unrecognized UNIXMAIL.SEND.MODE:" UNIXMAIL.SEND.MODE))) + + + +(* |;;| "Other functions Lafite uses and needs Unix equivalents for") + +(DEFINEQ + +(\\UNIXMAIL.AUTHENTICATE + (LAMBDA NIL (* \; "Edited 2-Apr-99 15:33 by rmk:") + (* \; "Edited 2-Apr-99 15:25 by rmk:") + (* \; "Edited 10-Mar-99 18:00 by N.H.Briggs") + + (* |;;| "No authentication really necessary (we're depending on underlying Unix to keep us from doing illegal things), so just return an appropriate LAFITEMODEDATA") + + (* |;;| "Unfortunately, all the various versions of the username have to be the short one, because Lafite insists they all be acceptable mailing addresses, in particular FULLUSERNAME... *sigh*...") + + (LET ((FQNAME (\\UNIXMAIL.FQNAME (UNIX-USERNAME)))) + (|create| LAFITEMODEDATA + LAFITEOPS _ (FASSOC 'UNIX LAFITEMODELST) + FULLUSERNAME _ (CONCAT (UNIX-FULLNAME) + " <" FQNAME ">") + UNPACKEDUSERNAME _ FQNAME + SHORTUSERNAME _ (UNIX-USERNAME) + MAILSERVERS _ (LIST (|create| MAILSERVER + MAILSERVERNAME _ "Unix mail" + MAILSERVEROPS _ (OR (CDR (FASSOC UNIXMAIL.RECEIVE.MODE + UNIXMAIL.MSOPS.LIST)) + (ERROR + "Not a known Unix mail receive mode" + UNIXMAIL.RECEIVE.MODE)))))))) + +(\\UNIXMAIL.LOGIN + (LAMBDA NIL (* \; "Edited 4-Jan-89 13:29 by bane") + (|if| (EQ (MACHINETYPE) + 'MAIKO) + |then| (\\LAFITE.GET.USER.DATA 'UNIX NIL T) + (\\LAFITE.WAKE.WATCHER) + |else| (PROMPTPRINT "No Unix mode; this isn't Maiko")))) + +(\\UNIXMAIL.PARSENAMES + (LAMBDA (FIELD) (* \; "Edited 7-Mar-99 23:31 by rmk:") + (* \; "Edited 7-Mar-99 23:28 by rmk:") + (* \; "Edited 4-Jan-89 15:41 by bane") + + (* |;;| + "Just returns a list of the unquoted, unparenthesized comma-seperated fields in this string") + + (FOR F RESULT INSIDE FIELD + DO (FOR I C SEGMENT (START _ 1) FROM 1 + DO (SELCHARQ (SETQ C (NTHCHARCODE F I)) + ((\, NIL) + (SETQ SEGMENT (CL:STRING-TRIM " " (SUBSTRING F START (SUB1 I)))) + (PUSH RESULT (\\UNIXMAIL.FIXMICROSOFT SEGMENT)) + (CL:UNLESS C (RETURN)) + (SETQ START (ADD1 I))) + (\" (FOR OLD I FROM (ADD1 I) BY 1 + WHILE (SETQ C (NTHCHARCODE F I)) + WHEN (EQ C (CHARCODE \")) DO (RETURN I) + FINALLY (* \; "ran off the end") + (SETQ I (SUB1 I)))) + (\( (FOR OLD I (PDEPTH _ 1) FROM (ADD1 I) BY 1 + WHILE (SETQ C (NTHCHARCODE F I)) + DO (SELCHARQ C + (\( (ADD PDEPTH 1)) + (\) (IF (EQ PDEPTH 1) + THEN (RETURN I) + ELSE (ADD PDEPTH -1))) + NIL) FINALLY + (* \; "ran off the end") + (SETQ I (SUB1 I)))) + NIL)) FINALLY (RETURN (\\UNIXMAIL.MUNG.RECIPIENTS (DREVERSE + RESULT)))))) + +(\\UNIXMAIL.MAKEANSWERFORM + (LAMBDA (MSGDESCRIPTORS MAILFOLDER) (* \; "Edited 11-Oct-91 09:13 by jrb:") + + (* |;;| " Code borrowed liberally from GV.MAKEANSWERFORM") + + (LET ((MSGFIELDS (\\LAFITE.PARSE.MESSAGE MAILFOLDER (OR (CAR (LISTP MSGDESCRIPTORS)) + MSGDESCRIPTORS))) + SUBJECT FROM DATE SENDER REPLYTO TO CC OLDFROM NEWTO NEWCC) + (* \; "get the fields from the file") + (|for| PAIR |in| MSGFIELDS |do| (SELECTQ (CAR PAIR) + (|Subject| (SETQ SUBJECT (CADR PAIR))) + (|Sender| (SETQ SENDER (CADR PAIR))) + (|From| (SETQ FROM (CADR PAIR))) + (|Date| (SETQ DATE (CADR PAIR))) + (|Reply-to| (SETQ REPLYTO (CDR PAIR))) + ((T\o TO) + (SETQ TO (CDR PAIR))) + (|cc| (SETQ CC (CDR PAIR))) + NIL)) + + (* |;;| "first parse the strings into recipients. Need to find the sender's registry in order to get the registry defaults correct for its recipients.") + + (COND + (SENDER (* \; + "Sender is a mail address, and has the official registry") + (SETQ OLDFROM (\\UNIXMAIL.PARSENAMES SENDER)) + (* \; + "Elements are of the form (prettyname gvname . registry)") + (|if| FROM + |then| (* \; "Now that we have a source of official registry (we hope), parse the From field with reference to it.") + (SETQ OLDFROM (\\UNIXMAIL.PARSENAMES FROM)))) + (FROM (* \; + "Have to parse the From field before we can get its registry") + (SETQ OLDFROM (\\UNIXMAIL.PARSENAMES FROM)))) + (|if| (NULL OLDFROM) + |then| (LAB.PROMPTPRINT MAILFOLDER T "Warning: message has no FROM field")) + (AND TO (SETQ TO (\\UNIXMAIL.PARSENAMES TO))) + (AND CC (SETQ CC (\\UNIXMAIL.PARSENAMES CC))) + (SETQ NEWTO (OR (AND REPLYTO (SETQ REPLYTO (\\UNIXMAIL.PARSENAMES REPLYTO))) + OLDFROM)) + (SETQ NEWCC (CL:SET-DIFFERENCE (COND + (REPLYTO (* \; + "Reply goes only to this address, so the only cc is to self") + (MKLIST (|fetch| (LAFITEMODEDATA SHORTUSERNAME) + |of| *LAFITE-MODE-DATA*))) + (T (* \; "By default CC everyone who received the original message and to whom we are not directly replying already") + (APPEND TO (CL:SET-DIFFERENCE CC TO :TEST + #'STRING-EQUAL)))) + NEWTO :TEST #'STRING-EQUAL)) + (LAFITE.FILL.IN.ANSWER.FORM SUBJECT (|if| (AND (OR (NULL REPLYTO) + (EQUAL REPLYTO OLDFROM)) + (NULL (CDR NEWCC)) + (OR (NULL NEWCC) + (STRING-EQUAL (CAR NEWCC) + (|fetch| (LAFITEMODEDATA + SHORTUSERNAME) + |of| *LAFITE-MODE-DATA* + )))) + |then| (* \; "Replying only to sender (and maybe self), so just say \"your\" instead of \"Joe Bob Smith 's\"") + NIL + |else| FROM) + DATE NEWTO NEWCC #'LA.PRINT.COMMA.LIST)))) + +(\\UNIXMAIL.MESSAGE.FROM.SELF.P + (LAMBDA (MSG) (* \; "Edited 6-Jul-99 15:22 by rmk:") + (* \; "Edited 2-Apr-99 15:27 by rmk:") + (* \; "Edited 6-Dec-88 15:41 by bane") + + (* |;;| "For the moment, we send stuff with our SHORTUSERNAME only in the FROM field") + + (OR (STRING-EQUAL (\\UNIXMAIL.FQNAME (|fetch| (LAFITEMSG FROM) |of| MSG)) + (\\UNIXMAIL.FQNAME (|fetch| (LAFITEMODEDATA SHORTUSERNAME) |of| + *LAFITE-MODE-DATA* + ))) + (STRING-EQUAL (\\UNIXMAIL.REALADDRESS (|fetch| (LAFITEMSG FROM) |of| MSG)) + (\\UNIXMAIL.FQNAME (|fetch| (LAFITEMODEDATA SHORTUSERNAME) |of| + *LAFITE-MODE-DATA* + )))))) + +(\\UNIXMAIL.MESSAGE.P + (LAMBDA (MSG) (* \; "Edited 6-Dec-88 15:39 by bane") + + (* |;;| "We're guessing here; basically if it doesn't look like an NS message, say maybe.") + + (AND (NOT (STRPOS ":" (|fetch| (LAFITEMSG FROM) |of| MSG))) + '?))) + +(\\UNIXMAIL.REALADDRESS + (LAMBDA (R) (* \; "Edited 1-Jul-99 00:00 by rmk:") + (* \; "Edited 30-Jun-99 23:57 by rmk:") + (* \; "Edited 2-Apr-99 15:30 by rmk:") + + (* |;;| "Finds the true address inside R. We look for angle brackets outside of double-quotes. If that doesn't work, send the whole string with parenthetic material replaced by white space.") + + (FOR I C (STARTTEXT _ 1) + SEGMENTS FROM 1 WHILE (SETQ C (NTHCHARCODE R I)) + DO (SELCHARQ C + (< + (* |;;| "If we find a top-level angle bracket, we're done") + + (RETURN (\\UNIXMAIL.FQNAME (CL:STRING-TRIM + " " + (SUBSTRING R (ADD1 I) + (SUB1 (OR (STRPOS ">" R (ADD1 I)) + 0))))))) + (\" (CL:UNLESS (EQ I STARTTEXT) + (PUSH SEGMENTS (LIST 'TEXT STARTTEXT (SUB1 I)))) + (PUSH SEGMENTS (LIST 'QUOTES I (FOR OLD I + FROM (ADD1 I) BY 1 + WHILE (SETQ C (NTHCHARCODE R I)) + WHEN (EQ C (CHARCODE \")) + DO (RETURN I) + FINALLY + (* \; "ran off the end") + (SETQ I (SUB1 I))))) + (SETQ STARTTEXT (ADD1 I))) + (\( (CL:UNLESS (EQ I STARTTEXT) + (PUSH SEGMENTS (LIST 'TEXT STARTTEXT (SUB1 I)))) + (PUSH SEGMENTS + (LIST 'PARENS I + (FOR OLD I (PDEPTH _ 1) FROM (ADD1 I) BY 1 + WHILE (SETQ C (NTHCHARCODE R I)) + DO (SELCHARQ C + (\( (ADD PDEPTH 1)) + (\) (IF (EQ PDEPTH 1) + THEN (RETURN I) + ELSE (ADD PDEPTH -1))) + NIL) FINALLY + (* \; "ran off the end") + (SETQ I (SUB1 I))))) + (SETQ STARTTEXT (ADD1 I))) + NIL) + FINALLY (RETURN + (\\UNIXMAIL.FQNAME + (IF (NULL SEGMENTS) + THEN R + ELSE (CL:STRING-TRIM " " (CONCATLIST + (FOR S IN SEGMENTS + COLLECT (SELECTQ (CAR S) + ((TEXT QUOTES) + (SUBSTRING R + (CADR S) + (CADDR S))) + (PARENS " ") + R)))))))))) + +(\\UNIXMAIL.FQNAME + (LAMBDA (NAME) (* \; "Edited 2-Apr-99 15:24 by rmk:") + (* \; "Edited 2-Apr-99 15:23 by rmk:") + (* \; "Edited 2-Apr-99 15:21 by rmk:") + + (* |;;| "Returns the fully qualified version of name") + + (IF (OR (STRPOS "@" NAME) + (NULL UNIXMAIL.DOMAIN.NAME) + (EQ 0 (NCHARS NAME))) + THEN NAME + ELSE (CONCAT NAME "@" UNIXMAIL.DOMAIN.NAME)))) + +(\\UNIXMAIL.FIXMICROSOFT + (LAMBDA (STRING) (* \; "Edited 7-Mar-99 16:13 by rmk:") + (* \; "Edited 7-Mar-99 16:10 by rmk:") + (* \; "Edited 7-Mar-99 16:10 by rmk:") + (* \; "Edited 7-Mar-99 16:09 by rmk:") + (* \; "Edited 7-Mar-99 16:08 by rmk:") + (* \; "Edited 7-Mar-99 16:05 by rmk:") + (* \; "Edited 7-Mar-99 16:03 by rmk:") + (* \; "Edited 7-Mar-99 16:02 by rmk:") + (* \; "Edited 7-Mar-99 15:54 by rmk:") + (* \; "Edited 7-Mar-99 15:53 by rmk:") + (* \; "Edited 7-Mar-99 15:52 by rmk:") + (* \; "Edited 7-Mar-99 15:18 by rmk:") + (* \; "Edited 7-Mar-99 15:15 by rmk:") + (SETQ STRING (CL:STRING-TRIM " " STRING)) + + (* |;;| "Try to simplify goofy addresses from Microsoft mailer. \"'foo '\" \"\" goes to foo . Foo is quoted if it contains commas") + + (DO (* \; "Strip leading blanks") + (SELCHARQ (CHCON1 STRING) + ((SPACE TAB) + (GNC STRING)) + (RETURN))) + (DO (* \; "Strip trailing blanks") + (SELCHARQ (NTHCHARCODE STRING -1) + ((SPACE TAB) + (GLC STRING)) + (RETURN))) + (LET ((HASQUOTE (EQ (CHARCODE \") + (CHCON1 STRING))) + SECONDQUOTE FQBRK SQBRK FBRK SBRK QUOTEDSTRING BRKSTRING) + (IF (AND HASQUOTE (SETQ SECONDQUOTE (STRPOS "\"" STRING 2)) + (SETQ FBRK (STRPOS "<" STRING (ADD1 SECONDQUOTE))) + (SETQ SBRK (STRPOS ">" STRING (ADD1 FBRK)))) + THEN (SETQ QUOTEDSTRING (CL:STRING-TRIM " " (SUBSTRING STRING 2 (SUB1 SECONDQUOTE) + (CONSTANT (CONCAT))))) + (SETQ BRKSTRING (CL:STRING-TRIM " " (SUBSTRING STRING (ADD1 FBRK) + (SUB1 SBRK) + (CONSTANT (CONCAT))))) + (CL:UNLESS (STRPOS "@" BRKSTRING) + (SETQ BRKSTRING (CONCAT BRKSTRING "@parc.xerox.com"))) + (IF (AND (SETQ FQBRK (STRPOS "<" QUOTEDSTRING)) + (SETQ SQBRK (STRPOS ">" QUOTEDSTRING (ADD1 FQBRK))) + (STRING-EQUAL BRKSTRING (SUBSTRING QUOTEDSTRING (ADD1 FQBRK) + (SUB1 SQBRK) + (CONSTANT (CONCAT))))) + THEN + + (* |;;| "The quoted string has a bracketed substring that matches the outer string, so that part of the quoted string is redundant.") + + (CL:WHEN (AND (EQ (CHARCODE \') + (CHCON1 QUOTEDSTRING)) + (EQ (CHARCODE \') + (NTHCHARCODE QUOTEDSTRING -1))) + (GNC QUOTEDSTRING) + (GLC QUOTEDSTRING) + (SETQ QUOTEDSTRING (CL:STRING-TRIM " " QUOTEDSTRING))) + + (* |;;| "Chop bracket stuff out of quoted string") + + (SETQ QUOTEDSTRING (CL:STRING-TRIM " " + (CONCAT (OR (SUBSTRING QUOTEDSTRING 1 + (SUB1 FQBRK) + (CONSTANT (CONCAT))) + "") + (OR (SUBSTRING QUOTEDSTRING + (ADD1 SQBRK) + -1 + (CONSTANT (CONCAT))) + "")))) + (IF (STRPOS "," QUOTEDSTRING) + THEN (CONCAT "\"" QUOTEDSTRING "\" " (SUBSTRING STRING FBRK SBRK + )) + ELSE (CONCAT QUOTEDSTRING " " (SUBSTRING STRING FBRK SBRK))) + ELSEIF (AND (EQ (CHARCODE \') + (CHCON1 QUOTEDSTRING)) + (EQ (CHARCODE \') + (NTHCHARCODE QUOTEDSTRING -1)) + (STRING-EQUAL BRKSTRING (SUBSTRING QUOTEDSTRING 2 -2 + (CONSTANT (CONCAT))))) + THEN + + (* |;;| "The quoted string is 'foo@parc.xerox.com' and the (possibly extended) bracketed string is the same. We can just return the original bracketed string") + + (SUBSTRING STRING (ADD1 FBRK) + (SUB1 SBRK)) + ELSE STRING) + ELSE STRING)))) +) + + + +(* |;;| +"This is a stub needed by the TEdit-uuencode strategy; if we ever decide on a reasonable way to do this and make it part of Lafite, this may go away" +) + + +(MOVD? 'NILL 'UNIX.UUDECODE.IF.NEEDED) + + + +(* |;;| +"Hack to install easy interface for line wrapping. I should really put line-wrapping into Lafite as a whole." +) + + +(CL:WHEN (CAR (NLSETQ (EDITE LAFITESENDINGMENUITEMS '(F \\SENDMSG.CHANGE.MODE)))) + + (* |;;| "The CONS below insures that Lafite notices you've changed LAFITESENDINGMENUITEMS, so the menu will get updated.") + + (SETQ LAFITESENDINGMENUITEMS (EDITE (CONS (CAR LAFITESENDINGMENUITEMS) + (CDR LAFITESENDINGMENUITEMS)) + '(CHANGE \\SENDMSG.CHANGE.MODE TO \\UNIXMAIL.CHANGE.MODE) + ))) + +(PUTPROPS UNIXMAIL FILETYPE :COMPILE-FILE) +(PUTPROPS UNIXMAIL COPYRIGHT ("ENVOS Corporation" 1989 1990 1991 1992 1997 1999 1920 2021)) +(DECLARE\: DONTCOPY + (FILEMAP (NIL (7835 26260 (UNIX.POLLNEWMAIL 7845 . 9795) (UNIX.NEXTMESSAGE 9797 . 9973) ( +UNIXMAILER.OPENMAILBOX 9975 . 14371) (UNIXMAILER.RETRIEVEMESSAGE 14373 . 15580) ( +UNIXMAILER.CLOSEMAILBOX 15582 . 16607) (UNIXSPOOL.OPENMAILBOX 16609 . 22826) ( +UNIXSPOOL.RETRIEVEMESSAGE 22828 . 24909) (UNIXSPOOL.CLOSEMAILBOX 24911 . 26258)) (26308 56798 ( +UNIX.FLUSH.STREAM 26318 . 26899) (UNIX.RETRIEVE.LINE 26901 . 28090) (\\UNIXMAIL.SEND 28092 . 38386) ( +\\UNIXMAIL.SEND.WRAPLINES 38388 . 42018) (\\SMTP-DUMP 42020 . 43290) (\\UNIXMAIL.SEND.PARSE 43292 . +46536) (\\UNIXMAIL.CHECK.ABORT 46538 . 47366) (\\UNIXMAIL.MUNG.RECIPIENTS 47368 . 52236) ( +\\UNIXMAIL.SMTP 52238 . 52843) (\\UNIXMAIL.SMTP.FLUSH 52845 . 55322) (\\UNIXMAIL.CHANGE.MODE 55324 . +56796)) (56886 60196 (\\UNIXMAIL.SMTP.TCP.STREAMS 56886 . 60196)) (60275 81847 ( +\\UNIXMAIL.AUTHENTICATE 60285 . 61976) (\\UNIXMAIL.LOGIN 61978 . 62323) (\\UNIXMAIL.PARSENAMES 62325 + . 64643) (\\UNIXMAIL.MAKEANSWERFORM 64645 . 69527) (\\UNIXMAIL.MESSAGE.FROM.SELF.P 69529 . 70658) ( +\\UNIXMAIL.MESSAGE.P 70660 . 70979) (\\UNIXMAIL.REALADDRESS 70981 . 75025) (\\UNIXMAIL.FQNAME 75027 . +75632) (\\UNIXMAIL.FIXMICROSOFT 75634 . 81845))))) +STOP diff --git a/library/UNIXMAIL.DFASL b/library/UNIXMAIL.DFASL index f38dedbdbb43cc6dca1f9d69efdddc6a7662c4d7..e5b40c0b4957229bccafcd10b0f09c6bc01712c8 100644 GIT binary patch delta 7052 zcmbt34RDjkmEYS>vW@W%7;ItL24Nc$46-E~+hBuiS^8`X>kmohCpfr397<{eap1TN z0bz3uNzQ>J8$chIwhpwp^jc;v=n~RiFO!x8a&DTy4V`J22|0%xkW!jvE>o`b65qbJ zpKRJVozC2h=G(XLy?y(3_x$Pp_@7=JY z_g-7A!yfJ3Zm)6FIBm}QMn`>PO?~Fm2aAhq9X3JO(YtkHZ@&%6i-_LP=%~$n`s`^) z<4=Qy?}dUiQ>#0wWhP&QZvo`J=M9Q&*I0_g_82NUdVruqWnm= z@>}YBNja_;@d{IU2MPFly%^>7~ifP1&H%)$Kex%?j1YyV8CH>Joh^|0sQ* z+NG~bZqB$4rKJhZ5{HJ&E4xB5O)nEY-G-lTeQtuQy5QpvX0FPZlj^*i`R&|w`fR-f znTm;%hs+C`5GqOxO{?DdP=EE#O&hDXZrIXivj=r6QVJ783bwNb@N4P7Z+=Ef=7&=k z71;G^y-IiJPQ6xNtk1T_q zD(aY5>36sJVwyb=@@jUkJLaww^ya+TGtQE(Z_@V-`kvw2^X9?Z{7Bv=cXi?jq_;2z zFiq@*5R{JY)*4!)SBpOADz4GkskdnKMf#2m2(r+jD%m*02~B4dxtVW>A-Jh;Dhjn{ zRg+$*n)M>R%ET0tA++WtUzNvmxlP~QEEvtL{*b4$p5$HTPvjRD*;O2K3u#&)99xUMPl^69|7rdpIJmc9 z`=(0@2#(A^v^~@n!*etAy{J1>MXW_GTN=%s%a)Qx2GUoO$fIrgBQAY+9d)iQl1&*k zm$}7K22S2&S7Ex#E zR=qag^wkEDGcsTiO0skkaGRem@>ZgCz)w(8RHHKs$0CUOKJk2j;4pz#xU1M&nTv=` zh=4r&1aV|2tOcX7h~^F;YN;W8u($zo_>YUNuJ;96d702}Z`RZ1i!tV~+tXQ@tJ_f^ zn?baX5tQ49AeIVC|O;-&s-)Mf_OF7a6dOP}O{R zb^$Err)NJK{~eQ#BTR-we3~*BeX;qkG0Z7jY1q+wh2~Q{q3~J}yCTu`g#0WbkfwkZ zXqB<-qZZN6XzTL(F(1_+&ot%Ad~9KwJnql|PoZ2QnJG^Ty65BDo$ueoIhIKT>-Sk~c-!(L1WWXr~s?SpAJb!S0X&ex-UQChR z9a!b}MPt~fG0JTOBg9LfU5_IsjWE{)$o@#+0D`|o5N0BHc>;TZhOl$E8g%I}(qGs2 zVsjcBo_E(Vn8{DxRT#gF0;EI&-zG5xo+I!eG9<@^!*>v*DdEux>;Qo@ta}2xdIBp~ zM8e3e71SRZ?nme*u@G5T-WspC$pd2pqmlxPpJ*f$f z+;%M{N(_Us$;` zs}F@F2+_y4S2n@}{0EgaSwIyPp{tS~SN<=+0e*GSqs}pz2f)n8<{?v+E-SSbpD719#_V3Zxu ze}_sG9N~Zvz~nJ;8b%0dmlFu(2GO|soW3Xd&8oc+ch)Rr)6r&x2h=QK(^6mq%N3xh zRU{Nf#{)r@l_J)&sVQ(V%S?f_Y)T5O6FzLntPxIYfKHZ{0v+UwX?{NFu)$G&!m(gs zzB*I4=zC_c$ud8DmlQvNUuA^fa@gTRKF`?&C;4t?W8qO%m2^>C;UOLu^%b_y^LLz< z`o~4-xsOqpg8OnsNt?Mkf^{M00U?e!Pom(T6Zn!u@S>XX_)%4w(DTLw#}h;8Zm$u^^okU>^UhAsot>^bJB`#aRG2Rf>80oNz5HCw-^5QC(!VRT znWgVlCoPixbgKr^J4oV8azJRPqFw`qZkQ(BB#){cCw11` zA?bK;1xcT`_^kSJDC5iPJKz+5wEhu@bG2cAd`y;D!o}qIu3+*wI>lV5RhMxDs|-EX zjJu+&lE(CSIw-24m(1U9(MXEYuu4k7uOceg?bI#!IyLKC^%*!v&vGK)mKF7FK5I#F z`!y4l4^Sn~&MNoVnkf>H+1(n7$b9u86n%xuK1U+=C3h{+7!31&Yb==?G~8@h7E$PK zq{gsOg9iB@8*N@S=3H!q9lvxTPskq*MUC}`rQ8`pZDY-}Pl{Z#q>k{rn~E%>xU|n` zhU*A^AVEIVbRbT&T0;B=X_N!urT~@C$Fa(X1QPZq(0FN)PFAOP|`dNpMQatmAr2Qxt_&dvIH4KQV$87AE%uTdk()Og~DHl+t zv_5HLA_|qbtQjEd`9a?7D#*JG(xJ9tjfE>5Om23q6+yPv!N`@BF_uBfnPnLdD;P}( zoy;s0R3qV-VeuiVP^M^+h_EJcfi?`^Efr@V4WBXN;9JKHU;6TxoIZ<;e+6Aw@3j8b zFRx}`x=(#TjlLT(^JQZtwXgHXTZ$K4!KM8VA?P+L>p~o){EWDj(?q<%-)XUw z^gK+R^$$?fBa5USy1GFRXYTTX7dH~ADnN}@9-oyjbJrE#ndnR+!rG0E-OrzJ|K3Z6 zsq7bVaFS~@qqC4+7)>d8A;J^-BLg&Zouw+rL5xtOaZSxl{D<}H$In=nOQ`5-wGX5WJ zzk=ob2kpDQW)pc~j=r3%0cSW@b-f(0dxL!C;NL_uT z9~`90hINQL-jW>gq&C>m3N8H24(Ie1A($4MnuMqOI|`&{VMV+ z(!gSokyZz4I*oT65ITz8$`S7*UM=d0_`^@KJ^aD*m{sV!ue@CF!s85XLx?wI^89B|B`T^(pDK|1!4`*Ohp6R z0a(j58j|nQw*E3e;%^iNvD9 z$iVjt5I!Hr!mkO$S_Iw~J0@PI#h&2>94-=tN}P8m_+QrtR|+Db|8)ZW0)kYrz%c~n z85|}C;yp0IOOHx)46s`A^3$tJ&sD=dNY)7~-Cm$H={q2LHv8r_@#M@c$Pr2KLM z`|k*nCdwPcK*iO`3G9m#*aI$vl~GD(%ILkaM<>b>l-rs3??JG@%`$A*v1!yKq~)(m z9$B*ymYR(R&Q$fy4BJ-6iwt?V&&vxhsPe+AjB)4PH7j4)K(h`nmW>Q~&zd{13s&-G zu*wrHl3C^`5bI&{4w19;3UPq+Oc(LBcf=BW3jde88}1Q<)BkG=(TVxTiKm9LJmLjF oJXG89wHp7JAj(VhJwaa?@Ag-xp6icGnl#aBtkd82c_=Oh5!Hn delta 7027 zcma($4RDjkmAm^%{x`;eE#x0892*B?$?`w8u|bw(TcAHAIR^8S@Z$s$2*iO9AXu2* zL3#)-WfRb*r2Mp3Ivp~TL`RcM+iQ;$80U}ldUq{1kRvcanvjrQZqnnfac|$-Pc|t| zCo`UJ-@fsPE@XKSsm%?@waJg}+({B90EPJ08;( zIlU5<8gw`pIJzVv-Q$nALtalfm^ejWpmYikYo%#AjhLY)dPl}>}_;ayIJ$}z3pTpy|h24Iatve8o zJS_71MKM2OXgB0JMG61FP;SVp64MhI#%!utL=`VcDWJAQL(1z^YZ9~hA5wQ}5z&*_ zl=dMlogU{b{`WEC!k$3HElTA~l)z_+u*A70Bp)BlxG!y5a&j@_dpUigSQG(MA#(Di z##yZZ6~to`t2aMBP`!E8%4)bai`6g8K$#kk5g1KF@Xhar@07Hp%v+gN`BlOutfE@j zMXjh4^+{4qRw;dgN3yDD3m?jwMVtAHSvx>`Zq43; zV^eDER_U!)aMYxq&VDXdwcQn7uw%|QiwAO8UhU4@vxR02ww_e!b#!_nZmTcga$8-F zh@(={S4^75|D|veJjyyl{7>QFCrifwZxr?JBua4u*>A(!~cyrRM?4Ho?o zXl`FHvKVH6K>COLYThnd%^%F)xatC-k|V;ZgMA09o1=Jr}VGv z_ytNE9x^r|aM6mx^)jh`iqjhiyE}{3ez|HOOa_zo*kE~jJeIL~aJyyDl{UCzuv}hN zZNfJ7Io3|tg!qA2Zl%)^aduln?nqC_Zw)#tVZGEO8|93!ESyu8i6dhfIBJ|0+M^ek zy2IZw19JbCX>goy7vYG^g+8K=?rZ&m(YsZM1auX&Jhi2kkHSYZ6W*1~YMlYE%N^28 zQ-xX7<{8HGs42Qf4Vk1lEEOf(=KodbqUU*2QE}G$VC7LnU*QiF6;w_D#46k|7eGI3 z76`ii$`U{|>r#GD)I_uS#iD}tixN#vA^NR{L`sERV}yiXnIo!lB#li*+J^wD0|k)2 zf!N>k`r?W#Gl+Nz5%2Pcil^t0L6}hUfExIr;xbyme^xwFLgpaKRvM2PZR<9ydZaKO zOW6*oeuuo)I(}i=v(Z~jg`D&?l=)fG&qST^n|O5kdR%sJwKOH&83-ykL z5^3s5$*Vamw)4N8-nDYxUmWNKv3>k4$OV*{Oc6#@mt32vb}GW*TAG@vJGzeB zv?Oe$Ki237zff+Wg#T}OX*yw(knb2TpD{zua$rUcJTjw+F5s~l<_Dx}%LtlOURLIF z1Z5D1d%O{AM1}}*5|$#V*>9#8kDoC>I_&m_dTy*}FHhG@ zsK!}sDvl$f#dLQXf3zY$kM<(N@KB9ZRC^XD=Q*z^jS@gCmvU2=`tFlWPz2_Sk>NIg zp)t@Z1_6_TnClW`|A*jC06ztgP6qJ(G3>8#2|EXRL(B$&{!6g~hF4+W_4htcC-d|7 znxmIMfRc#d+b9M>mE!jSLt<1oJu46E!%Vag&DhH*eSOOBi_cO)1J$g0-s@w)=O z)xbuVW7Z^l%ETas1YLu*n6A!}R88d+D}bAj-3;J^3go`Z=B!6RNE{K5@B@`CbUlBk zvNj9*u_cJMCNgLJiPGIX&APj0M5TUeVCcg%T~jVSqNO8qkERMmL{o)h5&wnNLDz6< zD~m3}3Q3n^rXaUVU;(*pScc=J`D!x^QEJAlLd`TK{$0HRp^pKetAxpp?v?_Wx~2oT z8WDX6jv>g$3ZWeqPbE&+25HpZRLgR~XQZz;)v$?4(9UusXy^z=LJY5m`dF4uY;0zk zNwA4!B*8|Oo&;yJv?SOd!&8ZGte3H+gOmZR|VcVKk9Ri zw=|Z~QhtA9H+`A^sPQQ}$jh6)6&+Dsl?*X;zaFNpW4_!Aw2J6g(4*_oI~t0r-5C*s zsZ@4gs)<$g7&Dy8(o`LNL}@pax)Fuut-)bghkzVQm$xDLwrZ_!^Oo5~&g%wj2dGsE zFsm~*XUI}xbaVtlD3P9^gPmo)lmP+{E)tDXm!(Z$JS z{{Eb4X}9Jg$1QGX`vf{rNDzP@|vy*JGA;IrXHW=%eelxy!(4%j6hgiRCV zk83Y>chI@~v+kN)`9r{0CGuL&f~SsbP1Q&+V7a z4)+|6I6|^}M|*sFSRT_o+>a4$?DV+3E>w7LraYj#^C9ci%}E2RMg+Jnxs5n@DU(-F z`pwx-sZnLm{T|s)WXe3~@poC}*N0oskMPRqO+s5_A+@ASuWC)~U+@ae{kfjPy?P2i z%@_LWWzE~|t4-H`Gol&%pM8ZDXGLqyxCNf|qXyVq%9^VAtLc7T=WmnW$NYthAC}6} z8f4iIdaIvJ_5z6AA3+dPu>vn3Z#FQz382FM(-?@BlfC?!-?3(cWYAxb8v(4s#fYsy z5U}JBg6{x`8JoO}9#7w04^bTI-?(n8b<>8W$o1X=9Nt!)&w16Eyvg?mY_y&KJmBl; z(;vxaMZ0_?k8^XX$pA;hCWozU0*PebEF5AgHrM7Uq{^cE`2E4Wl*b{PSp-Q;^x}*z%s!Ho=1aGQbd2^nU z&?CVw(Kv%FLaP`}MEc)XFLD5mrQ7}!uy&G^~y47!hh5_SfQ zP{cl2XU4ID?Lq4Bkfz+`26EF+@hr(@!e+?BoCha5Pe0N9iJg&yEcza<+n*tgxjS%G z0hZT419ZY)FVJL_2iRJPrC*|=P)O)U2tpG=FUb>=KSawjgU34kSEOL4bAF8fmtxmK zNksHd$Iw3n5L*@cJb>yBoc(HM45JHX`f7B#F^1Kub*gms<8?Z|%f z9vGOIh{GY}`F)8qi&oNRgYs$FmKczi>RFhL_801MkE+M9B&z@%;ScoHEMtx+8I(#;^7@WvxXL%6gs8 jT4Jty3E|`TeHp*Is*}IvA5%2ti8k^)So(`U|M~v`;jzvu diff --git a/library/lafite/LAFITE b/library/lafite/LAFITE index 5cadf883..57fb5654 100644 --- a/library/lafite/LAFITE +++ b/library/lafite/LAFITE @@ -1,12 +1,11 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "24-Jun-2021 19:17:01"  -{DSK}kaplan>Local>medley3.5>git-medley>library>lafite>LAFITE.;4 71992 +(FILECREATED "30-Sep-2021 22:59:08"  +{DSK}kaplan>Local>medley3.5>git-medley>library>lafite>LAFITE.;5 71956 - changes to%: (FNS \LAFITE.EOF) - (FILES LAFITEDECLS) + changes to%: (FILES LAFITEDECLS) - previous date%: "22-Aug-94 13:00:22" -{DSK}kaplan>Local>medley3.5>git-medley>library>lafite>LAFITE.;2) + previous date%: "24-Jun-2021 19:17:01" +{DSK}kaplan>Local>medley3.5>git-medley>library>lafite>LAFITE.;4) (* ; " @@ -75,19 +74,19 @@ Copyright (c) 1982-1989, 1993-1994, 2021 by Xerox Corporation and Bolt Beranek a (LAFITE.PERSONAL.VARS LAFITEDEFAULTHOST&DIR LAFITE.SIGNATURE)) (FNS LAFITE.AROUNDEXIT \LAFITE.MARK.FOLDERS.OBSOLETE \LAFITE.CHECK.FOLDERS \LAFITE.ASSURE.FOLDER.READY \LAFITE.AFTERLOGIN)) - (COMS (* ; "misc utilities") + (COMS (* ; "misc utilities") (FNS LA.RESETSHADE LA.MENU.ITEM NTHMESSAGE \LAFITE.MAKE.MSGARRAY \LAFITE.ADDMESSAGES.TO.ARRAY \MAILFOLDER.DEFPRINT \LAFITEMSG.DEFPRINT LA.POSITION.FROM.REGION MAILFOLDERBUSY) (CURSORS LA.CROSSCURSOR) - (* ; "Low level file functions") + (* ; "Low level file functions") (FNS TOCFILENAME DELETEMAILFOLDER \LAFITE.OPEN.FOLDER \LAFITE.REPORT.FILE.WONT.OPEN \LAFITE.FOLDER.CHANGED \LAFITE.REBROWSE.FOLDER \LAFITE.FOLDER.CHANGED.MENU \LAFITE.SET.FOLDER.STREAM \LAFITE.OPENSTREAM \LAFITE.CREATE.MENU \LAFITE.EOF \LAFITE.CLOSE.FOLDER) (FNS \LAFITE.DESCRIBE.FOLDER)) - (COMS (* ; - "Make is easy to load new versions of Lafite") + (COMS (* ; + "Make is easy to load new versions of Lafite") (FNS LOAD-LAFITE) (VARS LAFITEFILES)) [DECLARE%: DOEVAL@COMPILE DONTCOPY (FILES (SOURCE) @@ -102,14 +101,14 @@ Copyright (c) 1982-1989, 1993-1994, 2021 by Xerox Corporation and Bolt Beranek a (FILES LAFITEBROWSE LAFITECOMMANDS LAFITEFOLDERS LAFITESEND LAFITEMAIL LAFITESORT TEDIT LAFITETEDIT LAFITEFIND ATTACHEDWINDOW MAILSCAVENGE) (P * (PROGN LAFITE.PROCLAMATIONS)) - (* ; - "Proclaim user interface variables. Value is on LAFITEDECLS") + (* ; + "Proclaim user interface variables. Value is on LAFITEDECLS") (P (\LAFITE.GLOBAL.INIT) (COND ((EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSCHARPATCH) - (* ; - "Patch to horrid Lyric NS chars bug") + (* ; + "Patch to horrid Lyric NS chars bug") (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T] (DECLARE%: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) @@ -117,7 +116,7 @@ Copyright (c) 1982-1989, 1993-1994, 2021 by Xerox Corporation and Bolt Beranek a (RPAQQ LAFITEVERSION# 10) -(RPAQQ LAFITESYSTEMDATE "24-Jun-2021 19:17:01") +(RPAQQ LAFITESYSTEMDATE "30-Sep-2021 22:59:08") (DEFINEQ (LAFITE @@ -277,8 +276,8 @@ Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITE DEFAULTFONT) (CHARWIDTH (CHARCODE "W") DEFAULTFONT)) - (* ; - "Yes, user has not changed default to a variable width font") + (* ; + "Yes, user has not changed default to a variable width font") DEFAULTFONT) (T (FONTCREATE '(GACHA 10] (LAFITEHARDCOPYFONT LAFITEDISPLAYFONT) @@ -317,8 +316,8 @@ Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITE DEFAULTFONT) (CHARWIDTH (CHARCODE "W") DEFAULTFONT)) - (* ; - "Yes, user has not changed default to a variable width font") + (* ; + "Yes, user has not changed default to a variable width font") DEFAULTFONT) (T (FONTCREATE '(GACHA 10]) @@ -864,8 +863,8 @@ Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITE (COND ((EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) - NSCHARPATCH) (* ; - "Patch to horrid Lyric NS chars bug") + NSCHARPATCH) (* ; + "Patch to horrid Lyric NS chars bug") (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T))) ) (DECLARE%: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS @@ -879,28 +878,28 @@ Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITE (PUTPROPS LAFITE COPYRIGHT ("Xerox Corporation and Bolt Beranek and Newman Inc." 1982 1983 1984 1985 1986 1987 1988 1989 1993 1994 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (7140 22186 (LAFITE 7150 . 8461) (LAFITE.ON.FROM.BACKGROUND 8463 . 8834) (\LAFITE.OFF -8836 . 9220) (\LAFITE.START.PROC 9222 . 10998) (LAFITE.COMPUTE.CACHED.VARS 11000 . 13702) ( -\LAFITE.PROCESS 13704 . 14070) (\LAFITE.START.ABORT 14072 . 14264) (\LAFITE.QUIT 14266 . 14508) ( -\LAFITE.RESTART 14510 . 14643) (\LAFITE.SUBQUIT 14645 . 15943) (\LAFITE.QUIT.PROC 15945 . 18681) ( -\LAFITEDEFAULTHOST&DIR 18683 . 19493) (LAFITEDEFAULTHOST&DIR 19495 . 19665) (MAKELAFITECOMMANDWINDOW -19667 . 21306) (EXTRACTMENUCOMMAND 21308 . 21556) (DOMAINLAFITECOMMAND 21558 . 21707) ( -LAFITE.TOGGLE.SERVER.TRACE 21709 . 22184)) (22261 25229 (LAFITEMODE 22271 . 22751) (\LAFITE.INFER.MODE - 22753 . 23106) (\LAFITE.SHOW.MODE 23108 . 23345) (\LAFITE.MODE.TITLE 23347 . 23632) ( -LAFITE.SHOW.MODE.P 23634 . 23875) (LAFITE.ALL.MODES.P 23877 . 24220) (SET.LAFITE.MODE.INTERACTIVELY -24222 . 24804) (\LAFITE.COMPUTE.MODE.COMMANDS 24806 . 25227)) (26079 27835 (\LAFITE.LOGIN 26089 . -26471) (\LAFITE.LOGIN.NORESTART 26473 . 26579) (LAFITE.PROMPT.FOR.LOGIN 26581 . 27600) ( -\LAFITE.REAUTHENTICATE 27602 . 27833)) (35346 38788 (LAFITE.AROUNDEXIT 35356 . 35894) ( -\LAFITE.MARK.FOLDERS.OBSOLETE 35896 . 36812) (\LAFITE.CHECK.FOLDERS 36814 . 37213) ( -\LAFITE.ASSURE.FOLDER.READY 37215 . 37625) (\LAFITE.AFTERLOGIN 37627 . 38786)) (38820 41758 ( -LA.RESETSHADE 38830 . 39208) (LA.MENU.ITEM 39210 . 39628) (NTHMESSAGE 39630 . 39713) ( -\LAFITE.MAKE.MSGARRAY 39715 . 40145) (\LAFITE.ADDMESSAGES.TO.ARRAY 40147 . 40728) ( -\MAILFOLDER.DEFPRINT 40730 . 40977) (\LAFITEMSG.DEFPRINT 40979 . 41141) (LA.POSITION.FROM.REGION 41143 - . 41620) (MAILFOLDERBUSY 41622 . 41756)) (41936 58324 (TOCFILENAME 41946 . 42377) (DELETEMAILFOLDER -42379 . 42899) (\LAFITE.OPEN.FOLDER 42901 . 47516) (\LAFITE.REPORT.FILE.WONT.OPEN 47518 . 48242) ( -\LAFITE.FOLDER.CHANGED 48244 . 50648) (\LAFITE.REBROWSE.FOLDER 50650 . 53615) ( -\LAFITE.FOLDER.CHANGED.MENU 53617 . 54540) (\LAFITE.SET.FOLDER.STREAM 54542 . 55236) ( -\LAFITE.OPENSTREAM 55238 . 55777) (\LAFITE.CREATE.MENU 55779 . 56132) (\LAFITE.EOF 56134 . 57476) ( -\LAFITE.CLOSE.FOLDER 57478 . 58322)) (58325 58909 (\LAFITE.DESCRIBE.FOLDER 58335 . 58907)) (58970 -60076 (LOAD-LAFITE 58980 . 60074)) (67787 69064 (\LAFITE.GLOBAL.INIT 67797 . 69062))))) + (FILEMAP (NIL (7104 22150 (LAFITE 7114 . 8425) (LAFITE.ON.FROM.BACKGROUND 8427 . 8798) (\LAFITE.OFF +8800 . 9184) (\LAFITE.START.PROC 9186 . 10962) (LAFITE.COMPUTE.CACHED.VARS 10964 . 13666) ( +\LAFITE.PROCESS 13668 . 14034) (\LAFITE.START.ABORT 14036 . 14228) (\LAFITE.QUIT 14230 . 14472) ( +\LAFITE.RESTART 14474 . 14607) (\LAFITE.SUBQUIT 14609 . 15907) (\LAFITE.QUIT.PROC 15909 . 18645) ( +\LAFITEDEFAULTHOST&DIR 18647 . 19457) (LAFITEDEFAULTHOST&DIR 19459 . 19629) (MAKELAFITECOMMANDWINDOW +19631 . 21270) (EXTRACTMENUCOMMAND 21272 . 21520) (DOMAINLAFITECOMMAND 21522 . 21671) ( +LAFITE.TOGGLE.SERVER.TRACE 21673 . 22148)) (22225 25193 (LAFITEMODE 22235 . 22715) (\LAFITE.INFER.MODE + 22717 . 23070) (\LAFITE.SHOW.MODE 23072 . 23309) (\LAFITE.MODE.TITLE 23311 . 23596) ( +LAFITE.SHOW.MODE.P 23598 . 23839) (LAFITE.ALL.MODES.P 23841 . 24184) (SET.LAFITE.MODE.INTERACTIVELY +24186 . 24768) (\LAFITE.COMPUTE.MODE.COMMANDS 24770 . 25191)) (26043 27799 (\LAFITE.LOGIN 26053 . +26435) (\LAFITE.LOGIN.NORESTART 26437 . 26543) (LAFITE.PROMPT.FOR.LOGIN 26545 . 27564) ( +\LAFITE.REAUTHENTICATE 27566 . 27797)) (35310 38752 (LAFITE.AROUNDEXIT 35320 . 35858) ( +\LAFITE.MARK.FOLDERS.OBSOLETE 35860 . 36776) (\LAFITE.CHECK.FOLDERS 36778 . 37177) ( +\LAFITE.ASSURE.FOLDER.READY 37179 . 37589) (\LAFITE.AFTERLOGIN 37591 . 38750)) (38784 41722 ( +LA.RESETSHADE 38794 . 39172) (LA.MENU.ITEM 39174 . 39592) (NTHMESSAGE 39594 . 39677) ( +\LAFITE.MAKE.MSGARRAY 39679 . 40109) (\LAFITE.ADDMESSAGES.TO.ARRAY 40111 . 40692) ( +\MAILFOLDER.DEFPRINT 40694 . 40941) (\LAFITEMSG.DEFPRINT 40943 . 41105) (LA.POSITION.FROM.REGION 41107 + . 41584) (MAILFOLDERBUSY 41586 . 41720)) (41900 58288 (TOCFILENAME 41910 . 42341) (DELETEMAILFOLDER +42343 . 42863) (\LAFITE.OPEN.FOLDER 42865 . 47480) (\LAFITE.REPORT.FILE.WONT.OPEN 47482 . 48206) ( +\LAFITE.FOLDER.CHANGED 48208 . 50612) (\LAFITE.REBROWSE.FOLDER 50614 . 53579) ( +\LAFITE.FOLDER.CHANGED.MENU 53581 . 54504) (\LAFITE.SET.FOLDER.STREAM 54506 . 55200) ( +\LAFITE.OPENSTREAM 55202 . 55741) (\LAFITE.CREATE.MENU 55743 . 56096) (\LAFITE.EOF 56098 . 57440) ( +\LAFITE.CLOSE.FOLDER 57442 . 58286)) (58289 58873 (\LAFITE.DESCRIBE.FOLDER 58299 . 58871)) (58934 +60040 (LOAD-LAFITE 58944 . 60038)) (67751 69028 (\LAFITE.GLOBAL.INIT 67761 . 69026))))) STOP diff --git a/library/lafite/LAFITE.LCOM b/library/lafite/LAFITE.LCOM index 0d5cdb597653ea1907919f17fc2dc35d90b4b82b..10fd98acf00cce63351647139aee5185959231b3 100644 GIT binary patch delta 2162 zcmZ{ldrXs86u?sw(0rR1733k0OBu5W)V6?@ia?=X%QrtLw1wfs2SQag2L_p_fII{R zEKs285vq0jO_{TO)G}$AOo%2DBY>tFq&pr1%?!D*S z`#pK)@bH;~HPt0l7GgA?2vNusa-vYE!Xs2NWyAYvCE|YmCDGp>LT8?Mq z46NG3YKS;gwsBQvVO8{nDBe4q?371@?;x4SGIEZZPm=sxNG>=V2}8dV`BIH2eM0Bp znlEDL{!?b)7XkwdGC>wGZnU>R4bm?K?*gMvA3$xG5B=n{79@u=hk=hP(IV)=5uo!~ zU@y{DeWSTcNJyz7!Vm=ASzGzm!_BvecgE|beR2Q&j#fZ+2 zyV0*|);Yk|lIy);a>3?7tLoRSNTY)8+j=b7bAjGgiI+XY@^Na|*c6?X*O5eyhcFpd z3{zsoWw%;=fU{Oyq+i1(Cq^vnPt`y`v9AFSzOcd1ZFM|W&l53NGIXK=8*XzW?yj(L ztM9TMF|ur8g4(c$NaEtvhB&AuF(zSg?lfY$1%XSA7~PkmCW;CNK}o<$gm_kM(EKYz z3`AINK{`C?PVZ1Lcs`F-x?Kc*IJhS?UBeXnK!%dRE??_I@=+peL${+bZ!8v1W< z#WmEmVowaUVy>kiPa1674pO=euj8O?2XMjW3H;mUrL>>wO4mzGY(f$~W5$=gZ=b;n zA&raIb8$FH^=%#yBD*aJxY*|E^B;S72Q_=`+D66=yJxWtSN5XK%hR5BxjUpOM%EzZ z6193T3TyZCwoh+co)6*mIvtm&3*i#Cfkj?>6oeUT*8=}&Kk3Q@5=nB3-oy&sMU+H| zg)Z&D+q&3c09yJzXhLTKNEw|Tbo+oijUHGl{6Fl(ZeQ&5p-(#3(~vGDj9#6$+pYdx zLqF?!6D;p`;UUYrku3t3x-sja9xTM?J(3#5T^Wo2whdfX+S!R z@B7nXOk=vS7dUbQZ8nYIUeAtT1Kt}!eefuraLFisM}8c|S@liifWY-*7$I*AeSa7W z0XmMS1D}_N0-MLt_wo21VE6=j*(T6Zbn756;}))D_7<+tYZATAOrrc?5-nq=Qh+T} zLbNH&o^%_JX6!bu>WyiSD2$M>qIcd!$3;ZNDWXKIN9F-b*52Lw zcI>ijV=X!R4jfz<$8OOnHCmHesy1lY9eY@j#;nt^Z~IH7QW3i?;}H7%$GH(Qk;Fr+ z(dyKzjB2Gxt%Cb5X;L;?9viD*vp&w)v)yu#J+v1Ci8YBStjAm7B&b5a6c)x@g1i-B z%EQ~kVk202c$`cYr%+Vqu5nQehP(0(xiFwTVnOzCgId13({Y)6$)xP%8!j;=z@ z;+#}uYH1)ib5^7Db515Q`Ir*PKb`H$h~efDAvB!Up&}!fjBn;5!us;$Sj z!n3t}m{F*K>v|z%7AB&0ppb&4We7laVl7H}C+LWW9Mek#U@p?lW+uDA)diFXeBoA6 zf*Yev)S5t290Z}oE74^~F&%W5WAsUqTR5J*mH?^}e|%0aF(CU(gmOk~Oj0H%vyhbBzV4yn=6 zdMXqhM^4eL{=eStjD-HM9HmtC4V3|)D2qpFZ&?QNUK!md=1dy0;ml^_`YHv4mPeqp zxt!j8QBI>EuAnY@*@B_2LXFaQLp)Ctoy*-f0bHW_Zi!kQ#t~Eo1WqSBS%sBmjYe%u z(QZ<+3K?1?SBBsThbt3iP1|8Iv8Z}kxf~gJmclllrF31Yg5Ma8pIL~iq$)BkuZn;3 zBE38SRZpwvwYPN%a+x&{Io>RUXXVV4((9p@;vyw+dy4g*@1TY+bqJAW z2Q|FN;rqIt)89P&K&m#P^%VzIsK~*C#|7>v{pbkrd$;ydbBfw1)h22TXwJ60HFMPk zG$g4l%aM*24f6YzgFFV?oNPAWTGM2(F>DNN*sk-mig(T%k!&m7QQsi7_^H#CF z%?*TYG58SNCWHP~0sha0?zY*e8EGT)z;@#2?Lu(0>t`^m0)pD-gJ%ad(xu%WJUZsW zhwa`_+Cd9+se?*8_X2VMMFCV?pn^V_dKQB5;u?Hzx`@rNJ1MgaXZjpQuhi-^2AxW6 zWFr+I>-2>moYd%$P8tXn6Rz&0W`EsDLm1yh&CTc%z^iUA*x5A)?stWu#BlHBD7X+3km&_m^_>aomZ?NDOd#MoFS7@4UTp_)nkE*(}kA5@0?4!3~{lprMfA-S}sRQJDYk(4bKClHj zQ5=pezDm9iu2Q1GgXC2cW^D`Bf1MFULMW>BLDMGU%EH`RL>#z+VlN?p&iP NgnzogjlmIO{sFq{uUG&8 diff --git a/library/lafite/LAFITEBROWSE b/library/lafite/LAFITEBROWSE index be815b40..7356489e 100644 --- a/library/lafite/LAFITEBROWSE +++ b/library/lafite/LAFITEBROWSE @@ -1,153 +1,2315 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Feb-2001 09:26:50" {DSK}medley3.5>library>LAFITEBROWSE.;4 86175 changes to%: (VARS LAFITEBROWSECOMS) (FNS PRINTMESSAGESUMMARY) previous date%: "21-Jun-99 22:42:30" {DSK}medley3.5>library>LAFITEBROWSE.;2) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1999, 2001 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LAFITEBROWSECOMS) (RPAQQ LAFITEBROWSECOMS [(COMS (* ; "BROWSE") (FNS \LAFITE.BROWSE \LAFITE.SUBBROWSE \LAFITE.BROWSE.PROC \LAFITE.BROWSE.FORGET LAFITE.BROWSE.FOLDER \LAFITE.PREPARE.BROWSER \LAFITE.MAYBE.OPEN.FOLDER LAB.LOADFOLDER LAB.DISPLAYFOLDER LAB.MAKE.INITIAL.SELECTION LAB.CREATEWINDOW LAB.TITLE.STRING LAB.COMMANDFN LAB.DO.COMMAND LAB.ASSURE.SELECTIONS) (FNS BUILD.LAFITE.LAYOUTS \LAFITE.LAYOUT.FROM.WINDOW \LAFITE.MAKE.DUMMY.WINDOWS) (VARS LAFITE.DUMMY.SHADE LAFITE.DUMMY.HALF.SHADE) (INITVARS (\LAFITE.LAST.FOLDER.NAME)) (GLOBALVARS \LAFITE.LAST.FOLDER.NAME)) (COMS (* ; "Browser operations") (FNS LAB.SETUP LAB.BUTTONEVENTFN LAB.DO.UNLESS.BUSY LOADMAILFOLDER LAFITE.OBTAIN.FOLDER \LAFITE.FIND.EXISTING.FOLDER \LAFITE.CONFLICTING.OLD.FOLDER LAB.REPAINTFN LAB.SCROLLFN LAB.RESHAPEFN LAB.CLOSEFN LAB.SHRINKFN LAB.CLOSE/SHRINK LAB.EXPANDFN LAFITEEXTRABROWSERCOMMANDFN)) [COMS (* ; "Browser selection") (FNS LAB.SELECTMESSAGE LAB.CHANGEMARK LA.READ.NEW.MARK YPOS.TO.MESSAGE# MESSAGE#.TO.YPOS) (FNS LA.CONSIDERRANGE LA.DECONSIDERRANGE LA.RECONSIDERRANGE LA.SELECTRANGE LA.DESELECTRANGE LAB.FIND.SELECTED.MSG LAB.REV.FIND.SELECTED.MSG LA.UNDOSELECTION LA.VERIFY.SELECTION) (FNS LAB.COPYBUTTONEVENTFN LAB.SHOW.COPY.SELECTION) (DECLARE%: EVAL@COMPILE DONTCOPY (P (CL:PROCLAIM '(CL:SPECIAL *MAILFOLDER* *MESSAGES* *FIRST-VISIBLE* *LAST-VISIBLE* *TOC-STATE*)) (CL:PROCLAIM '(GLOBAL LASTMOUSEBUTTONS] [COMS (* ; "Browser display") (FNS LAB.PROMPTPRINT LAB.FORMAT LAB.MOUSECONFIRM LAB.PRINT.TO.PROMPTWINDOW LAB.PAGEFULLFN \LAFITE.MAYBE.CLEAR.PROMPT) (PROP ARGNAMES LAB.PROMPTPRINT LAB.FORMAT LAB.MOUSECONFIRM) (FNS PRINTMESSAGESUMMARY FIRSTVISIBLEMESSAGE LASTVISIBLEMESSAGE LAB.DISPLAYLINES LAB.EXPOSEMESSAGE LAB.SELECTED.MESSAGES UNSELECTALLMESSAGES SELECTMESSAGE LAB.GO.TO.MESSAGE MARKMESSAGE LAB.MARKS.CHANGED LA.SHOW.MARK LA.INVERT.MARK.BOX LA.BLT.MARK.BOX LA.SHOW.DELETION LA.SHOW.SELECTION SEENMESSAGE DELETEMESSAGE UNDELETEMESSAGE LAB.SET.EXPUNGEABILITY) (* ;; "PRINTMESSAGESUMMARY.STRING prints From and Subject. Redefined when MIME is loaded to deal with different character encodings.") (P (MOVD? 'PRIN3 'PRINTMESSAGESUMMARY.STRING] (COMS (* ; "ICON stuff") (FILES ICONW) (FNS LAB.ICONFN LAB.ICON.BUTTONEVENTFN) (VARS LAFITE.FOLDER.ICON)) (COMS (INITVARS (LAFITEFROMFRACTION 0.3) (LAFITEMINFROMCHARS 15) (LAFITEVERIFYFLG T) (LAFITEDELETEDLINEHEIGHT 1) (LAFITE.BROWSER.ICON.PREFERENCE)) (VARS LAFITEBROWSERMENUITEMS LAFITESUBBROWSEMENUITEMS LAFITEBROWSERICONMENUITEMS) (INITVARS (LAFITESUBBROWSEMENU) (LAFITEBROWSERICONMENU) (LAFITEEXTRAMENU)) (GLOBALVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) [ADDVARS (LAFITEMENUVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) (LAFITEEXTRAMENUITEMS ("Describe Folder" '\LAFITE.DESCRIBE.FOLDER "Display some relevant info about this folder" (SUBITEMS ("Inspect Folder" 'INSPECT "Inspect the MAILFOLDER data structure associated with this browser" ] (VARS (BROWSERMARKXPOSITION 8)) (BITMAPS LA.SELECTION.BITMAP)) [COMS (* ; "Obsolete") (INITVARS (LAFITEBROWSERREGION (CREATEREGION 30 30 575 210] (DECLARE%: DOEVAL@COMPILE DONTCOPY (CONSTANTS * TOCSTATES) [P (CL:PROCLAIM '(CL:SPECIAL \CURRENTDISPLAYLINE] (FILES (SOURCE) LAFITEDECLS) (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA LAB.MOUSECONFIRM LAB.FORMAT LAB.PROMPTPRINT]) (* ; "BROWSE") (DEFINEQ (\LAFITE.BROWSE -(LAMBDA (ITEM MENU BUTTON) (* ; "Edited 17-Sep-87 19:13 by bvm:") (* ;;; "Function called by the Browse button on main Lafite window.") (LET ((SUBP (EQ BUTTON (QUOTE MIDDLE)))) (* ; "Pass the :confirm option to LAFITE.BROWSE.FOLDER to require confirmation on folder creation.") (\LAFITE.PROCESS (BQUOTE ((\, (COND (SUBP (FUNCTION \LAFITE.SUBBROWSE)) (T (FUNCTION \LAFITE.BROWSE.PROC)))) (QUOTE (\, ITEM)) (QUOTE (\, MENU)) (\,@ (AND (NOT SUBP) (QUOTE (NIL (QUOTE (:CONFIRM)))))))) (QUOTE LAFITEBROWSE)))) -) (\LAFITE.SUBBROWSE -(LAMBDA (ITEM MENU) (* ; "Edited 3-Sep-87 18:00 by bvm:") (PROG ((COMMAND (MENU (.LAFITEMENU. LAFITESUBBROWSEMENU LAFITESUBBROWSEMENUITEMS "Browse subcommands")))) (COND (COMMAND (CL:FUNCALL COMMAND ITEM MENU))))) -) (\LAFITE.BROWSE.PROC -(LAMBDA (ITEM MENU FOLDERNAME OPTIONS) (* ; "Edited 10-Sep-87 15:19 by bvm:") (LET (MAILFOLDER) (COND ((NULL (OR FOLDERNAME (SETQ FOLDERNAME (\LAFITE.PROMPTFORFOLDER)))) (* ; "From BROWSE command, user aborted by not giving a file name") NIL) ((LISTP FOLDERNAME) (* ; "From LAFITE. Each element is (foldername browserregion displayregion iconposition . options)") (for ITEM in FOLDERNAME do (LAFITE.BROWSE.FOLDER (CAR FOLDERNAME) (CDR FOLDERNAME) (APPEND (CDDDDR FOLDERNAME) OPTIONS) ITEM MENU))) (T (LAFITE.BROWSE.FOLDER FOLDERNAME NIL OPTIONS ITEM MENU))))) -) (\LAFITE.BROWSE.FORGET -(LAMBDA (ITEM MENU) (* ; "Edited 18-Jul-88 11:41 by bvm") (LET ((FOLDERNAME (PROMPTFORFILENAME NIL \LAFITE.LAST.FOLDER.NAME))) (COND (FOLDERNAME (SETQ \LAFITE.LAST.FOLDER.NAME FOLDERNAME) (* ; "Save name as typed now in case it fails. Guy who gets the actual folder will set canonical name here.") (\LAFITE.BROWSE.PROC ITEM MENU FOLDERNAME (QUOTE (:FORGET :CONFIRM))))))) -) (LAFITE.BROWSE.FOLDER -(LAMBDA (FOLDERNAME LAYOUT OPTIONS ITEM MENU) (* ; "Edited 3-May-89 19:04 by bvm") (* ;; "Browse folder named FOLDERNAME. LAYOUT is a triple (browserregion iconposition displayregion). OPTIONS may include :SHRINK, meaning to shrink folder when finished, and :CONFIRM, meaning require confirmation before creating an empty folder. ITEM, if specified, is a menu item in MENU to shade while the browser is being prepared.") (LET ((FOLDER (RESETLST (AND ITEM (LA.RESETSHADE ITEM MENU)) (\LAFITE.PREPARE.BROWSER (LA.LONGFILENAME FOLDERNAME LAFITEMAIL.EXT) OPTIONS LAYOUT)))) (COND (FOLDER (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (if (NULL (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) then (* ; "Got a browser, but haven't loaded anything into it yet") (COND ((EQMEMB :ACTIVE OPTIONS) (replace (MAILFOLDER FOLDERGETSMAIL) of FOLDER with T))) (LAB.LOADFOLDER FOLDER) (COND ((EQMEMB :GETMAIL OPTIONS) (LAB.DO.COMMAND (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER) (FUNCTION \LAFITE.GETMAIL))) ((EQMEMB :SHRINK OPTIONS) (SHRINKW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)))))) FOLDER)))) -) (\LAFITE.PREPARE.BROWSER -(LAMBDA (FOLDERNAME OPTIONS LAYOUT) (* ; "Edited 7-Sep-88 12:18 by bvm") (* ;; "Get a browser on FOLDERNAME. If there already is one, we just top it, otherwise we create a new one. Returns the folder object or NIL on failure. OPTIONS are the options to browse. LAYOUT is where to put the browser if we have to create it.") (SETQ OPTIONS (CONS :BROWSE (MKLIST OPTIONS))) (WITH.MONITOR \LAFITE.BROWSELOCK (LET ((MAILFOLDER (LAFITE.OBTAIN.FOLDER FOLDERNAME (QUOTE INPUT) NIL OPTIONS)) BROWSERWINDOW STREAM) (AND MAILFOLDER (COND ((SETQ BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) (* ; "Already have browser") (COND ((OPENWP BROWSERWINDOW) (TOTOPW BROWSERWINDOW)) ((NOT (FMEMB :SHRINK OPTIONS)) (* ; "Make sure the EXPANDFN runs") (EXPANDW BROWSERWINDOW))) T) ((COND ((SETQ STREAM (fetch (MAILFOLDER FOLDERSTREAM) of MAILFOLDER)) (* ; "Already have folder open, e.g., from MOVETO, but no browser yet") (SETFILEINFO STREAM (QUOTE BUFFERS) LAFITEBUFFERSIZE) T) (T (\LAFITE.MAYBE.OPEN.FOLDER MAILFOLDER (QUOTE INPUT) NIL OPTIONS))) (* ; "Success in opening") (LAB.CREATEWINDOW MAILFOLDER LAYOUT))) MAILFOLDER)))) -) (\LAFITE.MAYBE.OPEN.FOLDER -(LAMBDA (FOLDER ACCESS PROMPTFOLDER OPTIONS RETURNERRORS) (* ; "Edited 8-Sep-88 17:41 by bvm") (* ;; "Open FOLDER for indicated access, with the possibility that the file does not yet exist. If it doesn't, then create it, asking for confirmation if PROMPTFOLDER is supplied (a folder in whose browser to prompt for confirmation, or T for global prompt). Returns the stream on success. On failure, returns the condition if RETURNERRORS true, else NIL.") (PROG* ((FOLDERNAME (OR (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER) (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of FOLDER))) (OLDP (EQMEMB :OLD OPTIONS)) (RECOG (AND (OR OLDP PROMPTFOLDER) (QUOTE OLD))) STREAM CONDITION) RETRY (* ;; "Just try opening. If confirmation desired, open only OLD file on first try.") (CL:MULTIPLE-VALUE-SETQ (STREAM CONDITION) (IGNORE-ERRORS (\LAFITE.OPENSTREAM FOLDERNAME ACCESS RECOG (FUNCTION \LAFITE.EOF) (EQMEMB :BROWSE OPTIONS) (QUOTE LAFITE)))) (RETURN (if CONDITION then (* ; "Failed to open") (if (AND (NEQ RECOG (QUOTE NEW)) (NOT OLDP) (TYPEP CONDITION (QUOTE XCL:FILE-NOT-FOUND))) then (* ; "Just couldn't find it, so maybe create it. If RECOG was NEW, we normally shouldn't be getting this error") (if (OR (NOT (EQMEMB :CONFIRM OPTIONS)) (LAB.MOUSECONFIRM PROMPTFOLDER "Click LEFT to confirm creating ~A" FOLDERNAME)) then (SETQ RECOG (QUOTE NEW)) (SETQ ACCESS (QUOTE BOTH)) (GO RETRY) else (* ; "Disconfirmed the create request.") NIL) elseif RETURNERRORS then (* ; "Caller wants to know why") CONDITION else (* ; "File wouldn't open for some other reason than just not existing, so report it. Should probably be a little more discriminating here.") (\LAFITE.REPORT.FILE.WONT.OPEN (AND (NEQ PROMPTFOLDER T) PROMPTFOLDER) CONDITION FOLDERNAME) NIL) else (\LAFITE.SET.FOLDER.STREAM FOLDER STREAM) (* ; "Notice name fields and such") STREAM)))) -) (LAB.LOADFOLDER -(LAMBDA (MAILFOLDER) (* ; "Edited 13-Sep-88 17:42 by bvm") (COND ((LOADMAILFOLDER MAILFOLDER) (replace (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER with 1) (* ; "Nothing selected") (replace (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER with 0) (LAB.DISPLAYFOLDER MAILFOLDER) MAILFOLDER))) -) (LAB.DISPLAYFOLDER -(LAMBDA (FOLDER) (* ; "Edited 28-Apr-89 15:50 by bvm") (LET* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (CLIPREGION (DSPCLIPPINGREGION NIL WINDOW)) MSG) (CLEARW WINDOW) (LAB.SETUP FOLDER) (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER with NIL) (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of FOLDER with NIL) (COND ((AND (SETQ MSG (LAB.MAKE.INITIAL.SELECTION FOLDER)) (< (MESSAGE#.TO.YPOS MSG FOLDER) (fetch (REGION BOTTOM) of CLIPREGION))) (* ; "Quietly scroll so that selected message is in window") (WYOFFSET (TIMES (- (fetch (LAFITEMSG %#) of MSG) (QUOTIENT (fetch (REGION HEIGHT) of CLIPREGION) (TIMES 2 (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER)))) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER)) WINDOW))) (COND ((EQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) 0) (LAB.PROMPTPRINT FOLDER T "Folder is empty.")) (T (LAB.DISPLAYLINES FOLDER NIL NIL CLIPREGION))))) -) (LAB.MAKE.INITIAL.SELECTION -(LAMBDA (MAILFOLDER) (* bvm%: "24-Feb-86 16:31") (LET ((LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) MSGDESCRIPTOR I) (COND ((EQ LASTMSG# 0) NIL) ((SETQ I (LAB.FIND.SELECTED.MSG MAILFOLDER 1 LASTMSG#)) (* ; "There are already selected messages") (NTHMESSAGE MESSAGES I)) (T (find old I from 1 to LASTMSG# suchthat (AND (NOT (fetch (LAFITEMSG SEEN?) of (SETQ MSGDESCRIPTOR (NTHMESSAGE MESSAGES I)))) (NOT (fetch (LAFITEMSG DELETED?) of MSGDESCRIPTOR)))) (* ;; "Found an unseen, undeleted message. If we don't find one, the last MSGDESCRIPTOR is the one to select") (SELECTMESSAGE MSGDESCRIPTOR MAILFOLDER) MSGDESCRIPTOR)))) -) (LAB.CREATEWINDOW -(LAMBDA (FOLDER LAYOUT TITLE) (* ; "Edited 20-Apr-89 16:05 by bvm") (* ;;; "Build a browser window, which consists of three attached windows: the main BROWSERWINDOW, the BROWSERMENUWINDOW containing the menu, and a BROWSERPROMPTWINDOW for displaying random info") (if (NULL TITLE) then (SETQ TITLE (if FOLDER then (LAB.TITLE.STRING FOLDER) else "Dummy Browser"))) (PROG (BROWSERPROMPTWINDOW BROWSERMENUWINDOW BROWSERMENU BROWSERWINDOW WIDTH HEIGHT MENUREGION WHOLEREGION) (SETQ BROWSERMENU (create MENU ITEMS _ LAFITEBROWSERMENUITEMS CENTERFLG _ T WHENSELECTEDFN _ (if FOLDER then (FUNCTION LAB.COMMANDFN) else (FUNCTION NILL)) MENUFONT _ LAFITEMENUFONT)) (SETQ MENUREGION (WINDOWPROP (SETQ BROWSERMENUWINDOW (MENUWINDOW BROWSERMENU)) (QUOTE REGION))) (SETQ WIDTH (fetch (REGION WIDTH) of MENUREGION)) (SETQ HEIGHT (HEIGHTIFWINDOW (FONTPROP LAFITEBROWSERFONT (QUOTE HEIGHT)))) (* ;; "Now figure out where to put it all") (if LAYOUT then (* ; "user tells us all. If this happens to match one of the default regions, make sure to use it instead (future test is with EQ).") (if (EQ LAYOUT T) then (* ; "Requires prompting") (SETQ LAYOUT NIL) else (for SPEC in LAFITE.BROWSER.LAYOUTS when (EQUAL SPEC LAYOUT) do (RETURN (SETQ LAYOUT SPEC)))) elseif LAFITE.BROWSER.LAYOUTS then (* ; "Take the first layout not currently in use") (for SPEC in LAFITE.BROWSER.LAYOUTS unless (for OPEN in \ACTIVELAFITEFOLDERS thereis (EQ (fetch (MAILFOLDER BROWSERLAYOUT) of OPEN) SPEC)) do (RETURN (SETQ LAYOUT SPEC))) elseif (AND LAFITEBROWSERREGION (for OPEN in \ACTIVELAFITEFOLDERS never (fetch (MAILFOLDER BROWSERWINDOW) of OPEN))) then (* ; "For backward compatibility: if there are no open browsers, use LAFITEBROWSERREGION") (SETQ LAYOUT (LIST LAFITEBROWSERREGION NIL LAFITEDISPLAYREGION))) (COND ((SETQ WHOLEREGION (LISTP (CAR LAYOUT))) (COND ((> (fetch (REGION WIDTH) of WHOLEREGION) WIDTH) (* ; "Only use specified region width if it is wide enough") (SETQ WIDTH (fetch (REGION WIDTH) of WHOLEREGION)))) (SETQ WHOLEREGION (create REGION using WHOLEREGION WIDTH _ WIDTH)) (* ; "Copy the region so we don't smash user variable")) (T (* ; "Prompt for region") (SETQ WHOLEREGION (GETBOXREGION WIDTH (TIMES HEIGHT 9) NIL NIL NIL (CONCAT "Specify region for " TITLE))))) (replace (REGION HEIGHT) of WHOLEREGION with (- (fetch (REGION HEIGHT) of WHOLEREGION) (+ HEIGHT (fetch (REGION HEIGHT) of MENUREGION)))) (* ; "Shrink user-supplied region by the combined heights of the menu and prompt window") (SETQ BROWSERWINDOW (CREATEW WHOLEREGION TITLE)) (ATTACHWINDOW BROWSERMENUWINDOW BROWSERWINDOW (QUOTE TOP) (QUOTE JUSTIFY)) (DSPFONT LAFITEBROWSERFONT BROWSERWINDOW) (SETQ BROWSERPROMPTWINDOW (GETPROMPTWINDOW BROWSERWINDOW 1 LAFITEBROWSERFONT)) (CLEARW BROWSERPROMPTWINDOW) (* ; "Get the xy set correctly for the actual font being used") (LINELENGTH MAX.SMALLP BROWSERPROMPTWINDOW) (* ; "Make LINELENGTH ignored -- we try not to overflow window anyway, and the LINELENGTH is no good for variable width font") (if FOLDER then (* ; "MAILFOLDER = NIL is used by dummy routine to set up regions") (WINDOWADDPROP BROWSERPROMPTWINDOW (QUOTE RESHAPEFN) (FUNCTION (LAMBDA (W) (LINELENGTH MAX.SMALLP W)))) (WINDOWADDPROP BROWSERPROMPTWINDOW (QUOTE RESHAPEFN) (FUNCTION RESHAPEBYREPAINTFN)) (* ; "Adding our own reshapefn overrode the default, so add the default back in.") (WINDOWPROP BROWSERPROMPTWINDOW (QUOTE PAGEFULLFN) (FUNCTION LAB.PAGEFULLFN)) (replace (MAILFOLDER ORIGINALBROWSERTITLE) of FOLDER with TITLE) (WINDOWPROP BROWSERWINDOW (QUOTE MAILFOLDER) FOLDER) (WINDOWPROP BROWSERWINDOW (QUOTE SCROLLFN) (FUNCTION LAB.SCROLLFN)) (replace (MAILFOLDER BROWSERWINDOW) of FOLDER with BROWSERWINDOW) (replace (MAILFOLDER BROWSERMENUWINDOW) of FOLDER with BROWSERMENUWINDOW) (replace (MAILFOLDER BROWSERMENU) of FOLDER with BROWSERMENU) (replace (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER with BROWSERPROMPTWINDOW) (replace (MAILFOLDER FOLDERDISPLAYREGION) of FOLDER with (CADDR LAYOUT)) (replace (MAILFOLDER BROWSERLAYOUT) of FOLDER with LAYOUT) (WINDOWPROP BROWSERWINDOW (QUOTE REPAINTFN) (FUNCTION LAB.REPAINTFN)) (WINDOWPROP BROWSERWINDOW (QUOTE ICONFN) (FUNCTION LAB.ICONFN)) (WINDOWPROP BROWSERWINDOW (QUOTE ICONPOSITION) (CADR LAYOUT)) (WINDOWPROP BROWSERWINDOW (QUOTE BUTTONEVENTFN) (FUNCTION LAB.BUTTONEVENTFN)) (WINDOWPROP BROWSERWINDOW (QUOTE RIGHTBUTTONFN) (FUNCTION LAB.BUTTONEVENTFN)) (WINDOWPROP BROWSERWINDOW (QUOTE COPYBUTTONEVENTFN) (FUNCTION LAB.COPYBUTTONEVENTFN)) (* ; "make sure Lafite has the first CLOSEFN and SHRINKFN") (WINDOWADDPROP BROWSERWINDOW (QUOTE CLOSEFN) (FUNCTION LAB.CLOSEFN) T) (WINDOWADDPROP BROWSERWINDOW (QUOTE SHRINKFN) (FUNCTION LAB.SHRINKFN) T) (WINDOWADDPROP BROWSERWINDOW (QUOTE RESHAPEFN) (FUNCTION LAB.RESHAPEFN))) (RETURN BROWSERWINDOW))) -) (LAB.TITLE.STRING -(LAMBDA (FOLDER) (* ; "Edited 24-Oct-88 18:07 by bvm") (* ;; "Returns string to be used for FOLDER's browser's title. It is arranged to convey as much info as possible before it falls off the right edge of the window.") (LET* ((DEST (fetch (MAILFOLDER DEFAULTMOVETOFILE) of FOLDER)) (FIELDS (UNPACKFILENAME.STRING (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER))) (BODY (FMEMB (QUOTE NAME) FIELDS))) (RPLACD (NLEFT FIELDS 1 BODY)) (* ; "detach name.ext;version from host/directory") (CONCAT "Browsing " (if (STRING-EQUAL (LISTGET BODY (QUOTE EXTENSION)) LAFITEMAIL.EXT) then (* ; "Just the name field will do") (LISTGET BODY (QUOTE NAME)) else (CL:APPLY (FUNCTION PACKFILENAME.STRING) BODY)) (if DEST then (CONCAT " (Move To: " (fetch (MAILFOLDER SHORTFOLDERNAME) of DEST) ")") else "") " on " (if (U-CASEP (SETQ FIELDS (CL:APPLY (FUNCTION PACKFILENAME.STRING) FIELDS))) then (CL:STRING-CAPITALIZE FIELDS) else (* ; "Leave the capitalization alone") FIELDS)))) -) (LAB.COMMANDFN -(LAMBDA (ITEM MENU KEY) (* ; "Edited 18-Jul-88 11:41 by bvm") (OR \LAFITE.READY (\LAFITE.MARK.FOLDERS.OBSOLETE)) (LET ((MENUW (WFROMMENU MENU)) WINDOW FOLDER) (AND MENUW (SETQ WINDOW (WINDOWPROP MENUW (QUOTE MAINWINDOW))) (SETQ FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) (fetch (MAILFOLDER BROWSERREADY) of FOLDER) (CL:FUNCALL (EXTRACTMENUCOMMAND ITEM) WINDOW FOLDER ITEM MENU KEY)))) -) (LAB.DO.COMMAND -(LAMBDA (WINDOW ITEM/FN MENU KEY) (* ; "Edited 18-Jul-88 11:41 by bvm") (* ;; "Runs some browser command--variant on LAB.COMMANDFN to be called programmatically. If ITEM/FN is a function name, we get the real item and MENU from the window.") (OR \LAFITE.READY (\LAFITE.MARK.FOLDERS.OBSOLETE)) (LET ((FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER)))) (AND FOLDER (fetch (MAILFOLDER BROWSERREADY) of FOLDER) (CL:FUNCALL (if (LITATOM ITEM/FN) then (PROG1 ITEM/FN (OR MENU (SETQ MENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER))) (SETQ ITEM/FN (LA.MENU.ITEM ITEM/FN MENU))) else (EXTRACTMENUCOMMAND ITEM/FN)) WINDOW FOLDER ITEM/FN MENU KEY)))) -) (LAB.ASSURE.SELECTIONS -(LAMBDA (MAILFOLDER) (* bvm%: " 3-Feb-86 14:44") (COND ((IGREATERP (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER) (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER)) (LAB.PROMPTPRINT MAILFOLDER T "No messages selected.") T))) -) ) (DEFINEQ (BUILD.LAFITE.LAYOUTS -(LAMBDA NIL (* ; "Edited 23-Nov-87 16:48 by bvm:") (LET (DUMMYWINDOWS) (CL:UNWIND-PROTECT (PROG ((ICONBM (fetch (TITLEDICON ICON) of LAFITE.FOLDER.ICON)) (N 0) W MAILFOLDER LAYOUTS LAYOUT CURRENT OLDLAYOUTS POS) (if (AND (LISTP LAFITE.BROWSER.LAYOUTS) (CL:Y-OR-N-P "Do you wish to retain the ~D browser specifications you already have? " (LENGTH LAFITE.BROWSER.LAYOUTS))) then (SETQ OLDLAYOUTS LAFITE.BROWSER.LAYOUTS) (for LAYOUT in OLDLAYOUTS do (for FOLDER in \ACTIVELAFITEFOLDERS when (EQ (fetch (MAILFOLDER BROWSERLAYOUT) of FOLDER) LAYOUT) do (add N 1) (RETURN (CL:FORMAT T "Retaining layout in use by ~A.~%%" (fetch (MAILFOLDER SHORTFOLDERNAME) of FOLDER))) finally (* ; "Display dummy browser and icon to aid in positioning.") (SETQ W (LAB.CREATEWINDOW NIL LAYOUT (CONCAT "Sample Browser " (add N 1)))) (push DUMMYWINDOWS (\LAFITE.MAKE.DUMMY.WINDOWS W LAYOUT N)))) (SETQ LAYOUTS (REVERSE OLDLAYOUTS))) (CL:FORMAT T "Click in preference order in each browser or browser icon whose current layout you wish to include; click in background to finish~%%") (while (SETQ W (WHICHW (GETPOSITION))) do (if (AND (NOT (SETQ MAILFOLDER (WINDOWPROP W (QUOTE MAILFOLDER)))) (OR (NOT (SETQ W (WINDOWPROP W (QUOTE ICONFOR)))) (NOT (SETQ MAILFOLDER (WINDOWPROP W (QUOTE MAILFOLDER)))))) then (CL:FORMAT T "That's not a Lafite browser window/icon; try again.~%%") elseif (OR (MEMB (fetch (MAILFOLDER BROWSERLAYOUT) of MAILFOLDER) OLDLAYOUTS) (MEMBER (SETQ LAYOUT (\LAFITE.LAYOUT.FROM.WINDOW W MAILFOLDER ICONBM)) LAYOUTS)) then (CL:FORMAT T "You have already included that browser's specification.~%%") else (* ; "It's a Lafite browser window or icon.") (push LAYOUTS LAYOUT) (CL:FORMAT T "Browser for ~A noted.~%%" (fetch (MAILFOLDER SHORTFOLDERNAME) of MAILFOLDER)) (add N 1))) (while (OR (NULL LAYOUTS) (MENU (create MENU ITEMS _ (QUOTE (("Specify another browser" T) ("Finish" (QUOTE NIL)))) MENUFONT _ LAFITEMENUFONT CENTERFLG _ T))) do (SETQ W (LAB.CREATEWINDOW NIL T (CONCAT "Sample Browser " (add N 1)))) (push DUMMYWINDOWS (\LAFITE.MAKE.DUMMY.WINDOWS W (SETQ LAYOUT (\LAFITE.LAYOUT.FROM.WINDOW W NIL ICONBM)) N)) (push LAYOUTS LAYOUT)) (RETURN (if (AND LAYOUTS (MOUSECONFIRM "Click LEFT to confirm setting LAFITEBROWSERLAYOUTS to these values" T T T)) then (/SETTOPVAL (QUOTE LAFITE.BROWSER.LAYOUTS) (REVERSE LAYOUTS)) (MARKASCHANGED (QUOTE LAFITE.BROWSER.LAYOUTS) (QUOTE VARS)) LAFITE.BROWSER.LAYOUTS))) (* ;; "Cleanup dummy windows put up earlier") (for X in DUMMYWINDOWS bind TMP do (CLOSEW X) (if (SETQ TMP (WINDOWPROP X (QUOTE DUMMY.ICON))) then (CLOSEW TMP)) (if (SETQ TMP (WINDOWPROP X (QUOTE DUMMY.DISPLAY))) then (CLOSEW TMP)))))) -) (\LAFITE.LAYOUT.FROM.WINDOW -(LAMBDA (W FOLDER ICONBM) (* ; "Edited 10-Dec-87 17:15 by bvm:") (* ;; "Return a browser layout spec corresponding to window W optionally containing FOLDER.") (LET ((PW (if (OPENWP W) then (GETPROMPTWINDOW W 1 LAFITEBROWSERFONT) else PROMPTWINDOW))) (LIST (WINDOWREGION W) (if (WINDOWPROP W (QUOTE ICONPOSITION)) else (CLEARW PW) (CL:FORMAT PW "Specify position for icon.") (PROG1 (GETBOXPOSITION (BITMAPWIDTH ICONBM) (BITMAPHEIGHT ICONBM)) (CLEARW PW))) (PROG (CURRENT) (if FOLDER then (* ; "Use current values, if known") (RETURN (OR (if (CAR (SETQ CURRENT (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER))) then (* ; "take current primary window region") (COPY (WINDOWPROP (CAR CURRENT) (QUOTE REGION))) elseif (COPY (fetch (MAILFOLDER FOLDERDISPLAYREGION) of FOLDER))) (GO PROMPT)))) PROMPT (CLEARW PW) (CL:FORMAT PW "Specify region for display window") (RETURN (PROG1 (if LAFITE.DISPLAY.SIZE then (GETBOXREGION (CAR LAFITE.DISPLAY.SIZE) (CDR LAFITE.DISPLAY.SIZE) NIL NIL) else (GETREGION)) (CLEARW PW))))))) -) (\LAFITE.MAKE.DUMMY.WINDOWS -(LAMBDA (MAINW LAYOUT N) (* ; "Edited 23-Nov-87 16:44 by bvm:") (LET (TMP SUBW) (DSPFILL NIL LAFITE.DUMMY.SHADE (QUOTE REPLACE) MAINW) (WINDOWPROP MAINW (QUOTE SHRINKFN) (QUOTE DON'T)) (if (SETQ TMP (CADR LAYOUT)) then (* ; "An icon position is given") (SETQ SUBW (TITLEDICONW LAFITE.FOLDER.ICON (CONCAT "Icon " N) LAFITETITLEFONT TMP)) (ICONW.SHADE SUBW LAFITE.DUMMY.HALF.SHADE) (WINDOWPROP SUBW (QUOTE BUTTONEVENTFN) (FUNCTION ICONBUTTONEVENTFN)) (WINDOWPROP MAINW (QUOTE DUMMY.ICON) SUBW)) (if (SETQ TMP (CADDR LAYOUT)) then (* ; "A display region is given") (SETQ SUBW (CREATEW TMP (CONCAT "Lafite Display window " N) LAFITETITLEFONT TMP)) (DSPFILL NIL LAFITE.DUMMY.SHADE (QUOTE REPLACE) SUBW) (WINDOWPROP MAINW (QUOTE DUMMY.DISPLAY) SUBW)) MAINW)) -) ) (RPAQQ LAFITE.DUMMY.SHADE #*(16 16)@L@HA@@FALD@@DJ@AHF@@@JDH@NFD@@EDD@EDJ@EDJD@@LD@@HD@@HDD@@DJ@@DL) (RPAQQ LAFITE.DUMMY.HALF.SHADE #*(16 16)@H@@A@@D@@D@@DB@A@D@@@HDH@DB@@@DDD@A@B@DDHD@@D@@@@D@@H@D@@DJ@@@@) (RPAQ? \LAFITE.LAST.FOLDER.NAME ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LAFITE.LAST.FOLDER.NAME) ) (* ; "Browser operations") (DEFINEQ (LAB.SETUP -(LAMBDA (MAILFOLDER) (* bvm%: "31-Jul-84 14:39") (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) WIDTH HEIGHT TOTALHEIGHT ASCENT DIGITWIDTH SPACEWIDTH XPOS) (CLEARW WINDOW) (SETQ LAFITEBROWSERFONT (FONTCREATE LAFITEBROWSERFONT)) (DSPFONT LAFITEBROWSERFONT WINDOW) (DSPRIGHTMARGIN MAX.SMALLP WINDOW) (LINELENGTH 10000 WINDOW) (replace (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER with (SETQ HEIGHT (FONTPROP LAFITEBROWSERFONT (QUOTE HEIGHT)))) (replace (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER with (SETQ ASCENT (FONTPROP LAFITEBROWSERFONT (QUOTE ASCENT)))) (replace (MAILFOLDER BROWSERFONTDESCENT) of MAILFOLDER with (FONTPROP LAFITEBROWSERFONT (QUOTE DESCENT))) (replace (MAILFOLDER BROWSERORIGIN) of MAILFOLDER with (+ (DSPYPOSITION NIL WINDOW) ASCENT)) (replace (MAILFOLDER BROWSERMAXXPOS) of MAILFOLDER with (SETQ WIDTH (WINDOWPROP WINDOW (QUOTE WIDTH)))) (SETQ TOTALHEIGHT (TIMES (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) HEIGHT)) (WINDOWPROP WINDOW (QUOTE EXTENT) (replace (MAILFOLDER BROWSEREXTENT) of MAILFOLDER with (create REGION LEFT _ 0 BOTTOM _ (- (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) TOTALHEIGHT) WIDTH _ WIDTH HEIGHT _ TOTALHEIGHT))) (* ;; "Now figure out columns for printing toc entries") (SETQ DIGITWIDTH (CHARWIDTH (CHARCODE 9) LAFITEBROWSERFONT)) (SETQ SPACEWIDTH (CHARWIDTH (CHARCODE r) LAFITEBROWSERFONT)) (replace (MAILFOLDER ORDINALXPOS) of MAILFOLDER with (SETQ XPOS (+ BROWSERMARKXPOSITION (CHARWIDTH (CHARCODE m) LAFITEBROWSERFONT) (LRSH DIGITWIDTH 1)))) (* ; "Message # starts here") (replace (MAILFOLDER DATEXPOS) of MAILFOLDER with (add XPOS (+ (TIMES 2 SPACEWIDTH) (TIMES 4 DIGITWIDTH)))) (* ; "Date starts here. Allow 4 columns of digits plus some space") (replace (MAILFOLDER FROMXPOS) of MAILFOLDER with (add XPOS (+ (TIMES 2 DIGITWIDTH) (TIMES 2 SPACEWIDTH) (CHARWIDTH (CHARCODE -) LAFITEBROWSERFONT) (STRINGWIDTH (QUOTE MAY) LAFITEBROWSERFONT)))) (* ; "From field starts here. Allow 3 columns of digits, a month, and some space") (replace (MAILFOLDER SUBJECTXPOS) of MAILFOLDER with (add XPOS (IMAX (TIMES LAFITEMINFROMCHARS (CHARWIDTH (CHARCODE A) LAFITEBROWSERFONT)) (FIXR (FTIMES LAFITEFROMFRACTION (- WIDTH XPOS)))))) (* ;; "Subject field starts here. Space is divided up between From and Subject so that From field gets LAFITEFROMFRACTION of the available space, but at least LAFITEMINFROMCHARS wide") (replace (MAILFOLDER FROMMAXXPOS) of MAILFOLDER with (- XPOS (TIMES 2 SPACEWIDTH))) (* ; "From field gets truncated beyond this position") (replace (MAILFOLDER BROWSERDIGITWIDTH) of MAILFOLDER with DIGITWIDTH))) -) (LAB.BUTTONEVENTFN -(LAMBDA (WINDOW) (* ; "Edited 28-Jul-88 17:37 by bvm") (TOTOPW WINDOW) (COND ((INSIDEP (DSPCLIPPINGREGION NIL WINDOW) (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (LAB.DO.UNLESS.BUSY WINDOW (FUNCTION LAB.SELECTMESSAGE))) ((LASTMOUSESTATE (ONLY RIGHT)) (DOWINDOWCOM WINDOW)) ((LASTMOUSESTATE (ONLY MIDDLE)) (LAB.DO.UNLESS.BUSY WINDOW (FUNCTION LAFITEEXTRABROWSERCOMMANDFN))))) -) (LAB.DO.UNLESS.BUSY -(LAMBDA (WINDOW FN ARGUMENT) (* ; "Edited 3-Sep-87 18:01 by bvm:") (RESETLST (PROG ((MAILFOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER)))) (COND ((AND (fetch (MAILFOLDER BROWSERREADY) of MAILFOLDER) (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) T T)) (CL:FUNCALL FN WINDOW MAILFOLDER ARGUMENT)))))) -) (LOADMAILFOLDER -(LAMBDA (FOLDER) (* ; "Edited 10-May-89 12:42 by bvm") (* ;; "LAFITEVERSION# is used to keep track of changed in internal datastructures that get written out to Lafite TOC files. If the datastructures change, then just change the version number to LAFITEVERSION#+1 and the rest of Lafite should adjust appropriately.") (replace (MAILFOLDER FOLDEROUTOFORDER) of FOLDER with NIL) (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with NIL) (* ; "Assume ok until we hear otherwise") (COND ((OR (\LAFITE.READ.TOC.FILE FOLDER) (\LAFITE.PARSE.FOLDER FOLDER)) (LAB.PROMPTPRINT FOLDER " done.") (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER with (OR (LAB.SET.EXPUNGEABILITY FOLDER) (MAX 1 (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)))) (* ; "Only %"changed%" messages are deleted ones now, except for possibly the last message in the case where it was truncated.") FOLDER))) -) (LAFITE.OBTAIN.FOLDER -(LAMBDA (FOLDERNAME ACCESS PROMPTFOLDER OPTIONS) (* ; "Edited 12-Sep-88 17:42 by bvm") (* ;;; "Locates a MAILFOLDER on FOLDERNAME, or creates one if there is none. If the folder is not already on the active list, we will try to open it for ACCESS, or just return NIL if ACCESS is NIL. If PROMPTFOLDER is supplied, it is a folder (or T for PROMPTWINDOW) indicating focus of attention for prompting for confirmation to create new folder. OPTIONS may include :FORGET, in which case we don't add this folder name to the set of known folders, or :BROWSE, meaning we plan to browse the folder.") (WITH.MONITOR \LAFITE.BROWSELOCK (OR (for FOLDER in \ACTIVELAFITEFOLDERS when (OR (STRING-EQUAL (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of FOLDER) FOLDERNAME) (STRING-EQUAL (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER) FOLDERNAME)) do (* ; "Found existing folder without sweating too hard") (RETURN FOLDER)) (AND ACCESS (LET* ((UNPACKEDNAME (UNPACKFILENAME.STRING FOLDERNAME)) (OLDVERSION (LISTGET UNPACKEDNAME (QUOTE VERSION))) (VERSIONLESSNAME (PROGN (LISTPUT UNPACKEDNAME (QUOTE VERSION) NIL) (PACKFILENAME.STRING UNPACKEDNAME))) SHORTNAME NEWNAME NEWFOLDER OLDFOLDER STREAM) (COND ((AND (NOT (STRING-EQUAL VERSIONLESSNAME FOLDERNAME)) (SETQ NEWFOLDER (\LAFITE.FIND.EXISTING.FOLDER VERSIONLESSNAME)) (\LAFITE.CONFLICTING.OLD.FOLDER NEWFOLDER FOLDERNAME OLDVERSION)) (* ; "Found a folder describing a different version--can't have more than one version up at once") NIL) ((NULL (SETQ STREAM (\LAFITE.MAYBE.OPEN.FOLDER (SETQ NEWFOLDER (create MAILFOLDER FULLFOLDERNAME _ FOLDERNAME VERSIONLESSFOLDERNAME _ VERSIONLESSNAME FOLDERLOCK _ (CREATE.MONITORLOCK VERSIONLESSNAME))) ACCESS PROMPTFOLDER OPTIONS T))) (* ; "File not found and user didn't confirm creating it") NIL) ((type? STREAM STREAM) (* ; "succeeded in opening the new folder.") (PROG ((VERSIONLESSNEW (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) (fetch (MAILFOLDER FULLFOLDERNAME) of NEWFOLDER))) (SHORTNAME (fetch SHORTFOLDERNAME of NEWFOLDER))) (if (NOT (STRING-EQUAL VERSIONLESSNEW VERSIONLESSNAME)) then (* ; "We guessed wrong about the versionless name--having actually opened the file, here's the canonical name") (if (SETQ OLDFOLDER (\LAFITE.FIND.EXISTING.FOLDER VERSIONLESSNEW)) then (* ; "it turns out we already had this file open under a different full name. Close the new one and return the old") (\LAFITE.CLOSE.FOLDER NEWFOLDER T) (RETURN (AND (NOT (\LAFITE.CONFLICTING.OLD.FOLDER OLDFOLDER FOLDERNAME OLDVERSION)) OLDFOLDER)) else (replace (MAILFOLDER VERSIONLESSFOLDERNAME) of NEWFOLDER with VERSIONLESSNEW))) (push \ACTIVELAFITEFOLDERS NEWFOLDER) (if (NOT (CL:MEMBER SHORTNAME (CDR LAFITEMAILFOLDERS) :TEST (QUOTE STRING-EQUAL))) then (* ; "This is a new folder") (COND ((EQMEMB :FORGET OPTIONS) (* ; "Don't remember it, but do set default for next Browse&Forget") (SETQ \LAFITE.LAST.FOLDER.NAME SHORTNAME)) (T (* ; "Add to list for menu") (\LAFITE.NOTICE.FILE SHORTNAME)))) (RETURN NEWFOLDER))) (T (* ; "STREAM is a condition signaled by the attempt to open the file") (if (AND (TYPEP STREAM (QUOTE XCL:FILE-WONT-OPEN)) (SETQ OLDFOLDER (OR (AND (SETQ NEWNAME (XCL:FILE-WONT-OPEN-PATHNAME STREAM)) (NOT (STRING-EQUAL VERSIONLESSNAME (SETQ VERSIONLESSNAME (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) NEWNAME)))) (\LAFITE.FIND.EXISTING.FOLDER VERSIONLESSNAME)) (AND (SETQ NEWNAME (INFILEP VERSIONLESSNAME)) (NOT (STRING-EQUAL VERSIONLESSNAME (SETQ VERSIONLESSNAME (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) NEWNAME)))) (\LAFITE.FIND.EXISTING.FOLDER VERSIONLESSNAME)))) (NOT (\LAFITE.CONFLICTING.OLD.FOLDER NEWFOLDER FOLDERNAME OLDVERSION))) then (* ; "Looks like file wouldn't open because we already have it open by a different name. Return that folder") OLDFOLDER else (* ; "Report the problem") (\LAFITE.REPORT.FILE.WONT.OPEN PROMPTFOLDER STREAM (OR NEWNAME FOLDERNAME)) NIL)))))))) -) (\LAFITE.FIND.EXISTING.FOLDER -(LAMBDA (VERSIONLESSNAME) (* ; "Edited 22-Aug-88 17:32 by bvm") (* ;; "Returns an existing mail folder object whose versionless name is (case-insensitively) equal to VERSIONLESSNAME, or NIL on failure.") (find FOLDER in \ACTIVELAFITEFOLDERS suchthat (STRING-EQUAL (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of FOLDER) VERSIONLESSNAME))) -) (\LAFITE.CONFLICTING.OLD.FOLDER -(LAMBDA (NEWFOLDER FOLDERNAME OLDVERSION) (* ; "Edited 22-Aug-88 18:30 by bvm") (* ;; "NEWFOLDER is a folder we found somewhere during the search for FOLDERNAME. Check that it works, i.e., that it doesn't have a version number that differs from that of FOLDERNAME") (COND ((NULL OLDVERSION) (* ; "User didn't ask for a specific version, so this folder is fine") NIL) ((OR (fetch (MAILFOLDER BROWSERWINDOW) of NEWFOLDER) (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of NEWFOLDER)) (printout PROMPTWINDOW T "A different version of " FOLDERNAME " is already being browsed." "Multiple versions may not be manipulated at once.") T) (T (* ; "Not being browsed, so kill it and pretend it never existed") (\LAFITE.CLOSE.FOLDER NEWFOLDER T) (SETQ \ACTIVELAFITEFOLDERS (DREMOVE NEWFOLDER \ACTIVELAFITEFOLDERS)) NIL))) -) (LAB.REPAINTFN -(LAMBDA (WINDOW REGION) (* ; "Edited 28-Apr-89 16:00 by bvm") (LET ((FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER)))) (AND (NEQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) 0) (fetch (MAILFOLDER BROWSERREADY) of FOLDER) (RESETLST (COND ((OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) T T) (LAB.DISPLAYLINES FOLDER NIL NIL REGION)) (T (MAILFOLDERBUSY FOLDER))))))) -) (LAB.SCROLLFN -(LAMBDA (WINDOW DX DY CONTINUOUSFLG) (* bvm%: " 3-Jan-84 14:53") (* ;;; "only scroll if can get the monitor lock") (RESETLST (PROG ((MAILFOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER)))) (COND ((AND (fetch (MAILFOLDER BROWSERREADY) of MAILFOLDER) (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) T T)) (SCROLLBYREPAINTFN WINDOW DX DY CONTINUOUSFLG)) (T (MAILFOLDERBUSY MAILFOLDER)))))) -) (LAB.RESHAPEFN -(LAMBDA (WINDOW OLDIMAGEBM OLDREGION) (* ; "Edited 28-Apr-89 15:57 by bvm") (RESETLST (PROG ((FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) (REGION (DSPCLIPPINGREGION NIL WINDOW)) MSG#) (COND ((NOT (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) T T)) (* ; "Folder is busy, have to wait until it is ready. But don't tie up mouse!") (ALLOW.BUTTON.EVENTS) (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) NIL T)) ((NOT (fetch (MAILFOLDER BROWSERREADY) of FOLDER)) (* ; "Browser not functional") (RETURN (RESHAPEBYREPAINTFN WINDOW OLDIMAGEBM OLDREGION)))) (SETQ MSG# (FIRSTVISIBLEMESSAGE FOLDER REGION)) (LAB.SETUP FOLDER) (WYOFFSET (ITIMES (SUB1 MSG#) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER)) WINDOW) (LAB.DISPLAYLINES FOLDER MSG# NIL REGION)))) -) (LAB.CLOSEFN -(LAMBDA (BROWSERWINDOW) (* ; "Edited 15-Sep-87 17:56 by bvm:") (LAB.CLOSE/SHRINK BROWSERWINDOW :CLOSE)) -) (LAB.SHRINKFN -(LAMBDA (WINDOW) (* ; "Edited 15-Sep-87 17:56 by bvm:") (LAB.CLOSE/SHRINK WINDOW :SHRINK))) (LAB.CLOSE/SHRINK -(LAMBDA (BROWSERWINDOW FLG) (* ; "Edited 7-Jun-88 14:42 by bvm") (* ;; "Called from CLOSEFN or SHRINKFN of BROWSERWINDOW with FLG = :CLOSE or :SHRINK. Before doing anything, let user update file.") (RESETLST (LET ((MAILFOLDER (WINDOWPROP BROWSERWINDOW (QUOTE MAILFOLDER))) HOW?) (COND ((OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) T T) (AND (OPENWP BROWSERWINDOW) (CLEARW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of MAILFOLDER))) (SELECTQ (SETQ HOW? (COND ((AND (fetch (MAILFOLDER BROWSERREADY) of MAILFOLDER) (SETQ HOW? (LAB.CHOOSE.UPDATE.MENU MAILFOLDER FLG))) (MENU HOW?)) (T (FUNCTION \LAFITE.FINISH.UPDATE)))) (NIL (QUOTE DON'T)) (PROGN (\LAFITE.PROCESS (LIST HOW? (KWOTE BROWSERWINDOW) (KWOTE MAILFOLDER) (KWOTE FLG)) (QUOTE LAFITEUPDATE)) (* ; "Return DON'T now, for UPDATE.PROC will do it later") (QUOTE DON'T)))) (T (printout PROMPTWINDOW T "Browser is busy, can't close") (QUOTE DON'T)))))) -) (LAB.EXPANDFN -(LAMBDA (BROWSERWINDOW) (* ; "Edited 28-Apr-89 18:50 by bvm") (LET ((FOLDER (WINDOWPROP BROWSERWINDOW (QUOTE MAILFOLDER)))) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (LET ((FIRSTCHANGEDMSG# (fetch (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER))) (* ; "Restore SHRINKFN prop if necessary") (WINDOWADDPROP BROWSERWINDOW (QUOTE SHRINKFN) (FUNCTION LAB.SHRINKFN) T) (COND (FIRSTCHANGEDMSG# (* ; "Browser has changed since shrinking") (COND ((EQ FIRSTCHANGEDMSG# 0) (* ; "After expunge") (LAB.DISPLAYFOLDER FOLDER)) (T (LAB.DISPLAYLINES FOLDER FIRSTCHANGEDMSG# NIL NIL T))) (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER with NIL))))))) -) (LAFITEEXTRABROWSERCOMMANDFN -(LAMBDA (WINDOW MAILFOLDER) (* ; "Edited 28-Jul-88 17:37 by bvm") (PROG ((FN (MENU (.LAFITEMENU. LAFITEEXTRAMENU LAFITEEXTRAMENUITEMS)))) (COND (FN (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (CL:FUNCALL FN MAILFOLDER))))) -) ) (* ; "Browser selection") (DEFINEQ (LAB.SELECTMESSAGE -(LAMBDA (WINDOW) (* ; "Edited 7-Jun-88 17:37 by bvm") (PROG ((*MAILFOLDER* (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) *MESSAGES* *FIRST-VISIBLE* *LAST-VISIBLE* *TOC-STATE* SELECTIONREGION FIRST# LAST# SEL# OLDSEL# CTRLDOWN OLDLASTMOUSEBUTTONS MSG LASTX LASTY MARKRIGHT) (COND ((EQ (fetch (MAILFOLDER %#OFMESSAGES) of *MAILFOLDER*) 0) (* ; "Nothing to select") (RETURN))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) (SETQ LAST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of *MAILFOLDER*)) (SETQ FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of *MAILFOLDER*)) (SETQ *FIRST-VISIBLE* (FIRSTVISIBLEMESSAGE *MAILFOLDER* SELECTIONREGION)) (SETQ *LAST-VISIBLE* (LASTVISIBLEMESSAGE *MAILFOLDER* SELECTIONREGION)) (SETQ *MESSAGES* (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of *MAILFOLDER*)) (SETQ MARKRIGHT (fetch (MAILFOLDER ORDINALXPOS) of *MAILFOLDER*)) (* ;; "keep looping until all mouse buttons are up") (do (GETMOUSESTATE) (COND ((NOT (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW)))) (* ;; "I would like to just return here and let the next window take over, but current mouse arrangement means I'll never get control back unless user lets up on mouse") (COND ((NEQ *TOC-STATE* TS.IDLE) (LA.UNDOSELECTION) (SETQ OLDSEL#))) (COND ((LASTMOUSESTATE UP) (RETURN)) (T (BLOCK)))) ((LASTMOUSESTATE UP) (* ; "Make selection permanent") (SELECTC *TOC-STATE* (TS.REPLACING (for MSG selectedin *MAILFOLDER* do (replace SELECTED? of MSG with NIL)) (replace SELECTED? of (NTHMESSAGE *MESSAGES* OLDSEL#) with T) (replace FIRSTSELECTEDMESSAGE of *MAILFOLDER* with (replace LASTSELECTEDMESSAGE of *MAILFOLDER* with OLDSEL#))) (TS.ADDING (LA.SELECTRANGE *MAILFOLDER* OLDSEL# OLDSEL# T)) (TS.REMOVING (LA.DESELECTRANGE *MAILFOLDER* OLDSEL# OLDSEL#)) (TS.EXTENDING.HI (LA.SELECTRANGE *MAILFOLDER* (ADD1 LAST#) OLDSEL# CTRLDOWN)) (TS.EXTENDING.LO (LA.SELECTRANGE *MAILFOLDER* OLDSEL# (SUB1 FIRST#) CTRLDOWN)) (TS.SHRINKING.HI (LA.DESELECTRANGE *MAILFOLDER* (ADD1 OLDSEL#) LAST#)) (TS.SHRINKING.LO (LA.DESELECTRANGE *MAILFOLDER* FIRST# (SUB1 OLDSEL#))) NIL) (RETURN)) ((AND (>= LASTX BROWSERMARKXPOSITION) (< LASTX MARKRIGHT)) (* ; "Inside mark region") (COND ((NEQ *TOC-STATE* TS.IDLE) (LA.UNDOSELECTION) (SETQ OLDSEL#))) (LAB.CHANGEMARK *MAILFOLDER*)) ((OR (NEQ (SETQ SEL# (YPOS.TO.MESSAGE# (LASTMOUSEY WINDOW) *MAILFOLDER*)) OLDSEL#) (NEQ LASTMOUSEBUTTONS OLDLASTMOUSEBUTTONS)) (COND ((AND (SHIFTDOWNP (QUOTE CTRL)) (NOT (LASTMOUSESTATE RIGHT))) (* ; "Deselect this message") (SELECTC *TOC-STATE* (TS.REMOVING (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* OLDSEL#) (QUOTE REPLACE))) (TS.IDLE) (LA.UNDOSELECTION)) (SETQ *TOC-STATE* (COND ((fetch SELECTED? of (SETQ MSG (NTHMESSAGE *MESSAGES* SEL#))) (LA.SHOW.SELECTION *MAILFOLDER* MSG (QUOTE ERASE)) TS.REMOVING) (T TS.IDLE)))) ((LASTMOUSESTATE LEFT) (* ; "Set (change) the selection to this single message") (COND ((EQ *TOC-STATE* TS.REPLACING) (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* OLDSEL#) (QUOTE ERASE))) (T (LA.DECONSIDERRANGE *FIRST-VISIBLE* *LAST-VISIBLE*) (SETQ *TOC-STATE* TS.REPLACING))) (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* SEL#) (QUOTE REPLACE))) ((LASTMOUSESTATE MIDDLE) (* ; "Add this message to the selection") (SELECTC *TOC-STATE* (TS.ADDING (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* OLDSEL#) (QUOTE ERASE))) (TS.IDLE) (LA.UNDOSELECTION)) (SETQ *TOC-STATE* (COND ((NOT (fetch SELECTED? of (SETQ MSG (NTHMESSAGE *MESSAGES* SEL#)))) (LA.SHOW.SELECTION *MAILFOLDER* MSG (QUOTE REPLACE)) TS.ADDING) (T TS.IDLE)))) ((LASTMOUSESTATE RIGHT) (* ; "Extend: either up or down, or shrink a selection. This is messy") (SELECTC *TOC-STATE* (TS.EXTENDING.HI (COND ((> SEL# OLDSEL#) (* ; "Extend further") (LA.CONSIDERRANGE (ADD1 OLDSEL#) SEL# CTRLDOWN)) (T (* ; "Shrinking back") (LA.RECONSIDERRANGE (ADD1 (COND ((> SEL# LAST#) SEL#) (T (SETQ *TOC-STATE* TS.IDLE) LAST#))) OLDSEL#)))) (TS.EXTENDING.LO (COND ((< SEL# OLDSEL#) (* ; "Extend further") (LA.CONSIDERRANGE SEL# (SUB1 OLDSEL#) CTRLDOWN)) (T (* ; "Shrinking back") (LA.RECONSIDERRANGE OLDSEL# (SUB1 (COND ((< SEL# FIRST#) SEL#) (T (SETQ *TOC-STATE* TS.IDLE) FIRST#))))))) (TS.SHRINKING.HI (COND ((>= SEL# OLDSEL#) (* ; "Shrinking less") (LA.RECONSIDERRANGE (ADD1 OLDSEL#) (COND ((< SEL# LAST#) SEL#) (T (SETQ *TOC-STATE* TS.IDLE) LAST#)))) ((>= SEL# FIRST#) (* ; "Shrinking further") (LA.DECONSIDERRANGE (ADD1 SEL#) OLDSEL#)) (T (* ; "Too far to shrink") (LA.RECONSIDERRANGE FIRST# LAST#) (SETQ *TOC-STATE* TS.IDLE)))) (TS.SHRINKING.LO (COND ((<= SEL# OLDSEL#) (* ; "Shrinking less") (LA.RECONSIDERRANGE (COND ((> SEL# FIRST#) SEL#) (T (SETQ *TOC-STATE* TS.IDLE) FIRST#)) (SUB1 OLDSEL#))) ((<= SEL# LAST#) (* ; "Shrinking further") (LA.DECONSIDERRANGE OLDSEL# (SUB1 SEL#))) (T (* ; "Too far to shrink") (LA.RECONSIDERRANGE FIRST# LAST#) (SETQ *TOC-STATE* TS.IDLE)))) (COND ((NOT (> FIRST# LAST#)) (COND ((NEQ *TOC-STATE* TS.IDLE) (LA.UNDOSELECTION))) (SETQ CTRLDOWN (SHIFTDOWNP (QUOTE CTRL))) (SETQ *TOC-STATE* (COND ((> SEL# LAST#) (LA.CONSIDERRANGE (ADD1 LAST#) SEL# CTRLDOWN) TS.EXTENDING.HI) ((< SEL# FIRST#) (LA.CONSIDERRANGE SEL# (SUB1 FIRST#) CTRLDOWN) TS.EXTENDING.LO) ((> SEL# (LRSH (+ LAST# FIRST#) 1)) (LA.DECONSIDERRANGE (ADD1 SEL#) LAST#) TS.SHRINKING.HI) (T (LA.DECONSIDERRANGE FIRST# (SUB1 SEL#)) TS.SHRINKING.LO)))))))) (SETQ OLDLASTMOUSEBUTTONS LASTMOUSEBUTTONS) (SETQ OLDSEL# (AND (NEQ *TOC-STATE* TS.IDLE) SEL#))))) (COND ((EQ LAFITEVERIFYFLG (QUOTE TOC)) (LA.VERIFY.SELECTION *MAILFOLDER*))))) -) (LAB.CHANGEMARK -(LAMBDA (MAILFOLDER) (* bvm%: "17-Feb-84 15:46") (* ;; "Called when mouse is inside the 'mark' region of a browser. Tracks mouse while in that region and does whatever is appropriate") (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) (RIGHT (fetch (MAILFOLDER ORDINALXPOS) of MAILFOLDER)) SEL# OLDSEL# COCKED REGION X Y TOP BOTTOM) (SETQ BOTTOM (fetch (REGION BOTTOM) of (SETQ REGION (DSPCLIPPINGREGION NIL WINDOW)))) (SETQ TOP (fetch (REGION TOP) of REGION)) (do (GETMOUSESTATE) (COND ((OR (< (SETQ X (LASTMOUSEX WINDOW)) BROWSERMARKXPOSITION) (> X RIGHT) (< (SETQ Y (LASTMOUSEY WINDOW)) BOTTOM) (> Y TOP)) (COND (COCKED (LA.INVERT.MARK.BOX MAILFOLDER OLDSEL#))) (RETURN)) ((LASTMOUSESTATE UP) (COND (COCKED (LA.READ.NEW.MARK MAILFOLDER OLDSEL#))) (RETURN)) ((NEQ (SETQ SEL# (YPOS.TO.MESSAGE# Y MAILFOLDER)) OLDSEL#) (COND (COCKED (LA.INVERT.MARK.BOX MAILFOLDER OLDSEL#)) (T (SETQ COCKED T))) (LA.INVERT.MARK.BOX MAILFOLDER (SETQ OLDSEL# SEL#))))))) -) (LA.READ.NEW.MARK -(LAMBDA (FOLDER MSG#) (* ; "Edited 25-Apr-89 17:55 by bvm") (PROG ((MSG (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) MSG#)) (WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) YPOS MARK) (RESETSAVE NIL (LIST (FUNCTION CLEARW) (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER))) (RESETSAVE NIL (LIST (FUNCTION LA.SHOW.MARK) MSG FOLDER)) (* ; "Display correct mark on exit no matter what happens") (RESETSAVE (TTYDISPLAYSTREAM WINDOW)) (* ; "So caret flashes in the right place") (RESETSAVE NIL (LIST (QUOTE WINDOWPROP) WINDOW (QUOTE PROCESS) NIL)) (* ;; "PROCESS prop put there by TTYDISPLAYSTREAM -- don't want it to linger, else MOUSE proc will get tty in future when we bug browser") (LA.BLT.MARK.BOX FOLDER WINDOW (SETQ YPOS (MESSAGE#.TO.YPOS MSG FOLDER)) (QUOTE REPLACE) WHITESHADE) (* ; "Erase whatever's there") (LAB.PROMPTPRINT FOLDER T "Type single character mark, or ESC to abort") (MOVETO BROWSERMARKXPOSITION YPOS WINDOW) (COND ((AND (>= (SETQ MARK (\GETKEY)) (CHARCODE SPACE)) (<= MARK (CHARCODE DEL))) (LAB.MARKS.CHANGED MSG FOLDER) (replace (LAFITEMSG SEEN?) of MSG with (NOT (UNSEENMARKP MARK))) (replace (LAFITEMSG MARKCHAR) of MSG with MARK))))) -) (YPOS.TO.MESSAGE# -(LAMBDA (YPOS MAILFOLDER) (* bvm%: "24-Dec-83 17:45") (PROG ((N (IQUOTIENT (IPLUS (IDIFFERENCE (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) YPOS) (fetch (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER)) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER)))) (RETURN (COND ((ILEQ N 0) 1) (T (IMIN N (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER))))))) -) (MESSAGE#.TO.YPOS -(LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* bvm%: "24-Dec-83 16:37") (IDIFFERENCE (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) (ITIMES (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER) (fetch (LAFITEMSG %#) of MSGDESCRIPTOR)))) -) ) (DEFINEQ (LA.CONSIDERRANGE -(LAMBDA (FIRST# LAST# EVENIFDELETED) (* ; "Edited 7-Jun-88 17:34 by bvm") (* ;;; "Change display so that messages from FIRST# to LAST# are marked as selected. Deleted messages are not selected unless EVENIFDELETED is true") (for I from (IMAX FIRST# *FIRST-VISIBLE*) to (IMIN LAST# *LAST-VISIBLE*) bind MSG do (SETQ MSG (NTHMESSAGE *MESSAGES* I)) (COND ((OR EVENIFDELETED (NOT (fetch DELETED? of MSG))) (LA.SHOW.SELECTION *MAILFOLDER* MSG (QUOTE REPLACE)))))) -) (LA.DECONSIDERRANGE -(LAMBDA (FIRST# LAST#) (* ; "Edited 7-Jun-88 17:35 by bvm") (* ;;; "Change display so that messages from FIRST# to LAST# are marked as unselected.") (for I from (IMAX FIRST# *FIRST-VISIBLE*) to (IMIN LAST# *LAST-VISIBLE*) do (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* I) (QUOTE ERASE)))) -) (LA.RECONSIDERRANGE -(LAMBDA (FIRST# LAST#) (* ; "Edited 7-Jun-88 17:35 by bvm") (* ;;; "Change display so that messages from FIRST# to LAST# are marked as selected or unselected according to the truth of the matter.") (for I from (IMAX FIRST# *FIRST-VISIBLE*) to (IMIN LAST# *LAST-VISIBLE*) bind MSG do (LA.SHOW.SELECTION *MAILFOLDER* (SETQ MSG (NTHMESSAGE *MESSAGES* I)) (COND ((fetch SELECTED? of MSG) (QUOTE REPLACE)) (T (QUOTE ERASE)))))) -) (LA.SELECTRANGE -(LAMBDA (MAILFOLDER FIRST# LAST# EVENIFDELETED) (* bvm%: "15-Feb-84 15:39") (* ;;; "Mark internally messages FIRST# thru LAST# as selected. Do not select deleted messages unless EVENIFDELETED is true. Keeps MAILFOLDER:LASTSELECTEDMESSAGE and MAILFOLDER:FIRSTSELECTEDMESSAGE up to date. Assumes display has already been appropriately modified") (PROG ((MESSAGES (fetch MESSAGEDESCRIPTORS of MAILFOLDER)) (FIRSTSEL (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER)) (LASTSEL (fetch LASTSELECTEDMESSAGE of MAILFOLDER)) MSG) (for I from FIRST# to LAST# do (SETQ MSG (NTHMESSAGE MESSAGES I)) (COND ((OR EVENIFDELETED (NOT (fetch DELETED? of MSG))) (replace SELECTED? of MSG with T)))) (COND ((OR (> FIRSTSEL LASTSEL) (< FIRST# (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER))) (replace FIRSTSELECTEDMESSAGE of MAILFOLDER with FIRST#))) (COND ((OR (> FIRSTSEL LASTSEL) (> LAST# (fetch LASTSELECTEDMESSAGE of MAILFOLDER))) (replace LASTSELECTEDMESSAGE of MAILFOLDER with LAST#))))) -) (LA.DESELECTRANGE -(LAMBDA (MAILFOLDER FIRST# LAST#) (* bvm%: "28-Mar-84 14:52") (* ;;; "Mark internally messages FIRST# thru LAST# as unselected. Keeps MAILFOLDER:LASTSELECTEDMESSAGE and MAILFOLDER:FIRSTSELECTEDMESSAGE up to date. Assumes display has already been appropriately modified") (COND ((ILEQ FIRST# LAST#) (PROG ((MESSAGES (fetch MESSAGEDESCRIPTORS of MAILFOLDER))) (for I from FIRST# to LAST# do (replace SELECTED? of (NTHMESSAGE MESSAGES I) with NIL)) (COND ((EQ FIRST# (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER)) (replace FIRSTSELECTEDMESSAGE of MAILFOLDER with (COND ((LAB.FIND.SELECTED.MSG MAILFOLDER (ADD1 LAST#) (fetch LASTSELECTEDMESSAGE of MAILFOLDER))) (T (replace LASTSELECTEDMESSAGE of MAILFOLDER with 0) (* ; "Null selection indicated by first GT last.") (ADD1 (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)))))) ((EQ LAST# (fetch LASTSELECTEDMESSAGE of MAILFOLDER)) (replace LASTSELECTEDMESSAGE of MAILFOLDER with (OR (LAB.REV.FIND.SELECTED.MSG MAILFOLDER (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER) (SUB1 FIRST#)) 1)))))))) -) (LAB.FIND.SELECTED.MSG -(LAMBDA (MAILFOLDER FIRST# LAST#) (* bvm%: "15-Feb-84 12:22") (find I from FIRST# to LAST# bind (MESSAGES _ (fetch MESSAGEDESCRIPTORS of MAILFOLDER)) suchthat (fetch SELECTED? of (NTHMESSAGE MESSAGES I)))) -) (LAB.REV.FIND.SELECTED.MSG -(LAMBDA (MAILFOLDER FIRST# LAST#) (* bvm%: " 2-Mar-84 18:02") (find I from LAST# to FIRST# by -1 bind (MESSAGES _ (fetch MESSAGEDESCRIPTORS of MAILFOLDER)) suchthat (fetch SELECTED? of (NTHMESSAGE MESSAGES I)))) -) (LA.UNDOSELECTION -(LAMBDA NIL (* ; "Edited 7-Jun-88 17:37 by bvm") (* ;;; "Restore browser to state before any selections were attempted") (LA.RECONSIDERRANGE *FIRST-VISIBLE* *LAST-VISIBLE*) (SETQ *TOC-STATE* TS.IDLE)) -) (LA.VERIFY.SELECTION -(LAMBDA (MAILFOLDER) (* bvm%: "15-Feb-84 11:53") (PROG ((FIRST# (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER)) (LAST# (fetch LASTSELECTEDMESSAGE of MAILFOLDER)) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) (%#OFMESSAGES (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) SEL) (COND ((IGREATERP FIRST# LAST#) (COND ((SETQ SEL (for I from 1 to %#OFMESSAGES collect I when (fetch SELECTED? of (NTHMESSAGE MESSAGES I)))) (HELP "First > Last, but these msgs selected" SEL)))) (T (for I from 1 to %#OFMESSAGES do (COND ((fetch SELECTED? of (NTHMESSAGE MESSAGES I)) (COND ((< I FIRST#) (HELP "First is too high" FIRST#)) ((> I LAST#) (HELP "Last is too low" LAST#)))))) (COND ((AND (EQ FIRST# 1) (EQ LAST# 1)) (* ; "The only time it is okay for them not to be selected")) ((NOT (fetch SELECTED? of (NTHMESSAGE MESSAGES FIRST#))) (HELP "First not selected" FIRST#)) ((NOT (fetch SELECTED? of (NTHMESSAGE MESSAGES LAST#))) (HELP "Last not selected" LAST#))))))) -) ) (DEFINEQ (LAB.COPYBUTTONEVENTFN -(LAMBDA (WINDOW) (* ; "Edited 11-Dec-87 17:17 by bvm:") (* ;;; "copy select an item from the window.") (PROG ((FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) SELECTIONREGION CURRENTITEM CURRENTMSG CURRENTFIELD NEWITEM NEWFIELD LASTX LASTY DATEX FROMX SUBJECTX MSGS) (COND ((EQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) 0) (* ; "Nothing to select") (RETURN (TOTOPW WINDOW)))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) (SETQ DATEX (fetch (MAILFOLDER DATEXPOS) of FOLDER)) (SETQ FROMX (fetch (MAILFOLDER FROMXPOS) of FOLDER)) (SETQ SUBJECTX (fetch (MAILFOLDER SUBJECTXPOS) of FOLDER)) (SETQ MSGS (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) LP (TOTOPW WINDOW) (SETQ NEWITEM (AND (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW))) (YPOS.TO.MESSAGE# LASTY FOLDER))) (SETQ NEWFIELD (if (< LASTX DATEX) then T elseif (< LASTX FROMX) then (QUOTE DATE) elseif (< LASTX SUBJECTX) then (QUOTE FROM) else (QUOTE SUBJECT))) (* ; "Figure out which field of the message is being pointed at by the xpos.") (COND ((OR (NEQ CURRENTITEM NEWITEM) (NEQ CURRENTFIELD NEWFIELD)) (* ; "Something changed") (COND (CURRENTITEM (* ; "turn off old selection.") (LAB.SHOW.COPY.SELECTION WINDOW FOLDER CURRENTMSG CURRENTFIELD))) (COND ((SETQ CURRENTITEM NEWITEM) (* ; "turn on new selection") (LAB.SHOW.COPY.SELECTION WINDOW FOLDER (SETQ CURRENTMSG (NTHMESSAGE MSGS CURRENTITEM)) (SETQ CURRENTFIELD NEWFIELD)))))) LP2 (* ;; "wait for a button up or move out of region") (BLOCK) (COND ((NOT (.COPYKEYDOWNP.)) (* ; "Finished, copy selected item") (COND (CURRENTITEM (* ; "If something is selected, bksysbuf the selected field") (LAB.SHOW.COPY.SELECTION WINDOW FOLDER CURRENTMSG CURRENTFIELD) (BKSYSBUF (OR (SELECTQ CURRENTFIELD (T (* ; "Do whole line") (CONCAT "#" (fetch (LAFITEMSG %#) of CURRENTMSG) " " (fetch (LAFITEMSG DATE) of CURRENTMSG) " " (COND ((fetch (LAFITEMSG MSGFROMMEP) of CURRENTMSG) (CONCAT "To: " (fetch (LAFITEMSG TO) of CURRENTMSG))) (T (CONCAT "From: " (OR (fetch (LAFITEMSG FROM) of CURRENTMSG) UNSUPPLIEDFIELDSTR)))) " -- " (OR (fetch (LAFITEMSG SUBJECT) of CURRENTMSG) UNSUPPLIEDFIELDSTR))) (DATE (fetch (LAFITEMSG DATE) of CURRENTMSG)) (FROM (COND ((fetch (LAFITEMSG MSGFROMMEP) of CURRENTMSG) (CONCAT "To: " (fetch (LAFITEMSG TO) of CURRENTMSG))) (T (fetch (LAFITEMSG FROM) of CURRENTMSG)))) (fetch (LAFITEMSG SUBJECT) of CURRENTMSG)) UNSUPPLIEDFIELDSTR)))) (RETURN)) ((MOUSESTATE UP) (* ; "button up, but shift still down, no action") (GO LP2)) (T (GO LP))))) -) (LAB.SHOW.COPY.SELECTION -(LAMBDA (WINDOW FOLDER MSG FIELD) (* ; "Edited 11-Dec-87 17:16 by bvm:") (* ;;; "underline FIELD of MSG in FOLDER's window") (LET ((BOTTOM (- (MESSAGE#.TO.YPOS MSG FOLDER) (fetch (MAILFOLDER BROWSERFONTDESCENT) of FOLDER))) LEFT STR) (SELECTQ FIELD (T (* ; "Whole line")) (DATE (SETQ LEFT (fetch (MAILFOLDER DATEXPOS) of FOLDER)) (SETQ STR (fetch (LAFITEMSG DATE) of MSG))) (FROM (SETQ LEFT (fetch (MAILFOLDER FROMXPOS) of FOLDER)) (SETQ STR (COND ((fetch (LAFITEMSG MSGFROMMEP) of MSG) (CONCAT "To: " (fetch (LAFITEMSG TO) of MSG))) (T (fetch (LAFITEMSG FROM) of MSG))))) (PROGN (SETQ LEFT (fetch (MAILFOLDER SUBJECTXPOS) of FOLDER)) (SETQ STR (fetch (LAFITEMSG SUBJECT) of MSG)))) (BLTSHADE GRAYSHADE WINDOW LEFT BOTTOM (if (EQ FIELD T) then (* ; "whole line") NIL else (* ; "width of just this field") (STRINGWIDTH (OR STR UNSUPPLIEDFIELDSTR) WINDOW)) 2 (QUOTE INVERT)))) -) ) (DECLARE%: EVAL@COMPILE DONTCOPY (CL:PROCLAIM '(CL:SPECIAL *MAILFOLDER* *MESSAGES* *FIRST-VISIBLE* *LAST-VISIBLE* *TOC-STATE*)) (CL:PROCLAIM '(GLOBAL LASTMOUSEBUTTONS)) ) (* ; "Browser display") (DEFINEQ (LAB.PROMPTPRINT -(CL:LAMBDA (FOLDER &REST ARGS) (* ; "Edited 14-Oct-87 15:36 by bvm:") (LAB.PRINT.TO.PROMPTWINDOW FOLDER ARGS)) -) (LAB.FORMAT -(CL:LAMBDA (FOLDER &REST ARGS) (* ; "Edited 14-Oct-87 15:53 by bvm:") (* ;; "Outputs to FOLDER's prompt window using FORMAT. If first format arg is T, then we clear the window first, and consider then next format arg to be the format string. All this is done in a way that lets the window expand if it needs to.") (LAB.PRINT.TO.PROMPTWINDOW FOLDER ARGS T)) -) (LAB.MOUSECONFIRM -(CL:LAMBDA (FOLDER &REST ARGS) (* ; "Edited 11-Dec-87 17:33 by bvm:") (* ;; "Version of MOUSECONFIRM using FOLDER's prompt window. ARGS are args to FORMAT.") (LAB.PRINT.TO.PROMPTWINDOW FOLDER ARGS T) (PROG1 (MOUSECONFIRM T T) (if FOLDER then (\LAFITE.MAYBE.CLEAR.PROMPT FOLDER) else (CLEARW PROMPTWINDOW)))) -) (LAB.PRINT.TO.PROMPTWINDOW -(LAMBDA (FOLDER ARGS FORMAT-P) (* ; "Edited 14-Oct-87 19:01 by bvm:") (* ;; "Outputs to FOLDER's prompt window the text in ARGS. If FORMAT-P is NIL, ARGS is a list of items to print, with T meaning clear the window. If FORMAT-P is true, ARGS is considered a format string and format args, except that ARGS may be prefixed with T to indicate clearing the window. All this is done in a way that lets the window expand if it needs to. If FOLDER is NIL, or its browser is not open, prints to global PROMPTWINDOW. Returns NIL.") (LET ((*PRINT-CASE* :UPCASE) (*PRINT-BASE* 10) (WINDOW (AND FOLDER (OPENWP (ffetch (MAILFOLDER BROWSERPROMPTWINDOW) of (\DTEST FOLDER (QUOTE MAILFOLDER)))))) \CURRENTDISPLAYLINE OLDTTY) (* ;; "*PRINT-CASE* is bound so symbols get printed in %"expected%" case. *PRINT-BASE* is 10 for benefit of printing numbers in the non-format case. \currentdisplayline changes with TTYDISPLAYSTREAM") (CL:UNWIND-PROTECT (LET ((ACTUALWINDOW (OR WINDOW PROMPTWINDOW))) (if WINDOW then (SETQ OLDTTY (TTYDISPLAYSTREAM WINDOW)) (SETQ \CURRENTDISPLAYLINE (fetch (MAILFOLDER CURRENTPROMPTLINE) of FOLDER)) (* ; "Do this second because TTYDISPLAYSTREAM smashes it.")) (if FORMAT-P then (if (EQ (CAR ARGS) T) then (* ; "First arg of T means clear window first.") (CLEARW ACTUALWINDOW) (SETQ ARGS (CDR ARGS))) (CL:APPLY (FUNCTION CL:FORMAT) ACTUALWINDOW ARGS) else (for ARG in ARGS do (COND ((EQ ARG T) (CLEARW ACTUALWINDOW)) (T (PRIN3 ARG ACTUALWINDOW)))))) (if WINDOW then (* ;; "Now clean up the mess. Note position for next time.") (replace (MAILFOLDER CURRENTPROMPTLINE) of FOLDER with \CURRENTDISPLAYLINE) (TTYDISPLAYSTREAM OLDTTY) (WINDOWPROP WINDOW (QUOTE PROCESS) NIL) (* ; "Get rid of process handle") (replace (MAILFOLDER BROWSERPROMPTDIRTY) of FOLDER with T))) NIL)) -) (LAB.PAGEFULLFN -(LAMBDA (PW) (* ; "Edited 14-Oct-87 16:54 by bvm:") (* ;; "PAGEFULLFN for prompt window--makes the window a line bigger and allows output to proceed") (SETQ \CURRENTDISPLAYLINE (PROG1 \#DISPLAYLINES (* ; "\Currentdisplayline is the line we're on when window fills, origin zero") (LET ((MAIN (MAINWINDOW PW)) FOLDER) (GETPROMPTWINDOW MAIN (+ 1 \#DISPLAYLINES)) (if (SETQ FOLDER (WINDOWPROP MAIN (QUOTE MAILFOLDER))) then (* ; "Note that we expanded window so that we can shrink it back later") (replace (MAILFOLDER BROWSERPROMPTGREW) of FOLDER with T)))))) -) (\LAFITE.MAYBE.CLEAR.PROMPT -(LAMBDA (FOLDER) (* ; "Edited 14-Oct-87 15:35 by bvm:") (* ;; "Clear's FOLDER's prompt window, and shrinks it back to a single line if it has grown") (LET (PW) (COND ((AND (fetch (MAILFOLDER BROWSERPROMPTDIRTY) of FOLDER) (OPENWP (SETQ PW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER)))) (CLEARW PW) (if (fetch (MAILFOLDER BROWSERPROMPTGREW) of FOLDER) then (* ; "Window grew") (LET (PROP HEIGHT) (SETQ HEIGHT (HEIGHTIFWINDOW (FONTPROP LAFITEBROWSERFONT (QUOTE HEIGHT)))) (WINDOWPROP PW (QUOTE MINSIZE) (CONS 0 HEIGHT)) (* ; "have to adjust the fixed size of the window before shaping, since SHAPEW obeys the minimum.") (WINDOWPROP PW (QUOTE MAXSIZE) (CONS 64000 HEIGHT)) (SHAPEW PW (create REGION using (WINDOWPROP PW (QUOTE REGION)) HEIGHT _ HEIGHT)) (CLEARW PW) (* ; "Clear it again to get coordinates right.") (if (SETQ PROP (WINDOWPROP (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER) (QUOTE PROMPTWINDOW))) then (* ; "Main window thinks it knows how tall the prompt window is.") (RPLACD PROP 1)) (replace (MAILFOLDER BROWSERPROMPTGREW) of FOLDER with NIL) (replace (MAILFOLDER CURRENTPROMPTLINE) of FOLDER with 0))) (replace (MAILFOLDER BROWSERPROMPTDIRTY) of FOLDER with NIL))))) -) ) (PUTPROPS LAB.PROMPTPRINT ARGNAMES (NIL (FOLDER &REST ARGS))) (PUTPROPS LAB.FORMAT ARGNAMES (NIL (FOLDER &REST ARGS))) (PUTPROPS LAB.MOUSECONFIRM ARGNAMES (NIL (FOLDER FORMAT-STRING &REST ARGS))) (DEFINEQ (PRINTMESSAGESUMMARY [LAMBDA (MSG FOLDER WINDOW) (* ; "Edited 5-May-89 12:15 by bvm") (PROG ((*PRINT-BASE* 10) (DIGITWIDTH (fetch (MAILFOLDER BROWSERDIGITWIDTH) of FOLDER)) FROMSTR HERE THERE EXTENT MSG#) (OR (fetch (LAFITEMSG PARSED?) of MSG) (LAFITE.PARSE.MSG.FOR.TOC MSG FOLDER)) (MOVETO 0 (MESSAGE#.TO.YPOS MSG FOLDER) WINDOW) (POSITION WINDOW 0) (LA.SHOW.MARK MSG FOLDER) (DSPXPOSITION [+ (fetch (MAILFOLDER ORDINALXPOS) of FOLDER) (TIMES DIGITWIDTH (COND ((< (SETQ MSG# (fetch (LAFITEMSG %#) of MSG)) 10) 3) ((< MSG# 100) 2) ((< MSG# 1000) 1) (T 0] WINDOW) (* ;  "Ugh. Manually right-justify message # given that font may be variable width") (PRIN3 MSG# WINDOW) (LET ((DATE (OR (fetch (LAFITEMSG DATE) of MSG) [if (fetch (LAFITEMSG DATEKNOWN?) of MSG) then (* ; "Convert idate to date") (replace (LAFITEMSG DATE) of MSG with (GDATE1-6 (fetch (LAFITEMSG IDATE) of MSG] UNSUPPLIEDFIELDSTR))) (DSPXPOSITION (+ (fetch (MAILFOLDER DATEXPOS) of FOLDER) (if (DIGITCHARP (NTHCHARCODE DATE 2)) then 0 else (* ;  "for 1-digit day, try to get the digits to line up") DIGITWIDTH)) WINDOW) (PRIN3 DATE WINDOW)) (DSPXPOSITION (fetch (MAILFOLDER FROMXPOS) of FOLDER) WINDOW) [COND [(fetch (LAFITEMSG MSGFROMMEP) of MSG) (PRIN3 "To: " WINDOW) (SETQ FROMSTR (OR (fetch (LAFITEMSG TO) of MSG) (LAFITE.FETCH.TO.FIELD MSG FOLDER] (T (SETQ FROMSTR (OR (fetch (LAFITEMSG FROM) of MSG) UNSUPPLIEDFIELDSTR] (* ;; "PRINTMESSAGESUMMARY.STRING defaults to PRIN3, redefined to deal with multiple character sets if MIME is loaded.") (PRINTMESSAGESUMMARY.STRING FROMSTR WINDOW) (COND ((> (SETQ HERE (DSPXPOSITION NIL WINDOW)) (SETQ THERE (fetch (MAILFOLDER FROMMAXXPOS) of FOLDER))) (* ; "Erase the overflow") (DSPBACKUP (- HERE THERE) WINDOW))) (DSPXPOSITION (fetch (MAILFOLDER SUBJECTXPOS) of FOLDER) WINDOW) (PRINTMESSAGESUMMARY.STRING (OR (fetch (LAFITEMSG SUBJECT) of MSG) UNSUPPLIEDFIELDSTR) WINDOW) (PRIN3 " [" WINDOW) (PRIN3 (fetch (LAFITEMSG MESSAGELENGTH) of MSG) WINDOW) (PRIN3 " chars]" WINDOW) (* ;; "keep track of maximum width printed to. If header is allowed to print on two lines, $$MAXWIDTH$$ was set to right margin by BUILDBROWSERMAP so this should not reset it.") (COND ((< (fetch (MAILFOLDER BROWSERMAXXPOS) of FOLDER) (SETQ HERE (DSPXPOSITION NIL WINDOW))) (replace (MAILFOLDER BROWSERMAXXPOS) of FOLDER with HERE) (replace (REGION WIDTH) of (SETQ EXTENT (fetch (MAILFOLDER BROWSEREXTENT) of FOLDER)) with HERE) (WINDOWPROP WINDOW 'EXTENT EXTENT))) [COND ((fetch (LAFITEMSG SELECTED?) of MSG) (LA.SHOW.SELECTION FOLDER MSG 'REPLACE] (COND ((fetch (LAFITEMSG DELETED?) of MSG) (LA.SHOW.DELETION FOLDER MSG WINDOW 'REPLACE]) (FIRSTVISIBLEMESSAGE -(LAMBDA (MAILFOLDER REGION) (* bvm%: "25-Feb-86 12:22") (* ;; "Computes number of the first message in MAILFOLDER that is visible in REGION") (IMAX 1 (IQUOTIENT (- (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) (+ (fetch (REGION TOP) of (OR REGION (DSPCLIPPINGREGION NIL (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)))) (fetch (MAILFOLDER BROWSERFONTDESCENT) of MAILFOLDER))) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER)))) -) (LASTVISIBLEMESSAGE -(LAMBDA (MAILFOLDER REGION) (* bvm%: "25-Feb-86 11:33") (* ;; "Computes number of the last message in MAILFOLDER that is visible in REGION") (IMIN (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) (IQUOTIENT (+ (- (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) (- (fetch (REGION BOTTOM) of (OR REGION (DSPCLIPPINGREGION NIL (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)))) (fetch (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER))) (SUB1 (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER))) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER)))) -) (LAB.DISPLAYLINES -(LAMBDA (FOLDER FIRST# LAST# REGION CLEAR) (* ; "Edited 28-Apr-89 18:48 by bvm") (* ;; "Display toc line for messages FIRST# thru LAST# (default to extreme). If REGION is given, only display messages visible in the region (default is the browser window's clipping region). If CLEAR is true, clear the region first (otherwise, caller has cleared it).") (LET* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (REG (OR REGION (DSPCLIPPINGREGION NIL WINDOW))) (MIN# (FIRSTVISIBLEMESSAGE FOLDER REGION)) (MAX# (LASTVISIBLEMESSAGE FOLDER REGION)) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER))) (if (AND FIRST# (> FIRST# MIN#)) then (SETQ MIN# FIRST#)) (if (AND LAST# (< LAST# MAX#)) then (SETQ MAX# LAST#)) (if CLEAR then (DSPFILL (LET ((LINEHEIGHT (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER))) (create REGION LEFT _ 0 BOTTOM _ (- (fetch (MAILFOLDER BROWSERORIGIN) of FOLDER) (fetch (MAILFOLDER BROWSERFONTDESCENT) of FOLDER) (TIMES LINEHEIGHT MAX#)) WIDTH _ MAX.SMALLP HEIGHT _ (TIMES LINEHEIGHT (ADD1 (- MAX# MIN#))))) WHITESHADE (QUOTE REPLACE) WINDOW)) (for MSG# from MIN# to MAX# do (PRINTMESSAGESUMMARY (NTHMESSAGE MESSAGES MSG#) FOLDER WINDOW)))) -) (LAB.EXPOSEMESSAGE -(LAMBDA (MAILFOLDER MSGDESCRIPTOR) (* bvm%: "24-Dec-83 19:00") (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) (YPOS (MESSAGE#.TO.YPOS MSGDESCRIPTOR MAILFOLDER)) CLIPREGION) (COND ((OR (IGREATERP (fetch (REGION BOTTOM) of (SETQ CLIPREGION (DSPCLIPPINGREGION NIL WINDOW))) YPOS) (ILESSP (fetch (REGION TOP) of CLIPREGION) YPOS)) (SCROLLBYREPAINTFN WINDOW 0 (IPLUS (fetch (REGION BOTTOM) of CLIPREGION) (IQUOTIENT (fetch (REGION HEIGHT) of CLIPREGION) 2) (IMINUS YPOS))))))) -) (LAB.SELECTED.MESSAGES -(LAMBDA (FOLDER) (* ; "Edited 14-Oct-87 16:15 by bvm:") (* ;; "Return a list of message descriptors currently selected") (for MSG selectedin FOLDER collect MSG)) -) (UNSELECTALLMESSAGES -(LAMBDA (MAILFOLDER) (* bvm%: "15-Feb-84 16:21") (for N from (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER) to (fetch LASTSELECTEDMESSAGE of MAILFOLDER) bind (MESSAGES _ (fetch MESSAGEDESCRIPTORS of MAILFOLDER)) do (LA.DESELECTRANGE MAILFOLDER N N) (LA.SHOW.SELECTION MAILFOLDER (NTHMESSAGE MESSAGES N) (QUOTE ERASE)))) -) (SELECTMESSAGE -(LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* bvm%: "15-Feb-84 12:34") (PROG ((N (fetch (LAFITEMSG %#) of MSGDESCRIPTOR))) (LA.SELECTRANGE MAILFOLDER N N T) (LA.SHOW.SELECTION MAILFOLDER MSGDESCRIPTOR (QUOTE REPLACE)))) -) (LAB.GO.TO.MESSAGE -(LAMBDA (FOLDER N) (* ; "Edited 23-Aug-88 18:14 by bvm") (* ;; "Jump to nth message in folder. N must be in range, or be a msg object in the folder. Returns the message object") (LET ((MSG (if (type? LAFITEMSG N) then N else (\DTEST (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) N) (QUOTE LAFITEMSG))))) (UNSELECTALLMESSAGES FOLDER) (LAB.EXPOSEMESSAGE FOLDER MSG) (LA.SHOW.SELECTION FOLDER MSG (QUOTE REPLACE)) (replace (LAFITEMSG SELECTED?) of MSG with T) (replace FIRSTSELECTEDMESSAGE of FOLDER with (replace LASTSELECTEDMESSAGE of FOLDER with (fetch (LAFITEMSG %#) of MSG))) MSG)) -) (MARKMESSAGE -(LAMBDA (MSG FOLDER MARK) (* ; "Edited 25-Apr-89 17:54 by bvm") (* ;;; "Changes the mark byte of MSGDESCRIPTOR to be MARK. This may also imply something about SEEN?") (replace (LAFITEMSG MARKCHAR) of MSG with MARK) (replace (LAFITEMSG SEEN?) of MSG with (NOT (UNSEENMARKP MARK))) (LAB.MARKS.CHANGED MSG FOLDER) (COND ((OPENWP (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (LA.SHOW.MARK MSG FOLDER)) (T (* ; "Wait until browser expanded before showing mark update") (PROG ((N (fetch (LAFITEMSG %#) of MSG)) (OLDU (fetch (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER))) (COND ((OR (NULL OLDU) (> OLDU N)) (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER with N))))))) -) (LAB.MARKS.CHANGED [LAMBDA (MSG FOLDER) (* ; "Edited 21-Jun-99 22:42 by rmk:") (* ;;  "Call this whenever you change one of the 3 mark bytes (seen, deleted, mark) of a message.") (LET ((N (fetch (LAFITEMSG %#) of MSG))) (if (< N (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER)) then (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER with N))) (replace (LAFITEMSG MARKSCHANGED?) of MSG with T) (* ;;  "rmk: MARKSCHANGEDINTOC? wasn't being set, and changes only to marks weren't being written out.") (replace (LAFITEMSG MARKSCHANGEDINTOC?) of MSG with T) (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with T]) (LA.SHOW.MARK -(LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* bvm%: "17-Feb-84 15:34") (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) (YPOS (MESSAGE#.TO.YPOS MSGDESCRIPTOR MAILFOLDER)) (MARK (fetch (LAFITEMSG MARKCHAR) of MSGDESCRIPTOR))) (LA.BLT.MARK.BOX MAILFOLDER WINDOW YPOS (QUOTE REPLACE) WHITESHADE) (* ; "Erase whatever's there") (COND ((NEQ MARK (CHARCODE SPACE)) (MOVETO BROWSERMARKXPOSITION YPOS WINDOW) (BOUT WINDOW MARK))))) -) (LA.INVERT.MARK.BOX -(LAMBDA (MAILFOLDER MSG#) (* bvm%: "17-Feb-84 14:44") (LA.BLT.MARK.BOX MAILFOLDER (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER) (MESSAGE#.TO.YPOS (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER) MSG#) MAILFOLDER) (QUOTE INVERT) BLACKSHADE)) -) (LA.BLT.MARK.BOX -(LAMBDA (MAILFOLDER WINDOW YPOS OPERATION TEXTURE) (* ; "Edited 3-Sep-87 18:02 by bvm:") (BLTSHADE TEXTURE WINDOW BROWSERMARKXPOSITION (- YPOS (fetch (MAILFOLDER BROWSERFONTDESCENT) of MAILFOLDER)) (- (fetch (MAILFOLDER ORDINALXPOS) of MAILFOLDER) BROWSERMARKXPOSITION) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER) OPERATION)) -) (LA.SHOW.DELETION -(LAMBDA (MAILFOLDER MSGDESCRIPTOR WINDOW OPERATION) (* ; "Edited 3-Sep-87 16:23 by bvm:") (* ;;; "Draws or erases, for OPERATION = REPLACE or ERASE, the line indicating that MSGDESCRIPTOR is deleted") (BLTSHADE BLACKSHADE WINDOW BROWSERMARKXPOSITION (- (+ (MESSAGE#.TO.YPOS MSGDESCRIPTOR MAILFOLDER) (LRSH (fetch (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER) 1)) (LRSH LAFITEDELETEDLINEHEIGHT 1)) NIL LAFITEDELETEDLINEHEIGHT OPERATION)) -) (LA.SHOW.SELECTION -(LAMBDA (MAILFOLDER MSGDESCRIPTOR OPERATION) (* bvm%: " 2-Feb-84 12:37") (* ;;; "Displays or erases, per OPERATION = REPLACE or ERASE, the mark indicating that MSGDESCRIPTOR is selected") (BITBLT LA.SELECTION.BITMAP 0 0 (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER) 0 (+ (MESSAGE#.TO.YPOS MSGDESCRIPTOR MAILFOLDER) (LRSH (fetch (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER) 1) -5) NIL NIL (QUOTE INPUT) OPERATION)) -) (SEENMESSAGE -(LAMBDA (MSG FOLDER) (* ; "Edited 25-Apr-89 17:52 by bvm") (* ;;; "causes the 'seen character' -- as opposed to the 'seen mark' -- to be changed to 'S' on the file") (LET ((OLDMARK (fetch (LAFITEMSG MARKCHAR) of MSG))) (COND ((OR (NULL (fetch (LAFITEMSG SEEN?) of MSG)) (UNSEENMARKP OLDMARK)) (replace (LAFITEMSG SEEN?) of MSG with T) (LAB.MARKS.CHANGED MSG FOLDER) (COND ((UNSEENMARKP OLDMARK) (* ;; "only change the mark if it was ? -- it might already be something more meaningful like an answer mark") (MARKMESSAGE MSG FOLDER SEENMARK))))))) -) (DELETEMESSAGE -(LAMBDA (MSG FOLDER) (* ; "Edited 25-Apr-89 17:53 by bvm") (replace (LAFITEMSG DELETED?) of MSG with T) (LAB.MARKS.CHANGED MSG FOLDER) (replace (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER with T) (LA.SHOW.DELETION FOLDER MSG (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER) (QUOTE REPLACE))) -) (UNDELETEMESSAGE -(LAMBDA (MSG FOLDER) (* ; "Edited 25-Apr-89 17:52 by bvm") (if (fetch (LAFITEMSG DELETED?) of MSG) then (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) (replace (LAFITEMSG DELETED?) of MSG with NIL) (LAB.MARKS.CHANGED MSG FOLDER) (LA.SHOW.DELETION FOLDER MSG WINDOW (QUOTE ERASE)) (* ; "undeleted; reprint the header.") (PRINTMESSAGESUMMARY MSG FOLDER WINDOW) (* ; "Finally, maybe clear the expungeable flag if this was the last deleted message") (LAB.SET.EXPUNGEABILITY FOLDER)))) -) (LAB.SET.EXPUNGEABILITY -(LAMBDA (FOLDER) (* ; "Edited 25-Apr-89 17:46 by bvm") (* ;; "Sets the FOLDERNEEDSEXPUNGE flag according to whether any messages are marked deleted, and returns the number of the first deleted message (or NIL if none).") (LET ((FIRSTDELETED (for I from 1 to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) bind (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) thereis (fetch (LAFITEMSG DELETED?) of (NTHMESSAGE MESSAGES I))))) (replace (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER with FIRSTDELETED) FIRSTDELETED)) -) ) (* ;; "PRINTMESSAGESUMMARY.STRING prints From and Subject. Redefined when MIME is loaded to deal with different character encodings." ) (MOVD? 'PRIN3 'PRINTMESSAGESUMMARY.STRING) (* ; "ICON stuff") (FILESLOAD ICONW) (DEFINEQ (LAB.ICONFN -(LAMBDA (WINDOW OLDICON) (* ; "Edited 20-Apr-89 19:38 by bvm") (* ;;; "the holding place for all the fancy stuff for making an icon for a mail broswer window") (OR (WINDOWP (WINDOWPROP WINDOW (QUOTE ICONWINDOW))) (LET ((MAILFOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) ICON) (SETQ ICON (TITLEDICONW LAFITE.FOLDER.ICON (COND (MAILFOLDER (LA.SHORTFILENAME (fetch (MAILFOLDER FULLFOLDERNAME) of MAILFOLDER) LAFITEMAIL.EXT)) (T "??")) NIL (OR (WINDOWPROP WINDOW (QUOTE ICONPOSITION)) (SELECTQ LAFITE.BROWSER.ICON.PREFERENCE ((:ASK ASK) (* ; "force prompt") NIL) (NIL (LA.POSITION.FROM.REGION (WINDOWPROP WINDOW (QUOTE REGION)))) (CL:FUNCALL LAFITE.BROWSER.ICON.PREFERENCE WINDOW))) T NIL (QUOTE FILE))) (WINDOWPROP ICON (QUOTE BUTTONEVENTFN) (FUNCTION LAB.ICON.BUTTONEVENTFN)) ICON))) -) (LAB.ICON.BUTTONEVENTFN -(LAMBDA (ICONW) (* ; "Edited 23-Aug-88 18:30 by bvm") (* ;; "BUTTONEVENTFN for browser windows. This one is like the default, except that middle button offers choices") (COND ((LASTMOUSESTATE MIDDLE) (LET (HOW) (if (AND (fetch (MAILFOLDER FOLDERGETSMAIL) of (WINDOWPROP (WINDOWPROP ICONW (QUOTE ICONFOR)) (QUOTE MAILFOLDER))) (SETQ HOW (MENU (OR LAFITEBROWSERICONMENU (SETQ LAFITEBROWSERICONMENU (\LAFITE.CREATE.MENU LAFITEBROWSERICONMENUITEMS NIL T)))))) then (* ; "Folder accepts new mail, and offer was accepted") (CL:FUNCALL HOW ICONW) else (* ; "No menu selection, just expand as you otherwise would") (EXPANDW ICONW)))) (T (MOVEW ICONW)))) -) ) (RPAQQ LAFITE.FOLDER.ICON (#*(100 72)@OOOOOOOO@@@@@@@@@@@@@@@@@@@AOOOOOOOOH@@@@@@@@@@@@@@@@@@C@@@@@@@@L@@@@@@@@@@@@@@@@@@F@@@@@@@@F@@@@@@@@@@@@@@@@@@L@DA@@@@@C@@@@@@@@@@@@@@@@@@L@FC@@@@@C@@@@@@@@@@@@@@@@@@L@EE@HGB@C@@@@@@@@@@@@@@@@@@L@EEADBB@C@@@@@@@@@@@@@@@@@@L@DIBBBB@COOOOOOOOOOOOOOL@@@L@DACNBB@COOOOOOOOOOOOOOL@@@L@DABBGCL@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@@@@@L@@@LOOOOOOOOOOOOOOOOOOOOOOOO@@@LOOOOOOOOOOOOOOOOOOOOOOOO@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@FL@@@@@@@@@@@@@@@@@@@@@@C@@@CL@@@@@@@@@@@@@@@@@@@@@@C@@@AOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOO@@@ #*(100 72)@OOOOOOOO@@@@@@@@@@@@@@@@@@@AOOOOOOOOH@@@@@@@@@@@@@@@@@@COOOOOOOOL@@@@@@@@@@@@@@@@@@GOOOOOOOON@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@COOOOOOOOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOO@@@ (8 4 88 51))) (RPAQ? LAFITEFROMFRACTION 0.3) (RPAQ? LAFITEMINFROMCHARS 15) (RPAQ? LAFITEVERIFYFLG T) (RPAQ? LAFITEDELETEDLINEHEIGHT 1) (RPAQ? LAFITE.BROWSER.ICON.PREFERENCE ) (RPAQQ LAFITEBROWSERMENUITEMS (("Display" '\LAFITE.DISPLAY "Displays the selected message in the display window.") ("Delete" '\LAFITE.DELETE "Deletes the selected messages.") ("Undel" '\LAFITE.UNDELETE "Undeletes the selected messages.") ("Answer" '\LAFITE.ANSWER "Prepares a delivery form to reply to the selected message.") ("Forward" '\LAFITE.FORWARD "Prepares a delivery form to forward the selected message(s).") (HCopy '\LAFITE.HARDCOPY "Sends hardcopy of the selected message(s) to the default printer") ("Move To" '\LAFITE.MOVETO "Moves the selected message(s) to another mail folder.") ("Update" '\LAFITE.UPDATE "Write out browser changes to the physical mail file.% - Option to expunge all deleted messages." ) ("Get Mail" '\LAFITE.GETMAIL "Retrieves new messages and puts them into this mail folder."))) (RPAQQ LAFITESUBBROWSEMENUITEMS [("Browse" '\LAFITE.BROWSE.PROC "Browse a mail file") ("Browse & Forget" '\LAFITE.BROWSE.FORGET "Browse a mail file, but don't add it to the menu of known folders") ("Forget Folders" '\LAFITE.UNCACHE.FOLDER "Remove one or more folders from list of known folders") ("Forget Message Form" '\LAFITE.UNCACHE.MESSAGEFORM "Remove a form from list of known message forms,% -but do not delete the file containing it." ) ("Delete Message Form" '\LAFITE.DELETE.MESSAGEFORM "Remove a form from list of known message forms% -and delete the file(s) containing it." ) ("Notice Folders" '\LAFITE.NOTICE.FOLDERS "Scan specified directory and add any folders found to the list of known folders") ("Clean up Folders" '\LAFITE.GC.FOLDERS "Check that all known folders correspond to actual files; remove those that no longer exist" ) ("Rename Folder" '\LAFITE.RENAME.FOLDER "Change the name of a folder") ("Edit Folder Hierarchy" '\LAFITE.EDIT.HIERARCHY "Add, delete, or change membership of a folder group" (SUBITEMS ("Edit a Group" '\LAFITE.EDIT.HIERARCHY "Modify an existing group") ("Add New Group" '[LAMBDA (ITEM MENU) (\LAFITE.ADD.NEW.GROUP] "Define a new top-level group") ("Change Top-Level Groups" '\LAFITE.CHANGE.TOP.GROUPS "Specify which subgroups should also appear at top level."]) (RPAQQ LAFITEBROWSERICONMENUITEMS (("Get Mail" '\LAFITE.GETMAIL.FROM.ICON "Open this window and retrieve new mail into it"))) (RPAQ? LAFITESUBBROWSEMENU ) (RPAQ? LAFITEBROWSERICONMENU ) (RPAQ? LAFITEEXTRAMENU ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) ) (ADDTOVAR LAFITEMENUVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) (ADDTOVAR LAFITEEXTRAMENUITEMS ("Describe Folder" '\LAFITE.DESCRIBE.FOLDER "Display some relevant info about this folder" (SUBITEMS ("Inspect Folder" 'INSPECT "Inspect the MAILFOLDER data structure associated with this browser" )))) (RPAQQ BROWSERMARKXPOSITION 8) (RPAQQ LA.SELECTION.BITMAP #*(8 10)L@@@N@@@O@@@OH@@OL@@OH@@O@@@N@@@L@@@@@@@) (* ; "Obsolete") (RPAQ? LAFITEBROWSERREGION (CREATEREGION 30 30 575 210)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (RPAQQ TOCSTATES ((TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7))) (DECLARE%: EVAL@COMPILE (RPAQQ TS.IDLE 0) (RPAQQ TS.REPLACING 1) (RPAQQ TS.ADDING 2) (RPAQQ TS.REMOVING 3) (RPAQQ TS.EXTENDING.HI 4) (RPAQQ TS.EXTENDING.LO 5) (RPAQQ TS.SHRINKING.HI 6) (RPAQQ TS.SHRINKING.LO 7) (CONSTANTS (TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7)) ) (CL:PROCLAIM '(CL:SPECIAL \CURRENTDISPLAYLINE)) (FILESLOAD (SOURCE) LAFITEDECLS) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA LAB.MOUSECONFIRM LAB.FORMAT LAB.PROMPTPRINT) ) (PUTPROPS LAFITEBROWSE COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988 1989 1999 2001)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5838 20874 (\LAFITE.BROWSE 5848 . 6374) (\LAFITE.SUBBROWSE 6376 . 6615) ( \LAFITE.BROWSE.PROC 6617 . 7204) (\LAFITE.BROWSE.FORGET 7206 . 7607) (LAFITE.BROWSE.FOLDER 7609 . 8741 ) (\LAFITE.PREPARE.BROWSER 8743 . 9904) (\LAFITE.MAYBE.OPEN.FOLDER 9906 . 11781) (LAB.LOADFOLDER 11783 . 12097) (LAB.DISPLAYFOLDER 12099 . 13023) (LAB.MAKE.INITIAL.SELECTION 13025 . 13760) ( LAB.CREATEWINDOW 13762 . 18546) (LAB.TITLE.STRING 18548 . 19531) (LAB.COMMANDFN 19533 . 19942) ( LAB.DO.COMMAND 19944 . 20603) (LAB.ASSURE.SELECTIONS 20605 . 20872)) (20875 25391 ( BUILD.LAFITE.LAYOUTS 20885 . 23550) (\LAFITE.LAYOUT.FROM.WINDOW 23552 . 24601) ( \LAFITE.MAKE.DUMMY.WINDOWS 24603 . 25389)) (25817 38951 (LAB.SETUP 25827 . 28440) (LAB.BUTTONEVENTFN 28442 . 28838) (LAB.DO.UNLESS.BUSY 28840 . 29183) (LOADMAILFOLDER 29185 . 30080) (LAFITE.OBTAIN.FOLDER 30082 . 33998) (\LAFITE.FIND.EXISTING.FOLDER 34000 . 34371) (\LAFITE.CONFLICTING.OLD.FOLDER 34373 . 35213) (LAB.REPAINTFN 35215 . 35612) (LAB.SCROLLFN 35614 . 36034) (LAB.RESHAPEFN 36036 . 36838) ( LAB.CLOSEFN 36840 . 36962) (LAB.SHRINKFN 36964 . 37073) (LAB.CLOSE/SHRINK 37075 . 38021) (LAB.EXPANDFN 38023 . 38694) (LAFITEEXTRABROWSERCOMMANDFN 38696 . 38949)) (38986 47364 (LAB.SELECTMESSAGE 38996 . 44530) (LAB.CHANGEMARK 44532 . 45521) (LA.READ.NEW.MARK 45523 . 46729) (YPOS.TO.MESSAGE# 46731 . 47108 ) (MESSAGE#.TO.YPOS 47110 . 47362)) (47365 52392 (LA.CONSIDERRANGE 47375 . 47859) (LA.DECONSIDERRANGE 47861 . 48187) (LA.RECONSIDERRANGE 48189 . 48638) (LA.SELECTRANGE 48640 . 49627) (LA.DESELECTRANGE 49629 . 50685) (LAB.FIND.SELECTED.MSG 50687 . 50921) (LAB.REV.FIND.SELECTED.MSG 50923 . 51167) ( LA.UNDOSELECTION 51169 . 51394) (LA.VERIFY.SELECTION 51396 . 52390)) (52393 55857 ( LAB.COPYBUTTONEVENTFN 52403 . 54948) (LAB.SHOW.COPY.SELECTION 54950 . 55855)) (56064 60544 ( LAB.PROMPTPRINT 56074 . 56207) (LAB.FORMAT 56209 . 56585) (LAB.MOUSECONFIRM 56587 . 56919) ( LAB.PRINT.TO.PROMPTWINDOW 56921 . 58740) (LAB.PAGEFULLFN 58742 . 59319) (\LAFITE.MAYBE.CLEAR.PROMPT 59321 . 60542)) (60768 75148 (PRINTMESSAGESUMMARY 60778 . 65535) (FIRSTVISIBLEMESSAGE 65537 . 66000) ( LASTVISIBLEMESSAGE 66002 . 66575) (LAB.DISPLAYLINES 66577 . 67776) (LAB.EXPOSEMESSAGE 67778 . 68292) ( LAB.SELECTED.MESSAGES 68294 . 68484) (UNSELECTALLMESSAGES 68486 . 68828) (SELECTMESSAGE 68830 . 69062) (LAB.GO.TO.MESSAGE 69064 . 69690) (MARKMESSAGE 69692 . 70381) (LAB.MARKS.CHANGED 70383 . 71190) ( LA.SHOW.MARK 71192 . 71643) (LA.INVERT.MARK.BOX 71645 . 71931) (LA.BLT.MARK.BOX 71933 . 72291) ( LA.SHOW.DELETION 72293 . 72754) (LA.SHOW.SELECTION 72756 . 73198) (SEENMESSAGE 73200 . 73765) ( DELETEMESSAGE 73767 . 74073) (UNDELETEMESSAGE 74075 . 74593) (LAB.SET.EXPUNGEABILITY 74595 . 75146)) ( 75385 76875 (LAB.ICONFN 75395 . 76195) (LAB.ICON.BUTTONEVENTFN 76197 . 76873))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "30-Sep-2021 22:58:57"  +{DSK}KAPLAN>LOCAL>MEDLEY3.5>GIT-MEDLEY>LIBRARY>LAFITE>LAFITEBROWSE.;1 141883 + + previous date%: "19-Feb-2001 09:26:50" +{DSK}KAPLAN>LOCAL>MEDLEY3.5>GIT-MEDLEY>LIBRARY>LAFITE>LAFITEBROWSE.;1) + + +(* ; " +Copyright (c) 1984-1989, 1999, 2001, 2021 by Xerox Corporation. +") + +(PRETTYCOMPRINT LAFITEBROWSECOMS) + +(RPAQQ LAFITEBROWSECOMS + [(COMS (* ; "BROWSE") + (FNS \LAFITE.BROWSE \LAFITE.SUBBROWSE \LAFITE.BROWSE.PROC \LAFITE.BROWSE.FORGET + LAFITE.BROWSE.FOLDER \LAFITE.PREPARE.BROWSER \LAFITE.MAYBE.OPEN.FOLDER + LAB.LOADFOLDER LAB.DISPLAYFOLDER LAB.MAKE.INITIAL.SELECTION LAB.CREATEWINDOW + LAB.TITLE.STRING LAB.COMMANDFN LAB.DO.COMMAND LAB.ASSURE.SELECTIONS) + (FNS BUILD.LAFITE.LAYOUTS \LAFITE.LAYOUT.FROM.WINDOW \LAFITE.MAKE.DUMMY.WINDOWS) + (VARS LAFITE.DUMMY.SHADE LAFITE.DUMMY.HALF.SHADE) + (INITVARS (\LAFITE.LAST.FOLDER.NAME)) + (GLOBALVARS \LAFITE.LAST.FOLDER.NAME)) + (COMS (* ; "Browser operations") + (FNS LAB.SETUP LAB.BUTTONEVENTFN LAB.DO.UNLESS.BUSY LOADMAILFOLDER LAFITE.OBTAIN.FOLDER + \LAFITE.FIND.EXISTING.FOLDER \LAFITE.CONFLICTING.OLD.FOLDER LAB.REPAINTFN + LAB.SCROLLFN LAB.RESHAPEFN LAB.CLOSEFN LAB.SHRINKFN LAB.CLOSE/SHRINK LAB.EXPANDFN + LAFITEEXTRABROWSERCOMMANDFN)) + [COMS (* ; "Browser selection") + (FNS LAB.SELECTMESSAGE LAB.CHANGEMARK LA.READ.NEW.MARK YPOS.TO.MESSAGE# + MESSAGE#.TO.YPOS) + (FNS LA.CONSIDERRANGE LA.DECONSIDERRANGE LA.RECONSIDERRANGE LA.SELECTRANGE + LA.DESELECTRANGE LAB.FIND.SELECTED.MSG LAB.REV.FIND.SELECTED.MSG LA.UNDOSELECTION + LA.VERIFY.SELECTION) + (FNS LAB.COPYBUTTONEVENTFN LAB.SHOW.COPY.SELECTION) + (DECLARE%: EVAL@COMPILE DONTCOPY (P (CL:PROCLAIM '(CL:SPECIAL *MAILFOLDER* *MESSAGES* + *FIRST-VISIBLE* *LAST-VISIBLE* + *TOC-STATE*)) + (CL:PROCLAIM '(GLOBAL LASTMOUSEBUTTONS] + [COMS (* ; "Browser display") + (FNS LAB.PROMPTPRINT LAB.FORMAT LAB.MOUSECONFIRM LAB.PRINT.TO.PROMPTWINDOW + LAB.PAGEFULLFN \LAFITE.MAYBE.CLEAR.PROMPT) + (PROP ARGNAMES LAB.PROMPTPRINT LAB.FORMAT LAB.MOUSECONFIRM) + (FNS PRINTMESSAGESUMMARY FIRSTVISIBLEMESSAGE LASTVISIBLEMESSAGE LAB.DISPLAYLINES + LAB.EXPOSEMESSAGE LAB.SELECTED.MESSAGES UNSELECTALLMESSAGES SELECTMESSAGE + LAB.GO.TO.MESSAGE MARKMESSAGE LAB.MARKS.CHANGED LA.SHOW.MARK LA.INVERT.MARK.BOX + LA.BLT.MARK.BOX LA.SHOW.DELETION LA.SHOW.SELECTION SEENMESSAGE DELETEMESSAGE + UNDELETEMESSAGE LAB.SET.EXPUNGEABILITY) + + (* ;; "PRINTMESSAGESUMMARY.STRING prints From and Subject. Redefined when MIME is loaded to deal with different character encodings.") + + (P (MOVD? 'PRIN3 'PRINTMESSAGESUMMARY.STRING] + (COMS (* ; "ICON stuff") + (FILES ICONW) + (FNS LAB.ICONFN LAB.ICON.BUTTONEVENTFN) + (VARS LAFITE.FOLDER.ICON)) + (COMS (INITVARS (LAFITEFROMFRACTION 0.3) + (LAFITEMINFROMCHARS 15) + (LAFITEVERIFYFLG T) + (LAFITEDELETEDLINEHEIGHT 1) + (LAFITE.BROWSER.ICON.PREFERENCE)) + (VARS LAFITEBROWSERMENUITEMS LAFITESUBBROWSEMENUITEMS LAFITEBROWSERICONMENUITEMS) + (INITVARS (LAFITESUBBROWSEMENU) + (LAFITEBROWSERICONMENU) + (LAFITEEXTRAMENU)) + (GLOBALVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) + [ADDVARS (LAFITEMENUVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) + (LAFITEEXTRAMENUITEMS ("Describe Folder" '\LAFITE.DESCRIBE.FOLDER + "Display some relevant info about this folder" + (SUBITEMS ("Inspect Folder" 'INSPECT + "Inspect the MAILFOLDER data structure associated with this browser" + ] + (VARS (BROWSERMARKXPOSITION 8)) + (BITMAPS LA.SELECTION.BITMAP)) + [COMS (* ; "Obsolete") + (INITVARS (LAFITEBROWSERREGION (CREATEREGION 30 30 575 210] + (DECLARE%: DOEVAL@COMPILE DONTCOPY (CONSTANTS * TOCSTATES) + [P (CL:PROCLAIM '(CL:SPECIAL \CURRENTDISPLAYLINE] + (FILES (SOURCE) + LAFITEDECLS) + (LOCALVARS . T)) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA LAB.MOUSECONFIRM + LAB.FORMAT + LAB.PROMPTPRINT]) + + + +(* ; "BROWSE") + +(DEFINEQ + +(\LAFITE.BROWSE + [LAMBDA (ITEM MENU BUTTON) (* ; "Edited 17-Sep-87 19:13 by bvm:") + +(* ;;; "Function called by the Browse button on main Lafite window.") + + (LET [(SUBP (EQ BUTTON 'MIDDLE] (* ; + "Pass the :confirm option to LAFITE.BROWSE.FOLDER to require confirmation on folder creation.") + (\LAFITE.PROCESS `[,(COND + (SUBP (FUNCTION \LAFITE.SUBBROWSE)) + (T (FUNCTION \LAFITE.BROWSE.PROC))) + ',ITEM + ',MENU + ,@(AND (NOT SUBP) + '(NIL '(:CONFIRM] + 'LAFITEBROWSE]) + +(\LAFITE.SUBBROWSE + [LAMBDA (ITEM MENU) (* ; "Edited 3-Sep-87 18:00 by bvm:") + (PROG [(COMMAND (MENU (.LAFITEMENU. LAFITESUBBROWSEMENU LAFITESUBBROWSEMENUITEMS + "Browse subcommands"] + (COND + (COMMAND (CL:FUNCALL COMMAND ITEM MENU]) + +(\LAFITE.BROWSE.PROC + [LAMBDA (ITEM MENU FOLDERNAME OPTIONS) (* ; "Edited 10-Sep-87 15:19 by bvm:") + (LET (MAILFOLDER) + (COND + ([NULL (OR FOLDERNAME (SETQ FOLDERNAME (\LAFITE.PROMPTFORFOLDER] + (* ; + "From BROWSE command, user aborted by not giving a file name") + NIL) + ((LISTP FOLDERNAME) (* ; + "From LAFITE. Each element is (foldername browserregion displayregion iconposition . options)") + (for ITEM in FOLDERNAME do (LAFITE.BROWSE.FOLDER (CAR FOLDERNAME) + (CDR FOLDERNAME) + (APPEND (CDDDDR FOLDERNAME) + OPTIONS) + ITEM MENU))) + (T (LAFITE.BROWSE.FOLDER FOLDERNAME NIL OPTIONS ITEM MENU]) + +(\LAFITE.BROWSE.FORGET + [LAMBDA (ITEM MENU) (* ; "Edited 18-Jul-88 11:41 by bvm") + (LET ((FOLDERNAME (PROMPTFORFILENAME NIL \LAFITE.LAST.FOLDER.NAME))) + (COND + (FOLDERNAME (SETQ \LAFITE.LAST.FOLDER.NAME FOLDERNAME) + (* ; "Save name as typed now in case it fails. Guy who gets the actual folder will set canonical name here.") + (\LAFITE.BROWSE.PROC ITEM MENU FOLDERNAME '(:FORGET :CONFIRM]) + +(LAFITE.BROWSE.FOLDER + [LAMBDA (FOLDERNAME LAYOUT OPTIONS ITEM MENU) (* ; "Edited 3-May-89 19:04 by bvm") + + (* ;; "Browse folder named FOLDERNAME. LAYOUT is a triple (browserregion iconposition displayregion). OPTIONS may include :SHRINK, meaning to shrink folder when finished, and :CONFIRM, meaning require confirmation before creating an empty folder. ITEM, if specified, is a menu item in MENU to shade while the browser is being prepared.") + + (LET [(FOLDER (RESETLST + (AND ITEM (LA.RESETSHADE ITEM MENU)) + (\LAFITE.PREPARE.BROWSER (LA.LONGFILENAME FOLDERNAME LAFITEMAIL.EXT) + OPTIONS LAYOUT))] + (COND + (FOLDER (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) + [if (NULL (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) + then (* ; + "Got a browser, but haven't loaded anything into it yet") + (COND + ((EQMEMB :ACTIVE OPTIONS) + (replace (MAILFOLDER FOLDERGETSMAIL) of FOLDER + with T))) + (LAB.LOADFOLDER FOLDER) + (COND + ((EQMEMB :GETMAIL OPTIONS) + (LAB.DO.COMMAND (fetch (MAILFOLDER BROWSERWINDOW) + of FOLDER) + (FUNCTION \LAFITE.GETMAIL))) + ((EQMEMB :SHRINK OPTIONS) + (SHRINKW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER]) + FOLDER]) + +(\LAFITE.PREPARE.BROWSER + [LAMBDA (FOLDERNAME OPTIONS LAYOUT) (* ; "Edited 7-Sep-88 12:18 by bvm") + + (* ;; "Get a browser on FOLDERNAME. If there already is one, we just top it, otherwise we create a new one. Returns the folder object or NIL on failure. OPTIONS are the options to browse. LAYOUT is where to put the browser if we have to create it.") + + (SETQ OPTIONS (CONS :BROWSE (MKLIST OPTIONS))) + (WITH.MONITOR \LAFITE.BROWSELOCK + (LET ((MAILFOLDER (LAFITE.OBTAIN.FOLDER FOLDERNAME 'INPUT NIL OPTIONS)) + BROWSERWINDOW STREAM) + (AND MAILFOLDER (COND + ((SETQ BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) + of MAILFOLDER)) + (* ; "Already have browser") + (COND + ((OPENWP BROWSERWINDOW) + (TOTOPW BROWSERWINDOW)) + ((NOT (FMEMB :SHRINK OPTIONS)) + (* ; "Make sure the EXPANDFN runs") + (EXPANDW BROWSERWINDOW))) + T) + ((COND + ((SETQ STREAM (fetch (MAILFOLDER FOLDERSTREAM) of + MAILFOLDER + )) (* ; + "Already have folder open, e.g., from MOVETO, but no browser yet") + (SETFILEINFO STREAM 'BUFFERS LAFITEBUFFERSIZE) + T) + (T (\LAFITE.MAYBE.OPEN.FOLDER MAILFOLDER 'INPUT NIL OPTIONS)) + ) (* ; "Success in opening") + (LAB.CREATEWINDOW MAILFOLDER LAYOUT))) + MAILFOLDER)))]) + +(\LAFITE.MAYBE.OPEN.FOLDER + [LAMBDA (FOLDER ACCESS PROMPTFOLDER OPTIONS RETURNERRORS) + (* ; "Edited 8-Sep-88 17:41 by bvm") + + (* ;; "Open FOLDER for indicated access, with the possibility that the file does not yet exist. If it doesn't, then create it, asking for confirmation if PROMPTFOLDER is supplied (a folder in whose browser to prompt for confirmation, or T for global prompt). Returns the stream on success. On failure, returns the condition if RETURNERRORS true, else NIL.") + + (PROG* ((FOLDERNAME (OR (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER) + (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of FOLDER))) + (OLDP (EQMEMB :OLD OPTIONS)) + (RECOG (AND (OR OLDP PROMPTFOLDER) + 'OLD)) + STREAM CONDITION) + RETRY + + + (* ;; "Just try opening. If confirmation desired, open only OLD file on first try.") + + [CL:MULTIPLE-VALUE-SETQ (STREAM CONDITION) + (IGNORE-ERRORS (\LAFITE.OPENSTREAM FOLDERNAME ACCESS RECOG (FUNCTION \LAFITE.EOF) + (EQMEMB :BROWSE OPTIONS) + 'LAFITE] + (RETURN (if CONDITION + then (* ; "Failed to open") + (if (AND (NEQ RECOG 'NEW) + (NOT OLDP) + (TYPEP CONDITION 'XCL:FILE-NOT-FOUND)) + then (* ; "Just couldn't find it, so maybe create it. If RECOG was NEW, we normally shouldn't be getting this error") + (if (OR (NOT (EQMEMB :CONFIRM OPTIONS)) + (LAB.MOUSECONFIRM PROMPTFOLDER + "Click LEFT to confirm creating ~A" + FOLDERNAME)) + then (SETQ RECOG 'NEW) + (SETQ ACCESS 'BOTH) + (GO RETRY) + else (* ; + "Disconfirmed the create request.") + NIL) + elseif RETURNERRORS + then (* ; "Caller wants to know why") + CONDITION + else (* ; "File wouldn't open for some other reason than just not existing, so report it. Should probably be a little more discriminating here.") + (\LAFITE.REPORT.FILE.WONT.OPEN (AND (NEQ PROMPTFOLDER T) + PROMPTFOLDER) + CONDITION FOLDERNAME) + NIL) + else (\LAFITE.SET.FOLDER.STREAM FOLDER STREAM) + (* ; "Notice name fields and such") + STREAM]) + +(LAB.LOADFOLDER + [LAMBDA (MAILFOLDER) (* ; "Edited 13-Sep-88 17:42 by bvm") + (COND + ((LOADMAILFOLDER MAILFOLDER) + (replace (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER with 1) + (* ; "Nothing selected") + (replace (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER with 0) + (LAB.DISPLAYFOLDER MAILFOLDER) + MAILFOLDER]) + +(LAB.DISPLAYFOLDER + [LAMBDA (FOLDER) (* ; "Edited 28-Apr-89 15:50 by bvm") + (LET* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) + (CLIPREGION (DSPCLIPPINGREGION NIL WINDOW)) + MSG) + (CLEARW WINDOW) + (LAB.SETUP FOLDER) + (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER with NIL) + (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of FOLDER with NIL) + (COND + ((AND (SETQ MSG (LAB.MAKE.INITIAL.SELECTION FOLDER)) + (< (MESSAGE#.TO.YPOS MSG FOLDER) + (fetch (REGION BOTTOM) of CLIPREGION))) + (* ; + "Quietly scroll so that selected message is in window") + (WYOFFSET (TIMES [- (fetch (LAFITEMSG %#) of MSG) + (QUOTIENT (fetch (REGION HEIGHT) of CLIPREGION) + (TIMES 2 (fetch (MAILFOLDER BROWSERFONTHEIGHT) + of FOLDER] + (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER)) + WINDOW))) + (COND + ((EQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) + 0) + (LAB.PROMPTPRINT FOLDER T "Folder is empty.")) + (T (LAB.DISPLAYLINES FOLDER NIL NIL CLIPREGION]) + +(LAB.MAKE.INITIAL.SELECTION + [LAMBDA (MAILFOLDER) (* bvm%: "24-Feb-86 16:31") + (LET ((LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) + (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) + MSGDESCRIPTOR I) + (COND + ((EQ LASTMSG# 0) + NIL) + ((SETQ I (LAB.FIND.SELECTED.MSG MAILFOLDER 1 LASTMSG#)) + (* ; + "There are already selected messages") + (NTHMESSAGE MESSAGES I)) + (T [find old I from 1 to LASTMSG# + suchthat (AND [NOT (fetch (LAFITEMSG SEEN?) of (SETQ MSGDESCRIPTOR + (NTHMESSAGE MESSAGES I] + (NOT (fetch (LAFITEMSG DELETED?) of MSGDESCRIPTOR] + + (* ;; "Found an unseen, undeleted message. If we don't find one, the last MSGDESCRIPTOR is the one to select") + + (SELECTMESSAGE MSGDESCRIPTOR MAILFOLDER) + MSGDESCRIPTOR]) + +(LAB.CREATEWINDOW + [LAMBDA (FOLDER LAYOUT TITLE) (* ; "Edited 20-Apr-89 16:05 by bvm") + +(* ;;; "Build a browser window, which consists of three attached windows: the main BROWSERWINDOW, the BROWSERMENUWINDOW containing the menu, and a BROWSERPROMPTWINDOW for displaying random info") + + (if (NULL TITLE) + then (SETQ TITLE (if FOLDER + then (LAB.TITLE.STRING FOLDER) + else "Dummy Browser"))) + (PROG (BROWSERPROMPTWINDOW BROWSERMENUWINDOW BROWSERMENU BROWSERWINDOW WIDTH HEIGHT MENUREGION + WHOLEREGION) + (SETQ BROWSERMENU (create MENU + ITEMS _ LAFITEBROWSERMENUITEMS + CENTERFLG _ T + WHENSELECTEDFN _ (if FOLDER + then (FUNCTION LAB.COMMANDFN) + else (FUNCTION NILL)) + MENUFONT _ LAFITEMENUFONT)) + (SETQ MENUREGION (WINDOWPROP (SETQ BROWSERMENUWINDOW (MENUWINDOW BROWSERMENU)) + 'REGION)) + (SETQ WIDTH (fetch (REGION WIDTH) of MENUREGION)) + [SETQ HEIGHT (HEIGHTIFWINDOW (FONTPROP LAFITEBROWSERFONT 'HEIGHT] + + (* ;; "Now figure out where to put it all") + + (if LAYOUT + then (* ; "user tells us all. If this happens to match one of the default regions, make sure to use it instead (future test is with EQ).") + [if (EQ LAYOUT T) + then (* ; "Requires prompting") + (SETQ LAYOUT NIL) + else (for SPEC in LAFITE.BROWSER.LAYOUTS + when (EQUAL SPEC LAYOUT) do (RETURN (SETQ LAYOUT SPEC] + elseif LAFITE.BROWSER.LAYOUTS + then (* ; + "Take the first layout not currently in use") + (for SPEC in LAFITE.BROWSER.LAYOUTS + unless (for OPEN in \ACTIVELAFITEFOLDERS + thereis (EQ (fetch (MAILFOLDER BROWSERLAYOUT) + of OPEN) + SPEC)) do (RETURN (SETQ LAYOUT SPEC))) + elseif (AND LAFITEBROWSERREGION (for OPEN in \ACTIVELAFITEFOLDERS + never (fetch (MAILFOLDER BROWSERWINDOW) + of OPEN))) + then (* ; + "For backward compatibility: if there are no open browsers, use LAFITEBROWSERREGION") + (SETQ LAYOUT (LIST LAFITEBROWSERREGION NIL LAFITEDISPLAYREGION))) + [COND + ((SETQ WHOLEREGION (LISTP (CAR LAYOUT))) + [COND + ((> (fetch (REGION WIDTH) of WHOLEREGION) + WIDTH) (* ; + "Only use specified region width if it is wide enough") + (SETQ WIDTH (fetch (REGION WIDTH) of WHOLEREGION] + (SETQ WHOLEREGION (create REGION using WHOLEREGION WIDTH _ WIDTH)) + (* ; + "Copy the region so we don't smash user variable") + ) + (T (* ; "Prompt for region") + (SETQ WHOLEREGION (GETBOXREGION WIDTH (TIMES HEIGHT 9) + NIL NIL NIL (CONCAT "Specify region for " TITLE] + [replace (REGION HEIGHT) of WHOLEREGION with (- (fetch (REGION HEIGHT) + of WHOLEREGION) + (+ HEIGHT (fetch + (REGION HEIGHT) + of MENUREGION] + (* ; + "Shrink user-supplied region by the combined heights of the menu and prompt window") + (SETQ BROWSERWINDOW (CREATEW WHOLEREGION TITLE)) + (ATTACHWINDOW BROWSERMENUWINDOW BROWSERWINDOW 'TOP 'JUSTIFY) + (DSPFONT LAFITEBROWSERFONT BROWSERWINDOW) + (SETQ BROWSERPROMPTWINDOW (GETPROMPTWINDOW BROWSERWINDOW 1 LAFITEBROWSERFONT)) + (CLEARW BROWSERPROMPTWINDOW) (* ; + "Get the xy set correctly for the actual font being used") + (LINELENGTH MAX.SMALLP BROWSERPROMPTWINDOW) (* ; "Make LINELENGTH ignored -- we try not to overflow window anyway, and the LINELENGTH is no good for variable width font") + (if FOLDER + then (* ; + "MAILFOLDER = NIL is used by dummy routine to set up regions") + [WINDOWADDPROP BROWSERPROMPTWINDOW 'RESHAPEFN (FUNCTION (LAMBDA (W) + (LINELENGTH MAX.SMALLP + W] + (WINDOWADDPROP BROWSERPROMPTWINDOW 'RESHAPEFN (FUNCTION RESHAPEBYREPAINTFN)) + (* ; + "Adding our own reshapefn overrode the default, so add the default back in.") + (WINDOWPROP BROWSERPROMPTWINDOW 'PAGEFULLFN (FUNCTION LAB.PAGEFULLFN)) + (replace (MAILFOLDER ORIGINALBROWSERTITLE) of FOLDER with TITLE) + (WINDOWPROP BROWSERWINDOW 'MAILFOLDER FOLDER) + (WINDOWPROP BROWSERWINDOW 'SCROLLFN (FUNCTION LAB.SCROLLFN)) + (replace (MAILFOLDER BROWSERWINDOW) of FOLDER with BROWSERWINDOW) + (replace (MAILFOLDER BROWSERMENUWINDOW) of FOLDER with + BROWSERMENUWINDOW + ) + (replace (MAILFOLDER BROWSERMENU) of FOLDER with BROWSERMENU) + (replace (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER with + BROWSERPROMPTWINDOW + ) + (replace (MAILFOLDER FOLDERDISPLAYREGION) of FOLDER with (CADDR + LAYOUT)) + (replace (MAILFOLDER BROWSERLAYOUT) of FOLDER with LAYOUT) + (WINDOWPROP BROWSERWINDOW 'REPAINTFN (FUNCTION LAB.REPAINTFN)) + (WINDOWPROP BROWSERWINDOW 'ICONFN (FUNCTION LAB.ICONFN)) + (WINDOWPROP BROWSERWINDOW 'ICONPOSITION (CADR LAYOUT)) + (WINDOWPROP BROWSERWINDOW 'BUTTONEVENTFN (FUNCTION LAB.BUTTONEVENTFN)) + (WINDOWPROP BROWSERWINDOW 'RIGHTBUTTONFN (FUNCTION LAB.BUTTONEVENTFN)) + (WINDOWPROP BROWSERWINDOW 'COPYBUTTONEVENTFN (FUNCTION LAB.COPYBUTTONEVENTFN)) + (* ; + "make sure Lafite has the first CLOSEFN and SHRINKFN") + (WINDOWADDPROP BROWSERWINDOW 'CLOSEFN (FUNCTION LAB.CLOSEFN) + T) + (WINDOWADDPROP BROWSERWINDOW 'SHRINKFN (FUNCTION LAB.SHRINKFN) + T) + (WINDOWADDPROP BROWSERWINDOW 'RESHAPEFN (FUNCTION LAB.RESHAPEFN))) + (RETURN BROWSERWINDOW]) + +(LAB.TITLE.STRING + [LAMBDA (FOLDER) (* ; "Edited 24-Oct-88 18:07 by bvm") + + (* ;; "Returns string to be used for FOLDER's browser's title. It is arranged to convey as much info as possible before it falls off the right edge of the window.") + + (LET* ((DEST (fetch (MAILFOLDER DEFAULTMOVETOFILE) of FOLDER)) + (FIELDS (UNPACKFILENAME.STRING (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER))) + (BODY (FMEMB 'NAME FIELDS))) + (RPLACD (NLEFT FIELDS 1 BODY)) (* ; + "detach name.ext;version from host/directory") + (CONCAT "Browsing " (if (STRING-EQUAL (LISTGET BODY 'EXTENSION) + LAFITEMAIL.EXT) + then (* ; "Just the name field will do") + (LISTGET BODY 'NAME) + else (CL:APPLY (FUNCTION PACKFILENAME.STRING) + BODY)) + (if DEST + then (CONCAT " (Move To: " (fetch (MAILFOLDER SHORTFOLDERNAME) + of DEST) + ")") + else "") + " on " + (if (U-CASEP (SETQ FIELDS (CL:APPLY (FUNCTION PACKFILENAME.STRING) + FIELDS))) + then (CL:STRING-CAPITALIZE FIELDS) + else (* ; "Leave the capitalization alone") + FIELDS]) + +(LAB.COMMANDFN + [LAMBDA (ITEM MENU KEY) (* ; "Edited 18-Jul-88 11:41 by bvm") + (OR \LAFITE.READY (\LAFITE.MARK.FOLDERS.OBSOLETE)) + (LET ((MENUW (WFROMMENU MENU)) + WINDOW FOLDER) + (AND MENUW (SETQ WINDOW (WINDOWPROP MENUW 'MAINWINDOW)) + (SETQ FOLDER (WINDOWPROP WINDOW 'MAILFOLDER)) + (fetch (MAILFOLDER BROWSERREADY) of FOLDER) + (CL:FUNCALL (EXTRACTMENUCOMMAND ITEM) + WINDOW FOLDER ITEM MENU KEY]) + +(LAB.DO.COMMAND + [LAMBDA (WINDOW ITEM/FN MENU KEY) (* ; "Edited 18-Jul-88 11:41 by bvm") + + (* ;; "Runs some browser command--variant on LAB.COMMANDFN to be called programmatically. If ITEM/FN is a function name, we get the real item and MENU from the window.") + + (OR \LAFITE.READY (\LAFITE.MARK.FOLDERS.OBSOLETE)) + (LET [(FOLDER (WINDOWPROP WINDOW 'MAILFOLDER] + (AND FOLDER (fetch (MAILFOLDER BROWSERREADY) of FOLDER) + (CL:FUNCALL (if (LITATOM ITEM/FN) + then (PROG1 ITEM/FN + (OR MENU (SETQ MENU (fetch (MAILFOLDER BROWSERMENU) + of FOLDER))) + (SETQ ITEM/FN (LA.MENU.ITEM ITEM/FN MENU))) + else (EXTRACTMENUCOMMAND ITEM/FN)) + WINDOW FOLDER ITEM/FN MENU KEY]) + +(LAB.ASSURE.SELECTIONS + [LAMBDA (MAILFOLDER) (* bvm%: " 3-Feb-86 14:44") + (COND + ((IGREATERP (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER) + (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER)) + (LAB.PROMPTPRINT MAILFOLDER T "No messages selected.") + T]) +) +(DEFINEQ + +(BUILD.LAFITE.LAYOUTS + [LAMBDA NIL (* ; "Edited 23-Nov-87 16:48 by bvm:") + (LET (DUMMYWINDOWS) + (CL:UNWIND-PROTECT + (PROG ((ICONBM (fetch (TITLEDICON ICON) of LAFITE.FOLDER.ICON)) + (N 0) + W MAILFOLDER LAYOUTS LAYOUT CURRENT OLDLAYOUTS POS) + (if (AND (LISTP LAFITE.BROWSER.LAYOUTS) + (CL:Y-OR-N-P + "Do you wish to retain the ~D browser specifications you already have? " + (LENGTH LAFITE.BROWSER.LAYOUTS))) + then (SETQ OLDLAYOUTS LAFITE.BROWSER.LAYOUTS) + [for LAYOUT in OLDLAYOUTS + do (for FOLDER in \ACTIVELAFITEFOLDERS + when (EQ (fetch (MAILFOLDER BROWSERLAYOUT) + of FOLDER) + LAYOUT) + do (add N 1) + (RETURN (CL:FORMAT T + "Retaining layout in use by ~A.~%%" + (fetch (MAILFOLDER SHORTFOLDERNAME + ) of FOLDER))) + finally (* ; + "Display dummy browser and icon to aid in positioning.") + [SETQ W (LAB.CREATEWINDOW NIL LAYOUT + (CONCAT "Sample Browser " + (add N 1] + (push DUMMYWINDOWS (\LAFITE.MAKE.DUMMY.WINDOWS + W LAYOUT N] + (SETQ LAYOUTS (REVERSE OLDLAYOUTS))) + (CL:FORMAT T "Click in preference order in each browser or browser icon whose current layout you wish to include; click in background to finish~%%" + ) + (while (SETQ W (WHICHW (GETPOSITION))) + do (if [AND [NOT (SETQ MAILFOLDER (WINDOWPROP W 'MAILFOLDER] + (OR [NOT (SETQ W (WINDOWPROP W 'ICONFOR] + (NOT (SETQ MAILFOLDER (WINDOWPROP W 'MAILFOLDER] + then (CL:FORMAT T + "That's not a Lafite browser window/icon; try again.~%%" + ) + elseif (OR (MEMB (fetch (MAILFOLDER BROWSERLAYOUT) + of MAILFOLDER) + OLDLAYOUTS) + (MEMBER (SETQ LAYOUT (\LAFITE.LAYOUT.FROM.WINDOW + W MAILFOLDER ICONBM)) + LAYOUTS)) + then (CL:FORMAT T + "You have already included that browser's specification.~%%" + ) + else (* ; + "It's a Lafite browser window or icon.") + (push LAYOUTS LAYOUT) + (CL:FORMAT T "Browser for ~A noted.~%%" (fetch (MAILFOLDER + + SHORTFOLDERNAME + ) + of MAILFOLDER)) + (add N 1))) + (while (OR (NULL LAYOUTS) + (MENU (create MENU + ITEMS _ '(("Specify another browser" T) + ("Finish" 'NIL)) + MENUFONT _ LAFITEMENUFONT + CENTERFLG _ T))) + do [SETQ W (LAB.CREATEWINDOW NIL T (CONCAT "Sample Browser " + (add N 1] + (push DUMMYWINDOWS (\LAFITE.MAKE.DUMMY.WINDOWS W + (SETQ LAYOUT (\LAFITE.LAYOUT.FROM.WINDOW + W NIL ICONBM)) + N)) + (push LAYOUTS LAYOUT)) + (RETURN (if (AND LAYOUTS (MOUSECONFIRM + "Click LEFT to confirm setting LAFITEBROWSERLAYOUTS to these values" + T T T)) + then (/SETTOPVAL 'LAFITE.BROWSER.LAYOUTS (REVERSE LAYOUTS)) + (MARKASCHANGED 'LAFITE.BROWSER.LAYOUTS 'VARS) + LAFITE.BROWSER.LAYOUTS))) + + (* ;; "Cleanup dummy windows put up earlier") + + (for X in DUMMYWINDOWS bind TMP + do (CLOSEW X) + (if (SETQ TMP (WINDOWPROP X 'DUMMY.ICON)) + then (CLOSEW TMP)) + (if (SETQ TMP (WINDOWPROP X 'DUMMY.DISPLAY)) + then (CLOSEW TMP))))]) + +(\LAFITE.LAYOUT.FROM.WINDOW + [LAMBDA (W FOLDER ICONBM) (* ; "Edited 10-Dec-87 17:15 by bvm:") + + (* ;; "Return a browser layout spec corresponding to window W optionally containing FOLDER.") + + (LET ((PW (if (OPENWP W) + then (GETPROMPTWINDOW W 1 LAFITEBROWSERFONT) + else PROMPTWINDOW))) + (LIST (WINDOWREGION W) + (if (WINDOWPROP W 'ICONPOSITION) + else (CLEARW PW) + (CL:FORMAT PW "Specify position for icon.") + (PROG1 (GETBOXPOSITION (BITMAPWIDTH ICONBM) + (BITMAPHEIGHT ICONBM)) + (CLEARW PW))) + (PROG (CURRENT) + [if FOLDER + then (* ; "Use current values, if known") + (RETURN (OR (if (CAR (SETQ CURRENT (fetch (MAILFOLDER + FOLDERDISPLAYWINDOWS + ) + of FOLDER))) + then (* ; + "take current primary window region") + (COPY (WINDOWPROP (CAR CURRENT) + 'REGION)) + elseif (COPY (fetch (MAILFOLDER + FOLDERDISPLAYREGION) + of FOLDER))) + (GO PROMPT] + PROMPT + (CLEARW PW) + (CL:FORMAT PW "Specify region for display window") + (RETURN (PROG1 (if LAFITE.DISPLAY.SIZE + then (GETBOXREGION (CAR LAFITE.DISPLAY.SIZE) + (CDR LAFITE.DISPLAY.SIZE) + NIL NIL) + else (GETREGION)) + (CLEARW PW]) + +(\LAFITE.MAKE.DUMMY.WINDOWS + [LAMBDA (MAINW LAYOUT N) (* ; "Edited 23-Nov-87 16:44 by bvm:") + (LET (TMP SUBW) + (DSPFILL NIL LAFITE.DUMMY.SHADE 'REPLACE MAINW) + (WINDOWPROP MAINW 'SHRINKFN 'DON'T) + (if (SETQ TMP (CADR LAYOUT)) + then (* ; "An icon position is given") + (SETQ SUBW (TITLEDICONW LAFITE.FOLDER.ICON (CONCAT "Icon " N) + LAFITETITLEFONT TMP)) + (ICONW.SHADE SUBW LAFITE.DUMMY.HALF.SHADE) + (WINDOWPROP SUBW 'BUTTONEVENTFN (FUNCTION ICONBUTTONEVENTFN)) + (WINDOWPROP MAINW 'DUMMY.ICON SUBW)) + (if (SETQ TMP (CADDR LAYOUT)) + then (* ; "A display region is given") + (SETQ SUBW (CREATEW TMP (CONCAT "Lafite Display window " N) + LAFITETITLEFONT TMP)) + (DSPFILL NIL LAFITE.DUMMY.SHADE 'REPLACE SUBW) + (WINDOWPROP MAINW 'DUMMY.DISPLAY SUBW)) + MAINW]) +) + +(RPAQQ LAFITE.DUMMY.SHADE + #*(16 16)@L@HA@@FALD@@DJ@AHF@@@JDH@NFD@@EDD@EDJ@EDJD@@LD@@HD@@HDD@@DJ@@DL) + +(RPAQQ LAFITE.DUMMY.HALF.SHADE + #*(16 16)@H@@A@@D@@D@@DB@A@D@@@HDH@DB@@@DDD@A@B@DDHD@@D@@@@D@@H@D@@DJ@@@@) + +(RPAQ? \LAFITE.LAST.FOLDER.NAME ) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \LAFITE.LAST.FOLDER.NAME) +) + + + +(* ; "Browser operations") + +(DEFINEQ + +(LAB.SETUP + [LAMBDA (MAILFOLDER) (* bvm%: "31-Jul-84 14:39") + (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) + WIDTH HEIGHT TOTALHEIGHT ASCENT DIGITWIDTH SPACEWIDTH XPOS) + (CLEARW WINDOW) + (SETQ LAFITEBROWSERFONT (FONTCREATE LAFITEBROWSERFONT)) + (DSPFONT LAFITEBROWSERFONT WINDOW) + (DSPRIGHTMARGIN MAX.SMALLP WINDOW) + (LINELENGTH 10000 WINDOW) + [replace (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER with + (SETQ HEIGHT + (FONTPROP LAFITEBROWSERFONT + 'HEIGHT] + [replace (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER with + (SETQ ASCENT + (FONTPROP LAFITEBROWSERFONT + 'ASCENT] + (replace (MAILFOLDER BROWSERFONTDESCENT) of MAILFOLDER with (FONTPROP + LAFITEBROWSERFONT + 'DESCENT)) + (replace (MAILFOLDER BROWSERORIGIN) of MAILFOLDER with (+ (DSPYPOSITION NIL + WINDOW) + ASCENT)) + [replace (MAILFOLDER BROWSERMAXXPOS) of MAILFOLDER with (SETQ WIDTH + (WINDOWPROP + WINDOW + 'WIDTH] + (SETQ TOTALHEIGHT (TIMES (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) + HEIGHT)) + (WINDOWPROP WINDOW 'EXTENT (replace (MAILFOLDER BROWSEREXTENT) of MAILFOLDER + with (create REGION + LEFT _ 0 + BOTTOM _ (- (fetch (MAILFOLDER + BROWSERORIGIN) + of MAILFOLDER) + TOTALHEIGHT) + WIDTH _ WIDTH + HEIGHT _ TOTALHEIGHT))) + + (* ;; "Now figure out columns for printing toc entries") + + (SETQ DIGITWIDTH (CHARWIDTH (CHARCODE 9) + LAFITEBROWSERFONT)) + (SETQ SPACEWIDTH (CHARWIDTH (CHARCODE r) + LAFITEBROWSERFONT)) + [replace (MAILFOLDER ORDINALXPOS) of MAILFOLDER with + (SETQ XPOS + (+ BROWSERMARKXPOSITION + (CHARWIDTH (CHARCODE m) + LAFITEBROWSERFONT) + (LRSH DIGITWIDTH 1] + (* ; "Message # starts here") + [replace (MAILFOLDER DATEXPOS) of MAILFOLDER with (add XPOS + (+ (TIMES 2 SPACEWIDTH + ) + (TIMES 4 DIGITWIDTH + ] + (* ; + "Date starts here. Allow 4 columns of digits plus some space") + [replace (MAILFOLDER FROMXPOS) of MAILFOLDER + with (add XPOS (+ (TIMES 2 DIGITWIDTH) + (TIMES 2 SPACEWIDTH) + (CHARWIDTH (CHARCODE -) + LAFITEBROWSERFONT) + (STRINGWIDTH 'MAY LAFITEBROWSERFONT] + (* ; + "From field starts here. Allow 3 columns of digits, a month, and some space") + [replace (MAILFOLDER SUBJECTXPOS) of MAILFOLDER + with (add XPOS (IMAX (TIMES LAFITEMINFROMCHARS (CHARWIDTH (CHARCODE A) + LAFITEBROWSERFONT)) + (FIXR (FTIMES LAFITEFROMFRACTION (- WIDTH XPOS] + + (* ;; "Subject field starts here. Space is divided up between From and Subject so that From field gets LAFITEFROMFRACTION of the available space, but at least LAFITEMINFROMCHARS wide") + + (replace (MAILFOLDER FROMMAXXPOS) of MAILFOLDER with (- XPOS (TIMES 2 + SPACEWIDTH) + )) + (* ; + "From field gets truncated beyond this position") + (replace (MAILFOLDER BROWSERDIGITWIDTH) of MAILFOLDER with DIGITWIDTH]) + +(LAB.BUTTONEVENTFN + [LAMBDA (WINDOW) (* ; "Edited 28-Jul-88 17:37 by bvm") + (TOTOPW WINDOW) + (COND + ((INSIDEP (DSPCLIPPINGREGION NIL WINDOW) + (LASTMOUSEX WINDOW) + (LASTMOUSEY WINDOW)) + (LAB.DO.UNLESS.BUSY WINDOW (FUNCTION LAB.SELECTMESSAGE))) + ((LASTMOUSESTATE (ONLY RIGHT)) + (DOWINDOWCOM WINDOW)) + ((LASTMOUSESTATE (ONLY MIDDLE)) + (LAB.DO.UNLESS.BUSY WINDOW (FUNCTION LAFITEEXTRABROWSERCOMMANDFN]) + +(LAB.DO.UNLESS.BUSY + [LAMBDA (WINDOW FN ARGUMENT) (* ; "Edited 3-Sep-87 18:01 by bvm:") + (RESETLST + [PROG [(MAILFOLDER (WINDOWPROP WINDOW 'MAILFOLDER] + (COND + ((AND (fetch (MAILFOLDER BROWSERREADY) of MAILFOLDER) + (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + T T)) + (CL:FUNCALL FN WINDOW MAILFOLDER ARGUMENT])]) + +(LOADMAILFOLDER + [LAMBDA (FOLDER) (* ; "Edited 10-May-89 12:42 by bvm") + + (* ;; "LAFITEVERSION# is used to keep track of changed in internal datastructures that get written out to Lafite TOC files. If the datastructures change, then just change the version number to LAFITEVERSION#+1 and the rest of Lafite should adjust appropriately.") + + (replace (MAILFOLDER FOLDEROUTOFORDER) of FOLDER with NIL) + (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with NIL) + (* ; + "Assume ok until we hear otherwise") + (COND + ((OR (\LAFITE.READ.TOC.FILE FOLDER) + (\LAFITE.PARSE.FOLDER FOLDER)) + (LAB.PROMPTPRINT FOLDER " done.") + [replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER + with (OR (LAB.SET.EXPUNGEABILITY FOLDER) + (MAX 1 (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER] + (* ; "Only %"changed%" messages are deleted ones now, except for possibly the last message in the case where it was truncated.") + FOLDER]) + +(LAFITE.OBTAIN.FOLDER + [LAMBDA (FOLDERNAME ACCESS PROMPTFOLDER OPTIONS) (* ; "Edited 12-Sep-88 17:42 by bvm") + +(* ;;; "Locates a MAILFOLDER on FOLDERNAME, or creates one if there is none. If the folder is not already on the active list, we will try to open it for ACCESS, or just return NIL if ACCESS is NIL. If PROMPTFOLDER is supplied, it is a folder (or T for PROMPTWINDOW) indicating focus of attention for prompting for confirmation to create new folder. OPTIONS may include :FORGET, in which case we don't add this folder name to the set of known folders, or :BROWSE, meaning we plan to browse the folder.") + + (WITH.MONITOR \LAFITE.BROWSELOCK + [OR + (for FOLDER in \ACTIVELAFITEFOLDERS when (OR (STRING-EQUAL (fetch + (MAILFOLDER + VERSIONLESSFOLDERNAME + ) + of FOLDER) + FOLDERNAME) + (STRING-EQUAL (fetch + (MAILFOLDER + FULLFOLDERNAME + ) + of FOLDER) + FOLDERNAME)) + do (* ; + "Found existing folder without sweating too hard") + (RETURN FOLDER)) + (AND ACCESS + (LET* ((UNPACKEDNAME (UNPACKFILENAME.STRING FOLDERNAME)) + (OLDVERSION (LISTGET UNPACKEDNAME 'VERSION)) + (VERSIONLESSNAME (PROGN (LISTPUT UNPACKEDNAME 'VERSION NIL) + (PACKFILENAME.STRING UNPACKEDNAME))) + SHORTNAME NEWNAME NEWFOLDER OLDFOLDER STREAM) + (COND + ((AND (NOT (STRING-EQUAL VERSIONLESSNAME FOLDERNAME)) + (SETQ NEWFOLDER (\LAFITE.FIND.EXISTING.FOLDER VERSIONLESSNAME)) + (\LAFITE.CONFLICTING.OLD.FOLDER NEWFOLDER FOLDERNAME OLDVERSION)) + (* ; + "Found a folder describing a different version--can't have more than one version up at once") + NIL) + ((NULL (SETQ STREAM + (\LAFITE.MAYBE.OPEN.FOLDER (SETQ NEWFOLDER + (create MAILFOLDER + FULLFOLDERNAME _ FOLDERNAME + VERSIONLESSFOLDERNAME _ + VERSIONLESSNAME + FOLDERLOCK _ ( + CREATE.MONITORLOCK + VERSIONLESSNAME)) + ) + ACCESS PROMPTFOLDER OPTIONS T))) + (* ; + "File not found and user didn't confirm creating it") + NIL) + ((type? STREAM STREAM) (* ; + "succeeded in opening the new folder.") + (PROG ((VERSIONLESSNEW (PACKFILENAME.STRING 'VERSION NIL 'BODY + (fetch (MAILFOLDER FULLFOLDERNAME) + of NEWFOLDER))) + (SHORTNAME (fetch SHORTFOLDERNAME of NEWFOLDER))) + (if (NOT (STRING-EQUAL VERSIONLESSNEW VERSIONLESSNAME)) + then (* ; "We guessed wrong about the versionless name--having actually opened the file, here's the canonical name") + (if (SETQ OLDFOLDER (\LAFITE.FIND.EXISTING.FOLDER + VERSIONLESSNEW)) + then (* ; "it turns out we already had this file open under a different full name. Close the new one and return the old") + (\LAFITE.CLOSE.FOLDER NEWFOLDER T) + (RETURN (AND (NOT (\LAFITE.CONFLICTING.OLD.FOLDER + OLDFOLDER FOLDERNAME OLDVERSION) + ) + OLDFOLDER)) + else (replace (MAILFOLDER VERSIONLESSFOLDERNAME) + of NEWFOLDER with VERSIONLESSNEW))) + (push \ACTIVELAFITEFOLDERS NEWFOLDER) + [if (NOT (CL:MEMBER SHORTNAME (CDR LAFITEMAILFOLDERS) + :TEST + 'STRING-EQUAL)) + then (* ; "This is a new folder") + (COND + ((EQMEMB :FORGET OPTIONS) + (* ; + "Don't remember it, but do set default for next Browse&Forget") + (SETQ \LAFITE.LAST.FOLDER.NAME SHORTNAME)) + (T (* ; "Add to list for menu") + (\LAFITE.NOTICE.FILE SHORTNAME] + (RETURN NEWFOLDER))) + (T (* ; + "STREAM is a condition signaled by the attempt to open the file") + (if (AND (TYPEP STREAM 'XCL:FILE-WONT-OPEN) + [SETQ OLDFOLDER + (OR (AND (SETQ NEWNAME (XCL:FILE-WONT-OPEN-PATHNAME STREAM)) + [NOT (STRING-EQUAL VERSIONLESSNAME + (SETQ VERSIONLESSNAME + (PACKFILENAME.STRING 'VERSION NIL + 'BODY NEWNAME] + (\LAFITE.FIND.EXISTING.FOLDER VERSIONLESSNAME)) + (AND (SETQ NEWNAME (INFILEP VERSIONLESSNAME)) + [NOT (STRING-EQUAL VERSIONLESSNAME + (SETQ VERSIONLESSNAME + (PACKFILENAME.STRING 'VERSION NIL + 'BODY NEWNAME] + (\LAFITE.FIND.EXISTING.FOLDER VERSIONLESSNAME] + (NOT (\LAFITE.CONFLICTING.OLD.FOLDER NEWFOLDER FOLDERNAME + OLDVERSION))) + then (* ; "Looks like file wouldn't open because we already have it open by a different name. Return that folder") + OLDFOLDER + else (* ; "Report the problem") + (\LAFITE.REPORT.FILE.WONT.OPEN PROMPTFOLDER STREAM (OR NEWNAME + FOLDERNAME)) + NIL])]) + +(\LAFITE.FIND.EXISTING.FOLDER + [LAMBDA (VERSIONLESSNAME) (* ; "Edited 22-Aug-88 17:32 by bvm") + + (* ;; "Returns an existing mail folder object whose versionless name is (case-insensitively) equal to VERSIONLESSNAME, or NIL on failure.") + + (find FOLDER in \ACTIVELAFITEFOLDERS suchthat (STRING-EQUAL (fetch (MAILFOLDER + + VERSIONLESSFOLDERNAME + ) + of FOLDER) + VERSIONLESSNAME]) + +(\LAFITE.CONFLICTING.OLD.FOLDER + [LAMBDA (NEWFOLDER FOLDERNAME OLDVERSION) (* ; "Edited 22-Aug-88 18:30 by bvm") + + (* ;; "NEWFOLDER is a folder we found somewhere during the search for FOLDERNAME. Check that it works, i.e., that it doesn't have a version number that differs from that of FOLDERNAME") + + (COND + ((NULL OLDVERSION) (* ; + "User didn't ask for a specific version, so this folder is fine") + NIL) + ((OR (fetch (MAILFOLDER BROWSERWINDOW) of NEWFOLDER) + (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of NEWFOLDER)) + (printout PROMPTWINDOW T "A different version of " FOLDERNAME " is already being browsed." + "Multiple versions may not be manipulated at once.") + T) + (T (* ; + "Not being browsed, so kill it and pretend it never existed") + (\LAFITE.CLOSE.FOLDER NEWFOLDER T) + (SETQ \ACTIVELAFITEFOLDERS (DREMOVE NEWFOLDER \ACTIVELAFITEFOLDERS)) + NIL]) + +(LAB.REPAINTFN + [LAMBDA (WINDOW REGION) (* ; "Edited 28-Apr-89 16:00 by bvm") + (LET [(FOLDER (WINDOWPROP WINDOW 'MAILFOLDER] + (AND (NEQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) + 0) + (fetch (MAILFOLDER BROWSERREADY) of FOLDER) + (RESETLST + (COND + ((OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) + T T) + (LAB.DISPLAYLINES FOLDER NIL NIL REGION)) + (T (MAILFOLDERBUSY FOLDER))))]) + +(LAB.SCROLLFN + [LAMBDA (WINDOW DX DY CONTINUOUSFLG) (* bvm%: " 3-Jan-84 14:53") + +(* ;;; "only scroll if can get the monitor lock") + + (RESETLST + [PROG [(MAILFOLDER (WINDOWPROP WINDOW 'MAILFOLDER] + (COND + ((AND (fetch (MAILFOLDER BROWSERREADY) of MAILFOLDER) + (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + T T)) + (SCROLLBYREPAINTFN WINDOW DX DY CONTINUOUSFLG)) + (T (MAILFOLDERBUSY MAILFOLDER])]) + +(LAB.RESHAPEFN + [LAMBDA (WINDOW OLDIMAGEBM OLDREGION) (* ; "Edited 28-Apr-89 15:57 by bvm") + (RESETLST + (PROG ((FOLDER (WINDOWPROP WINDOW 'MAILFOLDER)) + (REGION (DSPCLIPPINGREGION NIL WINDOW)) + MSG#) + [COND + ((NOT (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) + T T)) (* ; + "Folder is busy, have to wait until it is ready. But don't tie up mouse!") + (ALLOW.BUTTON.EVENTS) + (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) + NIL T)) + ((NOT (fetch (MAILFOLDER BROWSERREADY) of FOLDER)) + (* ; "Browser not functional") + (RETURN (RESHAPEBYREPAINTFN WINDOW OLDIMAGEBM OLDREGION] + (SETQ MSG# (FIRSTVISIBLEMESSAGE FOLDER REGION)) + (LAB.SETUP FOLDER) + (WYOFFSET (ITIMES (SUB1 MSG#) + (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER)) + WINDOW) + (LAB.DISPLAYLINES FOLDER MSG# NIL REGION)))]) + +(LAB.CLOSEFN + [LAMBDA (BROWSERWINDOW) (* ; "Edited 15-Sep-87 17:56 by bvm:") + (LAB.CLOSE/SHRINK BROWSERWINDOW :CLOSE]) + +(LAB.SHRINKFN + [LAMBDA (WINDOW) (* ; "Edited 15-Sep-87 17:56 by bvm:") + (LAB.CLOSE/SHRINK WINDOW :SHRINK]) + +(LAB.CLOSE/SHRINK + [LAMBDA (BROWSERWINDOW FLG) (* ; "Edited 7-Jun-88 14:42 by bvm") + + (* ;; "Called from CLOSEFN or SHRINKFN of BROWSERWINDOW with FLG = :CLOSE or :SHRINK. Before doing anything, let user update file.") + + (RESETLST + [LET ((MAILFOLDER (WINDOWPROP BROWSERWINDOW 'MAILFOLDER)) + HOW?) + (COND + [(OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + T T) + (AND (OPENWP BROWSERWINDOW) + (CLEARW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of MAILFOLDER))) + (SELECTQ [SETQ HOW? (COND + ((AND (fetch (MAILFOLDER BROWSERREADY) of MAILFOLDER) + (SETQ HOW? (LAB.CHOOSE.UPDATE.MENU MAILFOLDER FLG))) + (MENU HOW?)) + (T (FUNCTION \LAFITE.FINISH.UPDATE] + (NIL 'DON'T) + (PROGN (\LAFITE.PROCESS (LIST HOW? (KWOTE BROWSERWINDOW) + (KWOTE MAILFOLDER) + (KWOTE FLG)) + 'LAFITEUPDATE) (* ; + "Return DON'T now, for UPDATE.PROC will do it later") + 'DON'T] + (T (printout PROMPTWINDOW T "Browser is busy, can't close") + 'DON'T])]) + +(LAB.EXPANDFN + [LAMBDA (BROWSERWINDOW) (* ; "Edited 28-Apr-89 18:50 by bvm") + (LET [(FOLDER (WINDOWPROP BROWSERWINDOW 'MAILFOLDER] + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) + [LET ((FIRSTCHANGEDMSG# (fetch (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER))) + (* ; + "Restore SHRINKFN prop if necessary") + (WINDOWADDPROP BROWSERWINDOW 'SHRINKFN (FUNCTION LAB.SHRINKFN) + T) + (COND + (FIRSTCHANGEDMSG# (* ; + "Browser has changed since shrinking") + (COND + ((EQ FIRSTCHANGEDMSG# 0) (* ; "After expunge") + (LAB.DISPLAYFOLDER FOLDER)) + (T (LAB.DISPLAYLINES FOLDER FIRSTCHANGEDMSG# NIL NIL T))) + (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER + with NIL])]) + +(LAFITEEXTRABROWSERCOMMANDFN + [LAMBDA (WINDOW MAILFOLDER) (* ; "Edited 28-Jul-88 17:37 by bvm") + (PROG [(FN (MENU (.LAFITEMENU. LAFITEEXTRAMENU LAFITEEXTRAMENUITEMS] + (COND + (FN (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) + (CL:FUNCALL FN MAILFOLDER]) +) + + + +(* ; "Browser selection") + +(DEFINEQ + +(LAB.SELECTMESSAGE + [LAMBDA (WINDOW) (* ; "Edited 7-Jun-88 17:37 by bvm") + (PROG ((*MAILFOLDER* (WINDOWPROP WINDOW 'MAILFOLDER)) + *MESSAGES* *FIRST-VISIBLE* *LAST-VISIBLE* *TOC-STATE* SELECTIONREGION FIRST# LAST# SEL# + OLDSEL# CTRLDOWN OLDLASTMOUSEBUTTONS MSG LASTX LASTY MARKRIGHT) + (COND + ((EQ (fetch (MAILFOLDER %#OFMESSAGES) of *MAILFOLDER*) + 0) (* ; "Nothing to select") + (RETURN))) + (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) + (SETQ LAST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of *MAILFOLDER*)) + (SETQ FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of *MAILFOLDER*)) + (SETQ *FIRST-VISIBLE* (FIRSTVISIBLEMESSAGE *MAILFOLDER* SELECTIONREGION)) + (SETQ *LAST-VISIBLE* (LASTVISIBLEMESSAGE *MAILFOLDER* SELECTIONREGION)) + (SETQ *MESSAGES* (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of *MAILFOLDER*)) + (SETQ MARKRIGHT (fetch (MAILFOLDER ORDINALXPOS) of *MAILFOLDER*)) + + (* ;; "keep looping until all mouse buttons are up") + + [do (GETMOUSESTATE) + (COND + [[NOT (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) + (SETQ LASTY (LASTMOUSEY WINDOW] + + (* ;; "I would like to just return here and let the next window take over, but current mouse arrangement means I'll never get control back unless user lets up on mouse") + + (COND + ((NEQ *TOC-STATE* TS.IDLE) + (LA.UNDOSELECTION) + (SETQ OLDSEL#))) + (COND + ((LASTMOUSESTATE UP) + (RETURN)) + (T (BLOCK] + ((LASTMOUSESTATE UP) (* ; "Make selection permanent") + (SELECTC *TOC-STATE* + (TS.REPLACING (for MSG selectedin *MAILFOLDER* + do (replace SELECTED? of MSG with NIL)) + (replace SELECTED? of (NTHMESSAGE *MESSAGES* OLDSEL#) + with T) + (replace FIRSTSELECTEDMESSAGE of *MAILFOLDER* + with (replace LASTSELECTEDMESSAGE of + *MAILFOLDER* + with OLDSEL#))) + (TS.ADDING (LA.SELECTRANGE *MAILFOLDER* OLDSEL# OLDSEL# T)) + (TS.REMOVING (LA.DESELECTRANGE *MAILFOLDER* OLDSEL# OLDSEL#)) + (TS.EXTENDING.HI + (LA.SELECTRANGE *MAILFOLDER* (ADD1 LAST#) + OLDSEL# CTRLDOWN)) + (TS.EXTENDING.LO + (LA.SELECTRANGE *MAILFOLDER* OLDSEL# (SUB1 FIRST#) + CTRLDOWN)) + (TS.SHRINKING.HI + (LA.DESELECTRANGE *MAILFOLDER* (ADD1 OLDSEL#) + LAST#)) + (TS.SHRINKING.LO + (LA.DESELECTRANGE *MAILFOLDER* FIRST# (SUB1 OLDSEL#))) + NIL) + (RETURN)) + ((AND (>= LASTX BROWSERMARKXPOSITION) + (< LASTX MARKRIGHT)) (* ; "Inside mark region") + (COND + ((NEQ *TOC-STATE* TS.IDLE) + (LA.UNDOSELECTION) + (SETQ OLDSEL#))) + (LAB.CHANGEMARK *MAILFOLDER*)) + ((OR (NEQ (SETQ SEL# (YPOS.TO.MESSAGE# (LASTMOUSEY WINDOW) + *MAILFOLDER*)) + OLDSEL#) + (NEQ LASTMOUSEBUTTONS OLDLASTMOUSEBUTTONS)) + [COND + [(AND (SHIFTDOWNP 'CTRL) + (NOT (LASTMOUSESTATE RIGHT))) (* ; "Deselect this message") + (SELECTC *TOC-STATE* + (TS.REMOVING (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* + OLDSEL#) + 'REPLACE)) + (TS.IDLE) + (LA.UNDOSELECTION)) + (SETQ *TOC-STATE* (COND + ((fetch SELECTED? of (SETQ MSG (NTHMESSAGE + *MESSAGES* SEL# + ))) + (LA.SHOW.SELECTION *MAILFOLDER* MSG 'ERASE) + TS.REMOVING) + (T TS.IDLE] + ((LASTMOUSESTATE LEFT) (* ; + "Set (change) the selection to this single message") + (COND + ((EQ *TOC-STATE* TS.REPLACING) + (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* OLDSEL#) + 'ERASE)) + (T (LA.DECONSIDERRANGE *FIRST-VISIBLE* *LAST-VISIBLE*) + (SETQ *TOC-STATE* TS.REPLACING))) + (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* SEL#) + 'REPLACE)) + [(LASTMOUSESTATE MIDDLE) (* ; + "Add this message to the selection") + (SELECTC *TOC-STATE* + (TS.ADDING (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* + OLDSEL#) + 'ERASE)) + (TS.IDLE) + (LA.UNDOSELECTION)) + (SETQ *TOC-STATE* (COND + ([NOT (fetch SELECTED? of (SETQ MSG + (NTHMESSAGE + *MESSAGES* + SEL#] + (LA.SHOW.SELECTION *MAILFOLDER* MSG 'REPLACE) + TS.ADDING) + (T TS.IDLE] + ((LASTMOUSESTATE RIGHT) (* ; + "Extend: either up or down, or shrink a selection. This is messy") + (SELECTC *TOC-STATE* + (TS.EXTENDING.HI + (COND + ((> SEL# OLDSEL#) (* ; "Extend further") + (LA.CONSIDERRANGE (ADD1 OLDSEL#) + SEL# CTRLDOWN)) + (T (* ; "Shrinking back") + (LA.RECONSIDERRANGE (ADD1 (COND + ((> SEL# LAST#) + SEL#) + (T (SETQ *TOC-STATE* TS.IDLE + ) + LAST#))) + OLDSEL#)))) + (TS.EXTENDING.LO + [COND + ((< SEL# OLDSEL#) (* ; "Extend further") + (LA.CONSIDERRANGE SEL# (SUB1 OLDSEL#) + CTRLDOWN)) + (T (* ; "Shrinking back") + (LA.RECONSIDERRANGE OLDSEL# (SUB1 (COND + ((< SEL# FIRST#) + SEL#) + (T (SETQ *TOC-STATE* + TS.IDLE) + FIRST#]) + (TS.SHRINKING.HI + (COND + [(>= SEL# OLDSEL#) (* ; "Shrinking less") + (LA.RECONSIDERRANGE (ADD1 OLDSEL#) + (COND + ((< SEL# LAST#) + SEL#) + (T (SETQ *TOC-STATE* TS.IDLE) + LAST#] + ((>= SEL# FIRST#) (* ; "Shrinking further") + (LA.DECONSIDERRANGE (ADD1 SEL#) + OLDSEL#)) + (T (* ; "Too far to shrink") + (LA.RECONSIDERRANGE FIRST# LAST#) + (SETQ *TOC-STATE* TS.IDLE)))) + (TS.SHRINKING.LO + (COND + ((<= SEL# OLDSEL#) (* ; "Shrinking less") + (LA.RECONSIDERRANGE (COND + ((> SEL# FIRST#) + SEL#) + (T (SETQ *TOC-STATE* TS.IDLE) + FIRST#)) + (SUB1 OLDSEL#))) + ((<= SEL# LAST#) (* ; "Shrinking further") + (LA.DECONSIDERRANGE OLDSEL# (SUB1 SEL#))) + (T (* ; "Too far to shrink") + (LA.RECONSIDERRANGE FIRST# LAST#) + (SETQ *TOC-STATE* TS.IDLE)))) + (COND + ((NOT (> FIRST# LAST#)) + (COND + ((NEQ *TOC-STATE* TS.IDLE) + (LA.UNDOSELECTION))) + (SETQ CTRLDOWN (SHIFTDOWNP 'CTRL)) + (SETQ *TOC-STATE* (COND + ((> SEL# LAST#) + (LA.CONSIDERRANGE (ADD1 LAST#) + SEL# CTRLDOWN) + TS.EXTENDING.HI) + ((< SEL# FIRST#) + (LA.CONSIDERRANGE SEL# (SUB1 FIRST#) + CTRLDOWN) + TS.EXTENDING.LO) + ((> SEL# (LRSH (+ LAST# FIRST#) + 1)) + (LA.DECONSIDERRANGE (ADD1 SEL#) + LAST#) + TS.SHRINKING.HI) + (T (LA.DECONSIDERRANGE FIRST# (SUB1 SEL#)) + TS.SHRINKING.LO] + (SETQ OLDLASTMOUSEBUTTONS LASTMOUSEBUTTONS) + (SETQ OLDSEL# (AND (NEQ *TOC-STATE* TS.IDLE) + SEL#] + (COND + ((EQ LAFITEVERIFYFLG 'TOC) + (LA.VERIFY.SELECTION *MAILFOLDER*]) + +(LAB.CHANGEMARK + [LAMBDA (MAILFOLDER) (* bvm%: "17-Feb-84 15:46") + + (* ;; "Called when mouse is inside the 'mark' region of a browser. Tracks mouse while in that region and does whatever is appropriate") + + (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) + (RIGHT (fetch (MAILFOLDER ORDINALXPOS) of MAILFOLDER)) + SEL# OLDSEL# COCKED REGION X Y TOP BOTTOM) + [SETQ BOTTOM (fetch (REGION BOTTOM) of (SETQ REGION (DSPCLIPPINGREGION NIL WINDOW] + (SETQ TOP (fetch (REGION TOP) of REGION)) + (do (GETMOUSESTATE) + (COND + ((OR (< (SETQ X (LASTMOUSEX WINDOW)) + BROWSERMARKXPOSITION) + (> X RIGHT) + (< (SETQ Y (LASTMOUSEY WINDOW)) + BOTTOM) + (> Y TOP)) + (COND + (COCKED (LA.INVERT.MARK.BOX MAILFOLDER OLDSEL#))) + (RETURN)) + ((LASTMOUSESTATE UP) + (COND + (COCKED (LA.READ.NEW.MARK MAILFOLDER OLDSEL#))) + (RETURN)) + ((NEQ (SETQ SEL# (YPOS.TO.MESSAGE# Y MAILFOLDER)) + OLDSEL#) + (COND + (COCKED (LA.INVERT.MARK.BOX MAILFOLDER OLDSEL#)) + (T (SETQ COCKED T))) + (LA.INVERT.MARK.BOX MAILFOLDER (SETQ OLDSEL# SEL#]) + +(LA.READ.NEW.MARK + [LAMBDA (FOLDER MSG#) (* ; "Edited 25-Apr-89 17:55 by bvm") + (PROG ((MSG (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) + MSG#)) + (WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) + YPOS MARK) + (RESETSAVE NIL (LIST (FUNCTION CLEARW) + (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER))) + (RESETSAVE NIL (LIST (FUNCTION LA.SHOW.MARK) + MSG FOLDER)) (* ; + "Display correct mark on exit no matter what happens") + (RESETSAVE (TTYDISPLAYSTREAM WINDOW)) (* ; + "So caret flashes in the right place") + (RESETSAVE NIL (LIST 'WINDOWPROP WINDOW 'PROCESS NIL)) + + (* ;; "PROCESS prop put there by TTYDISPLAYSTREAM -- don't want it to linger, else MOUSE proc will get tty in future when we bug browser") + + (LA.BLT.MARK.BOX FOLDER WINDOW (SETQ YPOS (MESSAGE#.TO.YPOS MSG FOLDER)) + 'REPLACE WHITESHADE) (* ; "Erase whatever's there") + (LAB.PROMPTPRINT FOLDER T "Type single character mark, or ESC to abort") + (MOVETO BROWSERMARKXPOSITION YPOS WINDOW) + (COND + ((AND (>= (SETQ MARK (\GETKEY)) + (CHARCODE SPACE)) + (<= MARK (CHARCODE DEL))) + (LAB.MARKS.CHANGED MSG FOLDER) + (replace (LAFITEMSG SEEN?) of MSG with (NOT (UNSEENMARKP MARK))) + (replace (LAFITEMSG MARKCHAR) of MSG with MARK]) + +(YPOS.TO.MESSAGE# + [LAMBDA (YPOS MAILFOLDER) (* bvm%: "24-Dec-83 17:45") + (PROG [(N (IQUOTIENT (IPLUS (IDIFFERENCE (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) + YPOS) + (fetch (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER)) + (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER] + (RETURN (COND + ((ILEQ N 0) + 1) + (T (IMIN N (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER]) + +(MESSAGE#.TO.YPOS + [LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* bvm%: "24-Dec-83 16:37") + (IDIFFERENCE (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) + (ITIMES (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER) + (fetch (LAFITEMSG %#) of MSGDESCRIPTOR]) +) +(DEFINEQ + +(LA.CONSIDERRANGE + [LAMBDA (FIRST# LAST# EVENIFDELETED) (* ; "Edited 7-Jun-88 17:34 by bvm") + +(* ;;; "Change display so that messages from FIRST# to LAST# are marked as selected. Deleted messages are not selected unless EVENIFDELETED is true") + + (for I from (IMAX FIRST# *FIRST-VISIBLE*) to (IMIN LAST# *LAST-VISIBLE*) bind + MSG + do (SETQ MSG (NTHMESSAGE *MESSAGES* I)) + (COND + ((OR EVENIFDELETED (NOT (fetch DELETED? of MSG))) + (LA.SHOW.SELECTION *MAILFOLDER* MSG 'REPLACE]) + +(LA.DECONSIDERRANGE + [LAMBDA (FIRST# LAST#) (* ; "Edited 7-Jun-88 17:35 by bvm") + +(* ;;; "Change display so that messages from FIRST# to LAST# are marked as unselected.") + + (for I from (IMAX FIRST# *FIRST-VISIBLE*) to (IMIN LAST# *LAST-VISIBLE*) + do (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* I) + 'ERASE]) + +(LA.RECONSIDERRANGE + [LAMBDA (FIRST# LAST#) (* ; "Edited 7-Jun-88 17:35 by bvm") + +(* ;;; "Change display so that messages from FIRST# to LAST# are marked as selected or unselected according to the truth of the matter.") + + (for I from (IMAX FIRST# *FIRST-VISIBLE*) to (IMIN LAST# *LAST-VISIBLE*) bind + MSG + do (LA.SHOW.SELECTION *MAILFOLDER* (SETQ MSG (NTHMESSAGE *MESSAGES* I)) + (COND + ((fetch SELECTED? of MSG) + 'REPLACE) + (T 'ERASE]) + +(LA.SELECTRANGE + [LAMBDA (MAILFOLDER FIRST# LAST# EVENIFDELETED) (* bvm%: "15-Feb-84 15:39") + +(* ;;; "Mark internally messages FIRST# thru LAST# as selected. Do not select deleted messages unless EVENIFDELETED is true. Keeps MAILFOLDER:LASTSELECTEDMESSAGE and MAILFOLDER:FIRSTSELECTEDMESSAGE up to date. Assumes display has already been appropriately modified") + + (PROG ((MESSAGES (fetch MESSAGEDESCRIPTORS of MAILFOLDER)) + (FIRSTSEL (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER)) + (LASTSEL (fetch LASTSELECTEDMESSAGE of MAILFOLDER)) + MSG) + [for I from FIRST# to LAST# + do (SETQ MSG (NTHMESSAGE MESSAGES I)) + (COND + ((OR EVENIFDELETED (NOT (fetch DELETED? of MSG))) + (replace SELECTED? of MSG with T] + (COND + ((OR (> FIRSTSEL LASTSEL) + (< FIRST# (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER))) + (replace FIRSTSELECTEDMESSAGE of MAILFOLDER with FIRST#))) + (COND + ((OR (> FIRSTSEL LASTSEL) + (> LAST# (fetch LASTSELECTEDMESSAGE of MAILFOLDER))) + (replace LASTSELECTEDMESSAGE of MAILFOLDER with LAST#]) + +(LA.DESELECTRANGE + [LAMBDA (MAILFOLDER FIRST# LAST#) (* bvm%: "28-Mar-84 14:52") + +(* ;;; "Mark internally messages FIRST# thru LAST# as unselected. Keeps MAILFOLDER:LASTSELECTEDMESSAGE and MAILFOLDER:FIRSTSELECTEDMESSAGE up to date. Assumes display has already been appropriately modified") + + (COND + ((ILEQ FIRST# LAST#) + (PROG ((MESSAGES (fetch MESSAGEDESCRIPTORS of MAILFOLDER))) + (for I from FIRST# to LAST# do (replace SELECTED? + of (NTHMESSAGE MESSAGES I) + with NIL)) + (COND + [(EQ FIRST# (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER)) + (replace FIRSTSELECTEDMESSAGE of MAILFOLDER + with (COND + ((LAB.FIND.SELECTED.MSG MAILFOLDER (ADD1 LAST#) + (fetch LASTSELECTEDMESSAGE of MAILFOLDER))) + (T (replace LASTSELECTEDMESSAGE of MAILFOLDER with + 0) + (* ; + "Null selection indicated by first GT last.") + (ADD1 (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER] + ((EQ LAST# (fetch LASTSELECTEDMESSAGE of MAILFOLDER)) + (replace LASTSELECTEDMESSAGE of MAILFOLDER + with (OR (LAB.REV.FIND.SELECTED.MSG MAILFOLDER (fetch + FIRSTSELECTEDMESSAGE + of MAILFOLDER) + (SUB1 FIRST#)) + 1]) + +(LAB.FIND.SELECTED.MSG + [LAMBDA (MAILFOLDER FIRST# LAST#) (* bvm%: "15-Feb-84 12:22") + (find I from FIRST# to LAST# bind (MESSAGES _ (fetch MESSAGEDESCRIPTORS + of MAILFOLDER)) + suchthat (fetch SELECTED? of (NTHMESSAGE MESSAGES I]) + +(LAB.REV.FIND.SELECTED.MSG + [LAMBDA (MAILFOLDER FIRST# LAST#) (* bvm%: " 2-Mar-84 18:02") + (find I from LAST# to FIRST# by -1 bind (MESSAGES _ (fetch + MESSAGEDESCRIPTORS + of MAILFOLDER)) + suchthat (fetch SELECTED? of (NTHMESSAGE MESSAGES I]) + +(LA.UNDOSELECTION + [LAMBDA NIL (* ; "Edited 7-Jun-88 17:37 by bvm") + +(* ;;; "Restore browser to state before any selections were attempted") + + (LA.RECONSIDERRANGE *FIRST-VISIBLE* *LAST-VISIBLE*) + (SETQ *TOC-STATE* TS.IDLE]) + +(LA.VERIFY.SELECTION + [LAMBDA (MAILFOLDER) (* bvm%: "15-Feb-84 11:53") + (PROG ((FIRST# (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER)) + (LAST# (fetch LASTSELECTEDMESSAGE of MAILFOLDER)) + (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) + (%#OFMESSAGES (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) + SEL) + (COND + [(IGREATERP FIRST# LAST#) + (COND + ([SETQ SEL (for I from 1 to %#OFMESSAGES collect I + when (fetch SELECTED? of (NTHMESSAGE MESSAGES I] + (HELP "First > Last, but these msgs selected" SEL] + (T [for I from 1 to %#OFMESSAGES do (COND + ((fetch SELECTED? + of (NTHMESSAGE MESSAGES I + )) + (COND + ((< I FIRST#) + (HELP "First is too high" + FIRST#)) + ((> I LAST#) + (HELP "Last is too low" + LAST#] + (COND + ((AND (EQ FIRST# 1) + (EQ LAST# 1)) (* ; + "The only time it is okay for them not to be selected") + ) + ((NOT (fetch SELECTED? of (NTHMESSAGE MESSAGES FIRST#))) + (HELP "First not selected" FIRST#)) + ((NOT (fetch SELECTED? of (NTHMESSAGE MESSAGES LAST#))) + (HELP "Last not selected" LAST#]) +) +(DEFINEQ + +(LAB.COPYBUTTONEVENTFN + [LAMBDA (WINDOW) (* ; "Edited 11-Dec-87 17:17 by bvm:") + +(* ;;; "copy select an item from the window.") + + (PROG ((FOLDER (WINDOWPROP WINDOW 'MAILFOLDER)) + SELECTIONREGION CURRENTITEM CURRENTMSG CURRENTFIELD NEWITEM NEWFIELD LASTX LASTY DATEX + FROMX SUBJECTX MSGS) + [COND + ((EQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) + 0) (* ; "Nothing to select") + (RETURN (TOTOPW WINDOW] + (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) + (SETQ DATEX (fetch (MAILFOLDER DATEXPOS) of FOLDER)) + (SETQ FROMX (fetch (MAILFOLDER FROMXPOS) of FOLDER)) + (SETQ SUBJECTX (fetch (MAILFOLDER SUBJECTXPOS) of FOLDER)) + (SETQ MSGS (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) + LP (TOTOPW WINDOW) + (SETQ NEWITEM (AND (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) + (SETQ LASTY (LASTMOUSEY WINDOW))) + (YPOS.TO.MESSAGE# LASTY FOLDER))) + (SETQ NEWFIELD (if (< LASTX DATEX) + then T + elseif (< LASTX FROMX) + then 'DATE + elseif (< LASTX SUBJECTX) + then 'FROM + else 'SUBJECT)) (* ; + "Figure out which field of the message is being pointed at by the xpos.") + [COND + ((OR (NEQ CURRENTITEM NEWITEM) + (NEQ CURRENTFIELD NEWFIELD)) (* ; "Something changed") + (COND + (CURRENTITEM (* ; "turn off old selection.") + (LAB.SHOW.COPY.SELECTION WINDOW FOLDER CURRENTMSG CURRENTFIELD))) + (COND + ((SETQ CURRENTITEM NEWITEM) (* ; "turn on new selection") + (LAB.SHOW.COPY.SELECTION WINDOW FOLDER (SETQ CURRENTMSG (NTHMESSAGE MSGS + CURRENTITEM)) + (SETQ CURRENTFIELD NEWFIELD] + LP2 + + (* ;; "wait for a button up or move out of region") + + (BLOCK) + (COND + ((NOT (.COPYKEYDOWNP.)) (* ; "Finished, copy selected item") + [COND + (CURRENTITEM (* ; + "If something is selected, bksysbuf the selected field") + (LAB.SHOW.COPY.SELECTION WINDOW FOLDER CURRENTMSG CURRENTFIELD) + (BKSYSBUF (OR (SELECTQ CURRENTFIELD + (T (* ; "Do whole line") + (CONCAT "#" (fetch (LAFITEMSG %#) of CURRENTMSG) + " " + (fetch (LAFITEMSG DATE) of CURRENTMSG) + " " + [COND + ((fetch (LAFITEMSG MSGFROMMEP) of CURRENTMSG + ) + (CONCAT "To: " (fetch (LAFITEMSG TO) + of CURRENTMSG))) + (T (CONCAT "From: " (OR (fetch (LAFITEMSG FROM) + of CURRENTMSG) + UNSUPPLIEDFIELDSTR] + " -- " + (OR (fetch (LAFITEMSG SUBJECT) of CURRENTMSG) + UNSUPPLIEDFIELDSTR))) + (DATE (fetch (LAFITEMSG DATE) of CURRENTMSG)) + (FROM (COND + ((fetch (LAFITEMSG MSGFROMMEP) of CURRENTMSG) + (CONCAT "To: " (fetch (LAFITEMSG TO) of + CURRENTMSG + ))) + (T (fetch (LAFITEMSG FROM) of CURRENTMSG)))) + (fetch (LAFITEMSG SUBJECT) of CURRENTMSG)) + UNSUPPLIEDFIELDSTR] + (RETURN)) + ((MOUSESTATE UP) (* ; + "button up, but shift still down, no action") + (GO LP2)) + (T (GO LP]) + +(LAB.SHOW.COPY.SELECTION + [LAMBDA (WINDOW FOLDER MSG FIELD) (* ; "Edited 11-Dec-87 17:16 by bvm:") + +(* ;;; "underline FIELD of MSG in FOLDER's window") + + (LET ((BOTTOM (- (MESSAGE#.TO.YPOS MSG FOLDER) + (fetch (MAILFOLDER BROWSERFONTDESCENT) of FOLDER))) + LEFT STR) + [SELECTQ FIELD + (T (* ; "Whole line")) + (DATE (SETQ LEFT (fetch (MAILFOLDER DATEXPOS) of FOLDER)) + (SETQ STR (fetch (LAFITEMSG DATE) of MSG))) + (FROM (SETQ LEFT (fetch (MAILFOLDER FROMXPOS) of FOLDER)) + [SETQ STR (COND + ((fetch (LAFITEMSG MSGFROMMEP) of MSG) + (CONCAT "To: " (fetch (LAFITEMSG TO) of MSG))) + (T (fetch (LAFITEMSG FROM) of MSG]) + (PROGN (SETQ LEFT (fetch (MAILFOLDER SUBJECTXPOS) of FOLDER)) + (SETQ STR (fetch (LAFITEMSG SUBJECT) of MSG] + (BLTSHADE GRAYSHADE WINDOW LEFT BOTTOM (if (EQ FIELD T) + then (* ; "whole line") + NIL + else (* ; "width of just this field") + (STRINGWIDTH (OR STR UNSUPPLIEDFIELDSTR) + WINDOW)) + 2 + 'INVERT]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(CL:PROCLAIM '(CL:SPECIAL *MAILFOLDER* *MESSAGES* *FIRST-VISIBLE* *LAST-VISIBLE* *TOC-STATE*)) + +(CL:PROCLAIM '(GLOBAL LASTMOUSEBUTTONS)) +) + + + +(* ; "Browser display") + +(DEFINEQ + +(LAB.PROMPTPRINT + (CL:LAMBDA (FOLDER &REST ARGS) (* ; "Edited 14-Oct-87 15:36 by bvm:") + (LAB.PRINT.TO.PROMPTWINDOW FOLDER ARGS))) + +(LAB.FORMAT + (CL:LAMBDA (FOLDER &REST ARGS) (* ; "Edited 14-Oct-87 15:53 by bvm:") + + (* ;; "Outputs to FOLDER's prompt window using FORMAT. If first format arg is T, then we clear the window first, and consider then next format arg to be the format string. All this is done in a way that lets the window expand if it needs to.") + + (LAB.PRINT.TO.PROMPTWINDOW FOLDER ARGS T))) + +(LAB.MOUSECONFIRM + [CL:LAMBDA (FOLDER &REST ARGS) (* ; "Edited 11-Dec-87 17:33 by bvm:") + + (* ;; "Version of MOUSECONFIRM using FOLDER's prompt window. ARGS are args to FORMAT.") + + (LAB.PRINT.TO.PROMPTWINDOW FOLDER ARGS T) + (PROG1 (MOUSECONFIRM T T) + (if FOLDER + then (\LAFITE.MAYBE.CLEAR.PROMPT FOLDER) + else (CLEARW PROMPTWINDOW)))]) + +(LAB.PRINT.TO.PROMPTWINDOW + [LAMBDA (FOLDER ARGS FORMAT-P) (* ; "Edited 14-Oct-87 19:01 by bvm:") + + (* ;; "Outputs to FOLDER's prompt window the text in ARGS. If FORMAT-P is NIL, ARGS is a list of items to print, with T meaning clear the window. If FORMAT-P is true, ARGS is considered a format string and format args, except that ARGS may be prefixed with T to indicate clearing the window. All this is done in a way that lets the window expand if it needs to. If FOLDER is NIL, or its browser is not open, prints to global PROMPTWINDOW. Returns NIL.") + + (LET ((*PRINT-CASE* :UPCASE) + (*PRINT-BASE* 10) + [WINDOW (AND FOLDER (OPENWP (ffetch (MAILFOLDER BROWSERPROMPTWINDOW) + of (\DTEST FOLDER 'MAILFOLDER] + \CURRENTDISPLAYLINE OLDTTY) + + (* ;; "*PRINT-CASE* is bound so symbols get printed in %"expected%" case. *PRINT-BASE* is 10 for benefit of printing numbers in the non-format case. \currentdisplayline changes with TTYDISPLAYSTREAM") + + (CL:UNWIND-PROTECT + [LET ((ACTUALWINDOW (OR WINDOW PROMPTWINDOW))) + (if WINDOW + then (SETQ OLDTTY (TTYDISPLAYSTREAM WINDOW)) + (SETQ \CURRENTDISPLAYLINE (fetch (MAILFOLDER CURRENTPROMPTLINE) + of FOLDER)) + (* ; + "Do this second because TTYDISPLAYSTREAM smashes it.") + ) + (if FORMAT-P + then (if (EQ (CAR ARGS) + T) + then (* ; + "First arg of T means clear window first.") + (CLEARW ACTUALWINDOW) + (SETQ ARGS (CDR ARGS))) + (CL:APPLY (FUNCTION CL:FORMAT) + ACTUALWINDOW ARGS) + else (for ARG in ARGS do (COND + ((EQ ARG T) + (CLEARW ACTUALWINDOW)) + (T (PRIN3 ARG ACTUALWINDOW] + (if WINDOW + then + + (* ;; "Now clean up the mess. Note position for next time.") + + (replace (MAILFOLDER CURRENTPROMPTLINE) of FOLDER with + \CURRENTDISPLAYLINE + ) + (TTYDISPLAYSTREAM OLDTTY) + (WINDOWPROP WINDOW 'PROCESS NIL) (* ; "Get rid of process handle") + (replace (MAILFOLDER BROWSERPROMPTDIRTY) of FOLDER with T))) + NIL]) + +(LAB.PAGEFULLFN + [LAMBDA (PW) (* ; "Edited 14-Oct-87 16:54 by bvm:") + + (* ;; + "PAGEFULLFN for prompt window--makes the window a line bigger and allows output to proceed") + + (SETQ \CURRENTDISPLAYLINE (PROG1 \#DISPLAYLINES (* ; + "\Currentdisplayline is the line we're on when window fills, origin zero") + (LET ((MAIN (MAINWINDOW PW)) + FOLDER) + (GETPROMPTWINDOW MAIN (+ 1 \#DISPLAYLINES)) + (if (SETQ FOLDER (WINDOWPROP MAIN 'MAILFOLDER)) + then (* ; + "Note that we expanded window so that we can shrink it back later") + (replace (MAILFOLDER BROWSERPROMPTGREW) + of FOLDER with T))))]) + +(\LAFITE.MAYBE.CLEAR.PROMPT + [LAMBDA (FOLDER) (* ; "Edited 14-Oct-87 15:35 by bvm:") + + (* ;; "Clear's FOLDER's prompt window, and shrinks it back to a single line if it has grown") + + (LET (PW) + (COND + ([AND (fetch (MAILFOLDER BROWSERPROMPTDIRTY) of FOLDER) + (OPENWP (SETQ PW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER] + (CLEARW PW) + (if (fetch (MAILFOLDER BROWSERPROMPTGREW) of FOLDER) + then (* ; "Window grew") + (LET (PROP HEIGHT) + [SETQ HEIGHT (HEIGHTIFWINDOW (FONTPROP LAFITEBROWSERFONT 'HEIGHT] + (WINDOWPROP PW 'MINSIZE (CONS 0 HEIGHT)) + (* ; + "have to adjust the fixed size of the window before shaping, since SHAPEW obeys the minimum.") + (WINDOWPROP PW 'MAXSIZE (CONS 64000 HEIGHT)) + (SHAPEW PW (create REGION using (WINDOWPROP PW 'REGION) + HEIGHT _ HEIGHT)) + (CLEARW PW) (* ; + "Clear it again to get coordinates right.") + (if (SETQ PROP (WINDOWPROP (fetch (MAILFOLDER BROWSERWINDOW) + of FOLDER) + 'PROMPTWINDOW)) + then (* ; + "Main window thinks it knows how tall the prompt window is.") + (RPLACD PROP 1)) + (replace (MAILFOLDER BROWSERPROMPTGREW) of FOLDER with NIL) + (replace (MAILFOLDER CURRENTPROMPTLINE) of FOLDER with 0))) + (replace (MAILFOLDER BROWSERPROMPTDIRTY) of FOLDER with NIL]) +) + +(PUTPROPS LAB.PROMPTPRINT ARGNAMES (NIL (FOLDER &REST ARGS))) + +(PUTPROPS LAB.FORMAT ARGNAMES (NIL (FOLDER &REST ARGS))) + +(PUTPROPS LAB.MOUSECONFIRM ARGNAMES (NIL (FOLDER FORMAT-STRING &REST ARGS))) +(DEFINEQ + +(PRINTMESSAGESUMMARY + [LAMBDA (MSG FOLDER WINDOW) (* ; "Edited 5-May-89 12:15 by bvm") + (PROG ((*PRINT-BASE* 10) + (DIGITWIDTH (fetch (MAILFOLDER BROWSERDIGITWIDTH) of FOLDER)) + FROMSTR HERE THERE EXTENT MSG#) + (OR (fetch (LAFITEMSG PARSED?) of MSG) + (LAFITE.PARSE.MSG.FOR.TOC MSG FOLDER)) + (MOVETO 0 (MESSAGE#.TO.YPOS MSG FOLDER) + WINDOW) + (POSITION WINDOW 0) + (LA.SHOW.MARK MSG FOLDER) + (DSPXPOSITION [+ (fetch (MAILFOLDER ORDINALXPOS) of FOLDER) + (TIMES DIGITWIDTH (COND + ((< (SETQ MSG# (fetch (LAFITEMSG %#) of + MSG)) + 10) + 3) + ((< MSG# 100) + 2) + ((< MSG# 1000) + 1) + (T 0] + WINDOW) (* ; + "Ugh. Manually right-justify message # given that font may be variable width") + (PRIN3 MSG# WINDOW) + (LET ((DATE (OR (fetch (LAFITEMSG DATE) of MSG) + [if (fetch (LAFITEMSG DATEKNOWN?) of MSG) + then (* ; "Convert idate to date") + (replace (LAFITEMSG DATE) of MSG + with (GDATE1-6 (fetch (LAFITEMSG IDATE) of MSG] + UNSUPPLIEDFIELDSTR))) + (DSPXPOSITION (+ (fetch (MAILFOLDER DATEXPOS) of FOLDER) + (if (DIGITCHARP (NTHCHARCODE DATE 2)) + then 0 + else (* ; + "for 1-digit day, try to get the digits to line up") + DIGITWIDTH)) + WINDOW) + (PRIN3 DATE WINDOW)) + (DSPXPOSITION (fetch (MAILFOLDER FROMXPOS) of FOLDER) + WINDOW) + [COND + [(fetch (LAFITEMSG MSGFROMMEP) of MSG) + (PRIN3 "To: " WINDOW) + (SETQ FROMSTR (OR (fetch (LAFITEMSG TO) of MSG) + (LAFITE.FETCH.TO.FIELD MSG FOLDER] + (T (SETQ FROMSTR (OR (fetch (LAFITEMSG FROM) of MSG) + UNSUPPLIEDFIELDSTR] + + (* ;; "PRINTMESSAGESUMMARY.STRING defaults to PRIN3, redefined to deal with multiple character sets if MIME is loaded.") + + (PRINTMESSAGESUMMARY.STRING FROMSTR WINDOW) + (COND + ((> (SETQ HERE (DSPXPOSITION NIL WINDOW)) + (SETQ THERE (fetch (MAILFOLDER FROMMAXXPOS) of FOLDER))) + (* ; "Erase the overflow") + (DSPBACKUP (- HERE THERE) + WINDOW))) + (DSPXPOSITION (fetch (MAILFOLDER SUBJECTXPOS) of FOLDER) + WINDOW) + (PRINTMESSAGESUMMARY.STRING (OR (fetch (LAFITEMSG SUBJECT) of MSG) + UNSUPPLIEDFIELDSTR) + WINDOW) + (PRIN3 " [" WINDOW) + (PRIN3 (fetch (LAFITEMSG MESSAGELENGTH) of MSG) + WINDOW) + (PRIN3 " chars]" WINDOW) + + (* ;; "keep track of maximum width printed to. If header is allowed to print on two lines, $$MAXWIDTH$$ was set to right margin by BUILDBROWSERMAP so this should not reset it.") + + (COND + ((< (fetch (MAILFOLDER BROWSERMAXXPOS) of FOLDER) + (SETQ HERE (DSPXPOSITION NIL WINDOW))) + (replace (MAILFOLDER BROWSERMAXXPOS) of FOLDER with HERE) + (replace (REGION WIDTH) of (SETQ EXTENT (fetch (MAILFOLDER BROWSEREXTENT) + of FOLDER)) with HERE) + (WINDOWPROP WINDOW 'EXTENT EXTENT))) + [COND + ((fetch (LAFITEMSG SELECTED?) of MSG) + (LA.SHOW.SELECTION FOLDER MSG 'REPLACE] + (COND + ((fetch (LAFITEMSG DELETED?) of MSG) + (LA.SHOW.DELETION FOLDER MSG WINDOW 'REPLACE]) + +(FIRSTVISIBLEMESSAGE + [LAMBDA (MAILFOLDER REGION) (* bvm%: "25-Feb-86 12:22") + + (* ;; "Computes number of the first message in MAILFOLDER that is visible in REGION") + + (IMAX 1 (IQUOTIENT (- (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) + (+ [fetch (REGION TOP) of (OR REGION (DSPCLIPPINGREGION + NIL + (fetch (MAILFOLDER + BROWSERWINDOW + ) + of MAILFOLDER] + (fetch (MAILFOLDER BROWSERFONTDESCENT) of MAILFOLDER))) + (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER]) + +(LASTVISIBLEMESSAGE + [LAMBDA (MAILFOLDER REGION) (* bvm%: "25-Feb-86 11:33") + + (* ;; "Computes number of the last message in MAILFOLDER that is visible in REGION") + + (IMIN (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) + (IQUOTIENT (+ (- (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) + (- [fetch (REGION BOTTOM) of (OR REGION (DSPCLIPPINGREGION + NIL + (fetch (MAILFOLDER + BROWSERWINDOW + ) + of MAILFOLDER] + (fetch (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER))) + (SUB1 (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER))) + (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER]) + +(LAB.DISPLAYLINES + [LAMBDA (FOLDER FIRST# LAST# REGION CLEAR) (* ; "Edited 28-Apr-89 18:48 by bvm") + + (* ;; "Display toc line for messages FIRST# thru LAST# (default to extreme). If REGION is given, only display messages visible in the region (default is the browser window's clipping region). If CLEAR is true, clear the region first (otherwise, caller has cleared it).") + + (LET* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) + (REG (OR REGION (DSPCLIPPINGREGION NIL WINDOW))) + (MIN# (FIRSTVISIBLEMESSAGE FOLDER REGION)) + (MAX# (LASTVISIBLEMESSAGE FOLDER REGION)) + (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER))) + (if (AND FIRST# (> FIRST# MIN#)) + then (SETQ MIN# FIRST#)) + (if (AND LAST# (< LAST# MAX#)) + then (SETQ MAX# LAST#)) + (if CLEAR + then (DSPFILL [LET ((LINEHEIGHT (fetch (MAILFOLDER BROWSERFONTHEIGHT) + of FOLDER))) + (create REGION + LEFT _ 0 + BOTTOM _ (- (fetch (MAILFOLDER BROWSERORIGIN) + of FOLDER) + (fetch (MAILFOLDER BROWSERFONTDESCENT) + of FOLDER) + (TIMES LINEHEIGHT MAX#)) + WIDTH _ MAX.SMALLP + HEIGHT _ (TIMES LINEHEIGHT (ADD1 (- MAX# MIN#] + WHITESHADE + 'REPLACE WINDOW)) + (for MSG# from MIN# to MAX# do (PRINTMESSAGESUMMARY (NTHMESSAGE + MESSAGES + MSG#) + FOLDER WINDOW]) + +(LAB.EXPOSEMESSAGE + [LAMBDA (MAILFOLDER MSGDESCRIPTOR) (* bvm%: "24-Dec-83 19:00") + (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) + (YPOS (MESSAGE#.TO.YPOS MSGDESCRIPTOR MAILFOLDER)) + CLIPREGION) + (COND + ((OR (IGREATERP (fetch (REGION BOTTOM) of (SETQ CLIPREGION (DSPCLIPPINGREGION + NIL WINDOW))) + YPOS) + (ILESSP (fetch (REGION TOP) of CLIPREGION) + YPOS)) + (SCROLLBYREPAINTFN WINDOW 0 (IPLUS (fetch (REGION BOTTOM) of CLIPREGION) + (IQUOTIENT (fetch (REGION HEIGHT) of + CLIPREGION + ) + 2) + (IMINUS YPOS]) + +(LAB.SELECTED.MESSAGES + [LAMBDA (FOLDER) (* ; "Edited 14-Oct-87 16:15 by bvm:") + + (* ;; "Return a list of message descriptors currently selected") + + (for MSG selectedin FOLDER collect MSG]) + +(UNSELECTALLMESSAGES + [LAMBDA (MAILFOLDER) (* bvm%: "15-Feb-84 16:21") + (for N from (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER) + to (fetch LASTSELECTEDMESSAGE of MAILFOLDER) + bind (MESSAGES _ (fetch MESSAGEDESCRIPTORS of MAILFOLDER)) + do (LA.DESELECTRANGE MAILFOLDER N N) + (LA.SHOW.SELECTION MAILFOLDER (NTHMESSAGE MESSAGES N) + 'ERASE]) + +(SELECTMESSAGE + [LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* bvm%: "15-Feb-84 12:34") + (PROG ((N (fetch (LAFITEMSG %#) of MSGDESCRIPTOR))) + (LA.SELECTRANGE MAILFOLDER N N T) + (LA.SHOW.SELECTION MAILFOLDER MSGDESCRIPTOR 'REPLACE]) + +(LAB.GO.TO.MESSAGE + [LAMBDA (FOLDER N) (* ; "Edited 23-Aug-88 18:14 by bvm") + + (* ;; "Jump to nth message in folder. N must be in range, or be a msg object in the folder. Returns the message object") + + (LET [(MSG (if (type? LAFITEMSG N) + then N + else (\DTEST (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of + FOLDER) + N) + 'LAFITEMSG] + (UNSELECTALLMESSAGES FOLDER) + (LAB.EXPOSEMESSAGE FOLDER MSG) + (LA.SHOW.SELECTION FOLDER MSG 'REPLACE) + (replace (LAFITEMSG SELECTED?) of MSG with T) + (replace FIRSTSELECTEDMESSAGE of FOLDER with (replace LASTSELECTEDMESSAGE + of FOLDER + with (fetch (LAFITEMSG + %#) + of MSG))) + MSG]) + +(MARKMESSAGE + [LAMBDA (MSG FOLDER MARK) (* ; "Edited 25-Apr-89 17:54 by bvm") + +(* ;;; +"Changes the mark byte of MSGDESCRIPTOR to be MARK. This may also imply something about SEEN?") + + (replace (LAFITEMSG MARKCHAR) of MSG with MARK) + (replace (LAFITEMSG SEEN?) of MSG with (NOT (UNSEENMARKP MARK))) + (LAB.MARKS.CHANGED MSG FOLDER) + (COND + ((OPENWP (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) + (LA.SHOW.MARK MSG FOLDER)) + (T (* ; + "Wait until browser expanded before showing mark update") + (PROG ((N (fetch (LAFITEMSG %#) of MSG)) + (OLDU (fetch (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER))) + (COND + ((OR (NULL OLDU) + (> OLDU N)) + (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER with N]) + +(LAB.MARKS.CHANGED + [LAMBDA (MSG FOLDER) (* ; "Edited 21-Jun-99 22:42 by rmk:") + + (* ;; + "Call this whenever you change one of the 3 mark bytes (seen, deleted, mark) of a message.") + + (LET ((N (fetch (LAFITEMSG %#) of MSG))) + (if (< N (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER)) + then (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER with N))) + (replace (LAFITEMSG MARKSCHANGED?) of MSG with T) + + (* ;; + "rmk: MARKSCHANGEDINTOC? wasn't being set, and changes only to marks weren't being written out.") + + (replace (LAFITEMSG MARKSCHANGEDINTOC?) of MSG with T) + (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with T]) + +(LA.SHOW.MARK + [LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* bvm%: "17-Feb-84 15:34") + (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) + (YPOS (MESSAGE#.TO.YPOS MSGDESCRIPTOR MAILFOLDER)) + (MARK (fetch (LAFITEMSG MARKCHAR) of MSGDESCRIPTOR))) + (LA.BLT.MARK.BOX MAILFOLDER WINDOW YPOS 'REPLACE WHITESHADE) + (* ; "Erase whatever's there") + (COND + ((NEQ MARK (CHARCODE SPACE)) + (MOVETO BROWSERMARKXPOSITION YPOS WINDOW) + (BOUT WINDOW MARK]) + +(LA.INVERT.MARK.BOX + [LAMBDA (MAILFOLDER MSG#) (* bvm%: "17-Feb-84 14:44") + (LA.BLT.MARK.BOX MAILFOLDER (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER) + (MESSAGE#.TO.YPOS (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of + MAILFOLDER + ) + MSG#) + MAILFOLDER) + 'INVERT BLACKSHADE]) + +(LA.BLT.MARK.BOX + [LAMBDA (MAILFOLDER WINDOW YPOS OPERATION TEXTURE) (* ; "Edited 3-Sep-87 18:02 by bvm:") + (BLTSHADE TEXTURE WINDOW BROWSERMARKXPOSITION (- YPOS (fetch (MAILFOLDER BROWSERFONTDESCENT) + of MAILFOLDER)) + (- (fetch (MAILFOLDER ORDINALXPOS) of MAILFOLDER) + BROWSERMARKXPOSITION) + (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER) + OPERATION]) + +(LA.SHOW.DELETION + [LAMBDA (MAILFOLDER MSGDESCRIPTOR WINDOW OPERATION) (* ; "Edited 3-Sep-87 16:23 by bvm:") + +(* ;;; "Draws or erases, for OPERATION = REPLACE or ERASE, the line indicating that MSGDESCRIPTOR is deleted") + + (BLTSHADE BLACKSHADE WINDOW BROWSERMARKXPOSITION (- (+ (MESSAGE#.TO.YPOS MSGDESCRIPTOR + MAILFOLDER) + (LRSH (fetch (MAILFOLDER + BROWSERFONTASCENT) + of MAILFOLDER) + 1)) + (LRSH LAFITEDELETEDLINEHEIGHT 1)) + NIL LAFITEDELETEDLINEHEIGHT OPERATION]) + +(LA.SHOW.SELECTION + [LAMBDA (MAILFOLDER MSGDESCRIPTOR OPERATION) (* bvm%: " 2-Feb-84 12:37") + +(* ;;; "Displays or erases, per OPERATION = REPLACE or ERASE, the mark indicating that MSGDESCRIPTOR is selected") + + (BITBLT LA.SELECTION.BITMAP 0 0 (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER) + 0 + (+ (MESSAGE#.TO.YPOS MSGDESCRIPTOR MAILFOLDER) + (LRSH (fetch (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER) + 1) + -5) + NIL NIL 'INPUT OPERATION]) + +(SEENMESSAGE + [LAMBDA (MSG FOLDER) (* ; "Edited 25-Apr-89 17:52 by bvm") + +(* ;;; +"causes the 'seen character' -- as opposed to the 'seen mark' -- to be changed to 'S' on the file") + + (LET ((OLDMARK (fetch (LAFITEMSG MARKCHAR) of MSG))) + (COND + ((OR (NULL (fetch (LAFITEMSG SEEN?) of MSG)) + (UNSEENMARKP OLDMARK)) + (replace (LAFITEMSG SEEN?) of MSG with T) + (LAB.MARKS.CHANGED MSG FOLDER) + (COND + ((UNSEENMARKP OLDMARK) + + (* ;; "only change the mark if it was ? -- it might already be something more meaningful like an answer mark") + + (MARKMESSAGE MSG FOLDER SEENMARK]) + +(DELETEMESSAGE + [LAMBDA (MSG FOLDER) (* ; "Edited 25-Apr-89 17:53 by bvm") + (replace (LAFITEMSG DELETED?) of MSG with T) + (LAB.MARKS.CHANGED MSG FOLDER) + (replace (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER with T) + (LA.SHOW.DELETION FOLDER MSG (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER) + 'REPLACE]) + +(UNDELETEMESSAGE + [LAMBDA (MSG FOLDER) (* ; "Edited 25-Apr-89 17:52 by bvm") + (if (fetch (LAFITEMSG DELETED?) of MSG) + then (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) + (replace (LAFITEMSG DELETED?) of MSG with NIL) + (LAB.MARKS.CHANGED MSG FOLDER) + (LA.SHOW.DELETION FOLDER MSG WINDOW 'ERASE) + (* ; "undeleted; reprint the header.") + (PRINTMESSAGESUMMARY MSG FOLDER WINDOW) + (* ; + "Finally, maybe clear the expungeable flag if this was the last deleted message") + (LAB.SET.EXPUNGEABILITY FOLDER]) + +(LAB.SET.EXPUNGEABILITY + [LAMBDA (FOLDER) (* ; "Edited 25-Apr-89 17:46 by bvm") + + (* ;; "Sets the FOLDERNEEDSEXPUNGE flag according to whether any messages are marked deleted, and returns the number of the first deleted message (or NIL if none).") + + (LET [(FIRSTDELETED (for I from 1 to (fetch (MAILFOLDER %#OFMESSAGES) + of FOLDER) + bind (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) + of FOLDER)) + thereis (fetch (LAFITEMSG DELETED?) of (NTHMESSAGE MESSAGES I] + (replace (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER with FIRSTDELETED) + FIRSTDELETED]) +) + + + +(* ;; +"PRINTMESSAGESUMMARY.STRING prints From and Subject. Redefined when MIME is loaded to deal with different character encodings." +) + + +(MOVD? 'PRIN3 'PRINTMESSAGESUMMARY.STRING) + + + +(* ; "ICON stuff") + + +(FILESLOAD ICONW) +(DEFINEQ + +(LAB.ICONFN + [LAMBDA (WINDOW OLDICON) (* ; "Edited 20-Apr-89 19:38 by bvm") + +(* ;;; "the holding place for all the fancy stuff for making an icon for a mail broswer window") + + (OR (WINDOWP (WINDOWPROP WINDOW 'ICONWINDOW)) + (LET ((MAILFOLDER (WINDOWPROP WINDOW 'MAILFOLDER)) + ICON) + (SETQ ICON (TITLEDICONW LAFITE.FOLDER.ICON (COND + (MAILFOLDER (LA.SHORTFILENAME + (fetch (MAILFOLDER + FULLFOLDERNAME + ) + of MAILFOLDER) + LAFITEMAIL.EXT)) + (T "??")) + NIL + (OR (WINDOWPROP WINDOW 'ICONPOSITION) + (SELECTQ LAFITE.BROWSER.ICON.PREFERENCE + ((:ASK ASK) (* ; "force prompt") + NIL) + (NIL (LA.POSITION.FROM.REGION (WINDOWPROP WINDOW 'REGION))) + (CL:FUNCALL LAFITE.BROWSER.ICON.PREFERENCE WINDOW))) + T NIL 'FILE)) + (WINDOWPROP ICON 'BUTTONEVENTFN (FUNCTION LAB.ICON.BUTTONEVENTFN)) + ICON]) + +(LAB.ICON.BUTTONEVENTFN + [LAMBDA (ICONW) (* ; "Edited 23-Aug-88 18:30 by bvm") + + (* ;; "BUTTONEVENTFN for browser windows. This one is like the default, except that middle button offers choices") + + (COND + [(LASTMOUSESTATE MIDDLE) + (LET (HOW) + (if [AND (fetch (MAILFOLDER FOLDERGETSMAIL) of (WINDOWPROP + (WINDOWPROP ICONW + 'ICONFOR) + 'MAILFOLDER)) + (SETQ HOW (MENU (OR LAFITEBROWSERICONMENU (SETQ LAFITEBROWSERICONMENU + (\LAFITE.CREATE.MENU + LAFITEBROWSERICONMENUITEMS + NIL T] + then (* ; + "Folder accepts new mail, and offer was accepted") + (CL:FUNCALL HOW ICONW) + else (* ; + "No menu selection, just expand as you otherwise would") + (EXPANDW ICONW] + (T (MOVEW ICONW]) +) + +(RPAQQ LAFITE.FOLDER.ICON (#*(100 72)@OOOOOOOO@@@@@@@@@@@@@@@@@@@AOOOOOOOOH@@@@@@@@@@@@@@@@@@C@@@@@@@@L@@@@@@@@@@@@@@@@@@F@@@@@@@@F@@@@@@@@@@@@@@@@@@L@DA@@@@@C@@@@@@@@@@@@@@@@@@L@FC@@@@@C@@@@@@@@@@@@@@@@@@L@EE@HGB@C@@@@@@@@@@@@@@@@@@L@EEADBB@C@@@@@@@@@@@@@@@@@@L@DIBBBB@COOOOOOOOOOOOOOL@@@L@DACNBB@COOOOOOOOOOOOOOL@@@L@DABBGCL@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@@@@@L@@@LOOOOOOOOOOOOOOOOOOOOOOOO@@@LOOOOOOOOOOOOOOOOOOOOOOOO@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@FL@@@@@@@@@@@@@@@@@@@@@@C@@@CL@@@@@@@@@@@@@@@@@@@@@@C@@@AOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOO@@@ + #*(100 72)@OOOOOOOO@@@@@@@@@@@@@@@@@@@AOOOOOOOOH@@@@@@@@@@@@@@@@@@COOOOOOOOL@@@@@@@@@@@@@@@@@@GOOOOOOOON@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@COOOOOOOOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOO@@@ + (8 4 88 51))) + +(RPAQ? LAFITEFROMFRACTION 0.3) + +(RPAQ? LAFITEMINFROMCHARS 15) + +(RPAQ? LAFITEVERIFYFLG T) + +(RPAQ? LAFITEDELETEDLINEHEIGHT 1) + +(RPAQ? LAFITE.BROWSER.ICON.PREFERENCE ) + +(RPAQQ LAFITEBROWSERMENUITEMS + (("Display" '\LAFITE.DISPLAY "Displays the selected message in the display window.") + ("Delete" '\LAFITE.DELETE "Deletes the selected messages.") + ("Undel" '\LAFITE.UNDELETE "Undeletes the selected messages.") + ("Answer" '\LAFITE.ANSWER "Prepares a delivery form to reply to the selected message.") + ("Forward" '\LAFITE.FORWARD "Prepares a delivery form to forward the selected message(s).") + (HCopy '\LAFITE.HARDCOPY "Sends hardcopy of the selected message(s) to the default printer") + ("Move To" '\LAFITE.MOVETO "Moves the selected message(s) to another mail folder.") + ("Update" '\LAFITE.UPDATE + "Write out browser changes to the physical mail file.% + Option to expunge all deleted messages." + ) + ("Get Mail" '\LAFITE.GETMAIL "Retrieves new messages and puts them into this mail folder."))) + +(RPAQQ LAFITESUBBROWSEMENUITEMS + [("Browse" '\LAFITE.BROWSE.PROC "Browse a mail file") + ("Browse & Forget" '\LAFITE.BROWSE.FORGET + "Browse a mail file, but don't add it to the menu of known folders") + ("Forget Folders" '\LAFITE.UNCACHE.FOLDER + "Remove one or more folders from list of known folders") + ("Forget Message Form" '\LAFITE.UNCACHE.MESSAGEFORM + "Remove a form from list of known message forms,% +but do not delete the file containing it." + ) + ("Delete Message Form" '\LAFITE.DELETE.MESSAGEFORM + "Remove a form from list of known message forms% +and delete the file(s) containing it." + ) + ("Notice Folders" '\LAFITE.NOTICE.FOLDERS + "Scan specified directory and add any folders found to the list of known folders") + ("Clean up Folders" '\LAFITE.GC.FOLDERS + "Check that all known folders correspond to actual files; remove those that no longer exist" + ) + ("Rename Folder" '\LAFITE.RENAME.FOLDER "Change the name of a folder") + ("Edit Folder Hierarchy" '\LAFITE.EDIT.HIERARCHY + "Add, delete, or change membership of a folder group" + (SUBITEMS ("Edit a Group" '\LAFITE.EDIT.HIERARCHY "Modify an existing group") + ("Add New Group" '[LAMBDA (ITEM MENU) + (\LAFITE.ADD.NEW.GROUP] + "Define a new top-level group") + ("Change Top-Level Groups" '\LAFITE.CHANGE.TOP.GROUPS + "Specify which subgroups should also appear at top level."]) + +(RPAQQ LAFITEBROWSERICONMENUITEMS (("Get Mail" '\LAFITE.GETMAIL.FROM.ICON + "Open this window and retrieve new mail into it"))) + +(RPAQ? LAFITESUBBROWSEMENU ) + +(RPAQ? LAFITEBROWSERICONMENU ) + +(RPAQ? LAFITEEXTRAMENU ) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) +) + +(ADDTOVAR LAFITEMENUVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) + +(ADDTOVAR LAFITEEXTRAMENUITEMS ("Describe Folder" '\LAFITE.DESCRIBE.FOLDER + "Display some relevant info about this folder" + (SUBITEMS ("Inspect Folder" 'INSPECT + "Inspect the MAILFOLDER data structure associated with this browser" + )))) + +(RPAQQ BROWSERMARKXPOSITION 8) + +(RPAQQ LA.SELECTION.BITMAP #*(8 10)L@@@N@@@O@@@OH@@OL@@OH@@O@@@N@@@L@@@@@@@) + + + +(* ; "Obsolete") + + +(RPAQ? LAFITEBROWSERREGION (CREATEREGION 30 30 575 210)) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(RPAQQ TOCSTATES ((TS.IDLE 0) + (TS.REPLACING 1) + (TS.ADDING 2) + (TS.REMOVING 3) + (TS.EXTENDING.HI 4) + (TS.EXTENDING.LO 5) + (TS.SHRINKING.HI 6) + (TS.SHRINKING.LO 7))) +(DECLARE%: EVAL@COMPILE + +(RPAQQ TS.IDLE 0) + +(RPAQQ TS.REPLACING 1) + +(RPAQQ TS.ADDING 2) + +(RPAQQ TS.REMOVING 3) + +(RPAQQ TS.EXTENDING.HI 4) + +(RPAQQ TS.EXTENDING.LO 5) + +(RPAQQ TS.SHRINKING.HI 6) + +(RPAQQ TS.SHRINKING.LO 7) + + +(CONSTANTS (TS.IDLE 0) + (TS.REPLACING 1) + (TS.ADDING 2) + (TS.REMOVING 3) + (TS.EXTENDING.HI 4) + (TS.EXTENDING.LO 5) + (TS.SHRINKING.HI 6) + (TS.SHRINKING.LO 7)) +) + + +(CL:PROCLAIM '(CL:SPECIAL \CURRENTDISPLAYLINE)) + + +(FILESLOAD (SOURCE) + LAFITEDECLS) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA LAB.MOUSECONFIRM LAB.FORMAT LAB.PROMPTPRINT) +) +(PUTPROPS LAFITEBROWSE COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988 1989 1999 2001 2021)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (5768 31473 (\LAFITE.BROWSE 5778 . 6525) (\LAFITE.SUBBROWSE 6527 . 6864) ( +\LAFITE.BROWSE.PROC 6866 . 7959) (\LAFITE.BROWSE.FORGET 7961 . 8507) (LAFITE.BROWSE.FOLDER 8509 . +10444) (\LAFITE.PREPARE.BROWSER 10446 . 12612) (\LAFITE.MAYBE.OPEN.FOLDER 12614 . 16056) ( +LAB.LOADFOLDER 16058 . 16553) (LAB.DISPLAYFOLDER 16555 . 18126) (LAB.MAKE.INITIAL.SELECTION 18128 . +19364) (LAB.CREATEWINDOW 19366 . 27821) (LAB.TITLE.STRING 27823 . 29588) (LAB.COMMANDFN 29590 . 30120) + (LAB.DO.COMMAND 30122 . 31099) (LAB.ASSURE.SELECTIONS 31101 . 31471)) (31474 41387 ( +BUILD.LAFITE.LAYOUTS 31484 . 37742) (\LAFITE.LAYOUT.FROM.WINDOW 37744 . 40224) ( +\LAFITE.MAKE.DUMMY.WINDOWS 40226 . 41385)) (41813 67265 (LAB.SETUP 41823 . 48008) (LAB.BUTTONEVENTFN +48010 . 48540) (LAB.DO.UNLESS.BUSY 48542 . 49038) (LOADMAILFOLDER 49040 . 50323) (LAFITE.OBTAIN.FOLDER + 50325 . 59227) (\LAFITE.FIND.EXISTING.FOLDER 59229 . 60076) (\LAFITE.CONFLICTING.OLD.FOLDER 60078 . +61249) (LAB.REPAINTFN 61251 . 61876) (LAB.SCROLLFN 61878 . 62466) (LAB.RESHAPEFN 62468 . 63761) ( +LAB.CLOSEFN 63763 . 63932) (LAB.SHRINKFN 63934 . 64098) (LAB.CLOSE/SHRINK 64100 . 65685) (LAB.EXPANDFN + 65687 . 66931) (LAFITEEXTRABROWSERCOMMANDFN 66933 . 67263)) (67300 85005 (LAB.SELECTMESSAGE 67310 . +80668) (LAB.CHANGEMARK 80670 . 82271) (LA.READ.NEW.MARK 82273 . 84056) (YPOS.TO.MESSAGE# 84058 . 84666 +) (MESSAGE#.TO.YPOS 84668 . 85003)) (85006 93673 (LA.CONSIDERRANGE 85016 . 85700) (LA.DECONSIDERRANGE +85702 . 86118) (LA.RECONSIDERRANGE 86120 . 86824) (LA.SELECTRANGE 86826 . 88162) (LA.DESELECTRANGE +88164 . 90242) (LAB.FIND.SELECTED.MSG 90244 . 90621) (LAB.REV.FIND.SELECTED.MSG 90623 . 91108) ( +LA.UNDOSELECTION 91110 . 91404) (LA.VERIFY.SELECTION 91406 . 93671)) (93674 100537 ( +LAB.COPYBUTTONEVENTFN 93684 . 98889) (LAB.SHOW.COPY.SELECTION 98891 . 100535)) (100744 108238 ( +LAB.PROMPTPRINT 100754 . 100933) (LAB.FORMAT 100935 . 101372) (LAB.MOUSECONFIRM 101374 . 101837) ( +LAB.PRINT.TO.PROMPTWINDOW 101839 . 104988) (LAB.PAGEFULLFN 104990 . 106042) ( +\LAFITE.MAYBE.CLEAR.PROMPT 106044 . 108236)) (108462 129133 (PRINTMESSAGESUMMARY 108472 . 113229) ( +FIRSTVISIBLEMESSAGE 113231 . 114251) (LASTVISIBLEMESSAGE 114253 . 115442) (LAB.DISPLAYLINES 115444 . +117686) (LAB.EXPOSEMESSAGE 117688 . 118795) (LAB.SELECTED.MESSAGES 118797 . 119059) ( +UNSELECTALLMESSAGES 119061 . 119547) (SELECTMESSAGE 119549 . 119841) (LAB.GO.TO.MESSAGE 119843 . +121152) (MARKMESSAGE 121154 . 122201) (LAB.MARKS.CHANGED 122203 . 123010) (LA.SHOW.MARK 123012 . +123657) (LA.INVERT.MARK.BOX 123659 . 124228) (LA.BLT.MARK.BOX 124230 . 124736) (LA.SHOW.DELETION +124738 . 125642) (LA.SHOW.SELECTION 125644 . 126208) (SEENMESSAGE 126210 . 126996) (DELETEMESSAGE +126998 . 127406) (UNDELETEMESSAGE 127408 . 128287) (LAB.SET.EXPUNGEABILITY 128289 . 129131)) (129370 +132578 (LAB.ICONFN 129380 . 131073) (LAB.ICON.BUTTONEVENTFN 131075 . 132576))))) +STOP diff --git a/library/lafite/LAFITEBROWSE.LCOM b/library/lafite/LAFITEBROWSE.LCOM index a0587f9cb40f383d4ff005271f2126e6a6a58e75..79d71e3682d5f6168a08b585917da645b7b993c3 100644 GIT binary patch delta 1980 zcmah~c}$aM7!OnqKfz5w95Cdi!fYdy9#l$!vO-(v_@K}h8O94}#f}OLaPvmDIp+w9 zzVpBt1-U^v_PNEG%(TialO-lIGc)4c+~#J)#AS&_-Sf1fE?MS3zxO$Q&)s}=Ht>FG z;MJ$sFan*P)utJ>YO_{D_%d;f$yyO36-y;VDpQK3O1X?r1pMOibrm+d)k4b42%j*U zHKxq1NqJS)$|_Z9VTHZ0OvRQL7ur?ptQNaB`L8$y zU-*AB!9WV7JpTC%Cauw=%2emD>TDHjNK><_EUkvs7T^r&dUH*TTUD|8RHNEh@U;7X z4FNL{Nt{HXkdcZ?>wC8H^;ND0qm+cD(%+trigP~EpUjhAR{0aDA#x=k`rJVYEPq-y+uFrsn7bD0a za@wC5$ldkr!YJTy6U-!tT%TWnn;@l`vlno;{I{aj@=7ERc)RBw0VOiv8rnSP`C{y> zAT21lLD4he*%lt^3D1#;g~&L^7a`-$!VXuBCER%AeIF2=(Ko=`9FvHo>mmn+G)kKA zNsSBkf@gVx2_yTIcRU#Zoij6zUQRp>_D_xzdqF+BB#R4+tcav>^V1!OU`n7Ok3j&UxM|vVFh4D&T1DUo}0|Ecuq4m znV<+{kLQZa5?96yUq!TczK9Vk4y9UgA z)_P-8>)u&K@7p%Gq(@*bEnSAoXNiE;ltyrW*lS-<>Cv(+&z)3NUIm(th^f;SKu61M z5HG7J#w8xAyoXENy+Mq%&u;nvFnRNCz~Rjg0P);^Zz;hJR&ARE=9@L0sNCNEGbj@~ z(lN>Wk0NltezjqA>8H3BzuGA%&kAV3%hxA zY!}*gHktviHs%91`3KX?rYw*en($O}7KPGzC*&Yyo`4(=FfL2WAm*SBG&AKNgKx_v3&;dW#`ZqM*! z_;m8)P+Hu9&XEoz#&+fb?(D=g+a2N5yGsGmz2hOYpo^W!5J5U?NL90R`&bIS(-i`~ zh_L_~+Kr8sbr%3;U5uc=cWXh4J&73?k4xzANf}5FPhy?br_eflDjx93DT@yyFy^Rp zbLl==F#WJc&trrPo#-Lpo$5&j6!l^UCA}=*w;hTA_s7!28q^x1Pcvla3mNW7ua~bU zLug1}8mB+g?(-@%svvPhp&)XJP$*>fI~G8AxFZZO*%AD-XbRnND3~XKf*T!gfTz)s z3V73jVc$67~xUc*{C1CVWEOicweHp&SYPVKf>B_+cbpBAF%e4$}*ANDt z8NzbQmqX5&Y#?MzHY6NH*a7(Ii0gXbNDXBal8mKAV0u8VlO3Q9MJ) zSm?9)r;Z1Oz~2vEAceTU$=bKgMs=1pI}g@kA2UIKV+^~k>sI1zK`OtP@oc_#4+ilR bz`Sx1?-MzWw^}j2!jIrTGAuq@&oci2j7WGs delta 1956 zcmb7FYfO`86iz`vluyh68KUsELTsayUMQAwkqRwV3au^R@H(I!RE5@pn+z}PlHtbY zaL3C;rxXDN6g1V1EN*L^AOc>pO_!LNfx6916J53?%iQA5DR@ctXZ!Pf&pGEg=RN1V z&D)#%{Js19n{uXcLak1($ueow1)6LIUS9Y%nScoeW%f#kZN1gP>{U#_>axwbThbg( z`&w&RO-7~Fvff%N7b`N>+e)1!&e{yUTB|G2EHW9EnKk0nBoX5TEG0qha3;tk5($$k zRT8O6j)hB|)+d#%n;g#SconO%*HqZ5%9#yM(ra@vP@bT*mQt#eiN#_8vy{|eC!FBf zfJ~~AC{#&Gf#_c&%-;5&J7vmb=>i2St0<`|w^p+nd%TKc!XmZF%$}Vo%aCUlF`+i! z%#0>oenFnbY*y!J%!PS*YE!X@Ih@v)ZT5}TzE0y+E0{ngO<1zADj_9>$z-Y|nMy7Z zFz)}YQ6}P6jyEA5-z-yQD>-+HUl5PSf!hBkMA4*sJ{|${0tS(dr7J)bczK+;#X;wI z0i4jt6mTUZ+&wk8i!xE;zB^@<=f??QgEg$Nbb#Eiys{0d>?l^2qIh|a$brh8=w{?;c_}XnW?!J~oMdWYt z1JNgJoDI%*XdA-D2k4G^_asS&-}@f1d&g&pw)d%fbyEk1?=)#K>`we3pH$xF8L$hw zebG3u?4q3P-Jc>p+I=5o_xA*l?DxIb5mD^^@x!T)^CmarEAo4;YVDaH4 z$l$OE4i(J;UYicB+_qJ)VQn~^X)~h5wObLZ+e;9ywy#8#b*x6**@3qPe{@)&X-6bf zAIU`P)DhCoJi6GA6Tn|@MZ>nEmOu_41S5khy-MJBiZGtrS%~QBq>7mbV}Re4f{bgK z2^+ig!T7A?=nae1dN?q&5Q4jBl6FW1tGnkR3muMy&TbVl+b|yjj%kqP9-~fjMx=1- zm>gN;ahh)Paq`|ez5ublCma%cXqx(-ieL_3LX%OwbRnE4-~um56Wj(&n(& zu<_T@tT(8$nJ&wazf8orqfZ1(#;x=F?gmZAK9wwqDV0ni6^TR~%<{xwYN}^8f1>=v z%UGl_>9oaKeGV&la_~ocqk^SRteppA{jh+mB@8Zm60yi5Pq9BI$Oe};25P-p^mx3b zh;z=CAvT<)`R<*yKF=*JG!$sqGZ%7{Wc-^D^k)R$4n?mc%)8rT8%#NW*6m1_eBYrnTZ6yw` mKx`adJdw5(JbNN0F(rzB9j4349HEP<9a$BGThG_&xqkreLV#BQ diff --git a/library/lafite/LAFITECOMMANDS b/library/lafite/LAFITECOMMANDS index ee1ebbac..2719daeb 100644 --- a/library/lafite/LAFITECOMMANDS +++ b/library/lafite/LAFITECOMMANDS @@ -1,152 +1,2582 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "28-Jun-99 10:23:32" {DSK}medley3.5>library>LAFITECOMMANDS.;4 98281 changes to%: (FNS \LAFITE.DO.DISPLAY) previous date%: "27-Jun-99 22:47:32" {DSK}medley3.5>library>LAFITECOMMANDS.;3) (* ; " Copyright (c) 1988, 1989, 1992, 1993, 1999 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LAFITECOMMANDSCOMS) (RPAQQ LAFITECOMMANDSCOMS [ (* ;; "Handling of the main Lafite browser commands") (COMS (* ; "DISPLAY") (FNS \LAFITE.DISPLAY \LAFITE.DO.DISPLAY SELECTMESSAGETODISPLAY MESSAGEDISPLAYER LA.COPY.MESSAGE.TEXT \LAFITE.CLOSE.DISPLAYWINDOWS \LAFITE.CLOSE.DISPLAYER) (FNS \LAFITE.UNHIDE.HEADERS \LAFITE.HIDE.HEADERS \LAFITE.REHIDE.HEADERS LAFITE.EAT.UNDESIRABLE.FIELD LAFITE.EAT.GVGV \LAFITE.HARDCOPY.FROM.DISPLAY LAFITE.HARDCOPY.TAB.WIDTH) (FNS \LAFITE.SET.LOOKS.FROM.MENU \LAFITE.SET.DEFAULT.LOOKS \LAFITE.SET.FIXED.LOOKS LAFITE.SET.LOOKS LAFITE.SET.TAB.LOOKS LAFITE.SET.PARA.SEPARATION LAFITE.SET.LOWER.CASE LAFITE.SUBSTITUTE.VP.EOL) (INITVARS \LAFITE.DISPLAY.COMMANDS) (ADDVARS [LAFITE.EXTRA.DISPLAY.COMMANDS ("Looks" '\LAFITE.SET.LOOKS.FROM.MENU "Change the appearance of the selected text, or whole message if nothing selected" ) ("Hardcopy" '\LAFITE.HARDCOPY.FROM.DISPLAY "Hardcopy this message in its current appearance") ("Unhide" '\LAFITE.UNHIDE.HEADERS "Display the header fields that are hidden from view." (SUBITEMS ("Hide" '\LAFITE.REHIDE.HEADERS "Hide uninteresting fields from view again"] (LAFITE.LOOKS.SUBCOMMANDS ("VP Line Breaks" 'LAFITE.SUBSTITUTE.VP.EOL "Replace the Viewpoint end of line character with ours." ) ("Lowercase" 'LAFITE.SET.LOWER.CASE "Lowercase the region or whole message.") ("Spread Paragraphs" 'LAFITE.SET.PARA.SEPARATION "Separate paragraphs by 10 points (useful for Tioga messages).") ("Default" '\LAFITE.SET.DEFAULT.LOOKS "Change selection (or whole text) back to default font") ("Fixed Width" '\LAFITE.SET.FIXED.LOOKS "Change selection (or whole text) to fixed-width font"))) (GLOBALVARS \LAFITE.DISPLAY.COMMANDS)) (COMS (* ; "DELETE") (FNS LAFITE.DELETE.MESSAGES \LAFITE.DELETE DISPLAYAFTERDELETE \LAFITE.SELECT.NEXT \LAFITE.UNDELETE)) (COMS (* ; "MOVE") (FNS LAFITE.MOVE.MESSAGES \COERCE.TO.MSGLST \LAFITE.MOVETO \LAFITE.COPYTO \LAFITE.MOVETO.PROC \LAFITE.MOVE.MESSAGES.INTERNAL) (* ; "Aux move") (FNS \LAFITE.ENABLE.MOVE.MENU \LAFITE.ADD.TO.MOVE.MENU \LAFITE.UPDATE.MOVE.MENU \LAFITE.RESTORE.MOVE.MENU \LAFITE.HANDLE.AUTO.MOVE) (ADDVARS (LAFITEEXTRAMENUITEMS ("Enable MoveTo Menu" '\LAFITE.ENABLE.MOVE.MENU "Attach a menu of folders for accelerated MoveTo (or modify existing one)" (SUBITEMS ("Restore MoveTo Menu" '\LAFITE.RESTORE.MOVE.MENU "Just reopen the attached MoveTo menu if it existed." ))) ("Copy To" '\LAFITE.COPYTO "Like MoveTo, but don't delete the message(s).")) (LAFITE.EXTRA.MOVE.ITEMS ("---Display---" '\LAFITE.DISPLAY "Display the next message") ("---Delete---" '\LAFITE.DELETE "Delete the selected message(s)"))) (INITVARS (LAFITE.AUTO.MOVE.MENU))) (COMS (* ; "UPDATE") (FNS \LAFITE.UPDATE \LAFITE.EXPUNGE.PROC \LAFITE.UPDATE.PROC \LAFITE.HARDCOPYONLY.PROC LAB.CHOOSE.UPDATE.MENU LAB.CREATE.UPDATE.MENU LAB.UPDATE.NEEDED? \LAFITE.START.UPDATE LAB.START.COMMAND \LAFITE.FINISH.UPDATE \LAFITE.CLOSE.OTHER.FOLDERS) (FNS LAB.FLUSHWINDOW LAB.APPENDMESSAGES \LAFITE.COMPACT.FOLDER \LAFITE.COMPACT.FOLDER1 \LAFITE.COMPACT.FOLDER2 \LAFITE.COMPACT.EXTRA \LAFITE.INVALIDATE.TOC \LAFITE.RENAMEFILE SMART-RENAMEFILEP LA.OPENTEMPFILE) (FNS \LAFITE.UPDATE.FOLDER \LAFITE.UPDATE.CONTENTS \LAFITE.UPDATE.CONTENTS1 WRITETOCENTRY WRITETOCMARKBYTES WRITEFOLDERMARKBYTES)) [COMS (* ; "HARDCOPY") (FNS LAFITE.HARDCOPY.MESSAGES \LAFITE.HARDCOPY \LAFITE.HARDCOPY.PROC \LAFITE.HARDCOPY.HEADERS \LAFITE.MARK.HARDCOPIED \LAFITE.TRANSMIT.HARDCOPY \LAFITE.HARDCOPY.BODIES \LAFITE.APPEND.MESSAGE.BODY \LAFITE.DO.PENDING.HARDCOPY \LAFITE.CANCEL.HARDCOPY \LAFITE.CLEAR.HARDCOPY.STATE) (ADDVARS (LAFITEEXTRAMENUITEMS ("Cancel Pending Hardcopy" '\LAFITE.CANCEL.HARDCOPY "Forget about hardcopying the messages so far marked for hardcopy." ] [COMS (INITVARS (LAFITEHARDCOPYBATCHFLG NIL) (LAFITEHARDCOPY.MIN.TOC NIL) (LAFITEDISPLAYAFTERDELETEFLG T) (LAFITEMOVETOCONFIRMFLG 'ALWAYS) (LAFITENEWPAGEFLG T) (LAFITEENDOFMESSAGESTR "End of message") [LAFITEENDOFMESSAGEFONT (FONTCREATE '(TIMESROMAN 10 ITALIC] (LAFITE.DISPLAY.SIZE '(500 . 300)) (LAFITE.BROWSER.LAYOUTS NIL) (LAFITE.MIDDLE.UPDATE '(:EXPUNGE :SHRINK :CONFIRM)) (LAFITEHARDCOPYBATCHSHADE 1025) (LAFITEHARDCOPYSEPARATOR "% - Next Message % -")) (COMS (* ; "Obsolete") (INITVARS (LAFITEDISPLAYREGION (CREATEREGION 375 25 600 335] (DECLARE%: DOEVAL@COMPILE DONTCOPY (FILES (SOURCE) LAFITEDECLS) (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA LAFITE.HARDCOPY.MESSAGES ]) (* ;; "Handling of the main Lafite browser commands") (* ; "DISPLAY") (DEFINEQ (\LAFITE.DISPLAY -(LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* ; "Edited 22-Sep-87 14:56 by bvm:") (PROG (DISPLAYWINDOW) (COND ((WINDOWP (SETQ DISPLAYWINDOW (RESETLST (LA.RESETSHADE ITEM MENU) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (OR (LAB.ASSURE.SELECTIONS MAILFOLDER) (LET ((MSGDESCRIPTOR (SELECTMESSAGETODISPLAY WINDOW MAILFOLDER)) W) (COND (MSGDESCRIPTOR (\LAFITE.DO.DISPLAY MAILFOLDER MSGDESCRIPTOR (EQ KEY (QUOTE MIDDLE)))) (T (LAB.PROMPTPRINT MAILFOLDER T "No more messages.") (* ; "But return current display window for topping, just in case it was buried") (CAR (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of MAILFOLDER)))))))))) (* ; "make sure the display window is on top in case SHADEITEM put the browser back on top") (TOTOPW DISPLAYWINDOW))))) -) (\LAFITE.DO.DISPLAY [LAMBDA (MAILFOLDER MSGDESCRIPTOR NEWWINDOWFLG) (* ; "Edited 28-Jun-99 10:22 by rmk:") (* ; "Edited 27-Jun-99 22:44 by rmk:") (* ; "Edited 25-Jun-99 19:05 by rmk:") (* ; "Edited 25-Jun-99 18:31 by rmk:") (* ; "Edited 13-Oct-87 15:56 by bvm:") (* ;;; "Display MSGDESCRIPTOR from MAILFOLDER, using a new window if NEWWINDOWFLG is true, else reusing if possible the primary window. Returns the window.") (* ;;; "") (* ;;; "rmk, 6/99. I modified the interface to LA.COPY.MESSAGE.TEXT to make it easier to replace that function with something that deals with MIME attachments. I moved the MAYBEVERIFYMSG up to this level to eliminate a compile-time dependency on that macro, and this required moving the \LAFITE.OPEN.FOLDER as well. That call is harmlessly repeated in LA.COPY.MESSAGE.TEXT") (PROG (TEMPMSG DISPLAYWINDOW) (LAB.EXPOSEMESSAGE MAILFOLDER MSGDESCRIPTOR) (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of MAILFOLDER with NIL) (* ; "Clear it here in case of abort") (\LAFITE.OPEN.FOLDER MAILFOLDER 'INPUT :ABORT) (MAYBEVERIFYMSG MSGDESCRIPTOR MAILFOLDER) (SETQ TEMPMSG (LA.COPY.MESSAGE.TEXT MAILFOLDER MSGDESCRIPTOR NEWWINDOWFLG)) (SETQ DISPLAYWINDOW (MESSAGEDISPLAYER MAILFOLDER TEMPMSG (CONCAT "Message " (fetch (LAFITEMSG %#) of MSGDESCRIPTOR ) " from " (fetch (MAILFOLDER FULLFOLDERNAME ) of MAILFOLDER) " [" (fetch (LAFITEMSG MESSAGELENGTH ) of MSGDESCRIPTOR ) " chars]") NEWWINDOWFLG)) (SEENMESSAGE MSGDESCRIPTOR MAILFOLDER) (PROGN (* ; "Cache the stream that we copied the message text to, since we might be able to use it to accelerate a Move or Hardcopy. Unfortunately, we can't take advantage of it now, since NODIRCORE doesn't support multiple streams per file.") (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of MAILFOLDER with TEMPMSG) (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of MAILFOLDER with MSGDESCRIPTOR )) (RETURN DISPLAYWINDOW]) (SELECTMESSAGETODISPLAY -(LAMBDA (WINDOW MAILFOLDER) (* bvm%: " 1-Mar-86 18:19") (* ;;; "Laurel acts differently if there is currently only one message selected or many about whether it unselects the one that was displayed before. Lafite will follow the same model") (LET ((CURRENTDISPLAYEDMSG (fetch (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of MAILFOLDER)) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) (FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER)) (LAST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER)) DISPLAYED# MSGDESCRIPTOR) (COND ((IGREATERP FIRST# LAST#) (* ; "Nothing selected, so nothing to display") NIL) ((OR (NULL CURRENTDISPLAYEDMSG) (NOT (fetch (LAFITEMSG SELECTED?) of CURRENTDISPLAYEDMSG))) (* ; "haven't displayed any yet, or displayed one is not part of the selection") (NTHMESSAGE MESSAGES FIRST#)) ((EQ FIRST# LAST#) (* ; "Only one msg selected and it is displayed, so move on to next undeleted msg") (\LAFITE.SELECT.NEXT MAILFOLDER (fetch (LAFITEMSG %#) of CURRENTDISPLAYEDMSG))) (T (* ; "Multiple selections -- Cycle to the next one") (NTHMESSAGE MESSAGES (COND ((EQ (SETQ DISPLAYED# (fetch (LAFITEMSG %#) of CURRENTDISPLAYEDMSG)) LAST#) (* ; "Cycle back to first") FIRST#) (T (LAB.FIND.SELECTED.MSG MAILFOLDER (ADD1 DISPLAYED#) LAST#)))))))) -) (MESSAGEDISPLAYER [LAMBDA (MAILFOLDER TEXTFILE TITLE NEWWINDOWFLG) (* ; "Edited 24-Jun-99 15:34 by rmk:") (* ; "Edited 24-Jun-99 15:32 by rmk:") (* ; "Edited 24-Jun-99 15:32 by rmk:") (* ; "Edited 6-Aug-93 18:48 by bvm") (* ;;; "Displayer for individual messages") (LET ((CURRENTWINDOWS (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of MAILFOLDER)) [PROPS `(FONT ,LAFITEDISPLAYFONT] (WINDOWPROPS '(READONLY T PROMPTWINDOW DON'T)) (EOF (GETEOFPTR TEXTFILE)) TEXTSTREAM DISPLAYWINDOW FILTERED) (* ;; "WINDOWPROPS for when we finally give TEdit a window: READONLY in order to avoid TEdit's odd temptation to display an ugly caret at the start and prevent mouse actions from yielding %"NewEditProcess%" menu; PROMPTWINDOW to inhibit attaching a prompt window. Due to a TEdit bug, you can't give the PROMPTWINDOW prop when opening without a window or it will try to make the symbol DON'T be the promptwindow later on.") (if (AND \LAPARSE.DONT.DISPLAY.HEADERS (NEQ EOF 0) (SETQ FILTERED (LAFITE.NEW.PARSE.HEADER TEXTFILE \LAPARSE.DONT.DISPLAY.HEADERS 0))) then (* ;  "We will filter some headers out, so put * in title to show this") (SETQ TITLE (CONCAT "*" TITLE))) [COND ((AND (NOT NEWWINDOWFLG) (SETQ DISPLAYWINDOW (CAR CURRENTWINDOWS))) (MAPC (WINDOWPROP DISPLAYWINDOW 'EXTRAWINDOWS NIL) (FUNCTION CLOSEW)) (* ;  "Get rid of extra windows produced by attachments") (CLEARW DISPLAYWINDOW) (WINDOWPROP DISPLAYWINDOW 'TITLE TITLE)) (T (SETQ DISPLAYWINDOW (CREATEW (COND [(AND (NOT NEWWINDOWFLG) (PROGN (* ;  "This says where we'd like the primary window to be.") (fetch (MAILFOLDER FOLDERDISPLAYREGION) of MAILFOLDER] (LAFITE.DISPLAY.SIZE (* ; "Global default") (GETBOXREGION (CAR LAFITE.DISPLAY.SIZE) (CDR LAFITE.DISPLAY.SIZE) NIL NIL NIL TITLE))) TITLE)) (WINDOWADDPROP DISPLAYWINDOW 'CLOSEFN (FUNCTION \LAFITE.CLOSE.DISPLAYER)) (WINDOWPROP DISPLAYWINDOW 'TEDIT.MENU.COMMANDS \LAFITE.DISPLAY.COMMANDS) (COND [(NOT CURRENTWINDOWS) (replace (MAILFOLDER FOLDERDISPLAYWINDOWS) of MAILFOLDER with (if NEWWINDOWFLG then (* ;  "not primary, even though no window previously open") (LIST NIL DISPLAYWINDOW) else (LIST DISPLAYWINDOW] [NEWWINDOWFLG (RPLACD CURRENTWINDOWS (CONS DISPLAYWINDOW (CDR CURRENTWINDOWS] (T (* ;  "DIsplaying the primary window for the first time when there are already secondary windows.") (RPLACA CURRENTWINDOWS DISPLAYWINDOW] (* ; "Now let TEDIT display it") [COND ((EQ EOF 0) (LAB.PROMPTPRINT MAILFOLDER "Message is empty")) (T [LET (WINDOW) (if (NOT FILTERED) then (* ;  "Go ahead and display it right off. ") (SETQ PROPS (NCONC PROPS WINDOWPROPS)) (SETQ WINDOW DISPLAYWINDOW)) (SETQ TEXTSTREAM (OR (CAR (NLSETQ (OPENTEXTSTREAM TEXTFILE WINDOW NIL NIL PROPS)) ) (PROGN (LAB.PROMPTPRINT MAILFOLDER T "Problems displaying message, trying unformatted." ) (OPENTEXTSTREAM TEXTFILE WINDOW NIL NIL (LIST* 'CLEARGET T PROPS] (if FILTERED then (if (NOT (= EOF (GETEOFPTR TEXTSTREAM))) then (* ;  "rats, there may have been nschars in the header, so parse it now more carefully") (SETQ FILTERED (LAFITE.NEW.PARSE.HEADER TEXTSTREAM \LAPARSE.DONT.DISPLAY.HEADERS 0))) (\LAFITE.HIDE.HEADERS TEXTSTREAM FILTERED) (* ;  "Now we can display it without a major glitch") (OPENTEXTSTREAM TEXTSTREAM DISPLAYWINDOW NIL NIL WINDOWPROPS) (TEXTPROP TEXTSTREAM 'FILTERED FILTERED) (* ;  "Remember what's invisible, so we can easily undo it") ) (COND (LAFITEENDOFMESSAGESTR (* ;  "Add %"End of message%" token. Have to take away READONLY for a moment here...") (TEXTPROP TEXTSTREAM 'READONLY NIL) [SETFILEPTR TEXTSTREAM (SUB1 (SETQ EOF (GETEOFPTR TEXTSTREAM] (COND ((NEQ (BIN TEXTSTREAM) (CHARCODE CR)) (* ;  "Message doesn't end in CR, so add one before inserting end of message str") (TEDIT.INSERT TEXTSTREAM LAFITEEOL (ADD1 (add EOF 1)) NIL T))) (TEDIT.INSERT TEXTSTREAM LAFITEENDOFMESSAGESTR (ADD1 EOF) LAFITEENDOFMESSAGEFONT T) (TEXTPROP TEXTSTREAM 'READONLY T) (TEDIT.SETSEL TEXTSTREAM 1 0) (\CARET.DOWN) (* ; "Patch around TEdit bug") ] DISPLAYWINDOW]) (LA.COPY.MESSAGE.TEXT [LAMBDA (MAILFOLDER MSGDESCRIPTOR NEWWINDOWFLG) (* ; "Edited 27-Jun-99 22:47 by rmk:") (* ; "Edited 27-Jun-99 22:44 by rmk:") (* ; "Edited 25-Jun-99 18:30 by rmk:") (LET (OUTPUTSTREAM (INSTREAM (\LAFITE.OPEN.FOLDER MAILFOLDER 'INPUT :ABORT))) (SETQ OUTPUTSTREAM (OPENSTREAM '{NODIRCORE} 'BOTH)) (COPYBYTES INSTREAM OUTPUTSTREAM (fetch (LAFITEMSG START) of MSGDESCRIPTOR) (fetch (LAFITEMSG END) of MSGDESCRIPTOR)) (CLOSEF OUTPUTSTREAM) (OPENSTREAM OUTPUTSTREAM 'INPUT NIL '((ENDOFSTREAMOP \LAFITE.EOF]) (\LAFITE.CLOSE.DISPLAYWINDOWS -(LAMBDA (FOLDER) (* ; "Edited 22-Sep-87 15:36 by bvm:") (* ;; "Called when browser closed, to close associated windows.") (PROG ((WINDOWS (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER)) W) (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER with NIL) (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of FOLDER with NIL) (COND (WINDOWS (for WINDOW in (CDR WINDOWS) do (* ; "Leave secondary windows open, but disconnect them from browser") (WINDOWDELPROP WINDOW (QUOTE CLOSEFN) (FUNCTION \LAFITE.CLOSE.DISPLAYER))) (COND ((WINDOWP (SETQ W (CAR WINDOWS))) (* ; "Save region for later") (replace (MAILFOLDER FOLDERDISPLAYREGION) of FOLDER with (APPEND (WINDOWPROP W (QUOTE REGION)))) (WINDOWDELPROP W (QUOTE CLOSEFN) (FUNCTION \LAFITE.CLOSE.DISPLAYER)) (CLOSEW W))) (replace (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER with NIL))))) -) (\LAFITE.CLOSE.DISPLAYER -(LAMBDA (WINDOW) (* ; "Edited 16-Aug-89 11:27 by bvm") (* ;; "called via CLOSEFN when a display window is explicitly closed") (MAPC (WINDOWPROP WINDOW (QUOTE EXTRAWINDOWS) NIL) (FUNCTION CLOSEW)) (for FOLDER in \ACTIVELAFITEFOLDERS bind THESEWINDOWS when (MEMB WINDOW (SETQ THESEWINDOWS (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER))) do (* ; "Do we need a monitorlock here?") (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER with NIL) (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of FOLDER with NIL) (if (EQ WINDOW (CAR THESEWINDOWS)) then (* ; "the main window--keep its region") (replace (MAILFOLDER FOLDERDISPLAYREGION) of FOLDER with (APPEND (WINDOWPROP WINDOW (QUOTE REGION)))) (if (CDR THESEWINDOWS) then (RPLACA THESEWINDOWS NIL) else (replace (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER with NIL)) else (* ; "floating window, just remove") (RPLACD THESEWINDOWS (DREMOVE WINDOW (CDR THESEWINDOWS)))) (RETURN))) -) ) (DEFINEQ (\LAFITE.UNHIDE.HEADERS -(LAMBDA (TEXTSTREAM) (* ; "Edited 10-Dec-87 19:48 by bvm:") (LET ((FILTERED (TEXTPROP TEXTSTREAM (QUOTE FILTERED))) START W) (if (OR (NULL FILTERED) (TEXTPROP TEXTSTREAM (QUOTE VISIBLE))) then (PROMPTPRINT "The whole message is already displayed") else (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (TEDIT.LOOKS TEXTSTREAM (QUOTE (INVISIBLE OFF)) (ADD1 (SETQ START (CAAR (LAST FILTERED)))) (- (CADAR FILTERED) START)) (TEDIT.SETSEL TEXTSTREAM 1 0) (TEXTPROP TEXTSTREAM (QUOTE VISIBLE) T) (TEXTPROP TEXTSTREAM (QUOTE READONLY) T) (if (SETQ W (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM)) then (* ; "Remove the * from the title.") (WINDOWPROP W (QUOTE TITLE) (SUBSTRING (WINDOWPROP W (QUOTE TITLE)) 2)))))) -) (\LAFITE.HIDE.HEADERS -(LAMBDA (TEXTSTREAM FILTERED) (* ; "Edited 10-Dec-87 19:44 by bvm:") (for PAIR in FILTERED do (* ; "Make each filtered field invisible") (TEDIT.LOOKS TEXTSTREAM (QUOTE (INVISIBLE ON)) (+ (CAR PAIR) 1) (- (CADR PAIR) (CAR PAIR)))) (TEDIT.SETSEL TEXTSTREAM 1 0)) -) (\LAFITE.REHIDE.HEADERS -(LAMBDA (TEXTSTREAM) (* ; "Edited 10-Dec-87 19:44 by bvm:") (* ;; "Called from display window menu to hide the headers again after having them unhidden.") (LET ((FILTERED (TEXTPROP TEXTSTREAM (QUOTE FILTERED))) START W) (if (NULL FILTERED) then (PROMPTPRINT "No uninteresting header fields were found") elseif (NOT (TEXTPROP TEXTSTREAM (QUOTE VISIBLE))) then (PROMPTPRINT "Uninteresting headers are already hidden") else (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (\LAFITE.HIDE.HEADERS TEXTSTREAM FILTERED) (TEXTPROP TEXTSTREAM (QUOTE VISIBLE) NIL) (TEXTPROP TEXTSTREAM (QUOTE READONLY) T) (if (SETQ W (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM)) then (* ; "Add * back to the title.") (WINDOWPROP W (QUOTE TITLE) (CONCAT "*" (WINDOWPROP W (QUOTE TITLE)))))))) -) (LAFITE.EAT.UNDESIRABLE.FIELD -(LAMBDA (STREAM IGNORE) (* ; "Edited 23-Sep-87 13:12 by bvm:") (* ;; "Parser function called when a field to be filtered is found--skip over the field, and push onto the result a pair giving (start stop) of the whole field.") (DECLARE (USEDFREE PARSERESULT PARSEBEGIN)) (* ; "bound in parser") (LA.SKIP.TO.EOL STREAM) (if (AND PARSERESULT (= PARSEBEGIN (CADR (CAR PARSERESULT)))) then (* ; "two in a row--combine them") (CL:SETF (CADR (CAR PARSERESULT)) (GETFILEPTR STREAM)) else (push PARSERESULT (LIST PARSEBEGIN (GETFILEPTR STREAM))))) -) (LAFITE.EAT.GVGV -(LAMBDA (STREAM) (* ; "Edited 6-Feb-89 14:18 by bvm") (DECLARE (USEDFREE PARSERESULT)) (* ;; "Called when we get to the CR at the end of the header. Now look for a section of thext beginning and ending in lines of the form GVGVGVGV...") (LET ((HERE (GETFILEPTR STREAM)) GVSTART GVEND) (if (AND (EQ (SKIPSEPRCODES STREAM) (CHARCODE G)) (PROGN (SETQ GVSTART (GETFILEPTR STREAM)) (bind CH until (EQ (SETQ CH (BIN STREAM)) (CHARCODE EOL)) always (OR (EQ CH (CHARCODE G)) (EQ CH (CHARCODE V))))) (SETQ GVEND (FFILEPOS "GVGVGV +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "30-Sep-2021 22:58:57"  +{DSK}KAPLAN>LOCAL>MEDLEY3.5>GIT-MEDLEY>LIBRARY>LAFITE>LAFITECOMMANDS.;1 163531 -" STREAM NIL NIL NIL T))) then (push PARSERESULT (LIST GVSTART GVEND))) (SETFILEPTR STREAM HERE) (* ; "Return STOP to tell parser to stop") (QUOTE STOP))) -) (\LAFITE.HARDCOPY.FROM.DISPLAY -(LAMBDA (TEXTSTREAM) (* ; "Edited 10-Jun-88 18:36 by bvm") (* ;; "Hardcopy command on title bar of message display -- like window hardcopy, but gets the title right and omits the end of message string.") (RESETLST (if LAFITEENDOFMESSAGESTR then (* ; "Hide end of message") (LET ((LEN (GETEOFPTR TEXTSTREAM)) (NC (NCHARS LAFITEENDOFMESSAGESTR)) (FIXEDLOOKS (TEXTPROP TEXTSTREAM (QUOTE LAFITEFIXEDLOOKS)))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (TEXTSTREAM LEN NC FIXEDLOOKS) (LET ((W (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM))) (if (AND W (OPENWP W) (EQ (WINDOWPROP W (QUOTE TEXTSTREAM)) TEXTSTREAM)) then (* ; "Don't screw around if the message isn't in the window anymore") (TEDIT.LOOKS TEXTSTREAM (QUOTE (INVISIBLE OFF)) (ADD1 (- LEN NC)) NC) (TEDIT.SETSEL TEXTSTREAM 1 0) (TEXTPROP TEXTSTREAM (QUOTE READONLY) T) (if FIXEDLOOKS then (LAFITE.SET.TAB.LOOKS TEXTSTREAM FIXEDLOOKS (TIMES 8 (CHARWIDTH (CHARCODE X) LAFITEFIXEDWIDTHFONT)))))))) TEXTSTREAM LEN NC FIXEDLOOKS)) (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (TEDIT.LOOKS TEXTSTREAM (QUOTE (INVISIBLE ON)) (ADD1 (- LEN NC)) NC) (if FIXEDLOOKS then (* ; "Change to the hardcopy tab width") (LAFITE.SET.TAB.LOOKS TEXTSTREAM FIXEDLOOKS (LAFITE.HARDCOPY.TAB.WIDTH))))) (TEDIT.HARDCOPY TEXTSTREAM NIL NIL (LET ((TMP (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM))) (AND TMP (SETQ TMP (WINDOWPROP TMP (QUOTE TITLE))) (if (EQ (CHCON1 TMP) (CHARCODE *)) then (* ; "Remove the * that says filtered") (SUBSTRING TMP 2) else TMP)))))) -) (LAFITE.HARDCOPY.TAB.WIDTH -(LAMBDA NIL (* ; "Edited 10-Jun-88 18:27 by bvm") (FIXR (TIMES (FQUOTIENT (CHARWIDTH (CHARCODE X) (FONTCOPY LAFITEFIXEDWIDTHFONT (QUOTE DEVICE) (QUOTE INTERPRESS))) (CONSTANT (FQUOTIENT 2540 72))) 8))) -) ) (DEFINEQ (\LAFITE.SET.LOOKS.FROM.MENU -(LAMBDA (TEXTSTREAM) (* ; "Edited 22-Sep-87 12:43 by bvm:") (LAFITE.SET.LOOKS TEXTSTREAM T))) (\LAFITE.SET.DEFAULT.LOOKS -(LAMBDA (TEXTSTREAM) (* ; "Edited 22-Sep-87 12:33 by bvm:") (LAFITE.SET.LOOKS TEXTSTREAM LAFITEDISPLAYFONT)) -) (\LAFITE.SET.FIXED.LOOKS -(LAMBDA (TEXTSTREAM) (* ; "Edited 22-Sep-87 12:43 by bvm:") (LAFITE.SET.LOOKS TEXTSTREAM LAFITEFIXEDWIDTHFONT)) -) (LAFITE.SET.LOOKS -(LAMBDA (TEXTSTREAM NEWLOOKS PARALOOKS OMITHEADER USERFN) (* ; "Edited 3-Nov-89 14:50 by bvm") (* ;; "Called from Looks (sub)commands of Lafite display window. Change the looks of the current selection (if there is an interesting one) or the whole message to be NEWLOOKS. If NEWLOOKS is T, we use TEdit's menu interface. PARALOOKS is for paragraph formatting. USERFN is arbitrary function called with arg textstream & selection set appropriately. Any of NEWLOOKS, PARALOOKS, USERFN can be NIL. If OMITHEADER is true, the header is left out of the modification if user has not selected a region of text already.") (RESETLST (RESETSAVE NIL (LIST (QUOTE TEXTPROP) TEXTSTREAM (QUOTE READONLY) T)) (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (LET ((SEL (TEDIT.GETSEL TEXTSTREAM)) START LEN WIDTH FIXEDLOOKS) (if (AND (NOT PARALOOKS) (FONTP NEWLOOKS) (EQ (SETQ WIDTH (CHARWIDTH (CHARCODE "i") NEWLOOKS)) (CHARWIDTH (CHARCODE "W") NEWLOOKS))) then (* ; "If font is fixed-width, let's make the tab the right width. Might be nice to restore default tab if it's not fixed-width, but TEdit apparently doesn't support that.") (SETQ FIXEDLOOKS (SETQ PARALOOKS (BQUOTE (TABS ((\, (TIMES WIDTH 8)))))))) (if (> (SETQ LEN (fetch (SELECTION DCH) of SEL)) 1) then (* ; "User has already selected something. Assume any selection greater than a single character is not accidental.") (if (AND FIXEDLOOKS (NEQ (SETQ FIXEDLOOKS (TEXTPROP TEXTSTREAM (QUOTE LAFITEFIXEDLOOKS))) T)) then (* ;; "Record the portions we have so marked, so hardcopy can work right--T means everything. If FIXEDLOOKS is false, might want to unset, but that's tedious, unlikely to be worth the hairy code") (TEXTPROP TEXTSTREAM (QUOTE LAFITEFIXEDLOOKS) (CONS (CONS (fetch (SELECTION CH#) of SEL) LEN) FIXEDLOOKS))) else (SETQ START (if OMITHEADER then (* ; "Start after the blank line following the header") (\LAFITE.HEADER.EOF TEXTSTREAM) else 0)) (SETQ LEN (- (GETEOFPTR TEXTSTREAM) (if LAFITEENDOFMESSAGESTR then (NCHARS LAFITEENDOFMESSAGESTR) else 0) START)) (TEDIT.SETSEL TEXTSTREAM (ADD1 START) LEN (QUOTE RIGHT)) (if FIXEDLOOKS then (* ; "The whole thing is fixed now") (TEXTPROP TEXTSTREAM (QUOTE LAFITEFIXEDLOOKS) T))) (* ;; "Now do the modification") (if (EQ NEWLOOKS T) then (* ; "Use menu") (\TEDIT.LOOKS (TEXTOBJ TEXTSTREAM)) elseif NEWLOOKS then (TEDIT.LOOKS TEXTSTREAM NEWLOOKS)) (if PARALOOKS then (* ; "Paragraph looks") (TEDIT.PARALOOKS TEXTSTREAM PARALOOKS)) (if USERFN then (* ; "Arbitrary user manipulation.") (CL:FUNCALL USERFN TEXTSTREAM)) (* ;; "Finally, set selection back to where it was.") (TEDIT.SETSEL TEXTSTREAM SEL)))) -) (LAFITE.SET.TAB.LOOKS -(LAMBDA (TEXTSTREAM FIXEDLOOKS TABWIDTH) (* ; "Edited 11-Jun-88 17:07 by bvm") (LET ((LOOKS (BQUOTE (TABS ((\, TABWIDTH))))) (SEL (TEDIT.GETSEL TEXTSTREAM))) (if (EQ FIXEDLOOKS T) then (TEDIT.PARALOOKS TEXTSTREAM LOOKS 1 (GETEOFPTR TEXTSTREAM)) else (for PAIR in FIXEDLOOKS do (TEDIT.PARALOOKS TEXTSTREAM LOOKS (CAR PAIR) (CDR PAIR)))) (* ; "Finally, restore selection") (TEDIT.SETSEL TEXTSTREAM SEL))) -) (LAFITE.SET.PARA.SEPARATION -(LAMBDA (TEXTSTREAM) (* ; "Edited 29-Aug-89 14:53 by bvm") (LAFITE.SET.LOOKS TEXTSTREAM NIL (QUOTE (PARALEADING 10)) T)) -) (LAFITE.SET.LOWER.CASE -(LAMBDA (TEXTSTREAM) (* ; "Edited 7-Nov-89 13:06 by bvm") (* ;; "Called from Looks (sub)commands of Lafite display window. Change the current selection (if there is an interesting one) or the whole message to be lowercase.") (LAFITE.SET.LOOKS TEXTSTREAM NIL NIL T (FUNCTION (LAMBDA (TEXTSTREAM) (LET ((STR (TEDIT.SEL.AS.STRING TEXTSTREAM))) (TEDIT.DELETE TEXTSTREAM) (TEDIT.INSERT TEXTSTREAM (L-CASE STR))))))) -) (LAFITE.SUBSTITUTE.VP.EOL -(LAMBDA (TEXTSTREAM) (* ; "Edited 4-Aug-89 16:55 by bvm") (* ;; "Called from Looks (sub)commands of Lafite display window. Replace VP eol (29) with ours.") (RESETLST (RESETSAVE NIL (LIST (QUOTE TEXTPROP) TEXTSTREAM (QUOTE READONLY) T)) (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (LET* ((SEL (TEDIT.GETSEL TEXTSTREAM)) (LEN (fetch (SELECTION DCH) of SEL)) POS) (if (<= LEN 1) then (* ; "If user has already selected something (more than a single character), assume is not accidental.") (SETQ POS (CADAR (LAFITE.PARSE.HEADER TEXTSTREAM NIL NIL NIL NIL T))) (TEDIT.SETSEL TEXTSTREAM POS (- (GETEOFPTR TEXTSTREAM) (if LAFITEENDOFMESSAGESTR then (NCHARS LAFITEENDOFMESSAGESTR) else 0) POS))) (TEDIT.SUBSTITUTE TEXTSTREAM (ALLOCSTRING 1 29) (ALLOCSTRING 1 (CHARCODE EOL))) (if POS then (* ; "Undo the selection") (TEDIT.SETSEL TEXTSTREAM 1 0))))) -) ) (RPAQ? \LAFITE.DISPLAY.COMMANDS NIL) (ADDTOVAR LAFITE.EXTRA.DISPLAY.COMMANDS ("Looks" '\LAFITE.SET.LOOKS.FROM.MENU "Change the appearance of the selected text, or whole message if nothing selected" ) ("Hardcopy" '\LAFITE.HARDCOPY.FROM.DISPLAY "Hardcopy this message in its current appearance") ("Unhide" '\LAFITE.UNHIDE.HEADERS "Display the header fields that are hidden from view." (SUBITEMS ("Hide" '\LAFITE.REHIDE.HEADERS "Hide uninteresting fields from view again" )))) (ADDTOVAR LAFITE.LOOKS.SUBCOMMANDS ("VP Line Breaks" 'LAFITE.SUBSTITUTE.VP.EOL "Replace the Viewpoint end of line character with ours." ) ("Lowercase" 'LAFITE.SET.LOWER.CASE "Lowercase the region or whole message.") ("Spread Paragraphs" 'LAFITE.SET.PARA.SEPARATION "Separate paragraphs by 10 points (useful for Tioga messages)." ) ("Default" '\LAFITE.SET.DEFAULT.LOOKS "Change selection (or whole text) back to default font" ) ("Fixed Width" '\LAFITE.SET.FIXED.LOOKS "Change selection (or whole text) to fixed-width font")) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LAFITE.DISPLAY.COMMANDS) ) (* ; "DELETE") (DEFINEQ (LAFITE.DELETE.MESSAGES -(LAMBDA (FOLDER MESSAGES) (* ; "Edited 31-Aug-88 12:47 by bvm") (* ;; "Programmatic entrypoint to delete a single MSG (# or msg object) from FOLDER. FOLDER must have a browser.") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (for MSG inside MESSAGES do (DELETEMESSAGE (if (type? LAFITEMSG MSG) then MSG else (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) MSG)) FOLDER)))) -) (\LAFITE.DELETE -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* ; "Edited 30-Aug-88 11:42 by bvm") (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (OR (LAB.ASSURE.SELECTIONS MAILFOLDER) (for MSGDESCRIPTOR selectedin MAILFOLDER when (NOT (fetch (LAFITEMSG DELETED?) of MSGDESCRIPTOR)) do (* ; "delete all the currrently selected messages that aren't already deleted") (DELETEMESSAGE MSGDESCRIPTOR MAILFOLDER) finally (SHADEITEM ITEM MENU WHITESHADE) (DISPLAYAFTERDELETE MAILFOLDER WINDOW))))) -) (DISPLAYAFTERDELETE -(LAMBDA (FOLDER WINDOW) (* ; "Edited 29-Aug-88 15:34 by bvm") (* ;;; "Maybe select and maybe display the next message after a deletion, according to setting of LAFITEDISPLAYAFTERDELETEFLG --- T means display next if the deleted one is the one currently displayed and the next message is undeleted and unseen --- ALWAYS means display the next undeleted message if the deleted one is the one currently displayed; if it's not currently displayed, merely select the next undeleted message --- MULTIPLE means ALWAYS plus when the selection is multiple, still advance to next undeleted msg.") (COND (LAFITEDISPLAYAFTERDELETEFLG (LET ((FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER)) CURRENT LASTMSG# MESSAGES MENU) (COND ((NEQ FIRST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER)) (* ;; "More than one message was selected. Only do something if flag says MULTIPLE -- select but don't display next message") (COND ((EQ LAFITEDISPLAYAFTERDELETEFLG (QUOTE MULTIPLE)) (\LAFITE.SELECT.NEXT FOLDER FIRST#)))) ((OR (NOT (SETQ CURRENT (fetch (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER))) (NEQ FIRST# (fetch (LAFITEMSG %#) of CURRENT))) (* ; "Deleted message is not the one currently displayed") (SELECTQ LAFITEDISPLAYAFTERDELETEFLG ((ALWAYS MULTIPLE) (* ; "select but don't display next message") (\LAFITE.SELECT.NEXT FOLDER FIRST#)) NIL)) ((SELECTQ LAFITEDISPLAYAFTERDELETEFLG ((ALWAYS MULTIPLE) (* ; "Always do it, assuming there's a next message") (\LAFITE.SELECT.NEXT FOLDER FIRST#)) (AND (NEQ FIRST# (SETQ LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) (NOT (fetch (LAFITEMSG DELETED?) of (NTHMESSAGE (SETQ MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (ADD1 FIRST#)))) (for I from (ADD1 FIRST#) to LASTMSG# bind NEXTMSG do (* ;; "Next message undeleted, so maybe display it. LAFITEDISPLAYAFTERDELETEFLG = T means only do so if it is unexamined. However, messages from us are usually already examined, so pretend the message is unexamined if there is some unexamined message immediately after any from me") (COND ((NOT (fetch (LAFITEMSG SEEN?) of (SETQ NEXTMSG (NTHMESSAGE MESSAGES I)))) (* ; "An unexamined message, ok") (RETURN T)) ((NOT (fetch (LAFITEMSG MSGFROMMEP) of NEXTMSG)) (* ; "Not from me, but examined, so must not be in the stream of new mail") (RETURN NIL)))))) (\LAFITE.DISPLAY WINDOW FOLDER (LA.MENU.ITEM (FUNCTION \LAFITE.DISPLAY) (SETQ MENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER))) MENU))))))) -) (\LAFITE.SELECT.NEXT -(LAMBDA (MAILFOLDER AFTER#) (* ; "Edited 23-Aug-88 18:35 by bvm") (* ;;; "Select the next undeleted message in MAILFOLDER following AFTER# and return the msg, or NIL if there are no more") (for N from (ADD1 AFTER#) to (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) bind (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) MSG unless (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES N))) do (RETURN (LAB.GO.TO.MESSAGE MAILFOLDER MSG)))) -) (\LAFITE.UNDELETE -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* bvm%: "28-Mar-84 14:48") (RESETLST (LA.RESETSHADE ITEM MENU) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (OR (LAB.ASSURE.SELECTIONS MAILFOLDER) (for MSGDESCRIPTOR selectedin MAILFOLDER when (fetch (LAFITEMSG DELETED?) of MSGDESCRIPTOR) do (UNDELETEMESSAGE MSGDESCRIPTOR MAILFOLDER)))))) -) ) (* ; "MOVE") (DEFINEQ (LAFITE.MOVE.MESSAGES -(LAMBDA (SOURCEFOLDER DESTINATIONFOLDER MESSAGES COPYFLG) (* ; "Edited 13-Sep-88 18:38 by bvm") (* ;; "Programmatic entry to move (or copy if COPYFLG true) specified MESSAGES from SOURCEFOLDER to DESTINATIONFOLDER. Returns T on success.") (AND MESSAGES (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of SOURCEFOLDER) (\LAFITE.MOVE.MESSAGES.INTERNAL SOURCEFOLDER DESTINATIONFOLDER (\COERCE.TO.MSGLST MESSAGES SOURCEFOLDER) NIL NIL COPYFLG)))) -) (\COERCE.TO.MSGLST -(LAMBDA (MSGLST FOLDER) (* ; "Edited 30-Aug-88 14:11 by bvm") (* ;; "Accepts a singleton or list of LAFITEMSG objects or numbers relative to FOLDER and returns a list of LAFITEMSG objects") (if (AND (CL:LISTP MSGLST) (for M in MSGLST always (type? LAFITEMSG M))) then MSGLST else (LET ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER))) (for M inside MSGLST collect (if (type? LAFITEMSG M) then M else (NTHMESSAGE MESSAGES M)))))) -) (\LAFITE.MOVETO -(LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY COPYFLG) (* ; "Edited 13-Sep-88 18:33 by bvm") (PROG ((BROWSERPROMPTWINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of MAILFOLDER)) LONGFORMP TOFILE OUTPUTFILE DESTINATIONFOLDER MIDDLESELECTED) (CLEARW BROWSERPROMPTWINDOW) (COND ((LAB.ASSURE.SELECTIONS MAILFOLDER) (* ; "Nothing to move") (RETURN))) (COND ((AND (EQ KEY (QUOTE MIDDLE)) (SETQ DESTINATIONFOLDER (fetch (MAILFOLDER DEFAULTMOVETOFILE) of MAILFOLDER))) (* ; "Accelerator: don't use menu. We will still re-obtain the destination folder below, since the pointer sitting in the folder may be to a long-closed folder.") (SETQ MIDDLESELECTED T) (SETQ OUTPUTFILE (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of DESTINATIONFOLDER))) (T (CL:MULTIPLE-VALUE-SETQ (TOFILE LONGFORMP) (\LAFITE.PROMPTFORFOLDER BROWSERPROMPTWINDOW)) (if (NULL TOFILE) then (RETURN NIL)) (SETQ OUTPUTFILE (LA.LONGFILENAME TOFILE LAFITEMAIL.EXT)) (COND ((STRING-EQUAL OUTPUTFILE (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of MAILFOLDER)) (LAB.PROMPTPRINT MAILFOLDER T "This IS " TOFILE ", can't move to there.") (RETURN NIL))))) (AND ITEM (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE)) (COND (LONGFORMP (* ; "if user had to type file longhand, don't confirm now (but there may be a confirmation for creation later on)")) ((SELECTQ LAFITEMOVETOCONFIRMFLG (NIL (* ; "never confirm") T) (LEFT (* ; "don't confirm when middle selected") MIDDLESELECTED) (MIDDLE (* ; "confirm ONLY when middle selected") (NOT MIDDLESELECTED)) NIL)) ((LAB.MOUSECONFIRM MAILFOLDER "Click LEFT to confirm ~A ~@[of ~D msgs ~]to ~A" (if COPYFLG then "copy" else "move") (AND (< (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER) (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER)) (for MSG selectedin MAILFOLDER sum (* ; "Count how many selected") 1)) (if DESTINATIONFOLDER then (fetch (MAILFOLDER SHORTFOLDERNAME) of DESTINATIONFOLDER) else (LA.SHORTFILENAME OUTPUTFILE LAFITEMAIL.EXT)))) (T (* ; "abort") (AND ITEM (SHADEITEM ITEM MENU WHITESHADE)) (RETURN NIL))) (\LAFITE.PROCESS (BQUOTE ((\, (FUNCTION \LAFITE.MOVETO.PROC)) (QUOTE (\, WINDOW)) (QUOTE (\, MAILFOLDER)) (QUOTE (\, OUTPUTFILE)) (QUOTE (\, ITEM)) (QUOTE (\, MENU)) NIL (QUOTE (\, COPYFLG)))) (QUOTE LAFITEMOVE)))) -) (\LAFITE.COPYTO -(LAMBDA (FOLDER ITEM MENU KEY) (* ; "Edited 13-Sep-88 18:37 by bvm") (LET ((MENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER))) (\LAFITE.MOVETO (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER) FOLDER (LA.MENU.ITEM (FUNCTION \LAFITE.MOVETO) MENU) MENU NIL T))) -) (\LAFITE.MOVETO.PROC -(LAMBDA (WINDOW SOURCEFOLDER DESTINATIONFULLNAME ITEM MENU FROM.AUTO.MENU COPYFLG) (* ; "Edited 13-Sep-88 18:24 by bvm") (* ;; "Move selected messages from SOURCEFOLDER to the folder named by OUTPUTFILE. If FROM.AUTO.MENU is true, it came from the auxiliary moveto menu. Note that MENU is thus not necessarily SOURCEFOLDER's menu.") (if (RESETLST (LA.RESETSHADE ITEM MENU) (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of SOURCEFOLDER) NIL T) (LET ((DESTINATIONFOLDER (LAFITE.OBTAIN.FOLDER DESTINATIONFULLNAME (QUOTE BOTH) SOURCEFOLDER :CONFIRM))) (if DESTINATIONFOLDER then (\LAFITE.MOVE.MESSAGES.INTERNAL SOURCEFOLDER DESTINATIONFOLDER (LAB.SELECTED.MESSAGES SOURCEFOLDER) FROM.AUTO.MENU T COPYFLG)))) then (if COPYFLG then (LAB.PROMPTPRINT SOURCEFOLDER "Copy completed.") else (DISPLAYAFTERDELETE SOURCEFOLDER WINDOW)))) -) (\LAFITE.MOVE.MESSAGES.INTERNAL -(LAMBDA (SOURCEFOLDER DESTINATIONFOLDER MSGLST FROM.AUTO.MENU INTERACTIVE COPYFLG) (* ; "Edited 5-Aug-93 19:50 by bvm") (* ;; "Move the messages in MSGLST from SOURCEFOLDER to DESTINATIONFOLDER. Caller must have acquired the lock on SOURCEFOLDER. FROM.AUTO.MENU means the call was from the auxiliary move menu; INTERACTIVE means it was interactive call vs. programmatic.") (PROG (OUTPUTSTREAM MSGDESCRIPTORS OLDMOVETO) (COND ((NOT (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of DESTINATIONFOLDER) T T)) (LAB.PROMPTPRINT SOURCEFOLDER T "Waiting for " (fetch (MAILFOLDER SHORTFOLDERNAME) of DESTINATIONFOLDER) " to become available...") (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of DESTINATIONFOLDER) NIL T) (LAB.PROMPTPRINT SOURCEFOLDER T))) (COND ((NOT (AND (\LAFITE.OPEN.FOLDER SOURCEFOLDER (QUOTE INPUT) NIL) (SETQ OUTPUTSTREAM (\LAFITE.OPEN.FOLDER DESTINATIONFOLDER (QUOTE BOTH) :OK SOURCEFOLDER)))) (* ; "Failed to open source or dest") (RETURN NIL))) (COND ((NEQ (SETQ OLDMOVETO (fetch (MAILFOLDER DEFAULTMOVETOFILE) of SOURCEFOLDER)) DESTINATIONFOLDER) (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of SOURCEFOLDER))) (replace (MAILFOLDER DEFAULTMOVETOFILE) of SOURCEFOLDER with DESTINATIONFOLDER) (WINDOWPROP WINDOW (QUOTE TITLE) (LAB.TITLE.STRING SOURCEFOLDER)) (if (AND OLDMOVETO (NOT FROM.AUTO.MENU) (OR LAFITE.AUTO.MOVE.MENU (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES)))) then (\LAFITE.ADD.TO.MOVE.MENU SOURCEFOLDER DESTINATIONFOLDER OLDMOVETO))))) (SETQ MSGDESCRIPTORS (for OLDMSG in MSGLST bind NEWMSG (INSTREAM _ (\LAFITE.OPEN.FOLDER SOURCEFOLDER (QUOTE INPUT))) collect (MAYBEVERIFYMSG OLDMSG SOURCEFOLDER) (SETFILEPTR OUTPUTSTREAM -1) (SETQ NEWMSG (NCREATE (QUOTE LAFITEMSG) OLDMSG)) (* ; "New descriptor looks a lot like old") (replace (LAFITEMSG BEGIN) of NEWMSG with (GETFILEPTR OUTPUTSTREAM)) (replace (LAFITEMSG MESSAGELENGTHCHANGED?) of NEWMSG with NIL) (replace (LAFITEMSG MARKSCHANGEDINFILE?) of NEWMSG with NIL) (replace (LAFITEMSG MARKSCHANGEDINTOC?) of NEWMSG with NIL) (replace (LAFITEMSG DELETED?) of NEWMSG with NIL) (replace (LAFITEMSG SELECTED?) of NEWMSG with NIL) (LA.PRINTHEADER OUTPUTSTREAM (- (fetch (LAFITEMSG MESSAGELENGTH) of OLDMSG) (fetch (LAFITEMSG STAMPLENGTH) of OLDMSG)) NEWMSG) (PROGN (* ; "Now the 3 flag bytes") (BOUT OUTPUTSTREAM UNDELETEDFLAG) (BOUT OUTPUTSTREAM (COND ((fetch (LAFITEMSG SEEN?) of OLDMSG) SEENFLAG) (T UNSEENFLAG))) (BOUT OUTPUTSTREAM (fetch (LAFITEMSG MARKCHAR) of OLDMSG)) (BOUT OUTPUTSTREAM (CHARCODE CR))) (COPYBYTES INSTREAM OUTPUTSTREAM (fetch (LAFITEMSG START) of OLDMSG) (fetch (LAFITEMSG END) of OLDMSG)) (if (NOT COPYFLG) then (MARKMESSAGE OLDMSG SOURCEFOLDER MOVETOMARK) (* ; "delete it") (DELETEMESSAGE OLDMSG SOURCEFOLDER)) NEWMSG)) (* ; "delete them from FROMFILE") (COND ((AND (fetch (MAILFOLDER BROWSERWINDOW) of DESTINATIONFOLDER) (fetch (MAILFOLDER BROWSERREADY) of DESTINATIONFOLDER)) (* ; "now print them in the other window, if up") (LAB.APPENDMESSAGES DESTINATIONFOLDER MSGDESCRIPTORS)) (T (* ; "still have to update eof") (replace (MAILFOLDER FOLDEREOFPTR) of DESTINATIONFOLDER with (GETEOFPTR OUTPUTSTREAM)))) (RETURN T))) -) ) (* ; "Aux move") (DEFINEQ (\LAFITE.ENABLE.MOVE.MENU -(LAMBDA (FOLDER) (* ; "Edited 31-Aug-88 12:39 by bvm") (* ;; "Bring up a menu of folders attached to FOLDER's browser for accelerated MoveTo") (LET* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (ITEMS (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES))) (OLDDEFAULT (fetch (MAILFOLDER DEFAULTMOVETOFILE) of FOLDER))) (LAB.PROMPTPRINT FOLDER T "Specify which folders to include in the accelerated menu.") (if OLDDEFAULT then (CL:PUSHNEW (fetch (MAILFOLDER SHORTFOLDERNAME) of OLDDEFAULT) ITEMS :TEST (QUOTE STRING-EQUAL))) (if (SETQ ITEMS (LAFITE.SELECT.FOLDERS ITEMS)) then (* ; "Didn't abort") (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES) ITEMS) (\LAFITE.UPDATE.MOVE.MENU FOLDER T)) (LAB.PROMPTPRINT FOLDER T))) -) (\LAFITE.ADD.TO.MOVE.MENU -(LAMBDA (FOLDER NEWFOLDER OLDFOLDER) (* ; "Edited 31-Aug-88 12:43 by bvm") (* ;; "Add NEWFOLDER to FOLDER's auto move menu, creating it if necessary, in which case also include OLDFOLDER") (PROG* ((NEWNAME (fetch (MAILFOLDER SHORTFOLDERNAME) of NEWFOLDER)) (WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (OLDITEMS (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES))) (ITEMS OLDITEMS)) (COND ((NULL ITEMS) (SETQ ITEMS (LIST NEWNAME)) (if OLDFOLDER then (push ITEMS (fetch (MAILFOLDER SHORTFOLDERNAME) of OLDFOLDER)))) ((CL:MEMBER NEWNAME ITEMS :TEST (QUOTE STRING-EQUAL)) (* ; "Nothing new to do") (RETURN)) (T (push ITEMS NEWNAME))) (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES) ITEMS) (\LAFITE.UPDATE.MOVE.MENU FOLDER (NULL OLDITEMS)))) -) (\LAFITE.UPDATE.MOVE.MENU -(LAMBDA (FOLDER FORCE) (* ; "Edited 23-Aug-89 12:21 by bvm") (* ;; "Called when someone has changed the set of folder names in FOLDER's auto move menu. This function creates a new menu. If the menu is not currently open, we don't open one unless FORCE is true.") (PROG* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (MENUW (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.MENU))) HOW POSITION TITLE) (if (NOT (OPENWP WINDOW)) then (* ; "Maybe the browser is shrunk. The system doesn't know how to attach to shrunken windows, so just punt it") (RETURN) elseif MENUW then (* ; "Remove the old window and make a new") (DETACHWINDOW MENUW WINDOW) (CLOSEW MENUW) elseif (NULL FORCE) then (RETURN)) (SETQ POSITION (SELECTQ (SETQ HOW LAFITE.AUTO.MOVE.MENU) ((LEFT RIGHT) (QUOTE TOP)) ((BOTTOM TOP) (QUOTE LEFT)) (PROGN (SETQ HOW (QUOTE RIGHT)) (QUOTE TOP)))) (CL:MULTIPLE-VALUE-BIND (NCOLUMNS ITEMS) (\LAFITE.ARRANGE.MENU (APPEND (SORT (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES)) (FUNCTION UALPHORDER)) (AND LAFITE.EXTRA.MOVE.ITEMS (CONS (QUOTE ("" (QUOTE NILL) "")) LAFITE.EXTRA.MOVE.ITEMS))) LAFITE.FOLDER.MENU.FONT (- (LET* ((REG (WINDOWREGION WINDOW)) (BROWSERHEIGHT (fetch (REGION HEIGHT) of REG))) (if (EQ POSITION (QUOTE TOP)) then (* ; "Don't make the menu much taller than the window or below bottom of screen") (MIN (+ BROWSERHEIGHT (IQUOTIENT BROWSERHEIGHT 2)) (fetch (REGION TOP) of REG)) else (* ; "Don't make it taller than the screen") (- SCREENHEIGHT BROWSERHEIGHT))) (FONTPROP WINDOWTITLEFONT (QUOTE HEIGHT))) (SETQ TITLE "Move To:")) (SETQ MENUW (MENUWINDOW (create MENU ITEMS _ ITEMS MENUCOLUMNS _ NCOLUMNS CENTERFLG _ T TITLE _ TITLE WHENHELDFN _ (FUNCTION (LAMBDA (ITEM) (PROMPTPRINT (if (LISTP ITEM) then (CADDR ITEM) else "Move the selected message(s) to this folder")))) WHENSELECTEDFN _ (FUNCTION \LAFITE.HANDLE.AUTO.MOVE) MENUFONT _ LAFITE.FOLDER.MENU.FONT MENUTITLEFONT _ WINDOWTITLEFONT)))) (ATTACHWINDOW MENUW WINDOW HOW POSITION (QUOTE LOCALCLOSE)) (WINDOWADDPROP MENUW (QUOTE CLOSEFN) (FUNCTION (LAMBDA (W) (* ;; "Remove pointer to me. Note that this fn must come first, before detachwindow") (AND (SETQ W (MAINWINDOW W)) (WINDOWPROP W (QUOTE LAFITE.AUTO.MOVE.MENU) NIL)))) T) (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.MENU) MENUW))) -) (\LAFITE.RESTORE.MOVE.MENU -(LAMBDA (FOLDER) (* ; "Edited 31-Aug-88 15:19 by bvm") (LET* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (ITEMS (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES)))) (if ITEMS then (* ; "Yes, there was a menu, so bring it up") (\LAFITE.UPDATE.MOVE.MENU FOLDER T) else (* ; "Start from scratch") (\LAFITE.ENABLE.MOVE.MENU FOLDER)))) -) (\LAFITE.HANDLE.AUTO.MOVE -(LAMBDA (ITEM MENU KEY) (* ; "Edited 29-Aug-88 15:06 by bvm") (* ;; "Handle the selection of an item from Lafite's auto moveto menu. Just do the specified move") (LET ((MENUW (WFROMMENU MENU)) WINDOW FOLDER) (AND MENUW (SETQ WINDOW (MAINWINDOW MENUW)) (SETQ FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) (fetch (MAILFOLDER BROWSERREADY) of FOLDER) (if (LISTP ITEM) then (* ; "Handle other commands") (CL:FUNCALL (EXTRACTMENUCOMMAND ITEM) WINDOW FOLDER ITEM MENU KEY) else (\LAFITE.PROCESS (BQUOTE ((\, (FUNCTION \LAFITE.MOVETO.PROC)) (QUOTE (\, WINDOW)) (QUOTE (\, FOLDER)) (QUOTE (\, (LA.LONGFILENAME ITEM LAFITEMAIL.EXT))) (QUOTE (\, ITEM)) (QUOTE (\, MENU)) T)) (QUOTE LAFITEMOVE)))))) -) ) (ADDTOVAR LAFITEEXTRAMENUITEMS ("Enable MoveTo Menu" '\LAFITE.ENABLE.MOVE.MENU "Attach a menu of folders for accelerated MoveTo (or modify existing one)" (SUBITEMS ("Restore MoveTo Menu" '\LAFITE.RESTORE.MOVE.MENU "Just reopen the attached MoveTo menu if it existed." ))) ("Copy To" '\LAFITE.COPYTO "Like MoveTo, but don't delete the message(s).")) (ADDTOVAR LAFITE.EXTRA.MOVE.ITEMS ("---Display---" '\LAFITE.DISPLAY "Display the next message") ("---Delete---" '\LAFITE.DELETE "Delete the selected message(s)")) (RPAQ? LAFITE.AUTO.MOVE.MENU ) (* ; "UPDATE") (DEFINEQ (\LAFITE.UPDATE -(LAMBDA (WINDOW FOLDER ITEM MENU BUTTONS) (* ; "Edited 25-Apr-89 15:10 by bvm") (LET ((HOWINDEX (LAB.UPDATE.NEEDED? FOLDER)) HOW? HOWSTRING CLOSEFLG CONFIRMFLG) (\LAFITE.MAYBE.CLEAR.PROMPT FOLDER) (if (AND (EQ BUTTONS (QUOTE MIDDLE)) LAFITE.MIDDLE.UPDATE) then (* ; "Accelerator: do what this flag says, asking only for confirmation first") (for OP inside LAFITE.MIDDLE.UPDATE do (CASE OP ((:CLOSE :SHRINK) (SETQ CLOSEFLG OP)) ((:UPDATE :EXPUNGE) (SETQ HOWSTRING (if (AND (EQ OP :EXPUNGE) (BITTEST HOWINDEX \EXPUNGE.MENU.BIT)) then (* ; "Expunge is needed and requested") (SETQ HOW? (FUNCTION \LAFITE.EXPUNGE.PROC)) "Expunge" elseif (BITTEST HOWINDEX \SORT.MENU.BIT) then (* ; "Have to do wtih expunge") (SETQ HOW? (FUNCTION \LAFITE.EXPUNGE.PROC)) "Write sorted" elseif (BITTEST HOWINDEX \EXPUNGE&SORT.MENU.BIT) then (* ; "Have to do wtih expunge") (SETQ HOW? (FUNCTION \LAFITE.EXPUNGE.PROC)) "Expunge (write sorted)" elseif (BITTEST HOWINDEX \UPDATE.MENU.BIT) then (SETQ HOW? (FUNCTION \LAFITE.UPDATE.PROC)) "Write out changes" elseif (BITTEST HOWINDEX \TOC.MENU.BIT) then (SETQ HOW? (FUNCTION \LAFITE.UPDATE.PROC)) "Update table of contents")) (if (BITTEST HOWINDEX \HARDCOPY.MENU.BIT) then (* ; "Also might want to hardcopy") (SETQ HOWSTRING (if (NULL HOW?) then (SETQ HOW? (FUNCTION \LAFITE.HARDCOPYONLY.PROC)) "Hardcopy" else (CONCAT "Hardcopy, " HOWSTRING))) elseif (NULL HOW?) then (* ; "Pretend no update is needed, even if left-update would have said Expunge") (SETQ HOWINDEX 0))) (:CONFIRM (SETQ CONFIRMFLG T))))) (if (AND (NULL CLOSEFLG) (EQ 0 HOWINDEX)) then (* ; "We weren't asked to close it, and nothing changed.") (LAB.PROMPTPRINT FOLDER T "No changes since the last Update") elseif (SETQ HOW? (if (OR HOWSTRING CLOSEFLG) then (if (AND (NULL HOWSTRING) (EQ CLOSEFLG :SHRINK)) then (* ; "Accelerator says Shrink, and there is nothing else to do, so just shrink") (FUNCTION \LAFITE.FINISH.UPDATE) elseif (OR (NULL CONFIRMFLG) (LAB.MOUSECONFIRM FOLDER (CONCATLIST (CONS "Click LEFT to confirm " (LET ((CF (AND CLOSEFLG (LIST (L-CASE CLOSEFLG T))))) (if HOWSTRING then (LIST* HOWSTRING (AND CF (CONS " and " CF))) else CF)))))) then (OR HOW? (FUNCTION \LAFITE.FINISH.UPDATE))) else (MENU (LAB.CHOOSE.UPDATE.MENU HOWINDEX)))) then (\LAFITE.PROCESS (LIST HOW? (KWOTE WINDOW) (KWOTE FOLDER) CLOSEFLG (KWOTE ITEM) (KWOTE MENU)) (QUOTE LAFITEUPDATE))))) -) (\LAFITE.EXPUNGE.PROC -(LAMBDA (WINDOW MAILFOLDER CLOSEFLG ITEM MENU) (* ; "Edited 1-May-89 12:53 by bvm") (RESETLST (\LAFITE.START.UPDATE MAILFOLDER ITEM MENU) (\LAFITE.CLOSE.DISPLAYWINDOWS MAILFOLDER) (CLEARW WINDOW) (\LAFITE.COMPACT.FOLDER MAILFOLDER) (\LAFITE.CLOSE.FOLDER MAILFOLDER T) (COND (CLOSEFLG (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of MAILFOLDER with 0)) (T (LAB.DISPLAYFOLDER MAILFOLDER)))) (* ; "Do the following outside RESETLST so that Update gets unshaded") (\LAFITE.FINISH.UPDATE WINDOW MAILFOLDER CLOSEFLG)) -) (\LAFITE.UPDATE.PROC -(LAMBDA (WINDOW MAILFOLDER CLOSEFLG ITEM MENU) (* ; "Edited 14-Oct-87 20:00 by bvm:") (RESETLST (\LAFITE.START.UPDATE MAILFOLDER ITEM MENU) (COND ((OR (COND ((fetch (MAILFOLDER FOLDERNEEDSUPDATE) of MAILFOLDER) (\LAFITE.UPDATE.FOLDER MAILFOLDER) T)) (NEQ (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) (fetch (MAILFOLDER TOCLASTMESSAGE#) of MAILFOLDER))) (\LAFITE.UPDATE.CONTENTS MAILFOLDER (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER))) (T (LAB.PROMPTPRINT MAILFOLDER T "No changes since last update"))) (\LAFITE.CLOSE.FOLDER MAILFOLDER T)) (* ; "Do the following outside RESETLST so that Update gets unshaded") (\LAFITE.FINISH.UPDATE WINDOW MAILFOLDER CLOSEFLG)) -) (\LAFITE.HARDCOPYONLY.PROC -(LAMBDA (WINDOW MAILFOLDER CLOSEFLG ITEM MENU) (* ; "Edited 29-Aug-88 17:49 by bvm") (* ;; "Called by Update or Close to just do pending hardcopy, nothing else") (RESETLST (LAB.START.COMMAND MAILFOLDER (FUNCTION \LAFITE.UPDATE) ITEM MENU) (\LAFITE.DO.PENDING.HARDCOPY MAILFOLDER)) (\LAFITE.FINISH.UPDATE WINDOW MAILFOLDER CLOSEFLG)) -) (LAB.CHOOSE.UPDATE.MENU -(LAMBDA (FOLDER CLOSEFLG) (* ; "Edited 25-Apr-89 15:10 by bvm") (* ;; "Returns a menu for prompting the user about what to do with FOLDER when Update is requested, or if CLOSEFLG is true, if Close/Shrink is requested. Returns NIL if there is no interesting choice.") (LET ((INDEX (OR (FIXP FOLDER) (LAB.UPDATE.NEEDED? FOLDER)))) (if (NEQ INDEX 0) then (CASE CLOSEFLG (:CLOSE (SETQ INDEX (LOGOR INDEX \CLOSE.MENU.BIT))) (:SHRINK (SETQ INDEX (LOGOR INDEX \SHRINK.MENU.BIT)))) (OR (GETHASH INDEX LAFITE.UPDATE.MENU.HASH) (LAB.CREATE.UPDATE.MENU INDEX))))) -) (LAB.CREATE.UPDATE.MENU -(LAMBDA (INDEX) (* ; "Edited 25-Apr-89 15:08 by bvm") (* ;; "Create a menu to ask about updating. There is a bit in INDEX for each possible thing you might want to do to update this folder -- Update, Expunge, Update TOC, Hardcopy, Expunge&Sort. Not all bit combinations are possible. In practice, only a small number of combinations actually occur, so we remember menus in a hash table.") (LET* ((LASTITEM NIL) (ITEMS (for ITEM in LAFITEUPDATEMENUITEMS as (BIT _ 1) by (LLSH BIT 1) when (BITTEST INDEX BIT) collect (if (NOT (BITTEST INDEX (LOGOR \CLOSE.MENU.BIT \SHRINK.MENU.BIT))) then (SETQ LASTITEM ITEM)) ITEM)) MENU) (if (STRPOS "Only" (CAR LASTITEM) -4 NIL T NIL UPPERCASEARRAY) then (* ; "Sounds funny if last item says %"Only%"") (RPLACA (FMEMB LASTITEM ITEMS) (CONS (SUBSTRING (CAR LASTITEM) 1 -6) (CDR LASTITEM)))) (SETQ MENU (\LAFITE.CREATE.MENU ITEMS (if (BITTEST INDEX \CLOSE.MENU.BIT) then "Close Options" elseif (BITTEST INDEX \SHRINK.MENU.BIT) then "Shrink Options" else "Update Options"))) (PUTHASH INDEX MENU LAFITE.UPDATE.MENU.HASH) MENU)) -) (LAB.UPDATE.NEEDED? -(LAMBDA (FOLDER) (* ; "Edited 25-Apr-89 15:08 by bvm") (* ;; "Returns an integer whose bits indicate the type of updating needed by FOLDER; zero if it needs none.") (LOGOR (COND ((fetch (MAILFOLDER HARDCOPYSTREAM) of FOLDER) \HARDCOPY.MENU.BIT) (T 0)) (if (NOT (fetch (MAILFOLDER FOLDEROUTOFORDER) of FOLDER)) then (LOGOR (if (fetch (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER) then \UPDATE.MENU.BIT elseif (NEQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) (fetch (MAILFOLDER TOCLASTMESSAGE#) of FOLDER)) then (* ; "Update toc if messages have been appended") \TOC.MENU.BIT else 0) (if (fetch (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER) then \EXPUNGE.MENU.BIT else 0)) elseif (fetch (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER) then \EXPUNGE&SORT.MENU.BIT else \SORT.MENU.BIT))) -) (\LAFITE.START.UPDATE -(LAMBDA (MAILFOLDER ITEM MENU) (* ; "Edited 18-Jul-88 11:56 by bvm") (* ;; "Called under a RESETLST to start an UPDATE or EXPUNGE") (LAB.START.COMMAND MAILFOLDER (FUNCTION \LAFITE.UPDATE) ITEM MENU) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (MAILFOLDER) (replace (MAILFOLDER FOLDERBEINGUPDATED) of MAILFOLDER with NIL))) MAILFOLDER)) (* ; "Mark folder being updated for benefit of LOGOUT check") (replace (MAILFOLDER FOLDERBEINGUPDATED) of MAILFOLDER with T) (* ; "Close all other folders, so MoveTo's are up to date") (\LAFITE.CLOSE.OTHER.FOLDERS MAILFOLDER) (\LAFITE.DO.PENDING.HARDCOPY MAILFOLDER MENU)) -) (LAB.START.COMMAND -(LAMBDA (MAILFOLDER CMD ITEM MENU) (* ; "Edited 18-Jul-88 11:56 by bvm") (* ;; "Shades MAILFOLDER's command implemented by CMD, or ITEM of MENU if supplied and obtains the folder lock. Opens browser window if it is shrunk. Must be called under RESETLST surrounding command execution.") (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER))) (if (AND WINDOW (NOT (OPENWP WINDOW))) then (EXPANDW WINDOW))) (LA.RESETSHADE (OR ITEM (LA.MENU.ITEM CMD (SETQ MENU (fetch (MAILFOLDER BROWSERMENU) of MAILFOLDER)))) MENU) (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) NIL T) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER)) -) (\LAFITE.FINISH.UPDATE -(LAMBDA (WINDOW MAILFOLDER CLOSEFLG) (* ; "Edited 7-Jun-88 14:28 by bvm") (* ;;; "Takes care of closing/shrinking WINDOW after an update or expunge.") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (CASE CLOSEFLG ((:CLOSE :EXIT) (WITH.MONITOR \LAFITE.BROWSELOCK (\LAFITE.CLOSE.FOLDER MAILFOLDER T) (SETQ WINDOW (LAB.FLUSHWINDOW WINDOW MAILFOLDER)) (CLOSEW WINDOW) (COND ((AND (NEQ CLOSEFLG :EXIT) (OR (NOT (fetch (MAILFOLDER FOLDEREOFPTR) of MAILFOLDER)) (= (fetch (MAILFOLDER FOLDEREOFPTR) of MAILFOLDER) 0)) (EQ (GETFILEINFO (fetch (MAILFOLDER FULLFOLDERNAME) of MAILFOLDER) (QUOTE LENGTH)) 0)) (* ;; "Folder is empty, and we are explicitly closing it (as opposed to indirectly via the Quit command), so delete underlying file, etc. FOLDEREOFPTR should always be right, but be paranoid and double-check with the file itself before deleting") (DELETEMAILFOLDER MAILFOLDER))))) (:SHRINK (\LAFITE.CLOSE.DISPLAYWINDOWS MAILFOLDER) (\LAFITE.CLOSE.FOLDER MAILFOLDER T) (WINDOWADDPROP WINDOW (QUOTE EXPANDFN) (FUNCTION LAB.EXPANDFN)) (WINDOWDELPROP WINDOW (QUOTE SHRINKFN) (FUNCTION LAB.SHRINKFN)) (SHRINKW WINDOW)))) (COND (\LAFITEPROFILECHANGED (\LAFITE.WRITE.PROFILE)))) -) (\LAFITE.CLOSE.OTHER.FOLDERS -(LAMBDA (THISFOLDER) (* bvm%: "31-Jul-84 15:17") (* ;; "Closes or flushes output of all Lafite folders except THISFOLDER. If a folder does not have an open browser, the file is closed; else output is flushed") (WITH.MONITOR \LAFITE.MAINLOCK (for FOLDER in \ACTIVELAFITEFOLDERS when (AND (NEQ FOLDER THISFOLDER) (fetch (MAILFOLDER FOLDERSTREAM) of FOLDER)) do (RESETLST (COND ((OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) T T) (\LAFITE.CLOSE.FOLDER FOLDER (NULL (OPENWP (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)))))))))) -) ) (DEFINEQ (LAB.FLUSHWINDOW -(LAMBDA (WINDOW MAILFOLDER) (* ; "Edited 18-Jul-88 11:37 by bvm") (\LAFITE.CLOSE.DISPLAYWINDOWS MAILFOLDER) (WINDOWDELPROP WINDOW (QUOTE CLOSEFN) (FUNCTION LAB.CLOSEFN)) (replace (MAILFOLDER BROWSERREADY) of MAILFOLDER with (replace (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER with (replace (MAILFOLDER DEFAULTMOVETOFILE) of MAILFOLDER with (replace (MAILFOLDER BROWSERMENUWINDOW) of MAILFOLDER with (replace (MAILFOLDER BROWSERWINDOW) of MAILFOLDER with (replace (MAILFOLDER BROWSERMENU) of MAILFOLDER with (replace (MAILFOLDER BROWSERPROMPTWINDOW) of MAILFOLDER with NIL))))))) (WINDOWPROP WINDOW (QUOTE MAILFOLDER) NIL) (SETQ \ACTIVELAFITEFOLDERS (DREMOVE MAILFOLDER \ACTIVELAFITEFOLDERS)) (OR (OPENWP WINDOW) (OPENWP (WINDOWPROP WINDOW (QUOTE ICONWINDOW))))) -) (LAB.APPENDMESSAGES -(LAMBDA (FOLDER NEWMESSAGEDESCRIPTORS) (* ; "Edited 28-Apr-89 15:47 by bvm") (* ;; "Append list of message descriptors to folder, adjusting display, etc as needed.") (PROG ((LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) FIRSTMSG#) (SETQ FIRSTMSG# (ADD1 LASTMSG#)) (replace (MAILFOLDER FOLDEREOFPTR) of FOLDER with (GETEOFPTR (fetch (MAILFOLDER FOLDERSTREAM) of FOLDER))) (for MSGDESCRIPTOR in NEWMESSAGEDESCRIPTORS do (replace (LAFITEMSG %#) of MSGDESCRIPTOR with (add LASTMSG# 1)) (LAFITE.PARSE.MSG.FOR.TOC MSGDESCRIPTOR FOLDER)) (replace (MAILFOLDER %#OFMESSAGES) of FOLDER with LASTMSG#) (replace (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER with (\LAFITE.ADDMESSAGES.TO.ARRAY (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) NEWMESSAGEDESCRIPTORS FIRSTMSG# LASTMSG#)) (LET ((EXTENT (fetch (MAILFOLDER BROWSEREXTENT) of FOLDER)) (HEIGHT (TIMES LASTMSG# (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER))) WINDOW) (replace (REGION HEIGHT) of EXTENT with HEIGHT) (replace (REGION BOTTOM) of EXTENT with (- (fetch (MAILFOLDER BROWSERORIGIN) of FOLDER) HEIGHT)) (WINDOWPROP (SETQ WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (QUOTE EXTENT) EXTENT) (COND ((OPENWP WINDOW) (* ; "If window is visible, update it now") (LAB.DISPLAYLINES FOLDER FIRSTMSG#)) ((NULL (fetch (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER)) (* ; "Mark browser for display update after being unshrunk") (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER with FIRSTMSG#)))))) -) (\LAFITE.COMPACT.FOLDER -(LAMBDA (FOLDER) (* ; "Edited 10-May-89 12:42 by bvm") (* ;;; "Expunge deleted messages from MAILFOLDER. We copy undeleted messages after the first deleted one into a scratch file and copy the scratch file back into the main file. Returns the msg # of the last message before the compacted section. This function must also be used if the folder is out of order.") (LET* ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) (FIRSTCHANGED# (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER)) (LASTGOODMSG# (SUB1 FIRSTCHANGED#)) (LASTLENGTH 0) (LASTBEGIN 0) FOLDERSTREAM MSG TOCSTREAM) (if (> FIRSTCHANGED# 1) then (* ; "Get this loop initialized") (SETQ MSG (NTHMESSAGE MESSAGES LASTGOODMSG#)) (SETQ LASTBEGIN (fetch (LAFITEMSG BEGIN) of MSG)) (SETQ LASTLENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) (* ;; "first see if there are any messages to delete or messages out of order and while doing so collect information for rapidly compacting the file just in case we have to. We check for out of order by maintaining previous pointer and length so as to avoid boxing most of the time.") (for MSG# from (MAX 1 FIRSTCHANGED#) to LASTMSG# until (OR (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES MSG#))) (NOT (= (- (fetch (LAFITEMSG BEGIN) of MSG) LASTBEGIN) LASTLENGTH))) do (COND ((fetch (LAFITEMSG MARKSCHANGEDINFILE?) of MSG) (WRITEFOLDERMARKBYTES MSG FOLDER (OR FOLDERSTREAM (SETQ FOLDERSTREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE BOTH) :ABORT)))))) (SETQ LASTGOODMSG# MSG#) (SETQ LASTBEGIN (fetch (LAFITEMSG BEGIN) of MSG)) (SETQ LASTLENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) (COND ((NEQ LASTGOODMSG# LASTMSG#) (SETQ TOCSTREAM (\LAFITE.COMPACT.FOLDER1 FOLDER (OR FOLDERSTREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE BOTH) :ABORT)) LASTGOODMSG#)))) (replace (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER with NIL) (replace (MAILFOLDER FOLDEROUTOFORDER) of FOLDER with NIL) (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER with (ADD1 (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) (\LAFITE.UPDATE.CONTENTS FOLDER LASTGOODMSG# TOCSTREAM))) -) (\LAFITE.COMPACT.FOLDER1 -(LAMBDA (FOLDER FOLDERSTREAM LASTGOODMSG#) (* ; "Edited 13-Jul-92 16:01 by bvm") (* ;;; "LASTGOODMSG# is the number of the last good message before the region to be compacted. FOLDERSTREAM is open for io.") (LET (SCRATCHFILE STATE ORIGEOF CONDITION TOCSTREAM) (CL:UNWIND-PROTECT (PROG ((*PRINT-BASE* 10) (*UPPER-CASE-FILE-NAMES* NIL) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (OLDLASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) (FIRSTSELECTED (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER)) (LASTSELECTED (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER)) COMPACTLENGTH GOODMSGSPTR MSGLIST RESULT NEWDATE) (LAB.PROMPTPRINT FOLDER "Compacting folder... ") (COND ((> LASTSELECTED LASTGOODMSG#) (* ; "There are selections in the compacting region") (COND ((> FIRSTSELECTED LASTGOODMSG#) (* ; "All selections are there, so recompute completely") (SETQ LASTSELECTED (SETQ FIRSTSELECTED NIL))) (T (* ; "Some selections before it, so only Last changes") (SETQ LASTSELECTED (LAB.REV.FIND.SELECTED.MSG FOLDER FIRSTSELECTED LASTGOODMSG#)))))) (SETQ GOODMSGSPTR (COND ((EQ LASTGOODMSG# 0) 0) (T (fetch (LAFITEMSG END) of (NTHMESSAGE MESSAGES LASTGOODMSG#))))) (* ; "End of the region that we leave alone") (SETQ COMPACTLENGTH (for I from (ADD1 LASTGOODMSG#) to OLDLASTMSG# bind MSG unless (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) sum (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) (COND ((NEQ COMPACTLENGTH 0) (if (if (EQ LASTGOODMSG# 0) then (* ; "WIll have to rewrite whole folder") (SMART-RENAMEFILEP FOLDERSTREAM) elseif (AND (fetch (MAILFOLDER FOLDEROUTOFORDER) of FOLDER) (SMART-RENAMEFILEP FOLDERSTREAM)) then (* ; "Will it be faster to write a brand new file and rename it to the destination than to do the overwriting stuff, given the extra messages we'll have to save on the end in case of disaster?") (> (\LAFITE.COMPACT.EXTRA FOLDER LASTGOODMSG# GOODMSGSPTR GOODMSGSPTR) GOODMSGSPTR)) then (SETQ SCRATCHFILE (OPENSTREAM (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE EXTENSION) (CONCAT (UNPACKFILENAME.STRING FOLDERSTREAM (QUOTE EXTENSION)) "-compacted") (QUOTE BODY) FOLDERSTREAM) (QUOTE OUTPUT) (QUOTE NEW) (BQUOTE ((LENGTH (\, (+ GOODMSGSPTR COMPACTLENGTH))) (SEQUENTIAL T) (TYPE LAFITE))))) (COPYBYTES FOLDERSTREAM SCRATCHFILE 0 GOODMSGSPTR) (LINELENGTH T SCRATCHFILE) (SETQ MSGLIST (\LAFITE.COMPACT.FOLDER2 FOLDER FOLDERSTREAM LASTGOODMSG# GOODMSGSPTR SCRATCHFILE T)) (SETQ SCRATCHFILE (CLOSEF SCRATCHFILE)) (SETQ NEWDATE (GETFILEINFO SCRATCHFILE (QUOTE ICREATIONDATE))) (SETQ FOLDERSTREAM (FULLNAME FOLDERSTREAM)) (\LAFITE.CLOSE.FOLDER FOLDER T) (SETQ STATE :NEW) (CL:MULTIPLE-VALUE-SETQ (RESULT CONDITION) (\LAFITE.RENAMEFILE SCRATCHFILE FOLDERSTREAM)) (if (NULL RESULT) then (RETURN) else (* ; "Scratch file now gone") (SETQ SCRATCHFILE NIL) (SETQ STATE :OPEN) (* ; "At this point, file is inconsistent with in-core structures.") (SETQ TOCSTREAM (\LAFITE.INVALIDATE.TOC FOLDER))) else (SETQ ORIGEOF (GETEOFPTR FOLDERSTREAM)) (* ; "Save info for abort") (SETQ STATE :APPEND) (SETQ MSGLIST (\LAFITE.COMPACT.FOLDER2 FOLDER FOLDERSTREAM LASTGOODMSG# GOODMSGSPTR (SETQ SCRATCHFILE (LA.OPENTEMPFILE (QUOTE SCRATCH) (QUOTE BOTH) (QUOTE NEW) COMPACTLENGTH)))) (* ;; "Up til now, you could abort and nothing bad would happen--the folder hasn't been written on yet.") (SETFILEPTR FOLDERSTREAM GOODMSGSPTR) (* ; "set the pointer to the end of the good messages") (SETQ STATE :OPEN) (* ; "We're about to make the world inconsistent") (SETQ TOCSTREAM (\LAFITE.INVALIDATE.TOC FOLDER)) (COPYBYTES SCRATCHFILE FOLDERSTREAM 0 -1) (* ; "copy the scratch file to the end of the good messages left in the original file") (FORCEOUTPUT FOLDERSTREAM) (* ; "Ensure that all those writes succeeded, before we update core and truncate the file below.")) (for MSG in MSGLIST do (* ;; "Now that it's all written, update the incore structures") (if (LISTP MSG) then (* ; "Need to fix stamp & msg length") (replace (LAFITEMSG MESSAGELENGTH) of (CAR MSG) with (CADDR MSG)) (replace (LAFITEMSG STAMPLENGTH) of (CAR MSG) with (CADR MSG)) (SETQ MSG (CAR MSG))) (replace (LAFITEMSG MARKSCHANGEDINFILE?) of MSG with NIL) (replace (LAFITEMSG BEGIN) of MSG with GOODMSGSPTR) (add GOODMSGSPTR (fetch (LAFITEMSG MESSAGELENGTH) of MSG)) (replace (LAFITEMSG %#) of MSG with (add LASTGOODMSG# 1)) (SETA MESSAGES LASTGOODMSG# MSG) (COND ((fetch (LAFITEMSG SELECTED?) of MSG) (COND ((NOT FIRSTSELECTED) (SETQ FIRSTSELECTED LASTGOODMSG#))) (SETQ LASTSELECTED LASTGOODMSG#)))) (if (AND (NOT NEWDATE) (NOT (= GOODMSGSPTR (GETFILEPTR FOLDERSTREAM)))) then (HELP "Miscalculation in Lafite Expunge" (LIST GOODMSGSPTR (QUOTE NEQ) (GETFILEPTR FOLDERSTREAM)))))) (replace (MAILFOLDER %#OFMESSAGES) of FOLDER with LASTGOODMSG#) (replace (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER with (OR FIRSTSELECTED 1)) (replace (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER with (OR LASTSELECTED 0)) (for I from (ADD1 LASTGOODMSG#) to OLDLASTMSG# do (* ; "Erase entries beyond the new end of messages") (SETA MESSAGES I NIL)) (if NEWDATE then (* ; "Did via separate file, so get the date right") (replace (MAILFOLDER FOLDERCREATIONDATE) of FOLDER with NEWDATE) else (* ; "Truncate to new length") (SETFILEPTR FOLDERSTREAM GOODMSGSPTR) (SETFILEINFO FOLDERSTREAM (QUOTE LENGTH) GOODMSGSPTR)) (replace (MAILFOLDER FOLDEREOFPTR) of FOLDER with GOODMSGSPTR) (SETQ STATE :END) (RETURN TOCSTREAM)) (* ;; "Cleanup code--this runs even if we are aborted.") (if (NEQ STATE :END) then (LAB.PROMPTPRINT FOLDER " aborted.") (if (EQ STATE :OPEN) then (LAB.PROMPTPRINT FOLDER " Folder is now in an inconsistent state and must be rebrowsed.") else (* ; "We have not yet overwritten anything, so folder is still consistent, mainly") (if (AND (EQ STATE :APPEND) (> (GETEOFPTR FOLDERSTREAM) ORIGEOF)) then (* ; "We have written stuff to end of file--delete it") (SETFILEPTR FOLDERSTREAM ORIGEOF) (SETFILEINFO FOLDERSTREAM (QUOTE LENGTH) ORIGEOF)) (if (EQ STATE :NEW) then (* ; "The RENAMEFILE failed") (LAB.FORMAT FOLDER " Help! Could not replace mail file with compacted file~@[ because ~A~]. The compacted file is stored as ~A. You must rename this file to ~A before proceeding. " CONDITION SCRATCHFILE FOLDERSTREAM) else (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) (if (OPENWP WINDOW) then (* ; "Window was cleared, so redisplay it now") (REDISPLAYW WINDOW))))) (if TOCSTREAM then (CLOSEF TOCSTREAM))) (\LAFITE.CLOSE.FOLDER FOLDER T) (if SCRATCHFILE then (if (STREAMP SCRATCHFILE) then (SETQ SCRATCHFILE (CLOSEF SCRATCHFILE))) (DELFILE SCRATCHFILE)) (if (AND (EQ STATE :END) (EQ LAFITEVERIFYFLG (QUOTE ALL))) then (VERIFYMAILFOLDER FOLDER))))) -) (\LAFITE.COMPACT.FOLDER2 -(LAMBDA (FOLDER FOLDERSTREAM LASTGOODMSG# GOODMSGSPTR SCRATCHFILE NEWFILEP) (* ; "Edited 2-May-89 11:09 by bvm") (* ;; "We want to compact FOLDER's messages beyond LASTGOODMSG#, which ends at GOODMSGSPTR. We map down the messages moving the undeleted ones into SCRATCHFILE (which is a new mail file if NEWFILEP is true). Return a list of the messages written to SCRATCHFILE. If the stamp length of any message changed, the corresponding element is not the message but a list (msg newstamplength newmsglength).") (for I from (ADD1 LASTGOODMSG#) to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) bind (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (NEXTFILEPTR _ GOODMSGSPTR) MSG TMP unless (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) collect (MAYBEVERIFYMSG MSG FOLDER) (LET* ((BEGIN (fetch (LAFITEMSG BEGIN) of MSG)) (STAMPLENGTH (fetch (LAFITEMSG STAMPLENGTH) of MSG)) (MSGLENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG)) (BODYLENGTH (- MSGLENGTH STAMPLENGTH)) (NEWSTAMPLENGTH (LA.PRINTHEADER SCRATCHFILE BODYLENGTH))) (WRITEFOLDERMARKBYTES MSG NIL SCRATCHFILE) (BOUT SCRATCHFILE (CHARCODE CR)) (COPYBYTES FOLDERSTREAM SCRATCHFILE (+ BEGIN STAMPLENGTH) (+ BEGIN MSGLENGTH)) (if (NOT NEWFILEP) then (if (< BEGIN NEXTFILEPTR) then (* ;; "By the time we get to copying this message to the main file, we will already have overwritten at least part of the original message. That means we could lose messages if a crash occurs here. So instead, copy this message to after the eof as a saving place") (SETFILEPTR FOLDERSTREAM -1) (LA.PRINTHEADER FOLDERSTREAM BODYLENGTH NIL (+ (NCHARS BEGIN) (CONSTANT (ADD1 (NCHARS "*duplicate*"))))) (BOUT FOLDERSTREAM DELETEDFLAG) (* ; "Make message look deleted ordinarily") (BOUT FOLDERSTREAM UNSEENFLAG) (BOUT FOLDERSTREAM DUPLICATEMARK) (BOUT FOLDERSTREAM (CHARCODE CR)) (PRIN3 "*duplicate*" FOLDERSTREAM) (* ; "Mark as duplicate and tell where") (PRIN3 BEGIN FOLDERSTREAM) (BOUT FOLDERSTREAM (CHARCODE CR)) (COPYBYTES SCRATCHFILE FOLDERSTREAM (- (SETQ TMP (GETFILEPTR SCRATCHFILE)) BODYLENGTH) TMP) (SETFILEPTR SCRATCHFILE TMP)) (add NEXTFILEPTR BODYLENGTH NEWSTAMPLENGTH)) (if (EQ STAMPLENGTH NEWSTAMPLENGTH) then (* ; "normal case, no length changed") MSG else (LIST MSG NEWSTAMPLENGTH (+ BODYLENGTH NEWSTAMPLENGTH)))))) -) (\LAFITE.COMPACT.EXTRA -(LAMBDA (FOLDER LASTGOODMSG# GOODMSGSPTR STOPAT) (* ; "Edited 5-May-89 11:25 by bvm") (* ;; "Returns an estimate of the length of stuff we'll have to append to folder while compacting it, due to messages being out of order. If the estimate ever exceeds STOPAT we can stop counting and return the current estimate.") (for I from (ADD1 LASTGOODMSG#) to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) bind (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (NEXTFILEPTR _ GOODMSGSPTR) (EXTRALENGTH _ 0) MSG unless (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) do (LET ((MSGLENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) (if (< (fetch (LAFITEMSG BEGIN) of MSG) NEXTFILEPTR) then (* ;; "By the time we get to copying this message to the main file, we will already have overwritten at least part of the original message. That means we could lose messages if a crash occurs here. So instead, copy this message to after the eof as a saving place") (if (> (add EXTRALENGTH MSGLENGTH (CONSTANT (+ 6 (NCHARS "*duplicate*")))) STOPAT) then (RETURN EXTRALENGTH))) (add NEXTFILEPTR MSGLENGTH)) finally (RETURN EXTRALENGTH))) -) (\LAFITE.INVALIDATE.TOC -(LAMBDA (FOLDER) (* ; "Edited 5-May-89 11:45 by bvm") (* ;; "Invalidate the toc file for this folder by trashing the password. Returns the stream, if any.") (LET* ((*UPPER-CASE-FILE-NAMES* NIL) (NAME (INFILEP (TOCFILENAME FOLDER))) TOCSTREAM) (if (AND NAME (SETQ TOCSTREAM (IGNORE-ERRORS (\LAFITE.OPENSTREAM NAME (QUOTE BOTH) (QUOTE OLD) NIL NIL (QUOTE BINARY))))) then (WORDOUT TOCSTREAM (LOGXOR 65535 LAFITETOCPASSWORD)) (FORCEOUTPUT TOCSTREAM) TOCSTREAM))) -) (\LAFITE.RENAMEFILE -(LAMBDA (SCRATCHFILE FOLDERNAME) (* ; "Edited 2-May-89 11:33 by bvm") (* ;; "Called to replace FOLDERNAME with SCRATCHFILE, e.g., as a result of a scavenge. On success, returns the new file name, otherwise returns NIL and, if an error was signaled, a CONDITION.") (LET ((*UPPER-CASE-FILE-NAMES* NIL)) (IGNORE-ERRORS (DELFILE FOLDERNAME) (RENAMEFILE SCRATCHFILE FOLDERNAME)))) -) (SMART-RENAMEFILEP -(LAMBDA (OBJECT) (* ; "Edited 1-May-89 12:31 by bvm") (* ;; "true if RENAMEFILE can be done intelligently on this path/stream/device") (LET ((DEV (CL:TYPECASE OBJECT (FDEV OBJECT) (STREAM (fetch (STREAM DEVICE) of OBJECT)) (T (\GETDEVICEFROMNAME OBJECT T))))) (AND DEV (CASE (fetch (FDEV RENAMEFILE) of DEV) ((NILL \GENERIC.RENAMEFILE) NIL) (T T))))) -) (LA.OPENTEMPFILE -(LAMBDA (EXTENSION ACCESS RECOG LENGTH) (* ; "Edited 3-Sep-87 16:29 by bvm:") (LET ((STREAM (OPENSTREAM (PACKFILENAME.STRING (QUOTE HOST) (QUOTE SCRATCH) (QUOTE NAME) (QUOTE LAFITETEMPORARY) (QUOTE EXTENSION) EXTENSION) (OR ACCESS (QUOTE OUTPUT)) (OR RECOG (QUOTE NEW)) NIL (AND LENGTH (LIST (LIST (QUOTE LENGTH) LENGTH)))))) (COND (STREAM (WHENCLOSE STREAM (QUOTE CLOSEALL) (QUOTE NO)) (LINELENGTH MAX.SMALLP STREAM) (if NIL then (* ; "save them so they can be deleted by LAFITE.QUIT") (* ;; "no need to keep list--they vanish via gc") (push \LAFITE.TEMPFILES (FULLNAME STREAM))) STREAM)))) -) ) (DEFINEQ (\LAFITE.UPDATE.FOLDER -(LAMBDA (FOLDER) (* ; "Edited 28-Apr-89 10:55 by bvm") (* ;;; "Write out any changed marks in MAILFOLDER, but don't expunge deleted messages") (LET ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) OUTSTREAM MSG) (if (fetch (MAILFOLDER FOLDEROUTOFORDER) of FOLDER) then (LAB.PROMPTPRINT FOLDER "Folder has been reordered, so can't simply write out changes--must Expunge.")) (LAB.PROMPTPRINT FOLDER "Writing out changes...") (for MSG# from (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER) to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) when (fetch (LAFITEMSG MARKSCHANGEDINFILE?) of (SETQ MSG (NTHMESSAGE MESSAGES MSG#))) do (WRITEFOLDERMARKBYTES MSG FOLDER (OR OUTSTREAM (SETQ OUTSTREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE OUTPUT) :ABORT))))) (\LAFITE.CLOSE.FOLDER FOLDER) (LAB.PROMPTPRINT FOLDER (COND (OUTSTREAM " done. ") (T "nothing changed. "))) (if (NOT (fetch (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER)) then (* ; "Everything is up to date now.") (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER with (ADD1 (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)))) (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with NIL))) -) (\LAFITE.UPDATE.CONTENTS -(LAMBDA (MAILFOLDER LASTUNCHANGEDMESSAGE# TOCSTREAM) (* ; "Edited 1-May-89 13:02 by bvm") (* ;;; "Update the TOC file for MAILFOLDER, assuming that entries up to LASTUNCHANGEDMESSAGE# are okay.") (COND ((NLSETQ (\LAFITE.UPDATE.CONTENTS1 MAILFOLDER LASTUNCHANGEDMESSAGE# TOCSTREAM)) (LAB.PROMPTPRINT MAILFOLDER " done.")) (T (LAB.PROMPTPRINT MAILFOLDER " failed."))) (* ;; "FOLDERNEEDSUPDATE set to NIL now either because toc was completely written or because toc was deleted on error, in which case 'Update Table of Contents' is still needed") (replace (MAILFOLDER FOLDERNEEDSUPDATE) of MAILFOLDER with NIL)) -) (\LAFITE.UPDATE.CONTENTS1 -(LAMBDA (FOLDER LASTUNCHANGEDMESSAGE# TOCSTREAM) (* ; "Edited 1-May-89 13:02 by bvm") (* ;; "Write the table of contents file for FOLDER. LASTUNCHANGEDMESSAGE# is the last message in the folder before compacting changes set in. Prior to that message, we'll only have to update flag bytes if anything. If TOCSTREAM is supplied, it is a stream already open for i/o on the toc file (from Expunge, which invalidates the toc password before trashing the mail file).") (RESETLST (LET ((*UPPER-CASE-FILE-NAMES* NIL) (LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (TOCSTART LAFITETOCHEADERLENGTH) FIRSTMSG# MSG) (COND ((> LASTMSG# 0) (LAB.PROMPTPRINT FOLDER "Writing table of contents...") (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STREAM FOLDER) (SETQ STREAM (CLOSEF STREAM)) (COND (RESETSTATE (* ; "If we aborted out, assume toc is garbage") (replace (MAILFOLDER TOCLASTMESSAGE#) of FOLDER with 0) (DELFILE (FULLNAME STREAM)))))) (OR TOCSTREAM (SETQ TOCSTREAM (OPENSTREAM (TOCFILENAME FOLDER) (QUOTE BOTH) (QUOTE OLD/NEW) (QUOTE ((TYPE BINARY)))))) FOLDER)) (SETQ LASTUNCHANGEDMESSAGE# (IMIN LASTUNCHANGEDMESSAGE# (fetch (MAILFOLDER TOCLASTMESSAGE#) of FOLDER))) (COND ((EQ (GETEOFPTR TOCSTREAM) 0) (SETQ LASTUNCHANGEDMESSAGE# 0)) ((AND (EQ LASTUNCHANGEDMESSAGE# 0) (NEQ (PROGN (SETFILEPTR TOCSTREAM BYTESPERWORD) (WORDIN TOCSTREAM)) LAFITEVERSION#)) (* ; "A version number change, rewrite entire toc")) (T (* ; "TOC already existed, just update it") (for MSG# from 1 to LASTUNCHANGEDMESSAGE# do (COND ((fetch (LAFITEMSG MARKSCHANGEDINTOC?) of (SETQ MSG (NTHMESSAGE MESSAGES MSG#))) (* ; "Message not compacted out, but its mark bytes have changed") (SETFILEPTR TOCSTREAM TOCSTART) (WRITETOCMARKBYTES MSG TOCSTREAM) (replace (LAFITEMSG MARKSCHANGEDINTOC?) of MSG with NIL))) (add TOCSTART (fetch (LAFITEMSG TOCLENGTH) of MSG))))) (SETFILEPTR TOCSTREAM TOCSTART) (for MSG# from (ADD1 LASTUNCHANGEDMESSAGE#) to LASTMSG# do (WRITETOCENTRY (NTHMESSAGE MESSAGES MSG#) TOCSTREAM)) (SETFILEINFO TOCSTREAM (QUOTE LENGTH) (GETFILEPTR TOCSTREAM)) (SETFILEPTR TOCSTREAM 0) (* ; "Now write the header info") (WORDOUT TOCSTREAM LAFITETOCPASSWORD) (WORDOUT TOCSTREAM LAFITEVERSION#) (FIXPOUT TOCSTREAM (fetch (MAILFOLDER FOLDEREOFPTR) of FOLDER)) (WORDOUT TOCSTREAM LASTMSG#)) ((SETQ TOCSTREAM (INFILEP (TOCFILENAME FOLDER))) (LAB.PROMPTPRINT FOLDER "Deleting table of contents...") (DELFILE TOCSTREAM))) (replace (MAILFOLDER TOCLASTMESSAGE#) of FOLDER with LASTMSG#)))) -) (WRITETOCENTRY -(LAMBDA (MSG STREAM) (* ; "Edited 28-Apr-89 12:18 by bvm") (* ;;; "Dumps TOC entry for MSG on STREAM") (PROG ((TOCLENGTH 6) (MESSAGELENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG)) DAT NC) (* ; "TOCLENGTH 6 counts for 3 bytes of message length, 1 byte each of stamplength, flags and mark.") (WRITETOCMARKBYTES MSG STREAM) (COND ((> MESSAGELENGTH MAX.SMALLP) (* ;; "Ugh, length greater than fits in one word. Would be surprised if this ever happens, but file format permits it") (LET ((HIWORD (LRSH MESSAGELENGTH BITSPERWORD))) (if (> HIWORD 254) then (* ; "a very long length, escape to 4 bytes of length") (BOUT STREAM 255) (WORDOUT STREAM HIWORD) (add TOCLENGTH 2) else (BOUT STREAM HIWORD))) (WORDOUT STREAM (LOGAND MESSAGELENGTH MAX.SMALLP))) (T (* ; "Normal case, a small length") (BOUT STREAM 0) (WORDOUT STREAM MESSAGELENGTH))) (BOUT STREAM (fetch (LAFITEMSG STAMPLENGTH) of MSG)) (if (fetch (LAFITEMSG DATEFETCHED?) of MSG) then (* ; "Write 4 bytes of idate") (\BOUTS STREAM MSG (UNFOLD (INDEXF (FETCH (LAFITEMSG IDATE))) BYTESPERWORD) 4) (add TOCLENGTH 4)) (if (NOT (fetch (LAFITEMSG DATEKNOWN?) of MSG)) then (* ; "Write 6 bytes of ascii string") (PRIN3 (COND ((EQ (SETQ NC (NCHARS (SETQ DAT (fetch (LAFITEMSG DATE) of MSG)))) 6) (* ; "The usual case") DAT) (T (OR (SUBSTRING DAT 1 6) (CONCAT DAT (ALLOCSTRING (IDIFFERENCE 6 NC) (CHARCODE SPACE)))))) STREAM) (add TOCLENGTH 6)) (add TOCLENGTH (LA.PRINTSHORTSTRING STREAM (fetch (LAFITEMSG SUBJECT) of MSG))) (add TOCLENGTH (LA.PRINTSHORTSTRING STREAM (fetch (LAFITEMSG FROM) of MSG))) (add TOCLENGTH (LA.PRINTSHORTSTRING STREAM (fetch (LAFITEMSG TO) of MSG))) (replace (LAFITEMSG TOCLENGTH) of MSG with TOCLENGTH) (replace (LAFITEMSG MARKSCHANGEDINTOC?) of MSG with NIL))) -) (WRITETOCMARKBYTES -(LAMBDA (MSG STREAM) (* bvm%: "20-Feb-84 12:53") (BOUT STREAM (fetch (LAFITEMSG MSGFLAGBITS) of MSG)) (BOUT STREAM (fetch (LAFITEMSG MARKCHAR) of MSG))) -) (WRITEFOLDERMARKBYTES -(LAMBDA (MSG MAILFOLDER OUTSTREAM) (* ; "Edited 21-Apr-89 12:41 by bvm") (* ;;; "Write the three magic flag bytes for MSG onto OUTSTREAM. If MAILFOLDER is supplied, then OUTSTREAM is MAILFOLDER's own file, and we will first position OUTSTREAM accordingly--otherwise caller has positioned us properly.") (COND (MAILFOLDER (MAYBEVERIFYMSG MSG MAILFOLDER) (SETFILEPTR OUTSTREAM (fetch (LAFITEMSG BEGIN) of MSG)) (OR (LA.READSTAMP OUTSTREAM) (HELP)) (COND ((fetch (LAFITEMSG MESSAGELENGTHCHANGED?) of MSG) (* ; "Length is different in core and on file. This is for scavenging purposes") (LET ((LENPOS (GETFILEPTR OUTSTREAM)) LEN) (LA.READCOUNT OUTSTREAM T) (* ; "Skip over current length") (SETQ LEN (- (GETFILEPTR OUTSTREAM) LENPOS 1)) (* ; "Number of bytes of length--have to use the same format when overwriting it") (SETFILEPTR OUTSTREAM LENPOS) (LA.PRINTCOUNT (fetch (LAFITEMSG MESSAGELENGTH) of MSG) OUTSTREAM (BQUOTE (FIX (\, LEN) 10 T))) (BIN OUTSTREAM) (* ; "Skip over terminating space")) (replace (LAFITEMSG MESSAGELENGTHCHANGED?) of MSG with NIL)) (T (* ; "Just skip over lengths") (LA.READCOUNT OUTSTREAM T) (LA.READCOUNT OUTSTREAM T))))) (BOUT OUTSTREAM (COND ((fetch (LAFITEMSG DELETED?) of MSG) DELETEDFLAG) (T UNDELETEDFLAG))) (BOUT OUTSTREAM (COND ((fetch (LAFITEMSG SEEN?) of MSG) SEENFLAG) (T UNSEENFLAG))) (BOUT OUTSTREAM (fetch (LAFITEMSG MARKCHAR) of MSG)) (if MAILFOLDER then (replace (LAFITEMSG MARKSCHANGEDINFILE?) of MSG with NIL))) -) ) (* ; "HARDCOPY") (DEFINEQ (LAFITE.HARDCOPY.MESSAGES -(CL:LAMBDA (FOLDER MESSAGES &OPTIONAL (BATCHFLG NIL BATCHP)) (* ; "Edited 30-Aug-88 14:13 by bvm") (AND MESSAGES (\LAFITE.HARDCOPY.PROC FOLDER NIL NIL (\COERCE.TO.MSGLST MESSAGES) (if BATCHP then BATCHFLG else LAFITEHARDCOPYBATCHFLG)))) -) (\LAFITE.HARDCOPY -(LAMBDA (WINDOW FOLDER ITEM MENU) (* ; "Edited 23-Aug-88 15:45 by bvm") (\LAFITE.PROCESS (BQUOTE ((\, (FUNCTION \LAFITE.HARDCOPY.PROC)) (QUOTE (\, FOLDER)) (QUOTE (\, ITEM)) (QUOTE (\, MENU)) NIL (QUOTE (\, LAFITEHARDCOPYBATCHFLG)))) (QUOTE MESSAGEHARDCOPIER))) -) (\LAFITE.HARDCOPY.PROC -(LAMBDA (MAILFOLDER ITEM MENU MSGLST BATCHFLG) (* ; "Edited 23-Aug-88 15:37 by bvm") (PROG (LCASEFILENAME TEXTSTREAM) (RESETLST (LA.RESETSHADE ITEM MENU (AND BATCHFLG LAFITEHARDCOPYBATCHSHADE)) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (COND ((OR MSGLST (NOT (LAB.ASSURE.SELECTIONS MAILFOLDER))) (LET (CONTINUEFLG) (OR MSGLST (SETQ MSGLST (LAB.SELECTED.MESSAGES MAILFOLDER))) (SETQ LCASEFILENAME (L-CASE (fetch (MAILFOLDER FULLFOLDERNAME) of MAILFOLDER))) (SETQ TEXTSTREAM (COND ((AND BATCHFLG (SETQ CONTINUEFLG (fetch (MAILFOLDER HARDCOPYSTREAM) of MAILFOLDER)))) ((AND (NOT BATCHFLG) LAFITEHARDCOPY.MIN.TOC (>= (LENGTH MSGLST) LAFITEHARDCOPY.MIN.TOC)) (\LAFITE.HARDCOPY.HEADERS MAILFOLDER LCASEFILENAME MSGLST)) (T (* ; "Start fresh") (OPENTEXTSTREAM "" NIL NIL NIL (LIST (QUOTE FONT) LAFITEHARDCOPYFONT))))) (\LAFITE.HARDCOPY.BODIES MAILFOLDER TEXTSTREAM MSGLST CONTINUEFLG) (COND (BATCHFLG (\LAFITE.MARK.HARDCOPIED MAILFOLDER MSGLST HARDCOPYBATCHMARK) (replace (MAILFOLDER HARDCOPYSTREAM) of MAILFOLDER with TEXTSTREAM) (replace (MAILFOLDER HARDCOPYMESSAGES) of MAILFOLDER with (NCONC (fetch (MAILFOLDER HARDCOPYMESSAGES) of MAILFOLDER) MSGLST)) (SETQ TEXTSTREAM)))))))) (COND (TEXTSTREAM (* ; "Send to printer now...") (\LAFITE.TRANSMIT.HARDCOPY MAILFOLDER TEXTSTREAM MSGLST LCASEFILENAME))))) -) (\LAFITE.HARDCOPY.HEADERS -(LAMBDA (MAILFOLDER LCASEFILENAME MESSAGES INCLUDE# TEXTSTREAM) (* ; "Edited 3-Jun-88 17:50 by bvm") (PROG ((OUTPUTFILE (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH) (QUOTE NEW))) TITLELEN TITLE TOCSTART TOCLEN FROMSTR SUBJLEFT DATELEFT TABSTOPS) (LINELENGTH MAX.SMALLP OUTPUTFILE) (for MSG in MESSAGES as N from 1 do (* ;; "Each line consists of [#.]datefromsubject") (OR (fetch (LAFITEMSG PARSED?) of MSG) (LAFITE.PARSE.MSG.FOR.TOC MSG MAILFOLDER)) (POSITION OUTPUTFILE 0) (COND (INCLUDE# (\OUTCHAR OUTPUTFILE (CHARCODE TAB)) (CL:FORMAT OUTPUTFILE "~D." N) (\OUTCHAR OUTPUTFILE (CHARCODE TAB)))) (PRIN3 (OR (fetch (LAFITEMSG DATE) of MSG) UNSUPPLIEDFIELDSTR) OUTPUTFILE) (\OUTCHAR OUTPUTFILE (CHARCODE TAB)) (PRIN3 (OR (COND ((fetch (LAFITEMSG MSGFROMMEP) of MSG) (PRIN3 "To: " OUTPUTFILE) (OR (fetch (LAFITEMSG TO) of MSG) (LAFITE.FETCH.TO.FIELD MSG MAILFOLDER))) (T (fetch (LAFITEMSG FROM) of MSG))) UNSUPPLIEDFIELDSTR) OUTPUTFILE) (\OUTCHAR OUTPUTFILE (CHARCODE TAB)) (PRIN3 (OR (fetch (LAFITEMSG SUBJECT) of MSG) UNSUPPLIEDFIELDSTR) OUTPUTFILE) (TERPRI OUTPUTFILE)) (SETQ OUTPUTFILE (OPENSTREAM (CLOSEF OUTPUTFILE) (QUOTE INPUT))) (SETQ TITLE (CL:FORMAT NIL "Messages from ~A~%%Listed on ~A~%%~%%" LCASEFILENAME (DATE))) (SETQ TITLELEN (NCHARS TITLE)) (COND (TEXTSTREAM (* ; "Need to insert all this stuff at beginning of textstream") (TEDIT.INSERT TEXTSTREAM TITLE 1)) (T (SETQ TEXTSTREAM (OPENTEXTSTREAM TITLE (AND NIL (CREATEW NIL "Lafite headers")) NIL NIL (LIST (QUOTE FONT) LAFITEHARDCOPYFONT))))) (PROGN (* ; "Make title centered") (TEDIT.PARALOOKS TEXTSTREAM (QUOTE (QUAD CENTERED)) 1 (SUB1 TITLELEN)) (TEDIT.PARALOOKS TEXTSTREAM (QUOTE (POSTPARALEADING 30)) (- TITLELEN 4) 1)) (PROGN (* ; "Insert toc lines. ") (SETQ TOCLEN (LA.TEDIT.INCLUDE TEXTSTREAM OUTPUTFILE (SETQ TOCSTART (ADD1 TITLELEN)))) (TEDIT.INSERT TEXTSTREAM (CONSTANT (CONCATCODES (CHARCODE (FF)))) (+ TOCSTART TOCLEN))) (* ; "Formfeed after the insertion") (PROGN (* ; "Now give the toc lines the appropriate tab settings.") (SETQ DATELEFT (COND (INCLUDE# 30) (T 0))) (SETQ TABSTOPS (LIST (CONS (+ DATELEFT 50) (QUOTE LEFT)) (CONS (SETQ SUBJLEFT (+ DATELEFT 170)) (QUOTE LEFT)))) (COND (INCLUDE# (push TABSTOPS (QUOTE (20 . RIGHT)) (CONS DATELEFT (QUOTE LEFT))))) (TEDIT.PARALOOKS TEXTSTREAM (BQUOTE (TABS (NIL (\,@ TABSTOPS)) LEFTMARGIN (\, (+ SUBJLEFT 20)))) TOCSTART (SUB1 TOCLEN))) (RETURN TEXTSTREAM))) -) (\LAFITE.MARK.HARDCOPIED -(LAMBDA (MAILFOLDER MSGS MARK) (* bvm%: "26-Feb-86 12:34") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (LET ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) (LASTMSG (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) N) (COND (MESSAGES (* ; "If not, folder has been closed") (for MSG in MSGS when (AND (ILEQ (SETQ N (fetch (LAFITEMSG %#) of MSG)) LASTMSG) (EQ MSG (NTHMESSAGE MESSAGES N)) (SELCHARQ (fetch (LAFITEMSG MARKCHAR) of MSG) ((? SPACE H) T) NIL)) do (* ; "If message doesn't already have a more interesting mark, set the hardcopy mark") (MARKMESSAGE MSG MAILFOLDER MARK))))))) -) (\LAFITE.TRANSMIT.HARDCOPY -(LAMBDA (MAILFOLDER TEXTSTREAM MSGLST LCASEFILENAME) (* bvm%: " 2-Mar-84 13:32") (* ;;; "Sends TEXTSTREAM off to be hardcopied, then deletes it") (WITH.MONITOR \LAFITE.HARDCOPYLOCK (* ; "Because press isn't reentrant yet") (TEDIT.HARDCOPY TEXTSTREAM NIL NIL (CONCAT (COND ((CDR MSGLST) (CONCAT (LENGTH MSGLST) " messages")) (T (CONCAT "Message #" (fetch (LAFITEMSG %#) of (CAR MSGLST))))) " from " (OR LCASEFILENAME (L-CASE (fetch (MAILFOLDER FULLFOLDERNAME) of MAILFOLDER)))))) (CLOSEF TEXTSTREAM) (DELFILE TEXTSTREAM) (\LAFITE.MARK.HARDCOPIED MAILFOLDER MSGLST HARDCOPYMARK)) -) (\LAFITE.HARDCOPY.BODIES -(LAMBDA (MAILFOLDER TEXTSTREAM MESSAGES CONTINUEFLG NEXTMSG#) (* ; "Edited 23-Aug-88 12:50 by bvm") (for MSGDESCRIPTOR in MESSAGES bind (NTHTIME _ CONTINUEFLG) (INPUTFILE _ (\LAFITE.OPEN.FOLDER MAILFOLDER (QUOTE INPUT) :ABORT)) do (COND ((NULL NTHTIME) (SETQ NTHTIME T)) ((OR LAFITENEWPAGEFLG CONTINUEFLG) (\OUTCHAR TEXTSTREAM (CHARCODE FF)) (SETQ CONTINUEFLG)) (T (TERPRI TEXTSTREAM) (COND ((NOT NEXTMSG#) (PRIN3 LAFITEHARDCOPYSEPARATOR TEXTSTREAM) (TERPRI TEXTSTREAM))))) (COND (NEXTMSG# (CL:FORMAT TEXTSTREAM "Message ~D~%%~%%" NEXTMSG#) (add NEXTMSG# 1))) (\LAFITE.APPEND.MESSAGE.BODY TEXTSTREAM INPUTFILE MSGDESCRIPTOR \LAPARSE.DONT.HARDCOPY.HEADERS) (TEDIT.CARETLOOKS TEXTSTREAM LAFITEHARDCOPYFONT))) -) (\LAFITE.APPEND.MESSAGE.BODY -(LAMBDA (TEXTSTREAM MSGSTREAM MSGDESCRIPTOR FILTERS) (* ; "Edited 5-Aug-93 20:20 by bvm") (* ;; "Appends the text of the indicated message to TEXTSTREAM, filtering out any header fields found in FILTERS") (LET ((START (fetch (LAFITEMSG START) of MSGDESCRIPTOR)) (END (fetch (LAFITEMSG END) of MSGDESCRIPTOR)) (EOF (GETEOFPTR TEXTSTREAM)) FILTERED) (if FILTERS then (SETQ FILTERED (LAFITE.NEW.PARSE.HEADER MSGSTREAM FILTERS START END))) (TEDIT.SETSEL TEXTSTREAM (ADD1 EOF) 0 (QUOTE LEFT)) (* ; "Get selection right for TEDIT.INCLUDE") (TEDIT.INCLUDE TEXTSTREAM MSGSTREAM START END) (if FILTERED then (if (NOT (= (GETEOFPTR TEXTSTREAM) (+ EOF (- END START)))) then (* ; "Rats, we have to recalculate more slowly now, since there could be ns chars in header. TEdit counts them differently than the plain text file does") (SETQ FILTERED (LAFITE.PARSE.HEADER TEXTSTREAM FILTERS EOF))) (for PAIR in FILTERED do (* ; "Note: we are depending on the pairs being in reverse order from the parse, so that the deletions do not affect the char count") (TEDIT.DELETE TEXTSTREAM (+ EOF (- (CAR PAIR) START) 1) (- (CADR PAIR) (CAR PAIR))))) (TEDIT.SETSEL TEXTSTREAM (ADD1 (GETEOFPTR TEXTSTREAM)) 0) (SETFILEPTR TEXTSTREAM -1))) -) (\LAFITE.DO.PENDING.HARDCOPY -(LAMBDA (FOLDER) (* ; "Edited 20-Jan-89 14:29 by bvm") (LET ((TEXTSTREAM (fetch (MAILFOLDER HARDCOPYSTREAM) of FOLDER)) (MSGLST (fetch (MAILFOLDER HARDCOPYMESSAGES) of FOLDER))) (COND (TEXTSTREAM (LAB.PROMPTPRINT FOLDER T "Hardcopying... ") (COND ((AND LAFITEHARDCOPY.MIN.TOC (>= (LENGTH MSGLST) LAFITEHARDCOPY.MIN.TOC)) (\LAFITE.HARDCOPY.HEADERS FOLDER (L-CASE (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER)) MSGLST NIL TEXTSTREAM))) (\LAFITE.TRANSMIT.HARDCOPY FOLDER TEXTSTREAM MSGLST) (\LAFITE.CLEAR.HARDCOPY.STATE FOLDER) (LAB.PROMPTPRINT FOLDER "done. "))))) -) (\LAFITE.CANCEL.HARDCOPY -(LAMBDA (FOLDER) (* ; "Edited 20-Jan-89 14:29 by bvm") (LET ((PENDING (fetch (MAILFOLDER HARDCOPYMESSAGES) of FOLDER))) (if (NOT PENDING) then (LAB.PROMPTPRINT FOLDER "No messages are queued for hardcopy") elseif (LAB.MOUSECONFIRM FOLDER "Click LEFT to cancel hardcopy of ~D message~:P" (LENGTH PENDING)) then (for MSG in PENDING do (* ; "Set mark back to space") (MARKMESSAGE MSG FOLDER SEENMARK)) (\LAFITE.CLEAR.HARDCOPY.STATE FOLDER)))) -) (\LAFITE.CLEAR.HARDCOPY.STATE -(LAMBDA (FOLDER) (* ; "Edited 20-Jan-89 14:28 by bvm") (* ;; "Clear all the places that think there is pending hardcopy") (replace (MAILFOLDER HARDCOPYSTREAM) of FOLDER with (replace (MAILFOLDER HARDCOPYMESSAGES) of FOLDER with NIL)) (LET ((MENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER))) (* ; "Take the speckle off the menu") (SHADEITEM (LA.MENU.ITEM (FUNCTION \LAFITE.HARDCOPY) MENU) MENU WHITESHADE))) -) ) (ADDTOVAR LAFITEEXTRAMENUITEMS ("Cancel Pending Hardcopy" '\LAFITE.CANCEL.HARDCOPY "Forget about hardcopying the messages so far marked for hardcopy." )) (RPAQ? LAFITEHARDCOPYBATCHFLG NIL) (RPAQ? LAFITEHARDCOPY.MIN.TOC NIL) (RPAQ? LAFITEDISPLAYAFTERDELETEFLG T) (RPAQ? LAFITEMOVETOCONFIRMFLG 'ALWAYS) (RPAQ? LAFITENEWPAGEFLG T) (RPAQ? LAFITEENDOFMESSAGESTR "End of message") (RPAQ? LAFITEENDOFMESSAGEFONT (FONTCREATE '(TIMESROMAN 10 ITALIC))) (RPAQ? LAFITE.DISPLAY.SIZE '(500 . 300)) (RPAQ? LAFITE.BROWSER.LAYOUTS NIL) (RPAQ? LAFITE.MIDDLE.UPDATE '(:EXPUNGE :SHRINK :CONFIRM)) (RPAQ? LAFITEHARDCOPYBATCHSHADE 1025) (RPAQ? LAFITEHARDCOPYSEPARATOR "% + previous date%: "28-Jun-99 10:23:32" +{DSK}KAPLAN>LOCAL>MEDLEY3.5>GIT-MEDLEY>LIBRARY>LAFITE>LAFITECOMMANDS.;1) + + +(* ; " +Copyright (c) 1988-1989, 1992-1993, 1999, 2021 by Xerox Corporation. +") + +(PRETTYCOMPRINT LAFITECOMMANDSCOMS) + +(RPAQQ LAFITECOMMANDSCOMS + [ + (* ;; "Handling of the main Lafite browser commands") + + (COMS (* ; "DISPLAY") + (FNS \LAFITE.DISPLAY \LAFITE.DO.DISPLAY SELECTMESSAGETODISPLAY MESSAGEDISPLAYER + LA.COPY.MESSAGE.TEXT \LAFITE.CLOSE.DISPLAYWINDOWS \LAFITE.CLOSE.DISPLAYER) + (FNS \LAFITE.UNHIDE.HEADERS \LAFITE.HIDE.HEADERS \LAFITE.REHIDE.HEADERS + LAFITE.EAT.UNDESIRABLE.FIELD LAFITE.EAT.GVGV \LAFITE.HARDCOPY.FROM.DISPLAY + LAFITE.HARDCOPY.TAB.WIDTH) + (FNS \LAFITE.SET.LOOKS.FROM.MENU \LAFITE.SET.DEFAULT.LOOKS \LAFITE.SET.FIXED.LOOKS + LAFITE.SET.LOOKS LAFITE.SET.TAB.LOOKS LAFITE.SET.PARA.SEPARATION + LAFITE.SET.LOWER.CASE LAFITE.SUBSTITUTE.VP.EOL) + (INITVARS \LAFITE.DISPLAY.COMMANDS) + (ADDVARS [LAFITE.EXTRA.DISPLAY.COMMANDS ("Looks" '\LAFITE.SET.LOOKS.FROM.MENU + "Change the appearance of the selected text, or whole message if nothing selected" + ) + ("Hardcopy" '\LAFITE.HARDCOPY.FROM.DISPLAY + "Hardcopy this message in its current appearance") + ("Unhide" '\LAFITE.UNHIDE.HEADERS + "Display the header fields that are hidden from view." + (SUBITEMS ("Hide" '\LAFITE.REHIDE.HEADERS + "Hide uninteresting fields from view again"] + (LAFITE.LOOKS.SUBCOMMANDS ("VP Line Breaks" 'LAFITE.SUBSTITUTE.VP.EOL + "Replace the Viewpoint end of line character with ours." + ) + ("Lowercase" 'LAFITE.SET.LOWER.CASE + "Lowercase the region or whole message.") + ("Spread Paragraphs" 'LAFITE.SET.PARA.SEPARATION + "Separate paragraphs by 10 points (useful for Tioga messages).") + ("Default" '\LAFITE.SET.DEFAULT.LOOKS + "Change selection (or whole text) back to default font") + ("Fixed Width" '\LAFITE.SET.FIXED.LOOKS + "Change selection (or whole text) to fixed-width font"))) + (GLOBALVARS \LAFITE.DISPLAY.COMMANDS)) + (COMS (* ; "DELETE") + (FNS LAFITE.DELETE.MESSAGES \LAFITE.DELETE DISPLAYAFTERDELETE \LAFITE.SELECT.NEXT + \LAFITE.UNDELETE)) + (COMS (* ; "MOVE") + (FNS LAFITE.MOVE.MESSAGES \COERCE.TO.MSGLST \LAFITE.MOVETO \LAFITE.COPYTO + \LAFITE.MOVETO.PROC \LAFITE.MOVE.MESSAGES.INTERNAL) + (* ; "Aux move") + (FNS \LAFITE.ENABLE.MOVE.MENU \LAFITE.ADD.TO.MOVE.MENU \LAFITE.UPDATE.MOVE.MENU + \LAFITE.RESTORE.MOVE.MENU \LAFITE.HANDLE.AUTO.MOVE) + (ADDVARS (LAFITEEXTRAMENUITEMS ("Enable MoveTo Menu" '\LAFITE.ENABLE.MOVE.MENU + "Attach a menu of folders for accelerated MoveTo (or modify existing one)" + (SUBITEMS ("Restore MoveTo Menu" + '\LAFITE.RESTORE.MOVE.MENU + "Just reopen the attached MoveTo menu if it existed." + ))) + ("Copy To" '\LAFITE.COPYTO + "Like MoveTo, but don't delete the message(s).")) + (LAFITE.EXTRA.MOVE.ITEMS ("---Display---" '\LAFITE.DISPLAY + "Display the next message") + ("---Delete---" '\LAFITE.DELETE "Delete the selected message(s)"))) + (INITVARS (LAFITE.AUTO.MOVE.MENU))) + (COMS (* ; "UPDATE") + (FNS \LAFITE.UPDATE \LAFITE.EXPUNGE.PROC \LAFITE.UPDATE.PROC \LAFITE.HARDCOPYONLY.PROC + LAB.CHOOSE.UPDATE.MENU LAB.CREATE.UPDATE.MENU LAB.UPDATE.NEEDED? + \LAFITE.START.UPDATE LAB.START.COMMAND \LAFITE.FINISH.UPDATE + \LAFITE.CLOSE.OTHER.FOLDERS) + (FNS LAB.FLUSHWINDOW LAB.APPENDMESSAGES \LAFITE.COMPACT.FOLDER \LAFITE.COMPACT.FOLDER1 + \LAFITE.COMPACT.FOLDER2 \LAFITE.COMPACT.EXTRA \LAFITE.INVALIDATE.TOC + \LAFITE.RENAMEFILE SMART-RENAMEFILEP LA.OPENTEMPFILE) + (FNS \LAFITE.UPDATE.FOLDER \LAFITE.UPDATE.CONTENTS \LAFITE.UPDATE.CONTENTS1 + WRITETOCENTRY WRITETOCMARKBYTES WRITEFOLDERMARKBYTES)) + [COMS (* ; "HARDCOPY") + (FNS LAFITE.HARDCOPY.MESSAGES \LAFITE.HARDCOPY \LAFITE.HARDCOPY.PROC + \LAFITE.HARDCOPY.HEADERS \LAFITE.MARK.HARDCOPIED \LAFITE.TRANSMIT.HARDCOPY + \LAFITE.HARDCOPY.BODIES \LAFITE.APPEND.MESSAGE.BODY \LAFITE.DO.PENDING.HARDCOPY + \LAFITE.CANCEL.HARDCOPY \LAFITE.CLEAR.HARDCOPY.STATE) + (ADDVARS (LAFITEEXTRAMENUITEMS ("Cancel Pending Hardcopy" '\LAFITE.CANCEL.HARDCOPY + "Forget about hardcopying the messages so far marked for hardcopy." + ] + [COMS (INITVARS (LAFITEHARDCOPYBATCHFLG NIL) + (LAFITEHARDCOPY.MIN.TOC NIL) + (LAFITEDISPLAYAFTERDELETEFLG T) + (LAFITEMOVETOCONFIRMFLG 'ALWAYS) + (LAFITENEWPAGEFLG T) + (LAFITEENDOFMESSAGESTR "End of message") + [LAFITEENDOFMESSAGEFONT (FONTCREATE '(TIMESROMAN 10 ITALIC] + (LAFITE.DISPLAY.SIZE '(500 . 300)) + (LAFITE.BROWSER.LAYOUTS NIL) + (LAFITE.MIDDLE.UPDATE '(:EXPUNGE :SHRINK :CONFIRM)) + (LAFITEHARDCOPYBATCHSHADE 1025) + (LAFITEHARDCOPYSEPARATOR "%  Next Message % -") (* ; "Obsolete") (RPAQ? LAFITEDISPLAYREGION (CREATEREGION 375 25 600 335)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) LAFITEDECLS) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA LAFITE.HARDCOPY.MESSAGES) ) (PUTPROPS LAFITECOMMANDS COPYRIGHT ("Xerox Corporation" 1988 1989 1992 1993 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7817 24106 (\LAFITE.DISPLAY 7827 . 8649) (\LAFITE.DO.DISPLAY 8651 . 12800) ( SELECTMESSAGETODISPLAY 12802 . 14115) (MESSAGEDISPLAYER 14117 . 21521) (LA.COPY.MESSAGE.TEXT 21523 . 22269) (\LAFITE.CLOSE.DISPLAYWINDOWS 22271 . 23140) (\LAFITE.CLOSE.DISPLAYER 23142 . 24104)) (24107 28944 (\LAFITE.UNHIDE.HEADERS 24117 . 24842) (\LAFITE.HIDE.HEADERS 24844 . 25132) ( \LAFITE.REHIDE.HEADERS 25134 . 25918) (LAFITE.EAT.UNDESIRABLE.FIELD 25920 . 26494) (LAFITE.EAT.GVGV 26496 . 27197) (\LAFITE.HARDCOPY.FROM.DISPLAY 27199 . 28706) (LAFITE.HARDCOPY.TAB.WIDTH 28708 . 28942) ) (28945 33913 (\LAFITE.SET.LOOKS.FROM.MENU 28955 . 29081) (\LAFITE.SET.DEFAULT.LOOKS 29083 . 29224) ( \LAFITE.SET.FIXED.LOOKS 29226 . 29368) (LAFITE.SET.LOOKS 29370 . 32004) (LAFITE.SET.TAB.LOOKS 32006 . 32436) (LAFITE.SET.PARA.SEPARATION 32438 . 32592) (LAFITE.SET.LOWER.CASE 32594 . 33035) ( LAFITE.SUBSTITUTE.VP.EOL 33037 . 33911)) (35983 40392 (LAFITE.DELETE.MESSAGES 35993 . 36420) ( \LAFITE.DELETE 36422 . 37006) (DISPLAYAFTERDELETE 37008 . 39488) (\LAFITE.SELECT.NEXT 39490 . 39981) ( \LAFITE.UNDELETE 39983 . 40390)) (40414 47933 (LAFITE.MOVE.MESSAGES 40424 . 40892) (\COERCE.TO.MSGLST 40894 . 41360) (\LAFITE.MOVETO 41362 . 43608) (\LAFITE.COPYTO 43610 . 43891) (\LAFITE.MOVETO.PROC 43893 . 44750) (\LAFITE.MOVE.MESSAGES.INTERNAL 44752 . 47931)) (47959 52916 (\LAFITE.ENABLE.MOVE.MENU 47969 . 48727) (\LAFITE.ADD.TO.MOVE.MENU 48729 . 49508) (\LAFITE.UPDATE.MOVE.MENU 49510 . 51814) ( \LAFITE.RESTORE.MOVE.MENU 51816 . 52190) (\LAFITE.HANDLE.AUTO.MOVE 52192 . 52914)) (53898 63464 ( \LAFITE.UPDATE 53908 . 56290) (\LAFITE.EXPUNGE.PROC 56292 . 56831) (\LAFITE.UPDATE.PROC 56833 . 57528) (\LAFITE.HARDCOPYONLY.PROC 57530 . 57895) (LAB.CHOOSE.UPDATE.MENU 57897 . 58480) ( LAB.CREATE.UPDATE.MENU 58482 . 59573) (LAB.UPDATE.NEEDED? 59575 . 60372) (\LAFITE.START.UPDATE 60374 . 61005) (LAB.START.COMMAND 61007 . 61670) (\LAFITE.FINISH.UPDATE 61672 . 62884) ( \LAFITE.CLOSE.OTHER.FOLDERS 62886 . 63462)) (63465 79983 (LAB.FLUSHWINDOW 63475 . 64262) ( LAB.APPENDMESSAGES 64264 . 65750) (\LAFITE.COMPACT.FOLDER 65752 . 67903) (\LAFITE.COMPACT.FOLDER1 67905 . 74578) (\LAFITE.COMPACT.FOLDER2 74580 . 76910) (\LAFITE.COMPACT.EXTRA 76912 . 78088) ( \LAFITE.INVALIDATE.TOC 78090 . 78581) (\LAFITE.RENAMEFILE 78583 . 78986) (SMART-RENAMEFILEP 78988 . 79364) (LA.OPENTEMPFILE 79366 . 79981)) (79984 87782 (\LAFITE.UPDATE.FOLDER 79994 . 81161) ( \LAFITE.UPDATE.CONTENTS 81163 . 81803) (\LAFITE.UPDATE.CONTENTS1 81805 . 84358) (WRITETOCENTRY 84360 . 86114) (WRITETOCMARKBYTES 86116 . 86293) (WRITEFOLDERMARKBYTES 86295 . 87780)) (87808 96974 ( LAFITE.HARDCOPY.MESSAGES 87818 . 88086) (\LAFITE.HARDCOPY 88088 . 88373) (\LAFITE.HARDCOPY.PROC 88375 . 89760) (\LAFITE.HARDCOPY.HEADERS 89762 . 92206) (\LAFITE.MARK.HARDCOPIED 92208 . 92856) ( \LAFITE.TRANSMIT.HARDCOPY 92858 . 93468) (\LAFITE.HARDCOPY.BODIES 93470 . 94207) ( \LAFITE.APPEND.MESSAGE.BODY 94209 . 95457) (\LAFITE.DO.PENDING.HARDCOPY 95459 . 96056) ( \LAFITE.CANCEL.HARDCOPY 96058 . 96528) (\LAFITE.CLEAR.HARDCOPY.STATE 96530 . 96972))))) STOP \ No newline at end of file +")) + (COMS (* ; "Obsolete") + (INITVARS (LAFITEDISPLAYREGION (CREATEREGION 375 25 600 335] + (DECLARE%: DOEVAL@COMPILE DONTCOPY (FILES (SOURCE) + LAFITEDECLS) + (LOCALVARS . T)) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA + LAFITE.HARDCOPY.MESSAGES + ]) + + + +(* ;; "Handling of the main Lafite browser commands") + + + + +(* ; "DISPLAY") + +(DEFINEQ + +(\LAFITE.DISPLAY + [LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* ; "Edited 22-Sep-87 14:56 by bvm:") + (PROG (DISPLAYWINDOW) + (COND + ([WINDOWP (SETQ DISPLAYWINDOW + (RESETLST + (LA.RESETSHADE ITEM MENU) + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) + [OR (LAB.ASSURE.SELECTIONS MAILFOLDER) + (LET ((MSGDESCRIPTOR (SELECTMESSAGETODISPLAY WINDOW + MAILFOLDER)) + W) + (COND + [MSGDESCRIPTOR (\LAFITE.DO.DISPLAY + MAILFOLDER MSGDESCRIPTOR + (EQ KEY 'MIDDLE] + (T (LAB.PROMPTPRINT MAILFOLDER T "No more messages.") + (* ; + "But return current display window for topping, just in case it was buried") + (CAR (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) + of MAILFOLDER]))] + (* ; + "make sure the display window is on top in case SHADEITEM put the browser back on top") + (TOTOPW DISPLAYWINDOW]) + +(\LAFITE.DO.DISPLAY + [LAMBDA (MAILFOLDER MSGDESCRIPTOR NEWWINDOWFLG) (* ; "Edited 28-Jun-99 10:22 by rmk:") + (* ; "Edited 27-Jun-99 22:44 by rmk:") + (* ; "Edited 25-Jun-99 19:05 by rmk:") + (* ; "Edited 25-Jun-99 18:31 by rmk:") + (* ; "Edited 13-Oct-87 15:56 by bvm:") + +(* ;;; "Display MSGDESCRIPTOR from MAILFOLDER, using a new window if NEWWINDOWFLG is true, else reusing if possible the primary window. Returns the window.") + +(* ;;; "") + +(* ;;; "rmk, 6/99. I modified the interface to LA.COPY.MESSAGE.TEXT to make it easier to replace that function with something that deals with MIME attachments. I moved the MAYBEVERIFYMSG up to this level to eliminate a compile-time dependency on that macro, and this required moving the \LAFITE.OPEN.FOLDER as well. That call is harmlessly repeated in LA.COPY.MESSAGE.TEXT") + + (PROG (TEMPMSG DISPLAYWINDOW) + (LAB.EXPOSEMESSAGE MAILFOLDER MSGDESCRIPTOR) + (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of MAILFOLDER with NIL) + (* ; "Clear it here in case of abort") + (\LAFITE.OPEN.FOLDER MAILFOLDER 'INPUT :ABORT) + (MAYBEVERIFYMSG MSGDESCRIPTOR MAILFOLDER) + (SETQ TEMPMSG (LA.COPY.MESSAGE.TEXT MAILFOLDER MSGDESCRIPTOR NEWWINDOWFLG)) + (SETQ DISPLAYWINDOW (MESSAGEDISPLAYER MAILFOLDER TEMPMSG (CONCAT "Message " + (fetch (LAFITEMSG + %#) + of MSGDESCRIPTOR + ) + " from " + (fetch (MAILFOLDER + + FULLFOLDERNAME + ) + of MAILFOLDER) + " [" + (fetch (LAFITEMSG + + MESSAGELENGTH + ) + of MSGDESCRIPTOR + ) + " chars]") + NEWWINDOWFLG)) + (SEENMESSAGE MSGDESCRIPTOR MAILFOLDER) + (PROGN (* ; "Cache the stream that we copied the message text to, since we might be able to use it to accelerate a Move or Hardcopy. Unfortunately, we can't take advantage of it now, since NODIRCORE doesn't support multiple streams per file.") + (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of MAILFOLDER with TEMPMSG) + (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of MAILFOLDER with + MSGDESCRIPTOR + )) + (RETURN DISPLAYWINDOW]) + +(SELECTMESSAGETODISPLAY + [LAMBDA (WINDOW MAILFOLDER) (* bvm%: " 1-Mar-86 18:19") + +(* ;;; "Laurel acts differently if there is currently only one message selected or many about whether it unselects the one that was displayed before. Lafite will follow the same model") + + (LET ((CURRENTDISPLAYEDMSG (fetch (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of MAILFOLDER)) + (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) + (FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER)) + (LAST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER)) + DISPLAYED# MSGDESCRIPTOR) + (COND + ((IGREATERP FIRST# LAST#) (* ; + "Nothing selected, so nothing to display") + NIL) + ((OR (NULL CURRENTDISPLAYEDMSG) + (NOT (fetch (LAFITEMSG SELECTED?) of CURRENTDISPLAYEDMSG))) + (* ; + "haven't displayed any yet, or displayed one is not part of the selection") + (NTHMESSAGE MESSAGES FIRST#)) + ((EQ FIRST# LAST#) (* ; + "Only one msg selected and it is displayed, so move on to next undeleted msg") + (\LAFITE.SELECT.NEXT MAILFOLDER (fetch (LAFITEMSG %#) of CURRENTDISPLAYEDMSG + ))) + (T (* ; + "Multiple selections -- Cycle to the next one") + (NTHMESSAGE MESSAGES (COND + ((EQ (SETQ DISPLAYED# (fetch (LAFITEMSG %#) of + CURRENTDISPLAYEDMSG + )) + LAST#) (* ; "Cycle back to first") + FIRST#) + (T (LAB.FIND.SELECTED.MSG MAILFOLDER (ADD1 DISPLAYED#) + LAST#]) + +(MESSAGEDISPLAYER + [LAMBDA (MAILFOLDER TEXTFILE TITLE NEWWINDOWFLG) (* ; "Edited 24-Jun-99 15:34 by rmk:") + (* ; "Edited 24-Jun-99 15:32 by rmk:") + (* ; "Edited 24-Jun-99 15:32 by rmk:") + (* ; "Edited 6-Aug-93 18:48 by bvm") + +(* ;;; "Displayer for individual messages") + + (LET ((CURRENTWINDOWS (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of MAILFOLDER)) + [PROPS `(FONT ,LAFITEDISPLAYFONT] + (WINDOWPROPS '(READONLY T PROMPTWINDOW DON'T)) + (EOF (GETEOFPTR TEXTFILE)) + TEXTSTREAM DISPLAYWINDOW FILTERED) + + (* ;; "WINDOWPROPS for when we finally give TEdit a window: READONLY in order to avoid TEdit's odd temptation to display an ugly caret at the start and prevent mouse actions from yielding %"NewEditProcess%" menu; PROMPTWINDOW to inhibit attaching a prompt window. Due to a TEdit bug, you can't give the PROMPTWINDOW prop when opening without a window or it will try to make the symbol DON'T be the promptwindow later on.") + + (if (AND \LAPARSE.DONT.DISPLAY.HEADERS (NEQ EOF 0) + (SETQ FILTERED (LAFITE.NEW.PARSE.HEADER TEXTFILE \LAPARSE.DONT.DISPLAY.HEADERS + 0))) + then (* ; + "We will filter some headers out, so put * in title to show this") + (SETQ TITLE (CONCAT "*" TITLE))) + [COND + ((AND (NOT NEWWINDOWFLG) + (SETQ DISPLAYWINDOW (CAR CURRENTWINDOWS))) + (MAPC (WINDOWPROP DISPLAYWINDOW 'EXTRAWINDOWS NIL) + (FUNCTION CLOSEW)) (* ; + "Get rid of extra windows produced by attachments") + (CLEARW DISPLAYWINDOW) + (WINDOWPROP DISPLAYWINDOW 'TITLE TITLE)) + (T (SETQ DISPLAYWINDOW (CREATEW (COND + [(AND (NOT NEWWINDOWFLG) + (PROGN (* ; + "This says where we'd like the primary window to be.") + (fetch (MAILFOLDER + FOLDERDISPLAYREGION) + of MAILFOLDER] + (LAFITE.DISPLAY.SIZE + (* ; "Global default") + (GETBOXREGION (CAR LAFITE.DISPLAY.SIZE) + (CDR LAFITE.DISPLAY.SIZE) + NIL NIL NIL TITLE))) + TITLE)) + (WINDOWADDPROP DISPLAYWINDOW 'CLOSEFN (FUNCTION \LAFITE.CLOSE.DISPLAYER)) + (WINDOWPROP DISPLAYWINDOW 'TEDIT.MENU.COMMANDS \LAFITE.DISPLAY.COMMANDS) + (COND + [(NOT CURRENTWINDOWS) + (replace (MAILFOLDER FOLDERDISPLAYWINDOWS) of MAILFOLDER + with (if NEWWINDOWFLG + then (* ; + "not primary, even though no window previously open") + (LIST NIL DISPLAYWINDOW) + else (LIST DISPLAYWINDOW] + [NEWWINDOWFLG (RPLACD CURRENTWINDOWS (CONS DISPLAYWINDOW (CDR CURRENTWINDOWS] + (T (* ; + "DIsplaying the primary window for the first time when there are already secondary windows.") + (RPLACA CURRENTWINDOWS DISPLAYWINDOW] (* ; "Now let TEDIT display it") + [COND + ((EQ EOF 0) + (LAB.PROMPTPRINT MAILFOLDER "Message is empty")) + (T [LET (WINDOW) + (if (NOT FILTERED) + then (* ; + "Go ahead and display it right off. ") + (SETQ PROPS (NCONC PROPS WINDOWPROPS)) + (SETQ WINDOW DISPLAYWINDOW)) + (SETQ TEXTSTREAM (OR (CAR (NLSETQ (OPENTEXTSTREAM TEXTFILE WINDOW NIL NIL PROPS)) + ) + (PROGN (LAB.PROMPTPRINT MAILFOLDER T + "Problems displaying message, trying unformatted." + ) + (OPENTEXTSTREAM TEXTFILE WINDOW NIL NIL + (LIST* 'CLEARGET T PROPS] + (if FILTERED + then (if (NOT (= EOF (GETEOFPTR TEXTSTREAM))) + then (* ; + "rats, there may have been nschars in the header, so parse it now more carefully") + (SETQ FILTERED (LAFITE.NEW.PARSE.HEADER TEXTSTREAM + \LAPARSE.DONT.DISPLAY.HEADERS 0))) + (\LAFITE.HIDE.HEADERS TEXTSTREAM FILTERED) + (* ; + "Now we can display it without a major glitch") + (OPENTEXTSTREAM TEXTSTREAM DISPLAYWINDOW NIL NIL WINDOWPROPS) + (TEXTPROP TEXTSTREAM 'FILTERED FILTERED) + (* ; + "Remember what's invisible, so we can easily undo it") + ) + (COND + (LAFITEENDOFMESSAGESTR (* ; + "Add %"End of message%" token. Have to take away READONLY for a moment here...") + (TEXTPROP TEXTSTREAM 'READONLY NIL) + [SETFILEPTR TEXTSTREAM (SUB1 (SETQ EOF (GETEOFPTR TEXTSTREAM] + (COND + ((NEQ (BIN TEXTSTREAM) + (CHARCODE CR)) (* ; + "Message doesn't end in CR, so add one before inserting end of message str") + (TEDIT.INSERT TEXTSTREAM LAFITEEOL (ADD1 (add EOF 1)) + NIL T))) + (TEDIT.INSERT TEXTSTREAM LAFITEENDOFMESSAGESTR (ADD1 EOF) + LAFITEENDOFMESSAGEFONT T) + (TEXTPROP TEXTSTREAM 'READONLY T) + (TEDIT.SETSEL TEXTSTREAM 1 0) + (\CARET.DOWN) (* ; "Patch around TEdit bug") + ] + DISPLAYWINDOW]) + +(LA.COPY.MESSAGE.TEXT + [LAMBDA (MAILFOLDER MSGDESCRIPTOR NEWWINDOWFLG) (* ; "Edited 27-Jun-99 22:47 by rmk:") + (* ; "Edited 27-Jun-99 22:44 by rmk:") + (* ; "Edited 25-Jun-99 18:30 by rmk:") + (LET (OUTPUTSTREAM (INSTREAM (\LAFITE.OPEN.FOLDER MAILFOLDER 'INPUT :ABORT))) + (SETQ OUTPUTSTREAM (OPENSTREAM '{NODIRCORE} 'BOTH)) + (COPYBYTES INSTREAM OUTPUTSTREAM (fetch (LAFITEMSG START) of MSGDESCRIPTOR) + (fetch (LAFITEMSG END) of MSGDESCRIPTOR)) + (CLOSEF OUTPUTSTREAM) + (OPENSTREAM OUTPUTSTREAM 'INPUT NIL '((ENDOFSTREAMOP \LAFITE.EOF]) + +(\LAFITE.CLOSE.DISPLAYWINDOWS + [LAMBDA (FOLDER) (* ; "Edited 22-Sep-87 15:36 by bvm:") + + (* ;; "Called when browser closed, to close associated windows.") + + (PROG ((WINDOWS (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER)) + W) + (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER with NIL) + (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of FOLDER with NIL) + (COND + (WINDOWS (for WINDOW in (CDR WINDOWS) do + (* ; + "Leave secondary windows open, but disconnect them from browser") + (WINDOWDELPROP + WINDOW + 'CLOSEFN + (FUNCTION \LAFITE.CLOSE.DISPLAYER)) + ) + (COND + ((WINDOWP (SETQ W (CAR WINDOWS))) (* ; "Save region for later") + [replace (MAILFOLDER FOLDERDISPLAYREGION) of FOLDER + with (APPEND (WINDOWPROP W 'REGION] + (WINDOWDELPROP W 'CLOSEFN (FUNCTION \LAFITE.CLOSE.DISPLAYER)) + (CLOSEW W))) + (replace (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER with NIL]) + +(\LAFITE.CLOSE.DISPLAYER + [LAMBDA (WINDOW) (* ; "Edited 16-Aug-89 11:27 by bvm") + + (* ;; "called via CLOSEFN when a display window is explicitly closed") + + (MAPC (WINDOWPROP WINDOW 'EXTRAWINDOWS NIL) + (FUNCTION CLOSEW)) + (for FOLDER in \ACTIVELAFITEFOLDERS bind THESEWINDOWS + when (MEMB WINDOW (SETQ THESEWINDOWS (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) + of FOLDER))) + do (* ; "Do we need a monitorlock here?") + (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER with NIL) + (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of FOLDER with NIL) + [if (EQ WINDOW (CAR THESEWINDOWS)) + then (* ; + "the main window--keep its region") + [replace (MAILFOLDER FOLDERDISPLAYREGION) of FOLDER + with (APPEND (WINDOWPROP WINDOW 'REGION] + (if (CDR THESEWINDOWS) + then (RPLACA THESEWINDOWS NIL) + else (replace (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER + with NIL)) + else (* ; "floating window, just remove") + (RPLACD THESEWINDOWS (DREMOVE WINDOW (CDR THESEWINDOWS] + (RETURN]) +) +(DEFINEQ + +(\LAFITE.UNHIDE.HEADERS + [LAMBDA (TEXTSTREAM) (* ; "Edited 10-Dec-87 19:48 by bvm:") + (LET ((FILTERED (TEXTPROP TEXTSTREAM 'FILTERED)) + START W) + (if (OR (NULL FILTERED) + (TEXTPROP TEXTSTREAM 'VISIBLE)) + then (PROMPTPRINT "The whole message is already displayed") + else (TEXTPROP TEXTSTREAM 'READONLY NIL) + (TEDIT.LOOKS TEXTSTREAM '(INVISIBLE OFF) + [ADD1 (SETQ START (CAAR (LAST FILTERED] + (- (CADAR FILTERED) + START)) + (TEDIT.SETSEL TEXTSTREAM 1 0) + (TEXTPROP TEXTSTREAM 'VISIBLE T) + (TEXTPROP TEXTSTREAM 'READONLY T) + (if (SETQ W (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM)) + then (* ; "Remove the * from the title.") + (WINDOWPROP W 'TITLE (SUBSTRING (WINDOWPROP W 'TITLE) + 2]) + +(\LAFITE.HIDE.HEADERS + [LAMBDA (TEXTSTREAM FILTERED) (* ; "Edited 10-Dec-87 19:44 by bvm:") + [for PAIR in FILTERED do (* ; + "Make each filtered field invisible") + (TEDIT.LOOKS TEXTSTREAM '(INVISIBLE ON) + (+ (CAR PAIR) + 1) + (- (CADR PAIR) + (CAR PAIR] + (TEDIT.SETSEL TEXTSTREAM 1 0]) + +(\LAFITE.REHIDE.HEADERS + [LAMBDA (TEXTSTREAM) (* ; "Edited 10-Dec-87 19:44 by bvm:") + + (* ;; "Called from display window menu to hide the headers again after having them unhidden.") + + (LET ((FILTERED (TEXTPROP TEXTSTREAM 'FILTERED)) + START W) + (if (NULL FILTERED) + then (PROMPTPRINT "No uninteresting header fields were found") + elseif (NOT (TEXTPROP TEXTSTREAM 'VISIBLE)) + then (PROMPTPRINT "Uninteresting headers are already hidden") + else (TEXTPROP TEXTSTREAM 'READONLY NIL) + (\LAFITE.HIDE.HEADERS TEXTSTREAM FILTERED) + (TEXTPROP TEXTSTREAM 'VISIBLE NIL) + (TEXTPROP TEXTSTREAM 'READONLY T) + (if (SETQ W (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM)) + then (* ; "Add * back to the title.") + (WINDOWPROP W 'TITLE (CONCAT "*" (WINDOWPROP W 'TITLE]) + +(LAFITE.EAT.UNDESIRABLE.FIELD + [LAMBDA (STREAM IGNORE) (* ; "Edited 23-Sep-87 13:12 by bvm:") + + (* ;; "Parser function called when a field to be filtered is found--skip over the field, and push onto the result a pair giving (start stop) of the whole field.") + + (DECLARE (USEDFREE PARSERESULT PARSEBEGIN)) (* ; "bound in parser") + (LA.SKIP.TO.EOL STREAM) + (if [AND PARSERESULT (= PARSEBEGIN (CADR (CAR PARSERESULT] + then (* ; "two in a row--combine them") + (CL:SETF (CADR (CAR PARSERESULT)) + (GETFILEPTR STREAM)) + else (push PARSERESULT (LIST PARSEBEGIN (GETFILEPTR STREAM]) + +(LAFITE.EAT.GVGV + [LAMBDA (STREAM) (* ; "Edited 6-Feb-89 14:18 by bvm") + (DECLARE (USEDFREE PARSERESULT)) + + (* ;; "Called when we get to the CR at the end of the header. Now look for a section of thext beginning and ending in lines of the form GVGVGVGV...") + + (LET ((HERE (GETFILEPTR STREAM)) + GVSTART GVEND) + (if (AND (EQ (SKIPSEPRCODES STREAM) + (CHARCODE G)) + [PROGN (SETQ GVSTART (GETFILEPTR STREAM)) + (bind CH until (EQ (SETQ CH (BIN STREAM)) + (CHARCODE EOL)) + always (OR (EQ CH (CHARCODE G)) + (EQ CH (CHARCODE V] + (SETQ GVEND (FFILEPOS "GVGVGV + +" STREAM NIL NIL NIL T))) + then (push PARSERESULT (LIST GVSTART GVEND))) + (SETFILEPTR STREAM HERE) (* ; + "Return STOP to tell parser to stop") + 'STOP]) + +(\LAFITE.HARDCOPY.FROM.DISPLAY + [LAMBDA (TEXTSTREAM) (* ; "Edited 10-Jun-88 18:36 by bvm") + + (* ;; "Hardcopy command on title bar of message display -- like window hardcopy, but gets the title right and omits the end of message string.") + + (RESETLST + [if LAFITEENDOFMESSAGESTR + then (* ; "Hide end of message") + (LET [(LEN (GETEOFPTR TEXTSTREAM)) + (NC (NCHARS LAFITEENDOFMESSAGESTR)) + (FIXEDLOOKS (TEXTPROP TEXTSTREAM 'LAFITEFIXEDLOOKS] + (RESETSAVE + NIL + (LIST [FUNCTION (LAMBDA (TEXTSTREAM LEN NC FIXEDLOOKS) + (LET ((W (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM))) + (if (AND W (OPENWP W) + (EQ (WINDOWPROP W 'TEXTSTREAM) + TEXTSTREAM)) + then (* ; + "Don't screw around if the message isn't in the window anymore") + (TEDIT.LOOKS TEXTSTREAM '(INVISIBLE OFF) + (ADD1 (- LEN NC)) + NC) + (TEDIT.SETSEL TEXTSTREAM 1 0) + (TEXTPROP TEXTSTREAM 'READONLY T) + (if FIXEDLOOKS + then (LAFITE.SET.TAB.LOOKS + TEXTSTREAM FIXEDLOOKS + (TIMES 8 (CHARWIDTH (CHARCODE X) + LAFITEFIXEDWIDTHFONT + ] + TEXTSTREAM LEN NC FIXEDLOOKS)) + (TEXTPROP TEXTSTREAM 'READONLY NIL) + (TEDIT.LOOKS TEXTSTREAM '(INVISIBLE ON) + (ADD1 (- LEN NC)) + NC) + (if FIXEDLOOKS + then (* ; + "Change to the hardcopy tab width") + (LAFITE.SET.TAB.LOOKS TEXTSTREAM FIXEDLOOKS ( + LAFITE.HARDCOPY.TAB.WIDTH + ] + [TEDIT.HARDCOPY TEXTSTREAM NIL NIL (LET ((TMP (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM))) + (AND TMP (SETQ TMP (WINDOWPROP TMP 'TITLE)) + (if (EQ (CHCON1 TMP) + (CHARCODE *)) + then + (* ; "Remove the * that says filtered") + (SUBSTRING TMP 2) + else TMP])]) + +(LAFITE.HARDCOPY.TAB.WIDTH + [LAMBDA NIL (* ; "Edited 10-Jun-88 18:27 by bvm") + (FIXR (TIMES (FQUOTIENT (CHARWIDTH (CHARCODE X) + (FONTCOPY LAFITEFIXEDWIDTHFONT 'DEVICE 'INTERPRESS)) + (CONSTANT (FQUOTIENT 2540 72))) + 8]) +) +(DEFINEQ + +(\LAFITE.SET.LOOKS.FROM.MENU + [LAMBDA (TEXTSTREAM) (* ; "Edited 22-Sep-87 12:43 by bvm:") + (LAFITE.SET.LOOKS TEXTSTREAM T]) + +(\LAFITE.SET.DEFAULT.LOOKS + [LAMBDA (TEXTSTREAM) (* ; "Edited 22-Sep-87 12:33 by bvm:") + (LAFITE.SET.LOOKS TEXTSTREAM LAFITEDISPLAYFONT]) + +(\LAFITE.SET.FIXED.LOOKS + [LAMBDA (TEXTSTREAM) (* ; "Edited 22-Sep-87 12:43 by bvm:") + (LAFITE.SET.LOOKS TEXTSTREAM LAFITEFIXEDWIDTHFONT]) + +(LAFITE.SET.LOOKS + [LAMBDA (TEXTSTREAM NEWLOOKS PARALOOKS OMITHEADER USERFN) + (* ; "Edited 3-Nov-89 14:50 by bvm") + + (* ;; "Called from Looks (sub)commands of Lafite display window. Change the looks of the current selection (if there is an interesting one) or the whole message to be NEWLOOKS. If NEWLOOKS is T, we use TEdit's menu interface. PARALOOKS is for paragraph formatting. USERFN is arbitrary function called with arg textstream & selection set appropriately. Any of NEWLOOKS, PARALOOKS, USERFN can be NIL. If OMITHEADER is true, the header is left out of the modification if user has not selected a region of text already.") + + (RESETLST + (RESETSAVE NIL (LIST 'TEXTPROP TEXTSTREAM 'READONLY T)) + (TEXTPROP TEXTSTREAM 'READONLY NIL) + (LET ((SEL (TEDIT.GETSEL TEXTSTREAM)) + START LEN WIDTH FIXEDLOOKS) + [if (AND (NOT PARALOOKS) + (FONTP NEWLOOKS) + (EQ (SETQ WIDTH (CHARWIDTH (CHARCODE "i") + NEWLOOKS)) + (CHARWIDTH (CHARCODE "W") + NEWLOOKS))) + then (* ; "If font is fixed-width, let's make the tab the right width. Might be nice to restore default tab if it's not fixed-width, but TEdit apparently doesn't support that.") + (SETQ FIXEDLOOKS (SETQ PARALOOKS `(TABS (,(TIMES WIDTH 8] + (if (> (SETQ LEN (fetch (SELECTION DCH) of SEL)) + 1) + then (* ; "User has already selected something. Assume any selection greater than a single character is not accidental.") + (if (AND FIXEDLOOKS (NEQ (SETQ FIXEDLOOKS (TEXTPROP TEXTSTREAM + 'LAFITEFIXEDLOOKS)) + T)) + then + + (* ;; "Record the portions we have so marked, so hardcopy can work right--T means everything. If FIXEDLOOKS is false, might want to unset, but that's tedious, unlikely to be worth the hairy code") + + (TEXTPROP TEXTSTREAM 'LAFITEFIXEDLOOKS + (CONS (CONS (fetch (SELECTION CH#) of SEL) + LEN) + FIXEDLOOKS))) + else (SETQ START (if OMITHEADER + then (* ; + "Start after the blank line following the header") + (\LAFITE.HEADER.EOF TEXTSTREAM) + else 0)) + (SETQ LEN (- (GETEOFPTR TEXTSTREAM) + (if LAFITEENDOFMESSAGESTR + then (NCHARS LAFITEENDOFMESSAGESTR) + else 0) + START)) + (TEDIT.SETSEL TEXTSTREAM (ADD1 START) + LEN + 'RIGHT) + (if FIXEDLOOKS + then (* ; "The whole thing is fixed now") + (TEXTPROP TEXTSTREAM 'LAFITEFIXEDLOOKS T))) + + (* ;; "Now do the modification") + + (if (EQ NEWLOOKS T) + then (* ; "Use menu") + (\TEDIT.LOOKS (TEXTOBJ TEXTSTREAM)) + elseif NEWLOOKS + then (TEDIT.LOOKS TEXTSTREAM NEWLOOKS)) + (if PARALOOKS + then (* ; "Paragraph looks") + (TEDIT.PARALOOKS TEXTSTREAM PARALOOKS)) + (if USERFN + then (* ; "Arbitrary user manipulation.") + (CL:FUNCALL USERFN TEXTSTREAM)) + + (* ;; "Finally, set selection back to where it was.") + + (TEDIT.SETSEL TEXTSTREAM SEL)))]) + +(LAFITE.SET.TAB.LOOKS + [LAMBDA (TEXTSTREAM FIXEDLOOKS TABWIDTH) (* ; "Edited 11-Jun-88 17:07 by bvm") + (LET ([LOOKS `(TABS (,TABWIDTH] + (SEL (TEDIT.GETSEL TEXTSTREAM))) + [if (EQ FIXEDLOOKS T) + then (TEDIT.PARALOOKS TEXTSTREAM LOOKS 1 (GETEOFPTR TEXTSTREAM)) + else (for PAIR in FIXEDLOOKS do (TEDIT.PARALOOKS TEXTSTREAM LOOKS + (CAR PAIR) + (CDR PAIR] + (* ; "Finally, restore selection") + (TEDIT.SETSEL TEXTSTREAM SEL]) + +(LAFITE.SET.PARA.SEPARATION + [LAMBDA (TEXTSTREAM) (* ; "Edited 29-Aug-89 14:53 by bvm") + (LAFITE.SET.LOOKS TEXTSTREAM NIL '(PARALEADING 10) + T]) + +(LAFITE.SET.LOWER.CASE + [LAMBDA (TEXTSTREAM) (* ; "Edited 7-Nov-89 13:06 by bvm") + + (* ;; "Called from Looks (sub)commands of Lafite display window. Change the current selection (if there is an interesting one) or the whole message to be lowercase.") + + (LAFITE.SET.LOOKS TEXTSTREAM NIL NIL T (FUNCTION (LAMBDA (TEXTSTREAM) + (LET ((STR (TEDIT.SEL.AS.STRING TEXTSTREAM + ))) + (TEDIT.DELETE TEXTSTREAM) + (TEDIT.INSERT TEXTSTREAM (L-CASE + STR]) + +(LAFITE.SUBSTITUTE.VP.EOL + [LAMBDA (TEXTSTREAM) (* ; "Edited 4-Aug-89 16:55 by bvm") + + (* ;; + "Called from Looks (sub)commands of Lafite display window. Replace VP eol (29) with ours.") + + (RESETLST + (RESETSAVE NIL (LIST 'TEXTPROP TEXTSTREAM 'READONLY T)) + (TEXTPROP TEXTSTREAM 'READONLY NIL) + (LET* ((SEL (TEDIT.GETSEL TEXTSTREAM)) + (LEN (fetch (SELECTION DCH) of SEL)) + POS) + (if (<= LEN 1) + then (* ; + "If user has already selected something (more than a single character), assume is not accidental.") + (SETQ POS (CADAR (LAFITE.PARSE.HEADER TEXTSTREAM NIL NIL NIL NIL T))) + (TEDIT.SETSEL TEXTSTREAM POS (- (GETEOFPTR TEXTSTREAM) + (if LAFITEENDOFMESSAGESTR + then (NCHARS LAFITEENDOFMESSAGESTR) + else 0) + POS))) + (TEDIT.SUBSTITUTE TEXTSTREAM (ALLOCSTRING 1 29) + (ALLOCSTRING 1 (CHARCODE EOL))) + (if POS + then (* ; "Undo the selection") + (TEDIT.SETSEL TEXTSTREAM 1 0))))]) +) + +(RPAQ? \LAFITE.DISPLAY.COMMANDS NIL) + +(ADDTOVAR LAFITE.EXTRA.DISPLAY.COMMANDS ("Looks" '\LAFITE.SET.LOOKS.FROM.MENU + "Change the appearance of the selected text, or whole message if nothing selected" + ) + ("Hardcopy" '\LAFITE.HARDCOPY.FROM.DISPLAY + "Hardcopy this message in its current appearance") + ("Unhide" '\LAFITE.UNHIDE.HEADERS + "Display the header fields that are hidden from view." + (SUBITEMS ("Hide" '\LAFITE.REHIDE.HEADERS + "Hide uninteresting fields from view again" + )))) + +(ADDTOVAR LAFITE.LOOKS.SUBCOMMANDS ("VP Line Breaks" 'LAFITE.SUBSTITUTE.VP.EOL + "Replace the Viewpoint end of line character with ours." + ) + ("Lowercase" 'LAFITE.SET.LOWER.CASE + "Lowercase the region or whole message.") + ("Spread Paragraphs" 'LAFITE.SET.PARA.SEPARATION + "Separate paragraphs by 10 points (useful for Tioga messages)." + ) + ("Default" '\LAFITE.SET.DEFAULT.LOOKS + "Change selection (or whole text) back to default font" + ) + ("Fixed Width" '\LAFITE.SET.FIXED.LOOKS + "Change selection (or whole text) to fixed-width font")) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \LAFITE.DISPLAY.COMMANDS) +) + + + +(* ; "DELETE") + +(DEFINEQ + +(LAFITE.DELETE.MESSAGES + [LAMBDA (FOLDER MESSAGES) (* ; "Edited 31-Aug-88 12:47 by bvm") + + (* ;; "Programmatic entrypoint to delete a single MSG (# or msg object) from FOLDER. FOLDER must have a browser.") + + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) + (for MSG inside MESSAGES do (DELETEMESSAGE + (if (type? LAFITEMSG MSG) + then MSG + else (NTHMESSAGE (fetch (MAILFOLDER + MESSAGEDESCRIPTORS + ) + of FOLDER) + MSG)) + FOLDER)))]) + +(\LAFITE.DELETE + [LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* ; "Edited 30-Aug-88 11:42 by bvm") + (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE) + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) + (OR (LAB.ASSURE.SELECTIONS MAILFOLDER) + (for MSGDESCRIPTOR selectedin MAILFOLDER when (NOT (fetch (LAFITEMSG + DELETED?) + of MSGDESCRIPTOR)) + do (* ; + "delete all the currrently selected messages that aren't already deleted") + (DELETEMESSAGE MSGDESCRIPTOR MAILFOLDER) finally (SHADEITEM ITEM MENU + WHITESHADE) + (DISPLAYAFTERDELETE + MAILFOLDER WINDOW))))]) + +(DISPLAYAFTERDELETE + [LAMBDA (FOLDER WINDOW) (* ; "Edited 29-Aug-88 15:34 by bvm") + +(* ;;; "Maybe select and maybe display the next message after a deletion, according to setting of LAFITEDISPLAYAFTERDELETEFLG --- T means display next if the deleted one is the one currently displayed and the next message is undeleted and unseen --- ALWAYS means display the next undeleted message if the deleted one is the one currently displayed; if it's not currently displayed, merely select the next undeleted message --- MULTIPLE means ALWAYS plus when the selection is multiple, still advance to next undeleted msg.") + + (COND + (LAFITEDISPLAYAFTERDELETEFLG + (LET ((FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER)) + CURRENT LASTMSG# MESSAGES MENU) + (COND + [(NEQ FIRST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER)) + + (* ;; "More than one message was selected. Only do something if flag says MULTIPLE -- select but don't display next message") + + (COND + ((EQ LAFITEDISPLAYAFTERDELETEFLG 'MULTIPLE) + (\LAFITE.SELECT.NEXT FOLDER FIRST#] + ((OR (NOT (SETQ CURRENT (fetch (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER + ))) + (NEQ FIRST# (fetch (LAFITEMSG %#) of CURRENT))) + (* ; + "Deleted message is not the one currently displayed") + (SELECTQ LAFITEDISPLAYAFTERDELETEFLG + ((ALWAYS MULTIPLE) (* ; + "select but don't display next message") + (\LAFITE.SELECT.NEXT FOLDER FIRST#)) + NIL)) + ([SELECTQ LAFITEDISPLAYAFTERDELETEFLG + ((ALWAYS MULTIPLE) (* ; + "Always do it, assuming there's a next message") + (\LAFITE.SELECT.NEXT FOLDER FIRST#)) + (AND (NEQ FIRST# (SETQ LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) + of FOLDER))) + [NOT (fetch (LAFITEMSG DELETED?) of (NTHMESSAGE + (SETQ MESSAGES + (fetch (MAILFOLDER + MESSAGEDESCRIPTORS + ) + of FOLDER)) + (ADD1 FIRST#] + (for I from (ADD1 FIRST#) to LASTMSG# bind NEXTMSG + do + + (* ;; "Next message undeleted, so maybe display it. LAFITEDISPLAYAFTERDELETEFLG = T means only do so if it is unexamined. However, messages from us are usually already examined, so pretend the message is unexamined if there is some unexamined message immediately after any from me") + + (COND + ([NOT (fetch (LAFITEMSG SEEN?) of (SETQ NEXTMSG + (NTHMESSAGE MESSAGES + I] + (* ; "An unexamined message, ok") + (RETURN T)) + ((NOT (fetch (LAFITEMSG MSGFROMMEP) of NEXTMSG)) + (* ; + "Not from me, but examined, so must not be in the stream of new mail") + (RETURN NIL] + (\LAFITE.DISPLAY WINDOW FOLDER (LA.MENU.ITEM (FUNCTION \LAFITE.DISPLAY) + (SETQ MENU (fetch (MAILFOLDER + BROWSERMENU) + of FOLDER))) + MENU]) + +(\LAFITE.SELECT.NEXT + [LAMBDA (MAILFOLDER AFTER#) (* ; "Edited 23-Aug-88 18:35 by bvm") + +(* ;;; "Select the next undeleted message in MAILFOLDER following AFTER# and return the msg, or NIL if there are no more") + + (for N from (ADD1 AFTER#) to (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) + bind (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) + MSG unless (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES N)) + ) do (RETURN (LAB.GO.TO.MESSAGE MAILFOLDER MSG]) + +(\LAFITE.UNDELETE + [LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* bvm%: "28-Mar-84 14:48") + (RESETLST + (LA.RESETSHADE ITEM MENU) + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) + (OR (LAB.ASSURE.SELECTIONS MAILFOLDER) + (for MSGDESCRIPTOR selectedin MAILFOLDER when (fetch (LAFITEMSG + DELETED?) + of MSGDESCRIPTOR) + do (UNDELETEMESSAGE MSGDESCRIPTOR MAILFOLDER)))))]) +) + + + +(* ; "MOVE") + +(DEFINEQ + +(LAFITE.MOVE.MESSAGES + [LAMBDA (SOURCEFOLDER DESTINATIONFOLDER MESSAGES COPYFLG) + (* ; "Edited 13-Sep-88 18:38 by bvm") + + (* ;; "Programmatic entry to move (or copy if COPYFLG true) specified MESSAGES from SOURCEFOLDER to DESTINATIONFOLDER. Returns T on success.") + + (AND MESSAGES (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of SOURCEFOLDER) + (\LAFITE.MOVE.MESSAGES.INTERNAL SOURCEFOLDER DESTINATIONFOLDER + (\COERCE.TO.MSGLST MESSAGES SOURCEFOLDER) + NIL NIL COPYFLG))]) + +(\COERCE.TO.MSGLST + [LAMBDA (MSGLST FOLDER) (* ; "Edited 30-Aug-88 14:11 by bvm") + + (* ;; "Accepts a singleton or list of LAFITEMSG objects or numbers relative to FOLDER and returns a list of LAFITEMSG objects") + + (if (AND (CL:LISTP MSGLST) + (for M in MSGLST always (type? LAFITEMSG M))) + then MSGLST + else (LET ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER))) + (for M inside MSGLST collect (if (type? LAFITEMSG M) + then M + else (NTHMESSAGE MESSAGES M]) + +(\LAFITE.MOVETO + [LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY COPYFLG) (* ; "Edited 13-Sep-88 18:33 by bvm") + (PROG ((BROWSERPROMPTWINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of MAILFOLDER)) + LONGFORMP TOFILE OUTPUTFILE DESTINATIONFOLDER MIDDLESELECTED) + (CLEARW BROWSERPROMPTWINDOW) + (COND + ((LAB.ASSURE.SELECTIONS MAILFOLDER) (* ; "Nothing to move") + (RETURN))) + [COND + ((AND (EQ KEY 'MIDDLE) + (SETQ DESTINATIONFOLDER (fetch (MAILFOLDER DEFAULTMOVETOFILE) of + MAILFOLDER + ))) (* ; "Accelerator: don't use menu. We will still re-obtain the destination folder below, since the pointer sitting in the folder may be to a long-closed folder.") + (SETQ MIDDLESELECTED T) + (SETQ OUTPUTFILE (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of DESTINATIONFOLDER + ))) + (T (CL:MULTIPLE-VALUE-SETQ (TOFILE LONGFORMP) + (\LAFITE.PROMPTFORFOLDER BROWSERPROMPTWINDOW)) + (if (NULL TOFILE) + then (RETURN NIL)) + (SETQ OUTPUTFILE (LA.LONGFILENAME TOFILE LAFITEMAIL.EXT)) + (COND + ((STRING-EQUAL OUTPUTFILE (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) + of MAILFOLDER)) + (LAB.PROMPTPRINT MAILFOLDER T "This IS " TOFILE ", can't move to there.") + (RETURN NIL] + (AND ITEM (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE)) + (COND + (LONGFORMP (* ; "if user had to type file longhand, don't confirm now (but there may be a confirmation for creation later on)") + ) + ((SELECTQ LAFITEMOVETOCONFIRMFLG + (NIL (* ; "never confirm") + T) + (LEFT (* ; + "don't confirm when middle selected") + MIDDLESELECTED) + (MIDDLE (* ; + "confirm ONLY when middle selected") + (NOT MIDDLESELECTED)) + NIL)) + [(LAB.MOUSECONFIRM MAILFOLDER "Click LEFT to confirm ~A ~@[of ~D msgs ~]to ~A" + (if COPYFLG + then "copy" + else "move") + (AND (< (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER) + (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER)) + (for MSG selectedin MAILFOLDER sum + (* ; "Count how many selected") + 1)) + (if DESTINATIONFOLDER + then (fetch (MAILFOLDER SHORTFOLDERNAME) of DESTINATIONFOLDER) + else (LA.SHORTFILENAME OUTPUTFILE LAFITEMAIL.EXT] + (T (* ; "abort") + (AND ITEM (SHADEITEM ITEM MENU WHITESHADE)) + (RETURN NIL))) + (\LAFITE.PROCESS `(,(FUNCTION \LAFITE.MOVETO.PROC) + ',WINDOW + ',MAILFOLDER + ',OUTPUTFILE + ',ITEM + ',MENU NIL ',COPYFLG) + 'LAFITEMOVE]) + +(\LAFITE.COPYTO + [LAMBDA (FOLDER ITEM MENU KEY) (* ; "Edited 13-Sep-88 18:37 by bvm") + (LET ((MENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER))) + (\LAFITE.MOVETO (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER) + FOLDER + (LA.MENU.ITEM (FUNCTION \LAFITE.MOVETO) + MENU) + MENU NIL T]) + +(\LAFITE.MOVETO.PROC + [LAMBDA (WINDOW SOURCEFOLDER DESTINATIONFULLNAME ITEM MENU FROM.AUTO.MENU COPYFLG) + (* ; "Edited 13-Sep-88 18:24 by bvm") + + (* ;; "Move selected messages from SOURCEFOLDER to the folder named by OUTPUTFILE. If FROM.AUTO.MENU is true, it came from the auxiliary moveto menu. Note that MENU is thus not necessarily SOURCEFOLDER's menu.") + + (if (RESETLST + (LA.RESETSHADE ITEM MENU) + (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of SOURCEFOLDER) + NIL T) + (LET ((DESTINATIONFOLDER (LAFITE.OBTAIN.FOLDER DESTINATIONFULLNAME 'BOTH SOURCEFOLDER + :CONFIRM))) + (if DESTINATIONFOLDER + then (\LAFITE.MOVE.MESSAGES.INTERNAL SOURCEFOLDER DESTINATIONFOLDER + (LAB.SELECTED.MESSAGES SOURCEFOLDER) + FROM.AUTO.MENU T COPYFLG)))) + then (if COPYFLG + then (LAB.PROMPTPRINT SOURCEFOLDER "Copy completed.") + else (DISPLAYAFTERDELETE SOURCEFOLDER WINDOW]) + +(\LAFITE.MOVE.MESSAGES.INTERNAL + [LAMBDA (SOURCEFOLDER DESTINATIONFOLDER MSGLST FROM.AUTO.MENU INTERACTIVE COPYFLG) + (* ; "Edited 5-Aug-93 19:50 by bvm") + + (* ;; "Move the messages in MSGLST from SOURCEFOLDER to DESTINATIONFOLDER. Caller must have acquired the lock on SOURCEFOLDER. FROM.AUTO.MENU means the call was from the auxiliary move menu; INTERACTIVE means it was interactive call vs. programmatic.") + + (PROG (OUTPUTSTREAM MSGDESCRIPTORS OLDMOVETO) + (COND + ((NOT (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of DESTINATIONFOLDER) + T T)) + (LAB.PROMPTPRINT SOURCEFOLDER T "Waiting for " (fetch (MAILFOLDER SHORTFOLDERNAME) + of DESTINATIONFOLDER) + " to become available...") + (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of DESTINATIONFOLDER) + NIL T) + (LAB.PROMPTPRINT SOURCEFOLDER T))) + (COND + ([NOT (AND (\LAFITE.OPEN.FOLDER SOURCEFOLDER 'INPUT NIL) + (SETQ OUTPUTSTREAM (\LAFITE.OPEN.FOLDER DESTINATIONFOLDER 'BOTH :OK + SOURCEFOLDER] + (* ; "Failed to open source or dest") + (RETURN NIL))) + [COND + ((NEQ (SETQ OLDMOVETO (fetch (MAILFOLDER DEFAULTMOVETOFILE) of SOURCEFOLDER)) + DESTINATIONFOLDER) + (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of SOURCEFOLDER))) + (replace (MAILFOLDER DEFAULTMOVETOFILE) of SOURCEFOLDER with + DESTINATIONFOLDER + ) + (WINDOWPROP WINDOW 'TITLE (LAB.TITLE.STRING SOURCEFOLDER)) + (if [AND OLDMOVETO (NOT FROM.AUTO.MENU) + (OR LAFITE.AUTO.MOVE.MENU (WINDOWPROP WINDOW 'LAFITE.AUTO.MOVE.NAMES] + then (\LAFITE.ADD.TO.MOVE.MENU SOURCEFOLDER DESTINATIONFOLDER + OLDMOVETO] + (SETQ MSGDESCRIPTORS (for OLDMSG in MSGLST bind NEWMSG + (INSTREAM _ (\LAFITE.OPEN.FOLDER + SOURCEFOLDER + 'INPUT)) + collect (MAYBEVERIFYMSG OLDMSG SOURCEFOLDER) + (SETFILEPTR OUTPUTSTREAM -1) + (SETQ NEWMSG (NCREATE 'LAFITEMSG OLDMSG)) + (* ; + "New descriptor looks a lot like old") + (replace (LAFITEMSG BEGIN) of NEWMSG + with (GETFILEPTR OUTPUTSTREAM)) + (replace (LAFITEMSG MESSAGELENGTHCHANGED?) of NEWMSG + with NIL) + (replace (LAFITEMSG MARKSCHANGEDINFILE?) of NEWMSG + with NIL) + (replace (LAFITEMSG MARKSCHANGEDINTOC?) of NEWMSG + with NIL) + (replace (LAFITEMSG DELETED?) of NEWMSG with + NIL) + (replace (LAFITEMSG SELECTED?) of NEWMSG with + NIL) + (LA.PRINTHEADER OUTPUTSTREAM (- (fetch (LAFITEMSG + MESSAGELENGTH + ) + of OLDMSG) + (fetch (LAFITEMSG + STAMPLENGTH + ) + of OLDMSG)) + NEWMSG) + (PROGN (* ; "Now the 3 flag bytes") + (BOUT OUTPUTSTREAM UNDELETEDFLAG) + (BOUT OUTPUTSTREAM (COND + ((fetch (LAFITEMSG SEEN?) + of OLDMSG) + SEENFLAG) + (T UNSEENFLAG))) + (BOUT OUTPUTSTREAM (fetch (LAFITEMSG MARKCHAR) + of OLDMSG)) + (BOUT OUTPUTSTREAM (CHARCODE CR))) + (COPYBYTES INSTREAM OUTPUTSTREAM (fetch (LAFITEMSG START) + of OLDMSG) + (fetch (LAFITEMSG END) of OLDMSG)) + (if (NOT COPYFLG) + then (MARKMESSAGE OLDMSG SOURCEFOLDER MOVETOMARK) + (* ; "delete it") + (DELETEMESSAGE OLDMSG SOURCEFOLDER)) + NEWMSG)) (* ; "delete them from FROMFILE") + [COND + ((AND (fetch (MAILFOLDER BROWSERWINDOW) of DESTINATIONFOLDER) + (fetch (MAILFOLDER BROWSERREADY) of DESTINATIONFOLDER)) + (* ; + "now print them in the other window, if up") + (LAB.APPENDMESSAGES DESTINATIONFOLDER MSGDESCRIPTORS)) + (T (* ; "still have to update eof") + (replace (MAILFOLDER FOLDEREOFPTR) of DESTINATIONFOLDER with (GETEOFPTR + + OUTPUTSTREAM + ] + (RETURN T]) +) + + + +(* ; "Aux move") + +(DEFINEQ + +(\LAFITE.ENABLE.MOVE.MENU + [LAMBDA (FOLDER) (* ; "Edited 31-Aug-88 12:39 by bvm") + + (* ;; "Bring up a menu of folders attached to FOLDER's browser for accelerated MoveTo") + + (LET* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) + (ITEMS (WINDOWPROP WINDOW 'LAFITE.AUTO.MOVE.NAMES)) + (OLDDEFAULT (fetch (MAILFOLDER DEFAULTMOVETOFILE) of FOLDER))) + (LAB.PROMPTPRINT FOLDER T "Specify which folders to include in the accelerated menu.") + (if OLDDEFAULT + then (CL:PUSHNEW (fetch (MAILFOLDER SHORTFOLDERNAME) of OLDDEFAULT) + ITEMS :TEST 'STRING-EQUAL)) + (if (SETQ ITEMS (LAFITE.SELECT.FOLDERS ITEMS)) + then (* ; "Didn't abort") + (WINDOWPROP WINDOW 'LAFITE.AUTO.MOVE.NAMES ITEMS) + (\LAFITE.UPDATE.MOVE.MENU FOLDER T)) + (LAB.PROMPTPRINT FOLDER T]) + +(\LAFITE.ADD.TO.MOVE.MENU + [LAMBDA (FOLDER NEWFOLDER OLDFOLDER) (* ; "Edited 31-Aug-88 12:43 by bvm") + + (* ;; "Add NEWFOLDER to FOLDER's auto move menu, creating it if necessary, in which case also include OLDFOLDER") + + (PROG* ((NEWNAME (fetch (MAILFOLDER SHORTFOLDERNAME) of NEWFOLDER)) + (WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) + (OLDITEMS (WINDOWPROP WINDOW 'LAFITE.AUTO.MOVE.NAMES)) + (ITEMS OLDITEMS)) + (COND + [(NULL ITEMS) + (SETQ ITEMS (LIST NEWNAME)) + (if OLDFOLDER + then (push ITEMS (fetch (MAILFOLDER SHORTFOLDERNAME) of OLDFOLDER] + ((CL:MEMBER NEWNAME ITEMS :TEST 'STRING-EQUAL) (* ; "Nothing new to do") + (RETURN)) + (T (push ITEMS NEWNAME))) + (WINDOWPROP WINDOW 'LAFITE.AUTO.MOVE.NAMES ITEMS) + (\LAFITE.UPDATE.MOVE.MENU FOLDER (NULL OLDITEMS]) + +(\LAFITE.UPDATE.MOVE.MENU + [LAMBDA (FOLDER FORCE) (* ; "Edited 23-Aug-89 12:21 by bvm") + + (* ;; "Called when someone has changed the set of folder names in FOLDER's auto move menu. This function creates a new menu. If the menu is not currently open, we don't open one unless FORCE is true.") + + (PROG* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) + (MENUW (WINDOWPROP WINDOW 'LAFITE.AUTO.MOVE.MENU)) + HOW POSITION TITLE) + (if (NOT (OPENWP WINDOW)) + then (* ; "Maybe the browser is shrunk. The system doesn't know how to attach to shrunken windows, so just punt it") + (RETURN) + elseif MENUW + then (* ; + "Remove the old window and make a new") + (DETACHWINDOW MENUW WINDOW) + (CLOSEW MENUW) + elseif (NULL FORCE) + then (RETURN)) + [SETQ POSITION (SELECTQ (SETQ HOW LAFITE.AUTO.MOVE.MENU) + ((LEFT RIGHT) + 'TOP) + ((BOTTOM TOP) + 'LEFT) + (PROGN (SETQ HOW 'RIGHT) + 'TOP] + [CL:MULTIPLE-VALUE-BIND (NCOLUMNS ITEMS) + (\LAFITE.ARRANGE.MENU (APPEND (SORT (WINDOWPROP WINDOW 'LAFITE.AUTO.MOVE.NAMES) + (FUNCTION UALPHORDER)) + (AND LAFITE.EXTRA.MOVE.ITEMS + (CONS '("" 'NILL "") + LAFITE.EXTRA.MOVE.ITEMS))) + LAFITE.FOLDER.MENU.FONT + (- (LET* ((REG (WINDOWREGION WINDOW)) + (BROWSERHEIGHT (fetch (REGION HEIGHT) of REG))) + (if (EQ POSITION 'TOP) + then (* ; + "Don't make the menu much taller than the window or below bottom of screen") + (MIN (+ BROWSERHEIGHT (IQUOTIENT BROWSERHEIGHT 2)) + (fetch (REGION TOP) of REG)) + else (* ; + "Don't make it taller than the screen") + (- SCREENHEIGHT BROWSERHEIGHT))) + (FONTPROP WINDOWTITLEFONT 'HEIGHT)) + (SETQ TITLE "Move To:")) + (SETQ MENUW + (MENUWINDOW (create MENU + ITEMS _ ITEMS + MENUCOLUMNS _ NCOLUMNS + CENTERFLG _ T + TITLE _ TITLE + WHENHELDFN _ [FUNCTION (LAMBDA (ITEM) + (PROMPTPRINT (if (LISTP ITEM) + then (CADDR + ITEM) + else + "Move the selected message(s) to this folder" + ] + WHENSELECTEDFN _ (FUNCTION \LAFITE.HANDLE.AUTO.MOVE) + MENUFONT _ LAFITE.FOLDER.MENU.FONT + MENUTITLEFONT _ WINDOWTITLEFONT] + (ATTACHWINDOW MENUW WINDOW HOW POSITION 'LOCALCLOSE) + (WINDOWADDPROP MENUW 'CLOSEFN [FUNCTION (LAMBDA (W) + + (* ;; + "Remove pointer to me. Note that this fn must come first, before detachwindow") + + (AND (SETQ W (MAINWINDOW W)) + (WINDOWPROP W 'LAFITE.AUTO.MOVE.MENU NIL] + T) + (WINDOWPROP WINDOW 'LAFITE.AUTO.MOVE.MENU MENUW]) + +(\LAFITE.RESTORE.MOVE.MENU + [LAMBDA (FOLDER) (* ; "Edited 31-Aug-88 15:19 by bvm") + (LET* [(WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) + (ITEMS (WINDOWPROP WINDOW 'LAFITE.AUTO.MOVE.NAMES] + (if ITEMS + then (* ; + "Yes, there was a menu, so bring it up") + (\LAFITE.UPDATE.MOVE.MENU FOLDER T) + else (* ; "Start from scratch") + (\LAFITE.ENABLE.MOVE.MENU FOLDER]) + +(\LAFITE.HANDLE.AUTO.MOVE + [LAMBDA (ITEM MENU KEY) (* ; "Edited 29-Aug-88 15:06 by bvm") + + (* ;; + "Handle the selection of an item from Lafite's auto moveto menu. Just do the specified move") + + (LET ((MENUW (WFROMMENU MENU)) + WINDOW FOLDER) + (AND MENUW (SETQ WINDOW (MAINWINDOW MENUW)) + (SETQ FOLDER (WINDOWPROP WINDOW 'MAILFOLDER)) + (fetch (MAILFOLDER BROWSERREADY) of FOLDER) + (if (LISTP ITEM) + then (* ; "Handle other commands") + (CL:FUNCALL (EXTRACTMENUCOMMAND ITEM) + WINDOW FOLDER ITEM MENU KEY) + else (\LAFITE.PROCESS `(,(FUNCTION \LAFITE.MOVETO.PROC) + ',WINDOW + ',FOLDER + ',(LA.LONGFILENAME ITEM LAFITEMAIL.EXT) + ',ITEM + ',MENU T) + 'LAFITEMOVE]) +) + +(ADDTOVAR LAFITEEXTRAMENUITEMS ("Enable MoveTo Menu" '\LAFITE.ENABLE.MOVE.MENU + "Attach a menu of folders for accelerated MoveTo (or modify existing one)" + (SUBITEMS ("Restore MoveTo Menu" + '\LAFITE.RESTORE.MOVE.MENU + "Just reopen the attached MoveTo menu if it existed." + ))) + ("Copy To" '\LAFITE.COPYTO + "Like MoveTo, but don't delete the message(s).")) + +(ADDTOVAR LAFITE.EXTRA.MOVE.ITEMS ("---Display---" '\LAFITE.DISPLAY "Display the next message") + ("---Delete---" '\LAFITE.DELETE + "Delete the selected message(s)")) + +(RPAQ? LAFITE.AUTO.MOVE.MENU ) + + + +(* ; "UPDATE") + +(DEFINEQ + +(\LAFITE.UPDATE + [LAMBDA (WINDOW FOLDER ITEM MENU BUTTONS) (* ; "Edited 25-Apr-89 15:10 by bvm") + (LET + ((HOWINDEX (LAB.UPDATE.NEEDED? FOLDER)) + HOW? HOWSTRING CLOSEFLG CONFIRMFLG) + (\LAFITE.MAYBE.CLEAR.PROMPT FOLDER) + [if (AND (EQ BUTTONS 'MIDDLE) + LAFITE.MIDDLE.UPDATE) + then (* ; + "Accelerator: do what this flag says, asking only for confirmation first") + (for OP inside LAFITE.MIDDLE.UPDATE + do (CASE OP + ((:CLOSE :SHRINK) (SETQ CLOSEFLG OP)) + ((:UPDATE :EXPUNGE) + (SETQ HOWSTRING (if (AND (EQ OP :EXPUNGE) + (BITTEST HOWINDEX \EXPUNGE.MENU.BIT)) + then (* ; "Expunge is needed and requested") + (SETQ HOW? (FUNCTION \LAFITE.EXPUNGE.PROC)) + "Expunge" + elseif (BITTEST HOWINDEX \SORT.MENU.BIT) + then (* ; "Have to do wtih expunge") + (SETQ HOW? (FUNCTION \LAFITE.EXPUNGE.PROC)) + "Write sorted" + elseif (BITTEST HOWINDEX \EXPUNGE&SORT.MENU.BIT + ) + then (* ; "Have to do wtih expunge") + (SETQ HOW? (FUNCTION \LAFITE.EXPUNGE.PROC)) + "Expunge (write sorted)" + elseif (BITTEST HOWINDEX \UPDATE.MENU.BIT) + then (SETQ HOW? (FUNCTION \LAFITE.UPDATE.PROC + )) + "Write out changes" + elseif (BITTEST HOWINDEX \TOC.MENU.BIT) + then (SETQ HOW? (FUNCTION \LAFITE.UPDATE.PROC + )) + "Update table of contents")) + (if (BITTEST HOWINDEX \HARDCOPY.MENU.BIT) + then (* ; "Also might want to hardcopy") + (SETQ HOWSTRING (if (NULL HOW?) + then (SETQ HOW? + (FUNCTION + \LAFITE.HARDCOPYONLY.PROC)) + "Hardcopy" + else (CONCAT "Hardcopy, " HOWSTRING)) + ) + elseif (NULL HOW?) + then (* ; + "Pretend no update is needed, even if left-update would have said Expunge") + (SETQ HOWINDEX 0))) + (:CONFIRM (SETQ CONFIRMFLG T)))] + (if (AND (NULL CLOSEFLG) + (EQ 0 HOWINDEX)) + then (* ; + "We weren't asked to close it, and nothing changed.") + (LAB.PROMPTPRINT FOLDER T "No changes since the last Update") + elseif + [SETQ HOW? + (if (OR HOWSTRING CLOSEFLG) + then + (if (AND (NULL HOWSTRING) + (EQ CLOSEFLG :SHRINK)) + then (* ; + "Accelerator says Shrink, and there is nothing else to do, so just shrink") + (FUNCTION \LAFITE.FINISH.UPDATE) + elseif [OR (NULL CONFIRMFLG) + (LAB.MOUSECONFIRM + FOLDER + (CONCATLIST (CONS "Click LEFT to confirm " + (LET [(CF (AND CLOSEFLG (LIST (L-CASE CLOSEFLG T] + (if HOWSTRING + then (LIST* HOWSTRING + (AND CF (CONS " and " CF))) + else CF] + then (OR HOW? (FUNCTION \LAFITE.FINISH.UPDATE))) + else (MENU (LAB.CHOOSE.UPDATE.MENU HOWINDEX] + then (\LAFITE.PROCESS (LIST HOW? (KWOTE WINDOW) + (KWOTE FOLDER) + CLOSEFLG + (KWOTE ITEM) + (KWOTE MENU)) + 'LAFITEUPDATE]) + +(\LAFITE.EXPUNGE.PROC + [LAMBDA (WINDOW MAILFOLDER CLOSEFLG ITEM MENU) (* ; "Edited 1-May-89 12:53 by bvm") + (RESETLST + (\LAFITE.START.UPDATE MAILFOLDER ITEM MENU) + (\LAFITE.CLOSE.DISPLAYWINDOWS MAILFOLDER) + (CLEARW WINDOW) + (\LAFITE.COMPACT.FOLDER MAILFOLDER) + (\LAFITE.CLOSE.FOLDER MAILFOLDER T) + (COND + (CLOSEFLG (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of MAILFOLDER with + 0)) + (T (LAB.DISPLAYFOLDER MAILFOLDER)))) (* ; + "Do the following outside RESETLST so that Update gets unshaded") + (\LAFITE.FINISH.UPDATE WINDOW MAILFOLDER CLOSEFLG]) + +(\LAFITE.UPDATE.PROC + [LAMBDA (WINDOW MAILFOLDER CLOSEFLG ITEM MENU) (* ; "Edited 14-Oct-87 20:00 by bvm:") + (RESETLST + (\LAFITE.START.UPDATE MAILFOLDER ITEM MENU) + (COND + ((OR (COND + ((fetch (MAILFOLDER FOLDERNEEDSUPDATE) of MAILFOLDER) + (\LAFITE.UPDATE.FOLDER MAILFOLDER) + T)) + (NEQ (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) + (fetch (MAILFOLDER TOCLASTMESSAGE#) of MAILFOLDER))) + (\LAFITE.UPDATE.CONTENTS MAILFOLDER (fetch (MAILFOLDER %#OFMESSAGES) of + MAILFOLDER)) + ) + (T (LAB.PROMPTPRINT MAILFOLDER T "No changes since last update"))) + (\LAFITE.CLOSE.FOLDER MAILFOLDER T)) (* ; + "Do the following outside RESETLST so that Update gets unshaded") + (\LAFITE.FINISH.UPDATE WINDOW MAILFOLDER CLOSEFLG]) + +(\LAFITE.HARDCOPYONLY.PROC + [LAMBDA (WINDOW MAILFOLDER CLOSEFLG ITEM MENU) (* ; "Edited 29-Aug-88 17:49 by bvm") + + (* ;; "Called by Update or Close to just do pending hardcopy, nothing else") + + (RESETLST + (LAB.START.COMMAND MAILFOLDER (FUNCTION \LAFITE.UPDATE) + ITEM MENU) + (\LAFITE.DO.PENDING.HARDCOPY MAILFOLDER)) + (\LAFITE.FINISH.UPDATE WINDOW MAILFOLDER CLOSEFLG]) + +(LAB.CHOOSE.UPDATE.MENU + [LAMBDA (FOLDER CLOSEFLG) (* ; "Edited 25-Apr-89 15:10 by bvm") + + (* ;; "Returns a menu for prompting the user about what to do with FOLDER when Update is requested, or if CLOSEFLG is true, if Close/Shrink is requested. Returns NIL if there is no interesting choice.") + + (LET [(INDEX (OR (FIXP FOLDER) + (LAB.UPDATE.NEEDED? FOLDER] + (if (NEQ INDEX 0) + then (CASE CLOSEFLG + (:CLOSE (SETQ INDEX (LOGOR INDEX \CLOSE.MENU.BIT))) + (:SHRINK (SETQ INDEX (LOGOR INDEX \SHRINK.MENU.BIT)))) + (OR (GETHASH INDEX LAFITE.UPDATE.MENU.HASH) + (LAB.CREATE.UPDATE.MENU INDEX]) + +(LAB.CREATE.UPDATE.MENU + [LAMBDA (INDEX) (* ; "Edited 25-Apr-89 15:08 by bvm") + + (* ;; "Create a menu to ask about updating. There is a bit in INDEX for each possible thing you might want to do to update this folder -- Update, Expunge, Update TOC, Hardcopy, Expunge&Sort. Not all bit combinations are possible. In practice, only a small number of combinations actually occur, so we remember menus in a hash table.") + + (LET* ((LASTITEM NIL) + (ITEMS (for ITEM in LAFITEUPDATEMENUITEMS as (BIT _ 1) + by (LLSH BIT 1) when (BITTEST INDEX BIT) + collect (if (NOT (BITTEST INDEX (LOGOR \CLOSE.MENU.BIT \SHRINK.MENU.BIT) + )) + then (SETQ LASTITEM ITEM)) + ITEM)) + MENU) + [if (STRPOS "Only" (CAR LASTITEM) + -4 NIL T NIL UPPERCASEARRAY) + then (* ; + "Sounds funny if last item says %"Only%"") + (RPLACA (FMEMB LASTITEM ITEMS) + (CONS (SUBSTRING (CAR LASTITEM) + 1 -6) + (CDR LASTITEM] + (SETQ MENU (\LAFITE.CREATE.MENU ITEMS (if (BITTEST INDEX \CLOSE.MENU.BIT) + then "Close Options" + elseif (BITTEST INDEX \SHRINK.MENU.BIT) + then "Shrink Options" + else "Update Options"))) + (PUTHASH INDEX MENU LAFITE.UPDATE.MENU.HASH) + MENU]) + +(LAB.UPDATE.NEEDED? + [LAMBDA (FOLDER) (* ; "Edited 25-Apr-89 15:08 by bvm") + + (* ;; "Returns an integer whose bits indicate the type of updating needed by FOLDER; zero if it needs none.") + + (LOGOR (COND + ((fetch (MAILFOLDER HARDCOPYSTREAM) of FOLDER) + \HARDCOPY.MENU.BIT) + (T 0)) + (if (NOT (fetch (MAILFOLDER FOLDEROUTOFORDER) of FOLDER)) + then (LOGOR (if (fetch (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER) + then \UPDATE.MENU.BIT + elseif (NEQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) + (fetch (MAILFOLDER TOCLASTMESSAGE#) of + FOLDER)) + then (* ; + "Update toc if messages have been appended") + \TOC.MENU.BIT + else 0) + (if (fetch (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER) + then \EXPUNGE.MENU.BIT + else 0)) + elseif (fetch (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER) + then \EXPUNGE&SORT.MENU.BIT + else \SORT.MENU.BIT]) + +(\LAFITE.START.UPDATE + [LAMBDA (MAILFOLDER ITEM MENU) (* ; "Edited 18-Jul-88 11:56 by bvm") + + (* ;; "Called under a RESETLST to start an UPDATE or EXPUNGE") + + (LAB.START.COMMAND MAILFOLDER (FUNCTION \LAFITE.UPDATE) + ITEM MENU) + (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (MAILFOLDER) + (replace (MAILFOLDER FOLDERBEINGUPDATED) of MAILFOLDER + with NIL] + MAILFOLDER)) (* ; + "Mark folder being updated for benefit of LOGOUT check") + (replace (MAILFOLDER FOLDERBEINGUPDATED) of MAILFOLDER with T) + (* ; + "Close all other folders, so MoveTo's are up to date") + (\LAFITE.CLOSE.OTHER.FOLDERS MAILFOLDER) + (\LAFITE.DO.PENDING.HARDCOPY MAILFOLDER MENU]) + +(LAB.START.COMMAND + [LAMBDA (MAILFOLDER CMD ITEM MENU) (* ; "Edited 18-Jul-88 11:56 by bvm") + + (* ;; "Shades MAILFOLDER's command implemented by CMD, or ITEM of MENU if supplied and obtains the folder lock. Opens browser window if it is shrunk. Must be called under RESETLST surrounding command execution.") + + (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER))) + (if (AND WINDOW (NOT (OPENWP WINDOW))) + then (EXPANDW WINDOW))) + (LA.RESETSHADE [OR ITEM (LA.MENU.ITEM CMD (SETQ MENU (fetch (MAILFOLDER BROWSERMENU) + of MAILFOLDER] + MENU) + (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + NIL T) + (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER]) + +(\LAFITE.FINISH.UPDATE + [LAMBDA (WINDOW MAILFOLDER CLOSEFLG) (* ; "Edited 7-Jun-88 14:28 by bvm") + +(* ;;; "Takes care of closing/shrinking WINDOW after an update or expunge.") + + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + (CASE CLOSEFLG + ((:CLOSE :EXIT) (WITH.MONITOR \LAFITE.BROWSELOCK + (\LAFITE.CLOSE.FOLDER MAILFOLDER T) + (SETQ WINDOW (LAB.FLUSHWINDOW WINDOW MAILFOLDER)) + (CLOSEW WINDOW) + (COND + ((AND (NEQ CLOSEFLG :EXIT) + (OR (NOT (fetch (MAILFOLDER FOLDEREOFPTR) of + MAILFOLDER + )) + (= (fetch (MAILFOLDER FOLDEREOFPTR) of + MAILFOLDER + ) + 0)) + (EQ (GETFILEINFO (fetch (MAILFOLDER FULLFOLDERNAME) + of MAILFOLDER) + 'LENGTH) + 0)) + + (* ;; "Folder is empty, and we are explicitly closing it (as opposed to indirectly via the Quit command), so delete underlying file, etc. FOLDEREOFPTR should always be right, but be paranoid and double-check with the file itself before deleting") + + (DELETEMAILFOLDER MAILFOLDER))))) + (:SHRINK + (\LAFITE.CLOSE.DISPLAYWINDOWS MAILFOLDER) + (\LAFITE.CLOSE.FOLDER MAILFOLDER T) + (WINDOWADDPROP WINDOW 'EXPANDFN (FUNCTION LAB.EXPANDFN)) + (WINDOWDELPROP WINDOW 'SHRINKFN (FUNCTION LAB.SHRINKFN)) + (SHRINKW WINDOW)))) + (COND + (\LAFITEPROFILECHANGED (\LAFITE.WRITE.PROFILE]) + +(\LAFITE.CLOSE.OTHER.FOLDERS + [LAMBDA (THISFOLDER) (* bvm%: "31-Jul-84 15:17") + + (* ;; "Closes or flushes output of all Lafite folders except THISFOLDER. If a folder does not have an open browser, the file is closed; else output is flushed") + + (WITH.MONITOR \LAFITE.MAINLOCK + [for FOLDER in \ACTIVELAFITEFOLDERS when (AND (NEQ FOLDER THISFOLDER) + (fetch (MAILFOLDER FOLDERSTREAM + ) of FOLDER)) + do (RESETLST + [COND + ((OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) + T T) + (\LAFITE.CLOSE.FOLDER FOLDER (NULL (OPENWP (fetch (MAILFOLDER + BROWSERWINDOW) + of FOLDER])])]) +) +(DEFINEQ + +(LAB.FLUSHWINDOW + [LAMBDA (WINDOW MAILFOLDER) (* ; "Edited 18-Jul-88 11:37 by bvm") + (\LAFITE.CLOSE.DISPLAYWINDOWS MAILFOLDER) + (WINDOWDELPROP WINDOW 'CLOSEFN (FUNCTION LAB.CLOSEFN)) + [replace (MAILFOLDER BROWSERREADY) of MAILFOLDER + with (replace (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER + with (replace (MAILFOLDER DEFAULTMOVETOFILE) of MAILFOLDER + with (replace (MAILFOLDER BROWSERMENUWINDOW) of MAILFOLDER + with (replace (MAILFOLDER BROWSERWINDOW) + of MAILFOLDER + with (replace (MAILFOLDER BROWSERMENU) + of MAILFOLDER + with (replace (MAILFOLDER + + BROWSERPROMPTWINDOW + ) + of MAILFOLDER + with NIL] + (WINDOWPROP WINDOW 'MAILFOLDER NIL) + (SETQ \ACTIVELAFITEFOLDERS (DREMOVE MAILFOLDER \ACTIVELAFITEFOLDERS)) + (OR (OPENWP WINDOW) + (OPENWP (WINDOWPROP WINDOW 'ICONWINDOW]) + +(LAB.APPENDMESSAGES + [LAMBDA (FOLDER NEWMESSAGEDESCRIPTORS) (* ; "Edited 28-Apr-89 15:47 by bvm") + + (* ;; "Append list of message descriptors to folder, adjusting display, etc as needed.") + + (PROG ((LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) + FIRSTMSG#) + (SETQ FIRSTMSG# (ADD1 LASTMSG#)) + (replace (MAILFOLDER FOLDEREOFPTR) of FOLDER with (GETEOFPTR + (fetch (MAILFOLDER + FOLDERSTREAM) + of FOLDER))) + (for MSGDESCRIPTOR in NEWMESSAGEDESCRIPTORS do (replace (LAFITEMSG %#) + of MSGDESCRIPTOR + with (add LASTMSG# 1) + ) + (LAFITE.PARSE.MSG.FOR.TOC + MSGDESCRIPTOR FOLDER)) + (replace (MAILFOLDER %#OFMESSAGES) of FOLDER with LASTMSG#) + (replace (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER + with (\LAFITE.ADDMESSAGES.TO.ARRAY (fetch (MAILFOLDER MESSAGEDESCRIPTORS) + of FOLDER) + NEWMESSAGEDESCRIPTORS FIRSTMSG# LASTMSG#)) + (LET ((EXTENT (fetch (MAILFOLDER BROWSEREXTENT) of FOLDER)) + (HEIGHT (TIMES LASTMSG# (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER))) + WINDOW) + (replace (REGION HEIGHT) of EXTENT with HEIGHT) + (replace (REGION BOTTOM) of EXTENT with (- (fetch (MAILFOLDER + BROWSERORIGIN + ) + of FOLDER) + HEIGHT)) + (WINDOWPROP (SETQ WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) + 'EXTENT EXTENT) + (COND + ((OPENWP WINDOW) (* ; + "If window is visible, update it now") + (LAB.DISPLAYLINES FOLDER FIRSTMSG#)) + ((NULL (fetch (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER)) + (* ; + "Mark browser for display update after being unshrunk") + (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER with FIRSTMSG#]) + +(\LAFITE.COMPACT.FOLDER + [LAMBDA (FOLDER) (* ; "Edited 10-May-89 12:42 by bvm") + +(* ;;; "Expunge deleted messages from MAILFOLDER. We copy undeleted messages after the first deleted one into a scratch file and copy the scratch file back into the main file. Returns the msg # of the last message before the compacted section. This function must also be used if the folder is out of order.") + + (LET* ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) + (LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) + (FIRSTCHANGED# (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER)) + (LASTGOODMSG# (SUB1 FIRSTCHANGED#)) + (LASTLENGTH 0) + (LASTBEGIN 0) + FOLDERSTREAM MSG TOCSTREAM) + (if (> FIRSTCHANGED# 1) + then (* ; "Get this loop initialized") + (SETQ MSG (NTHMESSAGE MESSAGES LASTGOODMSG#)) + (SETQ LASTBEGIN (fetch (LAFITEMSG BEGIN) of MSG)) + (SETQ LASTLENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) + + (* ;; "first see if there are any messages to delete or messages out of order and while doing so collect information for rapidly compacting the file just in case we have to. We check for out of order by maintaining previous pointer and length so as to avoid boxing most of the time.") + + (for MSG# from (MAX 1 FIRSTCHANGED#) to LASTMSG# + until (OR (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES MSG# + ))) + (NOT (= (- (fetch (LAFITEMSG BEGIN) of MSG) + LASTBEGIN) + LASTLENGTH))) do [COND + ((fetch (LAFITEMSG MARKSCHANGEDINFILE? + ) of MSG) + (WRITEFOLDERMARKBYTES + MSG FOLDER (OR FOLDERSTREAM + (SETQ FOLDERSTREAM + (\LAFITE.OPEN.FOLDER + FOLDER + 'BOTH :ABORT] + (SETQ LASTGOODMSG# MSG#) + (SETQ LASTBEGIN (fetch (LAFITEMSG BEGIN) + of MSG)) + (SETQ LASTLENGTH (fetch (LAFITEMSG + MESSAGELENGTH + ) + of MSG))) + [COND + ((NEQ LASTGOODMSG# LASTMSG#) + (SETQ TOCSTREAM (\LAFITE.COMPACT.FOLDER1 FOLDER (OR FOLDERSTREAM + (\LAFITE.OPEN.FOLDER + FOLDER + 'BOTH :ABORT)) + LASTGOODMSG#] + (replace (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER with NIL) + (replace (MAILFOLDER FOLDEROUTOFORDER) of FOLDER with NIL) + (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER + with (ADD1 (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) + (\LAFITE.UPDATE.CONTENTS FOLDER LASTGOODMSG# TOCSTREAM]) + +(\LAFITE.COMPACT.FOLDER1 + [LAMBDA (FOLDER FOLDERSTREAM LASTGOODMSG#) (* ; "Edited 13-Jul-92 16:01 by bvm") + +(* ;;; "LASTGOODMSG# is the number of the last good message before the region to be compacted. FOLDERSTREAM is open for io.") + + (LET (SCRATCHFILE STATE ORIGEOF CONDITION TOCSTREAM) + (CL:UNWIND-PROTECT + (PROG ((*PRINT-BASE* 10) + (*UPPER-CASE-FILE-NAMES* NIL) + (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) + (OLDLASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) + (FIRSTSELECTED (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER)) + (LASTSELECTED (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER)) + COMPACTLENGTH GOODMSGSPTR MSGLIST RESULT NEWDATE) + (LAB.PROMPTPRINT FOLDER "Compacting folder... ") + [COND + ((> LASTSELECTED LASTGOODMSG#) (* ; + "There are selections in the compacting region") + (COND + ((> FIRSTSELECTED LASTGOODMSG#) (* ; + "All selections are there, so recompute completely") + (SETQ LASTSELECTED (SETQ FIRSTSELECTED NIL))) + (T (* ; + "Some selections before it, so only Last changes") + (SETQ LASTSELECTED (LAB.REV.FIND.SELECTED.MSG FOLDER FIRSTSELECTED + LASTGOODMSG#] + [SETQ GOODMSGSPTR (COND + ((EQ LASTGOODMSG# 0) + 0) + (T (fetch (LAFITEMSG END) of (NTHMESSAGE MESSAGES + LASTGOODMSG#] + (* ; + "End of the region that we leave alone") + (SETQ COMPACTLENGTH (for I from (ADD1 LASTGOODMSG#) to OLDLASTMSG# + bind MSG unless (fetch (LAFITEMSG DELETED?) + of (SETQ MSG + (NTHMESSAGE MESSAGES I)) + ) + sum (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) + [COND + ((NEQ COMPACTLENGTH 0) + (if (if (EQ LASTGOODMSG# 0) + then (* ; + "WIll have to rewrite whole folder") + (SMART-RENAMEFILEP FOLDERSTREAM) + elseif (AND (fetch (MAILFOLDER FOLDEROUTOFORDER) + of FOLDER) + (SMART-RENAMEFILEP FOLDERSTREAM)) + then (* ; "Will it be faster to write a brand new file and rename it to the destination than to do the overwriting stuff, given the extra messages we'll have to save on the end in case of disaster?") + (> (\LAFITE.COMPACT.EXTRA FOLDER LASTGOODMSG# + GOODMSGSPTR GOODMSGSPTR) + GOODMSGSPTR)) + then [SETQ SCRATCHFILE (OPENSTREAM (PACKFILENAME.STRING + 'VERSION NIL 'EXTENSION + (CONCAT (UNPACKFILENAME.STRING + FOLDERSTREAM + 'EXTENSION) + "-compacted") + 'BODY FOLDERSTREAM) + 'OUTPUT + 'NEW + `((LENGTH ,(+ GOODMSGSPTR COMPACTLENGTH) + ) + (SEQUENTIAL T) + (TYPE LAFITE] + (COPYBYTES FOLDERSTREAM SCRATCHFILE 0 GOODMSGSPTR) + (LINELENGTH T SCRATCHFILE) + (SETQ MSGLIST (\LAFITE.COMPACT.FOLDER2 FOLDER FOLDERSTREAM + LASTGOODMSG# GOODMSGSPTR SCRATCHFILE T)) + (SETQ SCRATCHFILE (CLOSEF SCRATCHFILE)) + (SETQ NEWDATE (GETFILEINFO SCRATCHFILE 'ICREATIONDATE)) + (SETQ FOLDERSTREAM (FULLNAME FOLDERSTREAM)) + (\LAFITE.CLOSE.FOLDER FOLDER T) + (SETQ STATE :NEW) + (CL:MULTIPLE-VALUE-SETQ (RESULT CONDITION) + (\LAFITE.RENAMEFILE SCRATCHFILE FOLDERSTREAM)) + (if (NULL RESULT) + then (RETURN) + else (* ; "Scratch file now gone") + (SETQ SCRATCHFILE NIL) + (SETQ STATE :OPEN) (* ; + "At this point, file is inconsistent with in-core structures.") + (SETQ TOCSTREAM (\LAFITE.INVALIDATE.TOC FOLDER))) + else (SETQ ORIGEOF (GETEOFPTR FOLDERSTREAM)) + (* ; "Save info for abort") + (SETQ STATE :APPEND) + [SETQ MSGLIST (\LAFITE.COMPACT.FOLDER2 FOLDER FOLDERSTREAM + LASTGOODMSG# GOODMSGSPTR (SETQ SCRATCHFILE + (LA.OPENTEMPFILE + 'SCRATCH + 'BOTH + 'NEW COMPACTLENGTH] + + (* ;; + "Up til now, you could abort and nothing bad would happen--the folder hasn't been written on yet.") + + (SETFILEPTR FOLDERSTREAM GOODMSGSPTR) + (* ; + "set the pointer to the end of the good messages") + (SETQ STATE :OPEN) (* ; + "We're about to make the world inconsistent") + (SETQ TOCSTREAM (\LAFITE.INVALIDATE.TOC FOLDER)) + (COPYBYTES SCRATCHFILE FOLDERSTREAM 0 -1) + (* ; + "copy the scratch file to the end of the good messages left in the original file") + (FORCEOUTPUT FOLDERSTREAM) (* ; + "Ensure that all those writes succeeded, before we update core and truncate the file below.") + ) + [for MSG in MSGLIST do + + (* ;; + "Now that it's all written, update the incore structures") + + (if (LISTP MSG) + then + (* ; "Need to fix stamp & msg length") + (replace (LAFITEMSG + MESSAGELENGTH) + of (CAR MSG) + with (CADDR MSG)) + (replace (LAFITEMSG + STAMPLENGTH) + of (CAR MSG) + with (CADR MSG)) + (SETQ MSG (CAR MSG))) + (replace (LAFITEMSG MARKSCHANGEDINFILE?) + of MSG with NIL) + (replace (LAFITEMSG BEGIN) of MSG + with GOODMSGSPTR) + (add GOODMSGSPTR (fetch (LAFITEMSG + + MESSAGELENGTH + ) + of MSG)) + (replace (LAFITEMSG %#) of MSG + with (add LASTGOODMSG# 1)) + (SETA MESSAGES LASTGOODMSG# MSG) + (COND + ((fetch (LAFITEMSG SELECTED?) + of MSG) + (COND + ((NOT FIRSTSELECTED) + (SETQ FIRSTSELECTED LASTGOODMSG#))) + (SETQ LASTSELECTED LASTGOODMSG#] + (if [AND (NOT NEWDATE) + (NOT (= GOODMSGSPTR (GETFILEPTR FOLDERSTREAM] + then (HELP "Miscalculation in Lafite Expunge" (LIST GOODMSGSPTR + 'NEQ + (GETFILEPTR + FOLDERSTREAM + ] + (replace (MAILFOLDER %#OFMESSAGES) of FOLDER with LASTGOODMSG#) + (replace (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER + with (OR FIRSTSELECTED 1)) + (replace (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER + with (OR LASTSELECTED 0)) + (for I from (ADD1 LASTGOODMSG#) to OLDLASTMSG# + do (* ; + "Erase entries beyond the new end of messages") + (SETA MESSAGES I NIL)) + (if NEWDATE + then (* ; + "Did via separate file, so get the date right") + (replace (MAILFOLDER FOLDERCREATIONDATE) of FOLDER with + NEWDATE) + else (* ; "Truncate to new length") + (SETFILEPTR FOLDERSTREAM GOODMSGSPTR) + (SETFILEINFO FOLDERSTREAM 'LENGTH GOODMSGSPTR)) + (replace (MAILFOLDER FOLDEREOFPTR) of FOLDER with GOODMSGSPTR) + (SETQ STATE :END) + (RETURN TOCSTREAM)) + + (* ;; "Cleanup code--this runs even if we are aborted.") + + (if (NEQ STATE :END) + then (LAB.PROMPTPRINT FOLDER " aborted.") + [if (EQ STATE :OPEN) + then (LAB.PROMPTPRINT FOLDER + " Folder is now in an inconsistent state and must be rebrowsed." + ) + else (* ; + "We have not yet overwritten anything, so folder is still consistent, mainly") + (if (AND (EQ STATE :APPEND) + (> (GETEOFPTR FOLDERSTREAM) + ORIGEOF)) + then (* ; + "We have written stuff to end of file--delete it") + (SETFILEPTR FOLDERSTREAM ORIGEOF) + (SETFILEINFO FOLDERSTREAM 'LENGTH ORIGEOF)) + (if (EQ STATE :NEW) + then (* ; "The RENAMEFILE failed") + (LAB.FORMAT FOLDER " Help! Could not replace mail file with compacted file~@[ because ~A~]. The compacted file is stored as ~A. You must rename this file to ~A before proceeding. " + CONDITION SCRATCHFILE FOLDERSTREAM) + else (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) + of FOLDER))) + (if (OPENWP WINDOW) + then (* ; + "Window was cleared, so redisplay it now") + (REDISPLAYW WINDOW] + (if TOCSTREAM + then (CLOSEF TOCSTREAM))) + (\LAFITE.CLOSE.FOLDER FOLDER T) + (if SCRATCHFILE + then (if (STREAMP SCRATCHFILE) + then (SETQ SCRATCHFILE (CLOSEF SCRATCHFILE))) + (DELFILE SCRATCHFILE)) + (if (AND (EQ STATE :END) + (EQ LAFITEVERIFYFLG 'ALL)) + then (VERIFYMAILFOLDER FOLDER)))]) + +(\LAFITE.COMPACT.FOLDER2 + [LAMBDA (FOLDER FOLDERSTREAM LASTGOODMSG# GOODMSGSPTR SCRATCHFILE NEWFILEP) + (* ; "Edited 2-May-89 11:09 by bvm") + + (* ;; "We want to compact FOLDER's messages beyond LASTGOODMSG#, which ends at GOODMSGSPTR. We map down the messages moving the undeleted ones into SCRATCHFILE (which is a new mail file if NEWFILEP is true). Return a list of the messages written to SCRATCHFILE. If the stamp length of any message changed, the corresponding element is not the message but a list (msg newstamplength newmsglength).") + + (for I from (ADD1 LASTGOODMSG#) to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER + ) bind (MESSAGES _ (fetch + (MAILFOLDER + MESSAGEDESCRIPTORS + ) + of FOLDER)) + (NEXTFILEPTR _ GOODMSGSPTR) + MSG TMP + unless (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) + collect (MAYBEVERIFYMSG MSG FOLDER) + (LET* ((BEGIN (fetch (LAFITEMSG BEGIN) of MSG)) + (STAMPLENGTH (fetch (LAFITEMSG STAMPLENGTH) of MSG)) + (MSGLENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG)) + (BODYLENGTH (- MSGLENGTH STAMPLENGTH)) + (NEWSTAMPLENGTH (LA.PRINTHEADER SCRATCHFILE BODYLENGTH))) + (WRITEFOLDERMARKBYTES MSG NIL SCRATCHFILE) + (BOUT SCRATCHFILE (CHARCODE CR)) + (COPYBYTES FOLDERSTREAM SCRATCHFILE (+ BEGIN STAMPLENGTH) + (+ BEGIN MSGLENGTH)) + (if (NOT NEWFILEP) + then (if (< BEGIN NEXTFILEPTR) + then + + (* ;; "By the time we get to copying this message to the main file, we will already have overwritten at least part of the original message. That means we could lose messages if a crash occurs here. So instead, copy this message to after the eof as a saving place") + + (SETFILEPTR FOLDERSTREAM -1) + [LA.PRINTHEADER FOLDERSTREAM BODYLENGTH NIL + (+ (NCHARS BEGIN) + (CONSTANT (ADD1 (NCHARS "*duplicate*"] + (BOUT FOLDERSTREAM DELETEDFLAG) + (* ; + "Make message look deleted ordinarily") + (BOUT FOLDERSTREAM UNSEENFLAG) + (BOUT FOLDERSTREAM DUPLICATEMARK) + (BOUT FOLDERSTREAM (CHARCODE CR)) + (PRIN3 "*duplicate*" FOLDERSTREAM) + (* ; + "Mark as duplicate and tell where") + (PRIN3 BEGIN FOLDERSTREAM) + (BOUT FOLDERSTREAM (CHARCODE CR)) + (COPYBYTES SCRATCHFILE FOLDERSTREAM (- (SETQ TMP + (GETFILEPTR + SCRATCHFILE) + ) + BODYLENGTH) + TMP) + (SETFILEPTR SCRATCHFILE TMP)) + (add NEXTFILEPTR BODYLENGTH NEWSTAMPLENGTH)) + (if (EQ STAMPLENGTH NEWSTAMPLENGTH) + then (* ; "normal case, no length changed") + MSG + else (LIST MSG NEWSTAMPLENGTH (+ BODYLENGTH NEWSTAMPLENGTH]) + +(\LAFITE.COMPACT.EXTRA + [LAMBDA (FOLDER LASTGOODMSG# GOODMSGSPTR STOPAT) (* ; "Edited 5-May-89 11:25 by bvm") + + (* ;; "Returns an estimate of the length of stuff we'll have to append to folder while compacting it, due to messages being out of order. If the estimate ever exceeds STOPAT we can stop counting and return the current estimate.") + + (for I from (ADD1 LASTGOODMSG#) to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER + ) bind (MESSAGES _ (fetch + (MAILFOLDER + MESSAGEDESCRIPTORS + ) + of FOLDER)) + (NEXTFILEPTR _ GOODMSGSPTR) + (EXTRALENGTH _ 0) + MSG + unless (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) + do (LET ((MSGLENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) + (if (< (fetch (LAFITEMSG BEGIN) of MSG) + NEXTFILEPTR) + then + + (* ;; "By the time we get to copying this message to the main file, we will already have overwritten at least part of the original message. That means we could lose messages if a crash occurs here. So instead, copy this message to after the eof as a saving place") + + (if (> [add EXTRALENGTH MSGLENGTH (CONSTANT (+ 6 (NCHARS + "*duplicate*" + ] + STOPAT) + then (RETURN EXTRALENGTH))) + (add NEXTFILEPTR MSGLENGTH)) finally (RETURN EXTRALENGTH]) + +(\LAFITE.INVALIDATE.TOC + [LAMBDA (FOLDER) (* ; "Edited 5-May-89 11:45 by bvm") + + (* ;; + "Invalidate the toc file for this folder by trashing the password. Returns the stream, if any.") + + (LET* ((*UPPER-CASE-FILE-NAMES* NIL) + (NAME (INFILEP (TOCFILENAME FOLDER))) + TOCSTREAM) + (if [AND NAME (SETQ TOCSTREAM (IGNORE-ERRORS (\LAFITE.OPENSTREAM NAME 'BOTH + 'OLD NIL NIL 'BINARY] + then (WORDOUT TOCSTREAM (LOGXOR 65535 LAFITETOCPASSWORD)) + (FORCEOUTPUT TOCSTREAM) + TOCSTREAM]) + +(\LAFITE.RENAMEFILE + [LAMBDA (SCRATCHFILE FOLDERNAME) (* ; "Edited 2-May-89 11:33 by bvm") + + (* ;; "Called to replace FOLDERNAME with SCRATCHFILE, e.g., as a result of a scavenge. On success, returns the new file name, otherwise returns NIL and, if an error was signaled, a CONDITION.") + + (LET ((*UPPER-CASE-FILE-NAMES* NIL)) + (IGNORE-ERRORS (DELFILE FOLDERNAME) + (RENAMEFILE SCRATCHFILE FOLDERNAME]) + +(SMART-RENAMEFILEP + [LAMBDA (OBJECT) (* ; "Edited 1-May-89 12:31 by bvm") + + (* ;; "true if RENAMEFILE can be done intelligently on this path/stream/device") + + (LET [(DEV (CL:TYPECASE OBJECT + (FDEV OBJECT) + (STREAM (fetch (STREAM DEVICE) of OBJECT)) + (T (\GETDEVICEFROMNAME OBJECT T)))] + (AND DEV (CASE (fetch (FDEV RENAMEFILE) of DEV) + ((NILL \GENERIC.RENAMEFILE) NIL) + (T T))]) + +(LA.OPENTEMPFILE + [LAMBDA (EXTENSION ACCESS RECOG LENGTH) (* ; "Edited 3-Sep-87 16:29 by bvm:") + (LET [(STREAM (OPENSTREAM (PACKFILENAME.STRING 'HOST 'SCRATCH 'NAME 'LAFITETEMPORARY 'EXTENSION + EXTENSION) + (OR ACCESS 'OUTPUT) + (OR RECOG 'NEW) + NIL + (AND LENGTH (LIST (LIST 'LENGTH LENGTH] + (COND + (STREAM (WHENCLOSE STREAM 'CLOSEALL 'NO) + (LINELENGTH MAX.SMALLP STREAM) + (if NIL + then (* ; + "save them so they can be deleted by LAFITE.QUIT") + + (* ;; "no need to keep list--they vanish via gc") + + (push \LAFITE.TEMPFILES (FULLNAME STREAM))) + STREAM]) +) +(DEFINEQ + +(\LAFITE.UPDATE.FOLDER + [LAMBDA (FOLDER) (* ; "Edited 28-Apr-89 10:55 by bvm") + +(* ;;; "Write out any changed marks in MAILFOLDER, but don't expunge deleted messages") + + (LET ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) + OUTSTREAM MSG) + (if (fetch (MAILFOLDER FOLDEROUTOFORDER) of FOLDER) + then (LAB.PROMPTPRINT FOLDER + "Folder has been reordered, so can't simply write out changes--must Expunge." + )) + (LAB.PROMPTPRINT FOLDER "Writing out changes...") + [for MSG# from (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER) + to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) + when (fetch (LAFITEMSG MARKSCHANGEDINFILE?) of (SETQ MSG (NTHMESSAGE MESSAGES + MSG#))) + do (WRITEFOLDERMARKBYTES MSG FOLDER (OR OUTSTREAM (SETQ OUTSTREAM + (\LAFITE.OPEN.FOLDER + FOLDER + 'OUTPUT :ABORT] + (\LAFITE.CLOSE.FOLDER FOLDER) + (LAB.PROMPTPRINT FOLDER (COND + (OUTSTREAM " done. ") + (T "nothing changed. "))) + [if (NOT (fetch (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER)) + then (* ; "Everything is up to date now.") + (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER + with (ADD1 (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER] + (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with NIL]) + +(\LAFITE.UPDATE.CONTENTS + [LAMBDA (MAILFOLDER LASTUNCHANGEDMESSAGE# TOCSTREAM) (* ; "Edited 1-May-89 13:02 by bvm") + +(* ;;; +"Update the TOC file for MAILFOLDER, assuming that entries up to LASTUNCHANGEDMESSAGE# are okay.") + + (COND + ((NLSETQ (\LAFITE.UPDATE.CONTENTS1 MAILFOLDER LASTUNCHANGEDMESSAGE# TOCSTREAM)) + (LAB.PROMPTPRINT MAILFOLDER " done.")) + (T (LAB.PROMPTPRINT MAILFOLDER " failed."))) + + (* ;; "FOLDERNEEDSUPDATE set to NIL now either because toc was completely written or because toc was deleted on error, in which case 'Update Table of Contents' is still needed") + + (replace (MAILFOLDER FOLDERNEEDSUPDATE) of MAILFOLDER with NIL]) + +(\LAFITE.UPDATE.CONTENTS1 + [LAMBDA (FOLDER LASTUNCHANGEDMESSAGE# TOCSTREAM) (* ; "Edited 1-May-89 13:02 by bvm") + + (* ;; "Write the table of contents file for FOLDER. LASTUNCHANGEDMESSAGE# is the last message in the folder before compacting changes set in. Prior to that message, we'll only have to update flag bytes if anything. If TOCSTREAM is supplied, it is a stream already open for i/o on the toc file (from Expunge, which invalidates the toc password before trashing the mail file).") + + (RESETLST + (LET ((*UPPER-CASE-FILE-NAMES* NIL) + (LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) + (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) + (TOCSTART LAFITETOCHEADERLENGTH) + FIRSTMSG# MSG) + (COND + ((> LASTMSG# 0) + (LAB.PROMPTPRINT FOLDER "Writing table of contents...") + (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM FOLDER) + (SETQ STREAM (CLOSEF STREAM)) + (COND + (RESETSTATE + (* ; + "If we aborted out, assume toc is garbage") + (replace (MAILFOLDER TOCLASTMESSAGE#) + of FOLDER with 0) + (DELFILE (FULLNAME STREAM] + [OR TOCSTREAM (SETQ TOCSTREAM (OPENSTREAM (TOCFILENAME FOLDER) + 'BOTH + 'OLD/NEW + '((TYPE BINARY] + FOLDER)) + (SETQ LASTUNCHANGEDMESSAGE# (IMIN LASTUNCHANGEDMESSAGE# (fetch (MAILFOLDER + TOCLASTMESSAGE#) + of FOLDER))) + [COND + ((EQ (GETEOFPTR TOCSTREAM) + 0) + (SETQ LASTUNCHANGEDMESSAGE# 0)) + ((AND (EQ LASTUNCHANGEDMESSAGE# 0) + (NEQ (PROGN (SETFILEPTR TOCSTREAM BYTESPERWORD) + (WORDIN TOCSTREAM)) + LAFITEVERSION#)) (* ; + "A version number change, rewrite entire toc") + ) + (T (* ; + "TOC already existed, just update it") + (for MSG# from 1 to LASTUNCHANGEDMESSAGE# + do (COND + ((fetch (LAFITEMSG MARKSCHANGEDINTOC?) + of (SETQ MSG (NTHMESSAGE MESSAGES MSG#))) + (* ; + "Message not compacted out, but its mark bytes have changed") + (SETFILEPTR TOCSTREAM TOCSTART) + (WRITETOCMARKBYTES MSG TOCSTREAM) + (replace (LAFITEMSG MARKSCHANGEDINTOC?) of MSG + with NIL))) + (add TOCSTART (fetch (LAFITEMSG TOCLENGTH) of MSG] + (SETFILEPTR TOCSTREAM TOCSTART) + (for MSG# from (ADD1 LASTUNCHANGEDMESSAGE#) to LASTMSG# + do (WRITETOCENTRY (NTHMESSAGE MESSAGES MSG#) + TOCSTREAM)) + (SETFILEINFO TOCSTREAM 'LENGTH (GETFILEPTR TOCSTREAM)) + (SETFILEPTR TOCSTREAM 0) (* ; "Now write the header info") + (WORDOUT TOCSTREAM LAFITETOCPASSWORD) + (WORDOUT TOCSTREAM LAFITEVERSION#) + (FIXPOUT TOCSTREAM (fetch (MAILFOLDER FOLDEREOFPTR) of FOLDER)) + (WORDOUT TOCSTREAM LASTMSG#)) + ((SETQ TOCSTREAM (INFILEP (TOCFILENAME FOLDER))) + (LAB.PROMPTPRINT FOLDER "Deleting table of contents...") + (DELFILE TOCSTREAM))) + (replace (MAILFOLDER TOCLASTMESSAGE#) of FOLDER with LASTMSG#)))]) + +(WRITETOCENTRY + [LAMBDA (MSG STREAM) (* ; "Edited 28-Apr-89 12:18 by bvm") + +(* ;;; "Dumps TOC entry for MSG on STREAM") + + (PROG ((TOCLENGTH 6) + (MESSAGELENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG)) + DAT NC) (* ; + "TOCLENGTH 6 counts for 3 bytes of message length, 1 byte each of stamplength, flags and mark.") + (WRITETOCMARKBYTES MSG STREAM) + (COND + ((> MESSAGELENGTH MAX.SMALLP) + + (* ;; "Ugh, length greater than fits in one word. Would be surprised if this ever happens, but file format permits it") + + (LET ((HIWORD (LRSH MESSAGELENGTH BITSPERWORD))) + (if (> HIWORD 254) + then (* ; + "a very long length, escape to 4 bytes of length") + (BOUT STREAM 255) + (WORDOUT STREAM HIWORD) + (add TOCLENGTH 2) + else (BOUT STREAM HIWORD))) + (WORDOUT STREAM (LOGAND MESSAGELENGTH MAX.SMALLP))) + (T (* ; "Normal case, a small length") + (BOUT STREAM 0) + (WORDOUT STREAM MESSAGELENGTH))) + (BOUT STREAM (fetch (LAFITEMSG STAMPLENGTH) of MSG)) + (if (fetch (LAFITEMSG DATEFETCHED?) of MSG) + then (* ; "Write 4 bytes of idate") + (\BOUTS STREAM MSG (UNFOLD (INDEXF (FETCH (LAFITEMSG IDATE))) + BYTESPERWORD) + 4) + (add TOCLENGTH 4)) + (if (NOT (fetch (LAFITEMSG DATEKNOWN?) of MSG)) + then (* ; "Write 6 bytes of ascii string") + (PRIN3 [COND + ((EQ [SETQ NC (NCHARS (SETQ DAT (fetch (LAFITEMSG DATE) + of MSG] + 6) (* ; "The usual case") + DAT) + (T (OR (SUBSTRING DAT 1 6) + (CONCAT DAT (ALLOCSTRING (IDIFFERENCE 6 NC) + (CHARCODE SPACE] + STREAM) + (add TOCLENGTH 6)) + (add TOCLENGTH (LA.PRINTSHORTSTRING STREAM (fetch (LAFITEMSG SUBJECT) of MSG))) + (add TOCLENGTH (LA.PRINTSHORTSTRING STREAM (fetch (LAFITEMSG FROM) of MSG))) + (add TOCLENGTH (LA.PRINTSHORTSTRING STREAM (fetch (LAFITEMSG TO) of MSG))) + (replace (LAFITEMSG TOCLENGTH) of MSG with TOCLENGTH) + (replace (LAFITEMSG MARKSCHANGEDINTOC?) of MSG with NIL]) + +(WRITETOCMARKBYTES + [LAMBDA (MSG STREAM) (* bvm%: "20-Feb-84 12:53") + (BOUT STREAM (fetch (LAFITEMSG MSGFLAGBITS) of MSG)) + (BOUT STREAM (fetch (LAFITEMSG MARKCHAR) of MSG]) + +(WRITEFOLDERMARKBYTES + [LAMBDA (MSG MAILFOLDER OUTSTREAM) (* ; "Edited 21-Apr-89 12:41 by bvm") + +(* ;;; "Write the three magic flag bytes for MSG onto OUTSTREAM. If MAILFOLDER is supplied, then OUTSTREAM is MAILFOLDER's own file, and we will first position OUTSTREAM accordingly--otherwise caller has positioned us properly.") + + [COND + (MAILFOLDER (MAYBEVERIFYMSG MSG MAILFOLDER) + (SETFILEPTR OUTSTREAM (fetch (LAFITEMSG BEGIN) of MSG)) + (OR (LA.READSTAMP OUTSTREAM) + (HELP)) + (COND + ((fetch (LAFITEMSG MESSAGELENGTHCHANGED?) of MSG) + (* ; + "Length is different in core and on file. This is for scavenging purposes") + (LET ((LENPOS (GETFILEPTR OUTSTREAM)) + LEN) + (LA.READCOUNT OUTSTREAM T) (* ; "Skip over current length") + (SETQ LEN (- (GETFILEPTR OUTSTREAM) + LENPOS 1)) (* ; + "Number of bytes of length--have to use the same format when overwriting it") + (SETFILEPTR OUTSTREAM LENPOS) + (LA.PRINTCOUNT (fetch (LAFITEMSG MESSAGELENGTH) of MSG) + OUTSTREAM + `(FIX ,LEN 10 T)) + (BIN OUTSTREAM) (* ; "Skip over terminating space") + ) + (replace (LAFITEMSG MESSAGELENGTHCHANGED?) of MSG with NIL)) + (T (* ; "Just skip over lengths") + (LA.READCOUNT OUTSTREAM T) + (LA.READCOUNT OUTSTREAM T] + (BOUT OUTSTREAM (COND + ((fetch (LAFITEMSG DELETED?) of MSG) + DELETEDFLAG) + (T UNDELETEDFLAG))) + (BOUT OUTSTREAM (COND + ((fetch (LAFITEMSG SEEN?) of MSG) + SEENFLAG) + (T UNSEENFLAG))) + (BOUT OUTSTREAM (fetch (LAFITEMSG MARKCHAR) of MSG)) + (if MAILFOLDER + then (replace (LAFITEMSG MARKSCHANGEDINFILE?) of MSG with NIL]) +) + + + +(* ; "HARDCOPY") + +(DEFINEQ + +(LAFITE.HARDCOPY.MESSAGES + [CL:LAMBDA (FOLDER MESSAGES &OPTIONAL (BATCHFLG NIL BATCHP)) + (* ; "Edited 30-Aug-88 14:13 by bvm") + (AND MESSAGES (\LAFITE.HARDCOPY.PROC FOLDER NIL NIL (\COERCE.TO.MSGLST MESSAGES) + (if BATCHP + then BATCHFLG + else LAFITEHARDCOPYBATCHFLG]) + +(\LAFITE.HARDCOPY + [LAMBDA (WINDOW FOLDER ITEM MENU) (* ; "Edited 23-Aug-88 15:45 by bvm") + (\LAFITE.PROCESS `(,(FUNCTION \LAFITE.HARDCOPY.PROC) + ',FOLDER + ',ITEM + ',MENU NIL ',LAFITEHARDCOPYBATCHFLG) + 'MESSAGEHARDCOPIER]) + +(\LAFITE.HARDCOPY.PROC + [LAMBDA (MAILFOLDER ITEM MENU MSGLST BATCHFLG) (* ; "Edited 23-Aug-88 15:37 by bvm") + (PROG (LCASEFILENAME TEXTSTREAM) + (RESETLST + (LA.RESETSHADE ITEM MENU (AND BATCHFLG LAFITEHARDCOPYBATCHSHADE)) + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) + [COND + ((OR MSGLST (NOT (LAB.ASSURE.SELECTIONS MAILFOLDER))) + (LET (CONTINUEFLG) + (OR MSGLST (SETQ MSGLST (LAB.SELECTED.MESSAGES MAILFOLDER))) + (SETQ LCASEFILENAME (L-CASE (fetch (MAILFOLDER FULLFOLDERNAME) + of MAILFOLDER))) + [SETQ TEXTSTREAM (COND + [(AND BATCHFLG (SETQ CONTINUEFLG (fetch + (MAILFOLDER + HARDCOPYSTREAM + ) + of MAILFOLDER] + ((AND (NOT BATCHFLG) + LAFITEHARDCOPY.MIN.TOC + (>= (LENGTH MSGLST) + LAFITEHARDCOPY.MIN.TOC)) + (\LAFITE.HARDCOPY.HEADERS MAILFOLDER + LCASEFILENAME MSGLST)) + (T (* ; "Start fresh") + (OPENTEXTSTREAM "" NIL NIL NIL (LIST 'FONT + LAFITEHARDCOPYFONT + ] + (\LAFITE.HARDCOPY.BODIES MAILFOLDER TEXTSTREAM MSGLST CONTINUEFLG) + (COND + (BATCHFLG (\LAFITE.MARK.HARDCOPIED MAILFOLDER MSGLST + HARDCOPYBATCHMARK) + (replace (MAILFOLDER HARDCOPYSTREAM) of MAILFOLDER + with TEXTSTREAM) + (replace (MAILFOLDER HARDCOPYMESSAGES) of MAILFOLDER + with (NCONC (fetch (MAILFOLDER HARDCOPYMESSAGES) + of MAILFOLDER) + MSGLST)) + (SETQ TEXTSTREAM])) + (COND + (TEXTSTREAM (* ; "Send to printer now...") + (\LAFITE.TRANSMIT.HARDCOPY MAILFOLDER TEXTSTREAM MSGLST LCASEFILENAME]) + +(\LAFITE.HARDCOPY.HEADERS + [LAMBDA (MAILFOLDER LCASEFILENAME MESSAGES INCLUDE# TEXTSTREAM) + (* ; "Edited 3-Jun-88 17:50 by bvm") + (PROG ((OUTPUTFILE (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW)) + TITLELEN TITLE TOCSTART TOCLEN FROMSTR SUBJLEFT DATELEFT TABSTOPS) + (LINELENGTH MAX.SMALLP OUTPUTFILE) + (for MSG in MESSAGES as N from 1 + do + + (* ;; "Each line consists of [#.]datefromsubject") + + (OR (fetch (LAFITEMSG PARSED?) of MSG) + (LAFITE.PARSE.MSG.FOR.TOC MSG MAILFOLDER)) + (POSITION OUTPUTFILE 0) + [COND + (INCLUDE# (\OUTCHAR OUTPUTFILE (CHARCODE TAB)) + (CL:FORMAT OUTPUTFILE "~D." N) + (\OUTCHAR OUTPUTFILE (CHARCODE TAB] + (PRIN3 (OR (fetch (LAFITEMSG DATE) of MSG) + UNSUPPLIEDFIELDSTR) + OUTPUTFILE) + (\OUTCHAR OUTPUTFILE (CHARCODE TAB)) + (PRIN3 (OR (COND + ((fetch (LAFITEMSG MSGFROMMEP) of MSG) + (PRIN3 "To: " OUTPUTFILE) + (OR (fetch (LAFITEMSG TO) of MSG) + (LAFITE.FETCH.TO.FIELD MSG MAILFOLDER))) + (T (fetch (LAFITEMSG FROM) of MSG))) + UNSUPPLIEDFIELDSTR) + OUTPUTFILE) + (\OUTCHAR OUTPUTFILE (CHARCODE TAB)) + (PRIN3 (OR (fetch (LAFITEMSG SUBJECT) of MSG) + UNSUPPLIEDFIELDSTR) + OUTPUTFILE) + (TERPRI OUTPUTFILE)) + (SETQ OUTPUTFILE (OPENSTREAM (CLOSEF OUTPUTFILE) + 'INPUT)) + (SETQ TITLE (CL:FORMAT NIL "Messages from ~A~%%Listed on ~A~%%~%%" LCASEFILENAME (DATE))) + (SETQ TITLELEN (NCHARS TITLE)) + [COND + (TEXTSTREAM (* ; + "Need to insert all this stuff at beginning of textstream") + (TEDIT.INSERT TEXTSTREAM TITLE 1)) + (T (SETQ TEXTSTREAM (OPENTEXTSTREAM TITLE (AND NIL (CREATEW NIL "Lafite headers")) + NIL NIL (LIST 'FONT LAFITEHARDCOPYFONT] + (PROGN (* ; "Make title centered") + (TEDIT.PARALOOKS TEXTSTREAM '(QUAD CENTERED) + 1 + (SUB1 TITLELEN)) + (TEDIT.PARALOOKS TEXTSTREAM '(POSTPARALEADING 30) + (- TITLELEN 4) + 1)) + (PROGN (* ; "Insert toc lines. ") + [SETQ TOCLEN (LA.TEDIT.INCLUDE TEXTSTREAM OUTPUTFILE (SETQ TOCSTART (ADD1 TITLELEN] + (TEDIT.INSERT TEXTSTREAM [CONSTANT (CONCATCODES (CHARCODE (FF] + (+ TOCSTART TOCLEN))) (* ; "Formfeed after the insertion") + (PROGN (* ; + "Now give the toc lines the appropriate tab settings.") + (SETQ DATELEFT (COND + (INCLUDE# 30) + (T 0))) + [SETQ TABSTOPS (LIST (CONS (+ DATELEFT 50) + 'LEFT) + (CONS (SETQ SUBJLEFT (+ DATELEFT 170)) + 'LEFT] + [COND + (INCLUDE# (push TABSTOPS '(20 . RIGHT) + (CONS DATELEFT 'LEFT] + (TEDIT.PARALOOKS TEXTSTREAM `(TABS (NIL ,@TABSTOPS) + LEFTMARGIN + ,(+ SUBJLEFT 20)) + TOCSTART + (SUB1 TOCLEN))) + (RETURN TEXTSTREAM]) + +(\LAFITE.MARK.HARDCOPIED + [LAMBDA (MAILFOLDER MSGS MARK) (* bvm%: "26-Feb-86 12:34") + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + [LET ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) + (LASTMSG (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) + N) + (COND + (MESSAGES (* ; "If not, folder has been closed") + (for MSG in MSGS when (AND (ILEQ (SETQ N (fetch (LAFITEMSG + %#) + of MSG)) + LASTMSG) + (EQ MSG (NTHMESSAGE MESSAGES N)) + (SELCHARQ (fetch (LAFITEMSG + MARKCHAR) + of MSG) + ((? SPACE H) + T) + NIL)) + do (* ; + "If message doesn't already have a more interesting mark, set the hardcopy mark") + (MARKMESSAGE MSG MAILFOLDER MARK])]) + +(\LAFITE.TRANSMIT.HARDCOPY + [LAMBDA (MAILFOLDER TEXTSTREAM MSGLST LCASEFILENAME) (* bvm%: " 2-Mar-84 13:32") + +(* ;;; "Sends TEXTSTREAM off to be hardcopied, then deletes it") + + (WITH.MONITOR \LAFITE.HARDCOPYLOCK (* ; + "Because press isn't reentrant yet") + [TEDIT.HARDCOPY TEXTSTREAM NIL NIL (CONCAT [COND + ((CDR MSGLST) + (CONCAT (LENGTH MSGLST) + " messages")) + (T (CONCAT "Message #" (fetch (LAFITEMSG + %#) + of (CAR MSGLST] + " from " + (OR LCASEFILENAME (L-CASE (fetch (MAILFOLDER + + FULLFOLDERNAME + ) + of MAILFOLDER]) + (CLOSEF TEXTSTREAM) + (DELFILE TEXTSTREAM) + (\LAFITE.MARK.HARDCOPIED MAILFOLDER MSGLST HARDCOPYMARK]) + +(\LAFITE.HARDCOPY.BODIES + [LAMBDA (MAILFOLDER TEXTSTREAM MESSAGES CONTINUEFLG NEXTMSG#) + (* ; "Edited 23-Aug-88 12:50 by bvm") + (for MSGDESCRIPTOR in MESSAGES bind (NTHTIME _ CONTINUEFLG) + (INPUTFILE _ (\LAFITE.OPEN.FOLDER MAILFOLDER + 'INPUT :ABORT)) + do [COND + ((NULL NTHTIME) + (SETQ NTHTIME T)) + ((OR LAFITENEWPAGEFLG CONTINUEFLG) + (\OUTCHAR TEXTSTREAM (CHARCODE FF)) + (SETQ CONTINUEFLG)) + (T (TERPRI TEXTSTREAM) + (COND + ((NOT NEXTMSG#) + (PRIN3 LAFITEHARDCOPYSEPARATOR TEXTSTREAM) + (TERPRI TEXTSTREAM] + (COND + (NEXTMSG# (CL:FORMAT TEXTSTREAM "Message ~D~%%~%%" NEXTMSG#) + (add NEXTMSG# 1))) + (\LAFITE.APPEND.MESSAGE.BODY TEXTSTREAM INPUTFILE MSGDESCRIPTOR + \LAPARSE.DONT.HARDCOPY.HEADERS) + (TEDIT.CARETLOOKS TEXTSTREAM LAFITEHARDCOPYFONT]) + +(\LAFITE.APPEND.MESSAGE.BODY + [LAMBDA (TEXTSTREAM MSGSTREAM MSGDESCRIPTOR FILTERS) (* ; "Edited 5-Aug-93 20:20 by bvm") + + (* ;; "Appends the text of the indicated message to TEXTSTREAM, filtering out any header fields found in FILTERS") + + (LET ((START (fetch (LAFITEMSG START) of MSGDESCRIPTOR)) + (END (fetch (LAFITEMSG END) of MSGDESCRIPTOR)) + (EOF (GETEOFPTR TEXTSTREAM)) + FILTERED) + (if FILTERS + then (SETQ FILTERED (LAFITE.NEW.PARSE.HEADER MSGSTREAM FILTERS START END))) + (TEDIT.SETSEL TEXTSTREAM (ADD1 EOF) + 0 + 'LEFT) (* ; + "Get selection right for TEDIT.INCLUDE") + (TEDIT.INCLUDE TEXTSTREAM MSGSTREAM START END) + [if FILTERED + then (if [NOT (= (GETEOFPTR TEXTSTREAM) + (+ EOF (- END START] + then (* ; "Rats, we have to recalculate more slowly now, since there could be ns chars in header. TEdit counts them differently than the plain text file does") + (SETQ FILTERED (LAFITE.PARSE.HEADER TEXTSTREAM FILTERS EOF))) + (for PAIR in FILTERED do (* ; "Note: we are depending on the pairs being in reverse order from the parse, so that the deletions do not affect the char count") + (TEDIT.DELETE TEXTSTREAM + (+ EOF (- (CAR PAIR) + START) + 1) + (- (CADR PAIR) + (CAR PAIR] + (TEDIT.SETSEL TEXTSTREAM (ADD1 (GETEOFPTR TEXTSTREAM)) + 0) + (SETFILEPTR TEXTSTREAM -1]) + +(\LAFITE.DO.PENDING.HARDCOPY + [LAMBDA (FOLDER) (* ; "Edited 20-Jan-89 14:29 by bvm") + (LET ((TEXTSTREAM (fetch (MAILFOLDER HARDCOPYSTREAM) of FOLDER)) + (MSGLST (fetch (MAILFOLDER HARDCOPYMESSAGES) of FOLDER))) + (COND + (TEXTSTREAM (LAB.PROMPTPRINT FOLDER T "Hardcopying... ") + (COND + ((AND LAFITEHARDCOPY.MIN.TOC (>= (LENGTH MSGLST) + LAFITEHARDCOPY.MIN.TOC)) + (\LAFITE.HARDCOPY.HEADERS FOLDER (L-CASE (fetch (MAILFOLDER + FULLFOLDERNAME) + of FOLDER)) + MSGLST NIL TEXTSTREAM))) + (\LAFITE.TRANSMIT.HARDCOPY FOLDER TEXTSTREAM MSGLST) + (\LAFITE.CLEAR.HARDCOPY.STATE FOLDER) + (LAB.PROMPTPRINT FOLDER "done. "]) + +(\LAFITE.CANCEL.HARDCOPY + [LAMBDA (FOLDER) (* ; "Edited 20-Jan-89 14:29 by bvm") + (LET ((PENDING (fetch (MAILFOLDER HARDCOPYMESSAGES) of FOLDER))) + (if (NOT PENDING) + then (LAB.PROMPTPRINT FOLDER "No messages are queued for hardcopy") + elseif (LAB.MOUSECONFIRM FOLDER "Click LEFT to cancel hardcopy of ~D message~:P" + (LENGTH PENDING)) + then (for MSG in PENDING do (* ; "Set mark back to space") + (MARKMESSAGE MSG FOLDER SEENMARK)) + (\LAFITE.CLEAR.HARDCOPY.STATE FOLDER]) + +(\LAFITE.CLEAR.HARDCOPY.STATE + [LAMBDA (FOLDER) (* ; "Edited 20-Jan-89 14:28 by bvm") + + (* ;; "Clear all the places that think there is pending hardcopy") + + (replace (MAILFOLDER HARDCOPYSTREAM) of FOLDER with (replace (MAILFOLDER + HARDCOPYMESSAGES + ) + of FOLDER with NIL)) + (LET ((MENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER))) + (* ; "Take the speckle off the menu") + (SHADEITEM (LA.MENU.ITEM (FUNCTION \LAFITE.HARDCOPY) + MENU) + MENU WHITESHADE]) +) + +(ADDTOVAR LAFITEEXTRAMENUITEMS ("Cancel Pending Hardcopy" '\LAFITE.CANCEL.HARDCOPY + "Forget about hardcopying the messages so far marked for hardcopy." + )) + +(RPAQ? LAFITEHARDCOPYBATCHFLG NIL) + +(RPAQ? LAFITEHARDCOPY.MIN.TOC NIL) + +(RPAQ? LAFITEDISPLAYAFTERDELETEFLG T) + +(RPAQ? LAFITEMOVETOCONFIRMFLG 'ALWAYS) + +(RPAQ? LAFITENEWPAGEFLG T) + +(RPAQ? LAFITEENDOFMESSAGESTR "End of message") + +(RPAQ? LAFITEENDOFMESSAGEFONT (FONTCREATE '(TIMESROMAN 10 ITALIC))) + +(RPAQ? LAFITE.DISPLAY.SIZE '(500 . 300)) + +(RPAQ? LAFITE.BROWSER.LAYOUTS NIL) + +(RPAQ? LAFITE.MIDDLE.UPDATE '(:EXPUNGE :SHRINK :CONFIRM)) + +(RPAQ? LAFITEHARDCOPYBATCHSHADE 1025) + +(RPAQ? LAFITEHARDCOPYSEPARATOR "% + Next Message % +") + + + +(* ; "Obsolete") + + +(RPAQ? LAFITEDISPLAYREGION (CREATEREGION 375 25 600 335)) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(FILESLOAD (SOURCE) + LAFITEDECLS) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA LAFITE.HARDCOPY.MESSAGES) +) +(PUTPROPS LAFITECOMMANDS COPYRIGHT ("Xerox Corporation" 1988 1989 1992 1993 1999 2021)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (7824 27492 (\LAFITE.DISPLAY 7834 . 9539) (\LAFITE.DO.DISPLAY 9541 . 13706) ( +SELECTMESSAGETODISPLAY 13708 . 16076) (MESSAGEDISPLAYER 16078 . 23494) (LA.COPY.MESSAGE.TEXT 23496 . +24250) (\LAFITE.CLOSE.DISPLAYWINDOWS 24252 . 25846) (\LAFITE.CLOSE.DISPLAYER 25848 . 27490)) (27493 +36085 (\LAFITE.UNHIDE.HEADERS 27503 . 28593) (\LAFITE.HIDE.HEADERS 28595 . 29248) ( +\LAFITE.REHIDE.HEADERS 29250 . 30286) (LAFITE.EAT.UNDESIRABLE.FIELD 30288 . 31047) (LAFITE.EAT.GVGV +31049 . 32210) (\LAFITE.HARDCOPY.FROM.DISPLAY 32212 . 35731) (LAFITE.HARDCOPY.TAB.WIDTH 35733 . 36083) +) (36086 44389 (\LAFITE.SET.LOOKS.FROM.MENU 36096 . 36273) (\LAFITE.SET.DEFAULT.LOOKS 36275 . 36466) ( +\LAFITE.SET.FIXED.LOOKS 36468 . 36660) (LAFITE.SET.LOOKS 36662 . 41119) (LAFITE.SET.TAB.LOOKS 41121 . +41832) (LAFITE.SET.PARA.SEPARATION 41834 . 42042) (LAFITE.SET.LOWER.CASE 42044 . 42895) ( +LAFITE.SUBSTITUTE.VP.EOL 42897 . 44387)) (46459 54787 (LAFITE.DELETE.MESSAGES 46469 . 47519) ( +\LAFITE.DELETE 47521 . 48708) (DISPLAYAFTERDELETE 48710 . 53436) (\LAFITE.SELECT.NEXT 53438 . 54076) ( +\LAFITE.UNDELETE 54078 . 54785)) (54809 69304 (LAFITE.MOVE.MESSAGES 54819 . 55466) (\COERCE.TO.MSGLST +55468 . 56226) (\LAFITE.MOVETO 56228 . 60172) (\LAFITE.COPYTO 60174 . 60590) (\LAFITE.MOVETO.PROC +60592 . 61862) (\LAFITE.MOVE.MESSAGES.INTERNAL 61864 . 69302)) (69330 77882 (\LAFITE.ENABLE.MOVE.MENU +69340 . 70382) (\LAFITE.ADD.TO.MOVE.MENU 70384 . 71400) (\LAFITE.UPDATE.MOVE.MENU 71402 . 76042) ( +\LAFITE.RESTORE.MOVE.MENU 76044 . 76720) (\LAFITE.HANDLE.AUTO.MOVE 76722 . 77880)) (78864 96348 ( +\LAFITE.UPDATE 78874 . 84507) (\LAFITE.EXPUNGE.PROC 84509 . 85314) (\LAFITE.UPDATE.PROC 85316 . 86399) + (\LAFITE.HARDCOPYONLY.PROC 86401 . 86843) (LAB.CHOOSE.UPDATE.MENU 86845 . 87626) ( +LAB.CREATE.UPDATE.MENU 87628 . 89527) (LAB.UPDATE.NEEDED? 89529 . 91099) (\LAFITE.START.UPDATE 91101 + . 92133) (LAB.START.COMMAND 92135 . 92985) (\LAFITE.FINISH.UPDATE 92987 . 95240) ( +\LAFITE.CLOSE.OTHER.FOLDERS 95242 . 96346)) (96349 131143 (LAB.FLUSHWINDOW 96359 . 98038) ( +LAB.APPENDMESSAGES 98040 . 101202) (\LAFITE.COMPACT.FOLDER 101204 . 105368) (\LAFITE.COMPACT.FOLDER1 +105370 . 121409) (\LAFITE.COMPACT.FOLDER2 121411 . 126125) (\LAFITE.COMPACT.EXTRA 126127 . 128442) ( +\LAFITE.INVALIDATE.TOC 128444 . 129137) (\LAFITE.RENAMEFILE 129139 . 129609) (SMART-RENAMEFILEP 129611 + . 130171) (LA.OPENTEMPFILE 130173 . 131141)) (131144 144486 (\LAFITE.UPDATE.FOLDER 131154 . 133131) ( +\LAFITE.UPDATE.CONTENTS 133133 . 133850) (\LAFITE.UPDATE.CONTENTS1 133852 . 138706) (WRITETOCENTRY +138708 . 141826) (WRITETOCMARKBYTES 141828 . 142070) (WRITEFOLDERMARKBYTES 142072 . 144484)) (144512 +162219 (LAFITE.HARDCOPY.MESSAGES 144522 . 144982) (\LAFITE.HARDCOPY 144984 . 145319) ( +\LAFITE.HARDCOPY.PROC 145321 . 148539) (\LAFITE.HARDCOPY.HEADERS 148541 . 152862) ( +\LAFITE.MARK.HARDCOPIED 152864 . 154574) (\LAFITE.TRANSMIT.HARDCOPY 154576 . 156166) ( +\LAFITE.HARDCOPY.BODIES 156168 . 157410) (\LAFITE.APPEND.MESSAGE.BODY 157412 . 159520) ( +\LAFITE.DO.PENDING.HARDCOPY 159522 . 160597) (\LAFITE.CANCEL.HARDCOPY 160599 . 161315) ( +\LAFITE.CLEAR.HARDCOPY.STATE 161317 . 162217))))) +STOP diff --git a/library/lafite/LAFITECOMMANDS.LCOM b/library/lafite/LAFITECOMMANDS.LCOM index 0da3ceba501467f52af76fb2ee2e49f3791111f5..97a061df72827a850698137dcbdcc7772f523069 100644 GIT binary patch delta 1136 zcmb`HOH30{6ov!D2&0k`A|hzLOn|g%o6giiDW*8IQ!&C8Z!+Tw5l!#^5NE zE+Cig1Kv+};QnwisARGnjwnFYM@Yr-hy+}YkT=X9j{zrE8Ms!4Wl=lCC!=Jt=g|{| zROi~qz*l0G*bpP7&c}%5Rjd=ZH|_-bY>5L84$%V^2WhF zIa9?bk+O6fjtuZXEad zy*+|+K-Vj{Ji?GlQLXd1yZv4MAsw$bnucv$eM@t*-fXZcj;WDW!)TPqd8MoGve1tP zyi!(#XrtMRI!LpPQy5wl1~?C|x66>vFI;nb2m28*DrLcG%^wpC!>VgiCPcftDA=&E z-GyqLPJcL&CdTh3F98ov5ss$#Ysv|_W4ayqXr%~GPS@cPc@aJsY=Dd>*aXynA^js% zDL(PR2ud952Kr*n8Hg6+i5L%&WLW?PmPsYHYz2;easeN#oWU1nazO>7`|+)rdQcNH zWM1Vg;r&?${%9}3`JY*c_N*QS8dpybHwH2_z}E5M}wm0$(}p&t-#oP zJHFaifKM$D$9EUb0UfssaoVC8lx5Kle7blMm=ih+9C=%e1EFeAFG3x_+^_}M876&W z$pXCgH5<=`Yawb#9KvkmB&a}yc#TJhi?L)Wb}f-RJX<2!y-^3SKT5p3k5&M`N85n^ zy&BYB$H)(NxfxW~R!GlIw@^af6(_sl8u(|N$`aG97X9g3eA8Z-E+bFNu{5lOhR!et ze3O*m=gCa+wasYwWlpBq#6xdMLJB#3LJssM4gg;zim@|Nlv0gbqs#IoxIDQpdvg`S kKO!Yt#TiE-E?Xjh-&mEGQaa#zlGxCGvt-F+V%RAD4OgCXssI20 diff --git a/library/lafite/LAFITEFIND b/library/lafite/LAFITEFIND index c94c7d0d..fd00c40c 100644 --- a/library/lafite/LAFITEFIND +++ b/library/lafite/LAFITEFIND @@ -1,47 +1,45 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 3-Jun-92 10:10:41" {DSK}local>users>welch>lisp>lafite>LAFITEFIND.;2 15951 +(FILECREATED "30-Sep-2021 23:01:05"  +{DSK}kaplan>Local>medley3.5>git-medley>library>lafite>LAFITEFIND.;2 14882 - previous date%: "15-Jun-90 16:06:40" {DSK}local>users>welch>lisp>lafite>LAFITEFIND.;1) + changes to%: (FILES LAFITEDECLS) + + previous date%: " 3-Jun-92 10:10:41" +{DSK}kaplan>Local>medley3.5>git-medley>library>lafite>LAFITEFIND.;1) (* ; " -Copyright (c) 1984, 1985, 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. +Copyright (c) 1984-1988, 1990, 1992, 2021 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT LAFITEFINDCOMS) -(RPAQQ LAFITEFINDCOMS ((FNS \LAFITE.FIND \LAFITE.FIND.RELATED \LAFITE.FIND.RELATED.BACKWARD - \LAFITE.GO.TO.FIRST \LAFITE.GO.TO.INTERACTIVE \LAFITE.GO.TO.LAST - \LAFITE.FIND.AGAIN \LAFITE.FIND.PROMPT \LAFITE.DO.FIND - \LAFITE.FIND.START) - (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SEARCHSTATE) - (GLOBALVARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS - LAFITEFINDTYPEMENU LAFITEFINDAREAMENU LAFITEEXTRAMENU - LAFITEEXTRAMENUFLG \LAFITE.LAST.SEARCH) - (FILES (SOURCE) - LAFITEDECLS) - (LOCALVARS . T)) - (INITVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU) - (VARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS) - (ADDVARS [LAFITEEXTRAMENUITEMS ("Find" '\LAFITE.FIND - "Search mail for something") - ["Find Related" '\LAFITE.FIND.RELATED - "Find all messages from here on in reply to this message" - (SUBITEMS ("Find Related Forward" - '\LAFITE.FIND.RELATED) - ("Find Related Backward" - '\LAFITE.FIND.RELATED.BACKWARD] - ("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search" - ) - ("Go to #" '\LAFITE.GO.TO.INTERACTIVE - "Scroll to and select a specific message by number." - (SUBITEMS ("Go to First" '\LAFITE.GO.TO.FIRST - "Scroll to and select first message." - ) - ("Go to Last" '\LAFITE.GO.TO.LAST - "Scroll to and select last message."] - (LAFITEMENUVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU)) - (VARS (\LAFITE.LAST.SEARCH)))) +(RPAQQ LAFITEFINDCOMS + ((FNS \LAFITE.FIND \LAFITE.FIND.RELATED \LAFITE.FIND.RELATED.BACKWARD \LAFITE.GO.TO.FIRST + \LAFITE.GO.TO.INTERACTIVE \LAFITE.GO.TO.LAST \LAFITE.FIND.AGAIN \LAFITE.FIND.PROMPT + \LAFITE.DO.FIND \LAFITE.FIND.START) + (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SEARCHSTATE) + (GLOBALVARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS LAFITEFINDTYPEMENU + LAFITEFINDAREAMENU LAFITEEXTRAMENU LAFITEEXTRAMENUFLG \LAFITE.LAST.SEARCH) + (FILES (SOURCE) + LAFITEDECLS) + (LOCALVARS . T)) + (INITVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU) + (VARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS) + (ADDVARS [LAFITEEXTRAMENUITEMS ("Find" '\LAFITE.FIND "Search mail for something") + ["Find Related" '\LAFITE.FIND.RELATED + "Find all messages from here on in reply to this message" + (SUBITEMS ("Find Related Forward" '\LAFITE.FIND.RELATED) + ("Find Related Backward" '\LAFITE.FIND.RELATED.BACKWARD] + ("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search") + ("Go to #" '\LAFITE.GO.TO.INTERACTIVE + "Scroll to and select a specific message by number." + (SUBITEMS ("Go to First" '\LAFITE.GO.TO.FIRST + "Scroll to and select first message.") + ("Go to Last" '\LAFITE.GO.TO.LAST + "Scroll to and select last message."] + (LAFITEMENUVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU)) + (VARS (\LAFITE.LAST.SEARCH)))) (DEFINEQ (\LAFITE.FIND @@ -147,45 +145,47 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporat (RPAQ? LAFITEFINDAREAMENU NIL) -(RPAQQ LAFITEFINDAREAMENUITEMS ((From 'From "Search From: field for string (or To: if from self)" - ) - (Subject 'Subject "Search Subject: field for string") - (Body 'Body "Search message bodies for string") - (Mark 'Mark "Search for messages with specified mark character") - (Related 'Related - "Search for a message with same Subject, modulo Re:"))) +(RPAQQ LAFITEFINDAREAMENUITEMS + ((From 'From "Search From: field for string (or To: if from self)") + (Subject 'Subject "Search Subject: field for string") + (Body 'Body "Search message bodies for string") + (Mark 'Mark "Search for messages with specified mark character") + (Related 'Related "Search for a message with same Subject, modulo Re:"))) -(RPAQQ LAFITEFINDTYPEMENUITEMS (("Find Next One" '(FORWARD ONE) - "Search forward from selected message") - ("Find Next All" '(FORWARD ALL) - "Search forward from selected message") - ("Find Previous One" '(BACKWARD ONE) - "Search backward from selected message") - ("Find Previous All" '(BACKWARD ALL) - "Search backward from selected message"))) +(RPAQQ LAFITEFINDTYPEMENUITEMS + (("Find Next One" '(FORWARD ONE) + "Search forward from selected message") + ("Find Next All" '(FORWARD ALL) + "Search forward from selected message") + ("Find Previous One" '(BACKWARD ONE) + "Search backward from selected message") + ("Find Previous All" '(BACKWARD ALL) + "Search backward from selected message"))) -(ADDTOVAR LAFITEEXTRAMENUITEMS ("Find" '\LAFITE.FIND "Search mail for something") - ["Find Related" '\LAFITE.FIND.RELATED - "Find all messages from here on in reply to this message" - (SUBITEMS ("Find Related Forward" '\LAFITE.FIND.RELATED) - ("Find Related Backward" - '\LAFITE.FIND.RELATED.BACKWARD] - ("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search") - ("Go to #" '\LAFITE.GO.TO.INTERACTIVE - "Scroll to and select a specific message by number." - (SUBITEMS ("Go to First" '\LAFITE.GO.TO.FIRST - "Scroll to and select first message.") - ("Go to Last" '\LAFITE.GO.TO.LAST - "Scroll to and select last message.")))) +(ADDTOVAR LAFITEEXTRAMENUITEMS + ("Find" '\LAFITE.FIND "Search mail for something") + ["Find Related" '\LAFITE.FIND.RELATED + "Find all messages from here on in reply to this message" (SUBITEMS + ("Find Related Forward" + '\LAFITE.FIND.RELATED) + ("Find Related Backward" + + ' + \LAFITE.FIND.RELATED.BACKWARD + ] + ("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search") + ("Go to #" '\LAFITE.GO.TO.INTERACTIVE "Scroll to and select a specific message by number." + (SUBITEMS ("Go to First" '\LAFITE.GO.TO.FIRST "Scroll to and select first message.") + ("Go to Last" '\LAFITE.GO.TO.LAST "Scroll to and select last message.")))) (ADDTOVAR LAFITEMENUVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU) (RPAQQ \LAFITE.LAST.SEARCH NIL) -(PUTPROPS LAFITEFIND COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1990 1992)) +(PUTPROPS LAFITEFIND COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1990 1992 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3089 12861 (\LAFITE.FIND 3099 . 4131) (\LAFITE.FIND.RELATED 4133 . 4798) ( -\LAFITE.FIND.RELATED.BACKWARD 4800 . 4936) (\LAFITE.GO.TO.FIRST 4938 . 5105) ( -\LAFITE.GO.TO.INTERACTIVE 5107 . 5719) (\LAFITE.GO.TO.LAST 5721 . 5929) (\LAFITE.FIND.AGAIN 5931 . -6513) (\LAFITE.FIND.PROMPT 6515 . 8637) (\LAFITE.DO.FIND 8639 . 11790) (\LAFITE.FIND.START 11792 . -12859))))) + (FILEMAP (NIL (2309 12081 (\LAFITE.FIND 2319 . 3351) (\LAFITE.FIND.RELATED 3353 . 4018) ( +\LAFITE.FIND.RELATED.BACKWARD 4020 . 4156) (\LAFITE.GO.TO.FIRST 4158 . 4325) ( +\LAFITE.GO.TO.INTERACTIVE 4327 . 4939) (\LAFITE.GO.TO.LAST 4941 . 5149) (\LAFITE.FIND.AGAIN 5151 . +5733) (\LAFITE.FIND.PROMPT 5735 . 7857) (\LAFITE.DO.FIND 7859 . 11010) (\LAFITE.FIND.START 11012 . +12079))))) STOP diff --git a/library/lafite/LAFITEFIND.LCOM b/library/lafite/LAFITEFIND.LCOM index 997ddcf05032acec6ccac4ef7ce1d90af68f5b53..daddd43854ad4a07ef3bdeaab7cbefc75da49472 100644 GIT binary patch delta 968 zcmb_bO=uHA6sD~;bV_<@v}&5ha$9z^g>gi_F>%kuHQ@6Eh7-<#dn`K|oc zbeo9ToS~=Z^;A*M08PYW1*;KL;))DPLXFF6e2jufm+ZAhwPr1YT?Y!}Zl-Yg{)JN0 za+=zz*{GRy&9Ilunzm*w*R0KiG^UlSt=J!?)vAk*>1=8>bEVp{G$WPG74>W`pOMbD zl_*eU;!smXRg$W#V3S41I%sR%X*kWW3U#|xsn*L-#babkh5?87N|Hoj*=*r4|5Y`d6E6Vab7C&@K0Lk)5gD?XE7alo4~T zI!bR`yIgAa-RmSg>?(IfH%lhB{&MpATtLozw=iXfTlg`NJBU-+i4rxp-pmxo>T zPGR)SyNLMH%hhYcD~NB0xk7y<#6H2#p8C#VR1{S9%NNCHU+}OGLWte;k03LB9+n7) z*gHR8H5ob1o`->nfdDeuHORh)&#(spv6B=PYmmVB1ti&Q@B~Jc;5ge3o^_MC(o9i@E2gs=1@<|Z$J}W;j(CesBfg|Fh(Bl% z(Fk!DMo8@8)jx)=BNGMg^09CmabH;JBXruv4+27LD=@@1!fDiZ!+ah?ky*q_WYR^% d`PtOm9NY68>&@p3to1%}!>s`SKd~}OYBK_RHmO52hJ5y-spoNAOC_;gD+!#n4rqfaxI!!-BqgY(% zPD6YyT&M{f6GPZYbm7LW8xvi)(48)IuZhvbJ1s~sIEyp)+_~?(^Ul2W_*Q&5g@$ZomBGfU>|V2;N=B=fB;KmZ8@J+l@w?>Ai!LYBrmLR^A9M#U1nk7ZkXD zf%6jhzv0TR6PAk(|iLl+VTkTOUr%yP;T|rA$i7pMe?A1vjtznT|f2V!R|T4 zhutDwXF90C6h}5=(tBH`G@{YGfOyMvoZd5suzG8rKs;fQ5e=3Oy6GVFqrHv3w%D=r z-fpBnEYny?J$|}swPN+ys#JL=?SdH_1MKdxCc{b5Q_ItZ55p#A!m~rvYc{sVW0QaR zM*Xoi*lWzvjruP78H_0U9R@0*2JGy`X)y|-=E9qlRPYuqA`w8!r9hSiNM{u_RfM!w zfMThD7nrz!9ap53QYh{&-l2F~cLXF=h2>%f7I)_Mt!CI{dEts8mw@_hhv}FtfNpNu z&M-A6Q&M3Gz0j97Jkaplan>Local>medley3.5>git-medley>library>lafite>LAFITEMAIL.;2 70964 +(FILECREATED "30-Sep-2021 23:01:47"  +{DSK}kaplan>Local>medley3.5>git-medley>library>lafite>LAFITEMAIL.;3 133718 - changes to%: (FNS LA.SKIP.TO.EOL LAFITE.SKIP.WHITE.SPACE) - (FILES LAFITEDECLS) - - previous date%: " 6-Aug-93 18:19:26" -{DSK}kaplan>Local>medley3.5>git-medley>library>lafite>LAFITEMAIL.;1) + previous date%: "22-Jun-2021 10:19:08" +{DSK}kaplan>Local>medley3.5>git-medley>library>lafite>LAFITEMAIL.;2) (* ; " @@ -16,15 +13,15 @@ Copyright (c) 1984-1989, 1991-1993, 2021 by Xerox Corporation. (PRETTYCOMPRINT LAFITEMAILCOMS) (RPAQQ LAFITEMAILCOMS - ((COMS (* ; "Retrieving mail") + ((COMS (* ; "Retrieving mail") (FNS \LAFITE.GETMAIL \LAFITE.GETMAIL.FROM.ICON \LAFITE.GETMAIL.PROC \LAFITE.GETNEWMAIL \LAFITE.GETNEWMAIL1 \LAFITE.GETNEWMAIL# \LAFITE.RETRIEVEMESSAGES)) - (COMS (* ; "Mail polling and registration") + (COMS (* ; "Mail polling and registration") (FNS \LAFITE.GET.USER.DATA \LAFITE.GUESS.MODE \LAFITE.REGISTER.MODE LAFITECLEARCACHE FULLUSERNAME LAFITE.USER.NAME.FROM.LOGIN LAFITEMAILWATCH \LAFITE.WAKE.WATCHER POLLNEWMAIL \LAFITE.NEW.MAIL.EXISTS PRINTLAFITESTATUS LAFITE.STATUS.WITH.TIME \LAFITE.REINITIALIZING)) - [COMS (* ; "Parsing mail files") + [COMS (* ; "Parsing mail files") (FNS \LAFITE.PARSE.FOLDER \LAFITE.PARSE.FOLDER1 \LAFITE.HANDLE.DUPLICATES \LAFITE.CHECK.DUPLICATE \LAFITE.REPORT.DUPLICATES BADMAILFILE BADMAILFILE.CLOSEFN BADMAILFILE.FLAGBYTE VERIFYMAILFOLDER VERIFYFAILED \LAFITE.READ.TOC.FILE @@ -39,7 +36,7 @@ Copyright (c) 1984-1989, 1991-1993, 2021 by Xerox Corporation. (COMS (VARS LA.FULLPARSEFIELDS LA.TOCFIELDS LA.TOFIELDONLY LA.DATEFIELDONLY LA.SUBJECTFIELDONLY) (FNS LAFITE.INIT.PARSETABLES LAFITE.MAKE.PARSE.TABLE LAFITE.MAKE.PARSE.TABLE1)) - (COMS (* ; "New header parser") + (COMS (* ; "New header parser") (FNS LAFITE.NEW.PARSE.HEADER LAFITE.HANDLE.ORIGINAL.FIELD) (INITVARS (*LAFITE-MAX-FIELD-WIDTH* 100) (*LAFITE-PARSE-HEADER-STRING-RESOURCE*] @@ -77,33 +74,273 @@ Copyright (c) 1984-1989, 1991-1993, 2021 by Xerox Corporation. (DEFINEQ (\LAFITE.GETMAIL -(LAMBDA (WINDOW MAILFILEDATA ITEM MENU) (* bvm%: "25-Mar-84 17:20") (\LAFITE.PROCESS (LIST (FUNCTION \LAFITE.GETMAIL.PROC) (KWOTE WINDOW) (KWOTE MAILFILEDATA) (KWOTE ITEM) (KWOTE MENU)) (QUOTE LAFITEGETMAIL))) -) + [LAMBDA (WINDOW MAILFILEDATA ITEM MENU) (* bvm%: "25-Mar-84 17:20") + (\LAFITE.PROCESS (LIST (FUNCTION \LAFITE.GETMAIL.PROC) + (KWOTE WINDOW) + (KWOTE MAILFILEDATA) + (KWOTE ITEM) + (KWOTE MENU)) + 'LAFITEGETMAIL]) (\LAFITE.GETMAIL.FROM.ICON -(LAMBDA (ICONW) (* ; "Edited 3-Jun-88 12:16 by bvm") (* ;; "Called from icon menu--expand the window and run GetMail.") (LAB.DO.COMMAND (PROG1 (WINDOWPROP ICONW (QUOTE ICONFOR)) (EXPANDW ICONW)) (FUNCTION \LAFITE.GETMAIL))) -) + [LAMBDA (ICONW) (* ; "Edited 3-Jun-88 12:16 by bvm") + + (* ;; "Called from icon menu--expand the window and run GetMail.") + + (LAB.DO.COMMAND (PROG1 (WINDOWPROP ICONW 'ICONFOR) + (EXPANDW ICONW)) + (FUNCTION \LAFITE.GETMAIL]) (\LAFITE.GETMAIL.PROC -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* bvm%: "11-Nov-84 18:30") (RESETLST (LA.RESETSHADE ITEM MENU) (OBTAIN.MONITORLOCK (fetch FOLDERLOCK of MAILFOLDER) NIL T) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (OBTAIN.MONITORLOCK \LAFITE.MAILSERVERLOCK NIL T) (\LAFITE.GETNEWMAIL MAILFOLDER WINDOW)) (\LAFITE.WAKE.WATCHER)) -) + [LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* bvm%: "11-Nov-84 18:30") + (RESETLST + (LA.RESETSHADE ITEM MENU) + (OBTAIN.MONITORLOCK (fetch FOLDERLOCK of MAILFOLDER) + NIL T) + (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) + (OBTAIN.MONITORLOCK \LAFITE.MAILSERVERLOCK NIL T) + (\LAFITE.GETNEWMAIL MAILFOLDER WINDOW)) + (\LAFITE.WAKE.WATCHER]) (\LAFITE.GETNEWMAIL -(LAMBDA (FOLDER WINDOW) (* ; "Edited 1-May-89 11:36 by bvm") (PROG* ((ALLMODES (LAFITE.ALL.MODES.P :GETMAIL)) (NEWMAILSEEN (for MODE in \LAFITE.ACTIVE.MODES when (OR ALLMODES (EQ (fetch (LAFITEMODEDATA LAFITEOPS) of MODE) \LAFITEMODE)) thereis (for MAILSERVER in (fetch (LAFITEMODEDATA MAILSERVERS) of MODE) thereis (fetch (MAILSERVER NEWMAILP) of MAILSERVER)))) (NBOXES 0) (FIRST# (ADD1 (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) ALLMESSAGELIST FIRSTMESSAGE SORTED) (\LAFITE.OPEN.FOLDER FOLDER (QUOTE APPEND) :OK) (replace (MAILFOLDER FOLDERGETSMAIL) of FOLDER with T) (for *LAFITE-MODE-DATA* in \LAFITE.ACTIVE.MODES when (OR ALLMODES (EQ (fetch (LAFITEMODEDATA LAFITEOPS) of *LAFITE-MODE-DATA*) \LAFITEMODE)) do (for MAILSERVER in (fetch (LAFITEMODEDATA MAILSERVERS) of *LAFITE-MODE-DATA*) bind MESSAGELIST when (AND (OR (NOT NEWMAILSEEN) (fetch (MAILSERVER NEWMAILP) of MAILSERVER)) (PROGN (* ; "I.e., only here if NOBODY reported mail (in which case user is asking for explicit poll), or if watcher already noticed mail") (if (> NBOXES 0) then (LAB.PROMPTPRINT FOLDER "; ")) (add NBOXES 1) (LAB.PROMPTPRINT FOLDER (fetch (MAILSERVER MAILSERVERNAME) of MAILSERVER) " .. ") (SETQ MESSAGELIST (\LAFITE.GETNEWMAIL1 MAILSERVER FOLDER FIRSTMESSAGE)))) do (LAB.APPENDMESSAGES FOLDER MESSAGELIST) (SETQ ALLMESSAGELIST (NCONC ALLMESSAGELIST MESSAGELIST)))) (if (EQ NBOXES 0) then (* ; "No mode had any mail servers") (LAB.PROMPTPRINT FOLDER "No mailboxes known") elseif ALLMESSAGELIST then (if (AND (CDR ALLMESSAGELIST) (SELECTQ LAFITE.SORT.NEW.MAIL (NIL NIL) (:MULTIPLE (> NBOXES 1)) T)) then (* ; "Sort the newly arrived messages by date") (LAB.PROMPTPRINT FOLDER "; ") (LAFITE.SORT.BY.DATE FOLDER FIRST#) (SETQ SORTED T)) (LET ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER))) (if LAFITE.AFTER.GETMAIL.FN then (* ; "User hook for mail filtering") (CL:FUNCALL LAFITE.AFTER.GETMAIL.FN FOLDER (if SORTED then (* ; "Recompute this list in the new order") (for I from FIRST# to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) collect (NTHMESSAGE MESSAGES I)) else ALLMESSAGELIST))) (if (< (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER) (SETQ FIRSTMESSAGE (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER))) then (* ; "Select the first message and make sure it is visible") (SELECTMESSAGE (SETQ FIRSTMESSAGE (NTHMESSAGE MESSAGES FIRST#)) FOLDER) else (* ; "Hook must have selected something") (SETQ FIRSTMESSAGE (NTHMESSAGE MESSAGES FIRSTMESSAGE))) (LAB.EXPOSEMESSAGE FOLDER FIRSTMESSAGE) (COND (LAFITEGETMAILTUNE (PLAYTUNE LAFITEGETMAILTUNE))) (PRINTLAFITESTATUS "Finished Retrieving Mail"))) (LAB.PROMPTPRINT FOLDER "."))) -) + [LAMBDA (FOLDER WINDOW) (* ; "Edited 1-May-89 11:36 by bvm") + (PROG* ((ALLMODES (LAFITE.ALL.MODES.P :GETMAIL)) + [NEWMAILSEEN (for MODE in \LAFITE.ACTIVE.MODES + when (OR ALLMODES (EQ (fetch (LAFITEMODEDATA LAFITEOPS) + of MODE) + \LAFITEMODE)) + thereis (for MAILSERVER in (fetch (LAFITEMODEDATA + MAILSERVERS) + of MODE) + thereis (fetch (MAILSERVER NEWMAILP) of + MAILSERVER + ] + (NBOXES 0) + (FIRST# (ADD1 (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) + ALLMESSAGELIST FIRSTMESSAGE SORTED) + (\LAFITE.OPEN.FOLDER FOLDER 'APPEND :OK) + (replace (MAILFOLDER FOLDERGETSMAIL) of FOLDER with T) + [for *LAFITE-MODE-DATA* in \LAFITE.ACTIVE.MODES + when (OR ALLMODES (EQ (fetch (LAFITEMODEDATA LAFITEOPS) of + *LAFITE-MODE-DATA* + ) + \LAFITEMODE)) + do (for MAILSERVER in (fetch (LAFITEMODEDATA MAILSERVERS) of + *LAFITE-MODE-DATA* + ) bind MESSAGELIST + when [AND (OR (NOT NEWMAILSEEN) + (fetch (MAILSERVER NEWMAILP) of MAILSERVER)) + (PROGN (* ; "I.e., only here if NOBODY reported mail (in which case user is asking for explicit poll), or if watcher already noticed mail") + (if (> NBOXES 0) + then (LAB.PROMPTPRINT FOLDER "; ")) + (add NBOXES 1) + (LAB.PROMPTPRINT FOLDER (fetch (MAILSERVER + MAILSERVERNAME + ) of + MAILSERVER) + " .. ") + (SETQ MESSAGELIST (\LAFITE.GETNEWMAIL1 MAILSERVER + FOLDER FIRSTMESSAGE] + do (LAB.APPENDMESSAGES FOLDER MESSAGELIST) + (SETQ ALLMESSAGELIST (NCONC ALLMESSAGELIST MESSAGELIST] + (if (EQ NBOXES 0) + then (* ; "No mode had any mail servers") + (LAB.PROMPTPRINT FOLDER "No mailboxes known") + elseif ALLMESSAGELIST + then (if (AND (CDR ALLMESSAGELIST) + (SELECTQ LAFITE.SORT.NEW.MAIL + (NIL NIL) + (:MULTIPLE (> NBOXES 1)) + T)) + then (* ; + "Sort the newly arrived messages by date") + (LAB.PROMPTPRINT FOLDER "; ") + (LAFITE.SORT.BY.DATE FOLDER FIRST#) + (SETQ SORTED T)) + (LET ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER))) + (if LAFITE.AFTER.GETMAIL.FN + then (* ; "User hook for mail filtering") + (CL:FUNCALL LAFITE.AFTER.GETMAIL.FN FOLDER + (if SORTED + then (* ; + "Recompute this list in the new order") + (for I from FIRST# + to (fetch (MAILFOLDER %#OFMESSAGES) + of FOLDER) + collect (NTHMESSAGE MESSAGES I)) + else ALLMESSAGELIST))) + (if (< (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER) + (SETQ FIRSTMESSAGE (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) + of FOLDER))) + then (* ; + "Select the first message and make sure it is visible") + (SELECTMESSAGE (SETQ FIRSTMESSAGE (NTHMESSAGE MESSAGES FIRST#)) + FOLDER) + else (* ; + "Hook must have selected something") + (SETQ FIRSTMESSAGE (NTHMESSAGE MESSAGES FIRSTMESSAGE))) + (LAB.EXPOSEMESSAGE FOLDER FIRSTMESSAGE) + (COND + (LAFITEGETMAILTUNE (PLAYTUNE LAFITEGETMAILTUNE))) + (PRINTLAFITESTATUS "Finished Retrieving Mail"))) + (LAB.PROMPTPRINT FOLDER "."]) (\LAFITE.GETNEWMAIL1 -(LAMBDA (MAILSERVER MAILFOLDER NTHTIME) (* ; "Edited 24-Oct-88 17:43 by bvm") (PROG (MESSAGELIST OPENRESULT MAILBOX %#OFMESSAGES OUTSTREAM) (SETQ OPENRESULT (CL:FUNCALL (fetch (MAILSERVER OPENMAILBOX) of MAILSERVER) (fetch (MAILSERVER MAILPORT) of MAILSERVER) (fetch (LAFITEMODEDATA FULLUSERNAME) of *LAFITE-MODE-DATA*) (fetch (LAFITEMODEDATA CREDENTIALS) of *LAFITE-MODE-DATA*) MAILSERVER)) (SELECTQ (COND ((LISTP OPENRESULT) (SETQ MAILBOX (fetch (OPENEDMAILBOX MAILBOX) of OPENRESULT))) (T OPENRESULT)) (EMPTY (* ; "Nothing to retrieve") (LAB.PROMPTPRINT MAILFOLDER "empty") (RETURN NIL)) (NIL (* ; "No response")) (COND (MAILBOX (COND ((NOT NTHTIME) (PRINTLAFITESTATUS "Retrieving Mail") (UNSELECTALLMESSAGES MAILFOLDER))) (\LAFITE.OPEN.FOLDER MAILFOLDER (QUOTE APPEND) :OK) (COND ((SETQ %#OFMESSAGES (LISTGET (fetch (OPENEDMAILBOX PROPERTIES) of OPENRESULT) (QUOTE %#OFMESSAGES))) (\LAFITE.GETNEWMAIL# MAILFOLDER %#OFMESSAGES))) (RETURN (COND ((SETQ MESSAGELIST (\LAFITE.RETRIEVEMESSAGES MAILSERVER MAILBOX MAILFOLDER)) (COND ((NULL %#OFMESSAGES) (\LAFITE.GETNEWMAIL# MAILFOLDER (LENGTH MESSAGELIST)))) MESSAGELIST)))))) (LAB.PROMPTPRINT MAILFOLDER "not responding") (COND ((CDR (LISTP OPENRESULT)) (* ; "Say more about why not responding") (LAB.PROMPTPRINT MAILFOLDER " (" (fetch (OPENEDMAILBOX PROPERTIES) of OPENRESULT) ")"))))) -) + [LAMBDA (MAILSERVER MAILFOLDER NTHTIME) (* ; "Edited 24-Oct-88 17:43 by bvm") + (PROG (MESSAGELIST OPENRESULT MAILBOX %#OFMESSAGES OUTSTREAM) + (SETQ OPENRESULT (CL:FUNCALL (fetch (MAILSERVER OPENMAILBOX) of MAILSERVER) + (fetch (MAILSERVER MAILPORT) of MAILSERVER) + (fetch (LAFITEMODEDATA FULLUSERNAME) of *LAFITE-MODE-DATA*) + (fetch (LAFITEMODEDATA CREDENTIALS) of *LAFITE-MODE-DATA*) + MAILSERVER)) + [SELECTQ (COND + ((LISTP OPENRESULT) + (SETQ MAILBOX (fetch (OPENEDMAILBOX MAILBOX) of OPENRESULT))) + (T OPENRESULT)) + (EMPTY (* ; "Nothing to retrieve") + (LAB.PROMPTPRINT MAILFOLDER "empty") + (RETURN NIL)) + (NIL (* ; "No response")) + (COND + (MAILBOX (COND + ((NOT NTHTIME) + (PRINTLAFITESTATUS "Retrieving Mail") + (UNSELECTALLMESSAGES MAILFOLDER))) + (\LAFITE.OPEN.FOLDER MAILFOLDER 'APPEND :OK) + (COND + ((SETQ %#OFMESSAGES (LISTGET (fetch (OPENEDMAILBOX PROPERTIES) + of OPENRESULT) + '%#OFMESSAGES)) + (\LAFITE.GETNEWMAIL# MAILFOLDER %#OFMESSAGES))) + (RETURN (COND + ((SETQ MESSAGELIST (\LAFITE.RETRIEVEMESSAGES MAILSERVER + MAILBOX MAILFOLDER)) + [COND + ((NULL %#OFMESSAGES) + (\LAFITE.GETNEWMAIL# MAILFOLDER (LENGTH MESSAGELIST] + MESSAGELIST] + (LAB.PROMPTPRINT MAILFOLDER "not responding") + (COND + ((CDR (LISTP OPENRESULT)) (* ; + "Say more about why not responding") + (LAB.PROMPTPRINT MAILFOLDER " (" (fetch (OPENEDMAILBOX PROPERTIES) of + OPENRESULT + ) + ")"]) (\LAFITE.GETNEWMAIL# -(LAMBDA (MAILFOLDER %#OFMESSAGES) (* bvm%: " 4-Feb-86 12:17") (LAB.PROMPTPRINT MAILFOLDER "(" %#OFMESSAGES (COND ((EQ %#OFMESSAGES 1) " msg") (T " msgs")) ") ")) -) + [LAMBDA (MAILFOLDER %#OFMESSAGES) (* bvm%: " 4-Feb-86 12:17") + (LAB.PROMPTPRINT MAILFOLDER "(" %#OFMESSAGES (COND + ((EQ %#OFMESSAGES 1) + " msg") + (T " msgs")) + ") "]) (\LAFITE.RETRIEVEMESSAGES -(LAMBDA (MAILSERVER MAILBOX FOLDER) (* ; "Edited 28-Apr-89 11:54 by bvm") (LET* ((OUTSTREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE APPEND) :OK)) (ORIGEOF (GETEOFPTR OUTSTREAM)) SUCCESS) (if (NOT (= ORIGEOF (fetch (MAILFOLDER FOLDEREOFPTR) of FOLDER))) then (* ; "Oops, something snuck in here. Ordinarily this is caught when we open the file, so probably this is result of internal bug") (SETQ ORIGEOF (GETEOFPTR (SETQ OUTSTREAM (\LAFITE.FOLDER.CHANGED FOLDER OUTSTREAM (QUOTE BOTH) :OK))))) (CL:UNWIND-PROTECT (CATCH-ABORT "Abort retrieval from this mailbox" (LET ((WINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER)) (NEXTMESSAGEFN (fetch (MAILSERVER NEXTMESSAGE) of MAILSERVER)) (RETRIEVEFN (fetch (MAILSERVER RETRIEVEMESSAGE) of MAILSERVER)) (ENDPOS ORIGEOF) (COUNTER 0) (MODEBITS (fetch (LAFITEMODEDATA MODEINDEX) of *LAFITE-MODE-DATA*)) XPOS MESSAGELIST STARTPOS LENGTHPOS MSGLENGTH NEXTMESSAGERESULT MSG) (if WINDOW then (* ; "We're going to print a number here each time we retrieve a message to show how far we've gotten. ") (SETQ XPOS (DSPXPOSITION NIL WINDOW)) (* ; "Number will start here") (if (< (- (DSPRIGHTMARGIN NIL WINDOW) XPOS) (TIMES (CHARWIDTH (CHARCODE 0) WINDOW) (LET ((N (LISTGET (fetch (OPENEDMAILBOX PROPERTIES) of MAILBOX) (QUOTE %#OFMESSAGES)))) (if N then (NCHARS N) else 2)))) then (* ;; "we're about to run off the right edge of the prompt window, so go to a new line. Guess about width is according to how large a number we expect ultimately to print.") (LAB.PROMPTPRINT FOLDER " -") (SETQ XPOS (DSPXPOSITION NIL WINDOW)))) (while (SETQ NEXTMESSAGERESULT (CL:FUNCALL NEXTMESSAGEFN MAILBOX)) unless (AND (LISTP NEXTMESSAGERESULT) (LISTGET NEXTMESSAGERESULT (QUOTE DELETED))) do (* ; "print the message stamp to the file") (SETFILEPTR OUTSTREAM (SETQ STARTPOS ENDPOS)) (COND ((NOT (= STARTPOS (GETEOFPTR OUTSTREAM))) (HELP "Lafite is confused about where the end of the file is.") (* ; "If the user cleverly returns from here, god help us") (SETFILEPTR OUTSTREAM (SETQ STARTPOS (GETEOFPTR OUTSTREAM))))) (LA.PRINTSTAMP OUTSTREAM) (SETQ LENGTHPOS (GETFILEPTR OUTSTREAM)) (PRIN3 "00000027 00027 UU " OUTSTREAM) (BOUT OUTSTREAM (CHARCODE CR)) (* ; "now get the message and put it in the file") (CL:FUNCALL RETRIEVEFN MAILBOX OUTSTREAM) (SETQ MSGLENGTH (- (SETQ ENDPOS (GETFILEPTR OUTSTREAM)) STARTPOS)) (* ; "go back and print the message length in the stamp") (SETQ MSG (create LAFITEMSG MARKCHAR _ UNSEENMARK BEGIN _ STARTPOS STAMPLENGTH _ (+ LAFITEBASICSTAMPLENGTH 8) MESSAGELENGTH _ MSGLENGTH MODEBITS _ MODEBITS)) (COND ((> MSGLENGTH 99999999) (* ; "Too big for this format to handle. You're probably in trouble already with a 100MB message! The file will be unparseable. We should probably issue some sort of warning") (LAB.FORMAT FOLDER "~%%Warning! Lafite has just retrieved a message ~D bytes long, which means this folder is now in an inconsistent format. You must Delete the message~@[ or Move it into another folder~] before Updating.~%%" MSGLENGTH (TYPENAMEP MSGLENGTH (QUOTE FIXP))) (SETQ MSGLENGTH 99999999))) (SETFILEPTR OUTSTREAM LENGTHPOS) (LA.PRINTCOUNT MSGLENGTH OUTSTREAM (QUOTE (FIX 8 10 T))) (push MESSAGELIST MSG) (COND (XPOS (DSPXPOSITION XPOS WINDOW) (printout WINDOW .I1 (add COUNTER 1)))) finally (COND (XPOS (* ; "Prepare to overwrite counter with 'done'") (DSPXPOSITION XPOS WINDOW))) (SETQ SUCCESS T) (RETURN (REVERSE MESSAGELIST))))) (* ;; "Cleanups: Do this whether we were successful or not") (if (NULL SUCCESS) then (* ; "Retrieval error somewhere. Dispose of what we have retrieved") (LAB.PROMPTPRINT FOLDER " retrieval aborted") (SETFILEPTR OUTSTREAM ORIGEOF) (SETFILEINFO OUTSTREAM (QUOTE LENGTH) ORIGEOF)) (\LAFITE.CLOSE.FOLDER FOLDER (NULL SUCCESS)) (* ; "Force output on the mail file so we're sure we have it") (LET* ((FLUSHP (AND SUCCESS LAFITEFLUSHMAILFLG)) (FLUSHED (IGNORE-ERRORS (* ; "Tell server we're thru, flushing if successful") (CL:FUNCALL (fetch (MAILSERVER CLOSEMAILBOX) of MAILSERVER) MAILBOX FLUSHP)))) (if SUCCESS then (LAB.FORMAT FOLDER "done~@[, mailbox maybe not flushed~]" (AND FLUSHP (NOT FLUSHED)))))))) -) + [LAMBDA (MAILSERVER MAILBOX FOLDER) (* ; "Edited 28-Apr-89 11:54 by bvm") + (LET* + ((OUTSTREAM (\LAFITE.OPEN.FOLDER FOLDER 'APPEND :OK)) + (ORIGEOF (GETEOFPTR OUTSTREAM)) + SUCCESS) + [if (NOT (= ORIGEOF (fetch (MAILFOLDER FOLDEREOFPTR) of FOLDER))) + then (* ; "Oops, something snuck in here. Ordinarily this is caught when we open the file, so probably this is result of internal bug") + (SETQ ORIGEOF (GETEOFPTR (SETQ OUTSTREAM (\LAFITE.FOLDER.CHANGED FOLDER OUTSTREAM + 'BOTH :OK] + (CL:UNWIND-PROTECT + [CATCH-ABORT + "Abort retrieval from this mailbox" + (LET ((WINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER)) + (NEXTMESSAGEFN (fetch (MAILSERVER NEXTMESSAGE) of MAILSERVER)) + (RETRIEVEFN (fetch (MAILSERVER RETRIEVEMESSAGE) of MAILSERVER)) + (ENDPOS ORIGEOF) + (COUNTER 0) + (MODEBITS (fetch (LAFITEMODEDATA MODEINDEX) of *LAFITE-MODE-DATA*)) + XPOS MESSAGELIST STARTPOS LENGTHPOS MSGLENGTH NEXTMESSAGERESULT MSG) + [if WINDOW + then (* ; +"We're going to print a number here each time we retrieve a message to show how far we've gotten. ") + (SETQ XPOS (DSPXPOSITION NIL WINDOW)) + (* ; "Number will start here") + (if [< (- (DSPRIGHTMARGIN NIL WINDOW) + XPOS) + (TIMES (CHARWIDTH (CHARCODE 0) + WINDOW) + (LET [(N (LISTGET (fetch (OPENEDMAILBOX PROPERTIES) + of MAILBOX) + '%#OFMESSAGES] + (if N + then (NCHARS N) + else 2] + then + + (* ;; "we're about to run off the right edge of the prompt window, so go to a new line. Guess about width is according to how large a number we expect ultimately to print.") + + (LAB.PROMPTPRINT FOLDER " +") + (SETQ XPOS (DSPXPOSITION NIL WINDOW] + (while (SETQ NEXTMESSAGERESULT (CL:FUNCALL NEXTMESSAGEFN MAILBOX)) + unless (AND (LISTP NEXTMESSAGERESULT) + (LISTGET NEXTMESSAGERESULT 'DELETED)) + do (* ; + "print the message stamp to the file") + (SETFILEPTR OUTSTREAM (SETQ STARTPOS ENDPOS)) + [COND + ((NOT (= STARTPOS (GETEOFPTR OUTSTREAM))) + (HELP "Lafite is confused about where the end of the file is.") + (* ; + "If the user cleverly returns from here, god help us") + (SETFILEPTR OUTSTREAM (SETQ STARTPOS (GETEOFPTR OUTSTREAM] + (LA.PRINTSTAMP OUTSTREAM) + (SETQ LENGTHPOS (GETFILEPTR OUTSTREAM)) + (PRIN3 "00000027 00027 UU " OUTSTREAM) + (BOUT OUTSTREAM (CHARCODE CR)) (* ; + "now get the message and put it in the file") + (CL:FUNCALL RETRIEVEFN MAILBOX OUTSTREAM) + (SETQ MSGLENGTH (- (SETQ ENDPOS (GETFILEPTR OUTSTREAM)) + STARTPOS)) (* ; + "go back and print the message length in the stamp") + (SETQ MSG (create LAFITEMSG + MARKCHAR _ UNSEENMARK + BEGIN _ STARTPOS + STAMPLENGTH _ (+ LAFITEBASICSTAMPLENGTH 8) + MESSAGELENGTH _ MSGLENGTH + MODEBITS _ MODEBITS)) + (COND + ((> MSGLENGTH 99999999) (* ; "Too big for this format to handle. You're probably in trouble already with a 100MB message! The file will be unparseable. We should probably issue some sort of warning") + (LAB.FORMAT FOLDER "~%%Warning! Lafite has just retrieved a message ~D bytes long, which means this folder is now in an inconsistent format. You must Delete the message~@[ or Move it into another folder~] before Updating.~%%" + MSGLENGTH (TYPENAMEP MSGLENGTH 'FIXP)) + (SETQ MSGLENGTH 99999999))) + (SETFILEPTR OUTSTREAM LENGTHPOS) + (LA.PRINTCOUNT MSGLENGTH OUTSTREAM '(FIX 8 10 T)) + (push MESSAGELIST MSG) + [COND + (XPOS (DSPXPOSITION XPOS WINDOW) + (printout WINDOW .I1 (add COUNTER 1] + finally (COND + (XPOS (* ; + "Prepare to overwrite counter with 'done'") + (DSPXPOSITION XPOS WINDOW))) + (SETQ SUCCESS T) + (RETURN (REVERSE MESSAGELIST] + + (* ;; "Cleanups: Do this whether we were successful or not") + + (if (NULL SUCCESS) + then (* ; + "Retrieval error somewhere. Dispose of what we have retrieved") + (LAB.PROMPTPRINT FOLDER " retrieval aborted") + (SETFILEPTR OUTSTREAM ORIGEOF) + (SETFILEINFO OUTSTREAM 'LENGTH ORIGEOF)) + (\LAFITE.CLOSE.FOLDER FOLDER (NULL SUCCESS)) (* ; + "Force output on the mail file so we're sure we have it") + [LET* [(FLUSHP (AND SUCCESS LAFITEFLUSHMAILFLG)) + (FLUSHED (IGNORE-ERRORS (* ; + "Tell server we're thru, flushing if successful") + (CL:FUNCALL (fetch (MAILSERVER CLOSEMAILBOX) of MAILSERVER) + MAILBOX FLUSHP] + (if SUCCESS + then (LAB.FORMAT FOLDER "done~@[, mailbox maybe not flushed~]" + (AND FLUSHP (NOT FLUSHED])]) ) @@ -113,56 +350,433 @@ Copyright (c) 1984-1989, 1991-1993, 2021 by Xerox Corporation. (DEFINEQ (\LAFITE.GET.USER.DATA -(LAMBDA (MODE DONTWAIT RECOMPUTE) (* ; "Edited 26-May-92 12:21 by bvm") (* ;;; "Return the mode data for specified MODE, or the current mode if NIL. This function is in charge of setting \LAFITEUSERDATA") (COND ((NOT (OR (LISTP MODE) (SETQ MODE (if MODE then (ASSOC MODE LAFITEMODELST) else (OR \LAFITEMODE (\LAFITE.INFER.MODE)))))) (SETQ \LAFITE.AUTHENTICATION.FAILURE "No Mode") NIL) ((AND (NOT RECOMPUTE) (ASSOC MODE \LAFITE.ACTIVE.MODES))) ((NOT DONTWAIT) (WITH.MONITOR \LAFITE.MAILSERVERLOCK (* ; "Let's not have everyone try this at once") (ALLOW.BUTTON.EVENTS) (* ; "Make sure not to trap the mouse") (LET ((DATA (ASSOC MODE \LAFITE.ACTIVE.MODES))) (if RECOMPUTE then (SETQ \LAFITE.ACTIVE.MODES (DREMOVE DATA \LAFITE.ACTIVE.MODES)) (SETQ DATA NIL)) (OR DATA (LET ((HOW (CONS "Authenticating" (AND (OR (NEQ MODE \LAFITEMODE) (LAFITE.SHOW.MODE.P)) (LIST " " (fetch (LAFITEOPS LAFITEMODE) of MODE)))))) (\LAFITE.REGISTER.MODE MODE) (* ; "In case it hasn't been done yet") (PRINTLAFITESTATUS (LAFITE.STATUS.WITH.TIME (CONCATLIST HOW))) (if (SETQ DATA (CL:FUNCALL (fetch (LAFITEOPS AUTHENTICATOR) of MODE))) then (replace (LAFITEMODEDATA LAFITEOPS) of DATA with MODE) (push \LAFITE.ACTIVE.MODES DATA) (PRINTLAFITESTATUS (LAFITE.STATUS.WITH.TIME (CONCATLIST (RPLACA HOW "Authenticated")))) (\LAFITE.WAKE.WATCHER) (* ; "To update status window") DATA)))))))) -) + [LAMBDA (MODE DONTWAIT RECOMPUTE) (* ; "Edited 26-May-92 12:21 by bvm") + +(* ;;; "Return the mode data for specified MODE, or the current mode if NIL. This function is in charge of setting \LAFITEUSERDATA") + + (COND + ([NOT (OR (LISTP MODE) + (SETQ MODE (if MODE + then (ASSOC MODE LAFITEMODELST) + else (OR \LAFITEMODE (\LAFITE.INFER.MODE] + (SETQ \LAFITE.AUTHENTICATION.FAILURE "No Mode") + NIL) + ((AND (NOT RECOMPUTE) + (ASSOC MODE \LAFITE.ACTIVE.MODES))) + ((NOT DONTWAIT) + (WITH.MONITOR \LAFITE.MAILSERVERLOCK (* ; + "Let's not have everyone try this at once") + (ALLOW.BUTTON.EVENTS) (* ; "Make sure not to trap the mouse") + [LET ((DATA (ASSOC MODE \LAFITE.ACTIVE.MODES))) + (if RECOMPUTE + then (SETQ \LAFITE.ACTIVE.MODES (DREMOVE DATA \LAFITE.ACTIVE.MODES)) + (SETQ DATA NIL)) + (OR DATA (LET [(HOW (CONS "Authenticating" (AND (OR (NEQ MODE \LAFITEMODE) + (LAFITE.SHOW.MODE.P)) + (LIST " " (fetch (LAFITEOPS + LAFITEMODE) + of MODE] + (\LAFITE.REGISTER.MODE MODE) + (* ; "In case it hasn't been done yet") + (PRINTLAFITESTATUS (LAFITE.STATUS.WITH.TIME (CONCATLIST HOW))) + (if (SETQ DATA (CL:FUNCALL (fetch (LAFITEOPS AUTHENTICATOR) + of MODE))) + then (replace (LAFITEMODEDATA LAFITEOPS) of DATA + with MODE) + (push \LAFITE.ACTIVE.MODES DATA) + [PRINTLAFITESTATUS (LAFITE.STATUS.WITH.TIME + (CONCATLIST (RPLACA HOW + "Authenticated"] + (\LAFITE.WAKE.WATCHER) + (* ; "To update status window") + DATA])]) (\LAFITE.GUESS.MODE -(LAMBDA (MSG) (* ; "Edited 9-May-88 18:40 by bvm") (* ;; "Try to figure out the mode of the message. If we're sure about it, fix the message, too.") (if (NULL (CDR \LAFITE.ACTIVE.MODES)) then (* ; "Only one mode, assume it's that one, but don't bother recording this fact") (fetch (LAFITEMODEDATA LAFITEMODE) of (CAR \LAFITE.ACTIVE.MODES)) else (LET (BESTMODE OKMODE) (for *LAFITE-MODE-DATA* in \LAFITE.ACTIVE.MODES do (CASE (CL:FUNCALL (fetch (LAFITEMODEDATA MESSAGEP) of *LAFITE-MODE-DATA*) MSG) ((T) (* ; "Definitely this type") (RETURN (SETQ BESTMODE *LAFITE-MODE-DATA*))) (? (* ; "Could be this type") (if (NOT OKMODE) then (SETQ OKMODE *LAFITE-MODE-DATA*) else (SETQ OKMODE T))))) (if (OR BESTMODE (AND (SETQ BESTMODE OKMODE) (NEQ BESTMODE T))) then (* ; "Found it, or found an ok one with no competitors.") (replace (LAFITEMSG MODEBITS) of MSG with (fetch (LAFITEMODEDATA MODEINDEX) of BESTMODE)) (fetch (LAFITEMODEDATA LAFITEMODE) of BESTMODE))))) -) + [LAMBDA (MSG) (* ; "Edited 9-May-88 18:40 by bvm") + + (* ;; + "Try to figure out the mode of the message. If we're sure about it, fix the message, too.") + + (if (NULL (CDR \LAFITE.ACTIVE.MODES)) + then (* ; + "Only one mode, assume it's that one, but don't bother recording this fact") + (fetch (LAFITEMODEDATA LAFITEMODE) of (CAR \LAFITE.ACTIVE.MODES)) + else (LET (BESTMODE OKMODE) + [for *LAFITE-MODE-DATA* in \LAFITE.ACTIVE.MODES + do (CASE (CL:FUNCALL (fetch (LAFITEMODEDATA MESSAGEP) of + *LAFITE-MODE-DATA* + ) + MSG) + ((T) (* ; "Definitely this type") + (RETURN (SETQ BESTMODE *LAFITE-MODE-DATA*))) + (? (* ; "Could be this type") + (if (NOT OKMODE) + then (SETQ OKMODE *LAFITE-MODE-DATA*) + else (SETQ OKMODE T))))] + (if (OR BESTMODE (AND (SETQ BESTMODE OKMODE) + (NEQ BESTMODE T))) + then (* ; + "Found it, or found an ok one with no competitors.") + (replace (LAFITEMSG MODEBITS) of MSG with + (fetch (LAFITEMODEDATA + MODEINDEX) + of BESTMODE)) + (fetch (LAFITEMODEDATA LAFITEMODE) of BESTMODE]) (\LAFITE.REGISTER.MODE -(LAMBDA (MODEDATA) (* ; "Edited 6-May-88 15:15 by bvm") (* ;; "Take note of this element of LAFITEMODELST. Currently this just means adding the mode to the index-to-name list *LAFITE-WELL-KNOWN-MODES*.") (if (NOT (FMEMB (fetch (LAFITEOPS LAFITEMODE) of MODEDATA) *LAFITE-WELL-KNOWN-MODES*)) then (* ; "Register this mode") (LET ((N (fetch (LAFITEOPS MODEINDEX) of MODEDATA))) (while (<= (LENGTH *LAFITE-WELL-KNOWN-MODES*) N) do (* ; "Make sure mode list has at least n+1 elements (zeroth elt is NIL for mode = unknown).") (SETQ *LAFITE-WELL-KNOWN-MODES* (NCONC1 *LAFITE-WELL-KNOWN-MODES* NIL))) (CL:SETF (CL:NTH N *LAFITE-WELL-KNOWN-MODES*) (fetch (LAFITEOPS LAFITEMODE) of MODEDATA)))) MODEDATA) -) + [LAMBDA (MODEDATA) (* ; "Edited 6-May-88 15:15 by bvm") + + (* ;; "Take note of this element of LAFITEMODELST. Currently this just means adding the mode to the index-to-name list *LAFITE-WELL-KNOWN-MODES*.") + + [if (NOT (FMEMB (fetch (LAFITEOPS LAFITEMODE) of MODEDATA) + *LAFITE-WELL-KNOWN-MODES*)) + then (* ; "Register this mode") + (LET ((N (fetch (LAFITEOPS MODEINDEX) of MODEDATA))) + (while (<= (LENGTH *LAFITE-WELL-KNOWN-MODES*) + N) do (* ; + "Make sure mode list has at least n+1 elements (zeroth elt is NIL for mode = unknown).") + (SETQ *LAFITE-WELL-KNOWN-MODES* (NCONC1 + *LAFITE-WELL-KNOWN-MODES* + NIL))) + (CL:SETF (CL:NTH N *LAFITE-WELL-KNOWN-MODES*) + (fetch (LAFITEOPS LAFITEMODE) of MODEDATA] + MODEDATA]) (LAFITECLEARCACHE -(LAMBDA (RECURSIVEP) (* ; "Edited 13-Jun-88 12:47 by bvm") (* ;; "Called when login has changed, or we otherwise want to reauthenticate. If WAKEFLG, then recompute them right now.") (RESETLST (if (OBTAIN.MONITORLOCK \LAFITE.MAILSERVERLOCK (NULL RECURSIVEP) T) then (SETQ \LAFITE.ACTIVE.MODES NIL) (\LAFITE.WAKE.WATCHER) else (* ; "Spawn process to do it when the lock becomes free") (\LAFITE.PROCESS (BQUOTE ((\, (FUNCTION LAFITECLEARCACHE)) T)))))) -) + [LAMBDA (RECURSIVEP) (* ; "Edited 13-Jun-88 12:47 by bvm") + + (* ;; "Called when login has changed, or we otherwise want to reauthenticate. If WAKEFLG, then recompute them right now.") + + (RESETLST + [if (OBTAIN.MONITORLOCK \LAFITE.MAILSERVERLOCK (NULL RECURSIVEP) + T) + then (SETQ \LAFITE.ACTIVE.MODES NIL) + (\LAFITE.WAKE.WATCHER) + else (* ; + "Spawn process to do it when the lock becomes free") + (\LAFITE.PROCESS `(,(FUNCTION LAFITECLEARCACHE) + T])]) (FULLUSERNAME -(LAMBDA (UNPACKEDFLG MODE) (* ; "Edited 3-May-89 18:36 by bvm") (if (NOT MODE) then (SETQ MODE \LAFITEMODE) elseif (LITATOM MODE) then (SETQ MODE (OR (ASSOC MODE LAFITEMODELST) (\ILLEGAL.ARG MODE)))) (LET (DATA) (COND ((AND \LAFITE.ACTIVE.MODES (SETQ DATA (ASSOC MODE \LAFITE.ACTIVE.MODES))) (COND (UNPACKEDFLG (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of DATA)) (T (fetch (LAFITEMODEDATA FULLUSERNAME) of DATA)))) ((AND (OR MODE (SETQ MODE (\LAFITE.INFER.MODE))) (EQ (fetch (LAFITEOPS LAFITEMODE) of MODE) (QUOTE NS))) (* ; "Special-case NS username when not yet authenticated--use login name with colon, letting sendmail do the defaulting later") (CONCAT (CAR (LAFITE.USER.NAME.FROM.LOGIN T)) ":")) (T (LAFITE.USER.NAME.FROM.LOGIN UNPACKEDFLG))))) -) + [LAMBDA (UNPACKEDFLG MODE) (* ; "Edited 3-May-89 18:36 by bvm") + [if (NOT MODE) + then (SETQ MODE \LAFITEMODE) + elseif (LITATOM MODE) + then (SETQ MODE (OR (ASSOC MODE LAFITEMODELST) + (\ILLEGAL.ARG MODE] + (LET (DATA) + (COND + [(AND \LAFITE.ACTIVE.MODES (SETQ DATA (ASSOC MODE \LAFITE.ACTIVE.MODES))) + (COND + (UNPACKEDFLG (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of DATA)) + (T (fetch (LAFITEMODEDATA FULLUSERNAME) of DATA] + ((AND (OR MODE (SETQ MODE (\LAFITE.INFER.MODE))) + (EQ (fetch (LAFITEOPS LAFITEMODE) of MODE) + 'NS)) (* ; "Special-case NS username when not yet authenticated--use login name with colon, letting sendmail do the defaulting later") + (CONCAT (CAR (LAFITE.USER.NAME.FROM.LOGIN T)) + ":")) + (T (LAFITE.USER.NAME.FROM.LOGIN UNPACKEDFLG]) (LAFITE.USER.NAME.FROM.LOGIN -(LAMBDA (UNPACKEDFLG RECOMPUTE) (* ; "Edited 7-Sep-88 11:49 by bvm") (* ;; "Return name of current logged in user. If UNPACKEDFLG return it as a gv cons, else a string fullname.reg") (if (OR RECOMPUTE (NULL \LAFITE.CURRENT.USER)) then (\INTERNAL/GETPASSWORD) (* ; "Insure logged in") (LET ((USER (USERNAME NIL NIL T)) DOT REGISTRY SIMPLENAME) (COND ((NOT (SETQ DOT (STRPOS "." USER))) (SETQ SIMPLENAME USER) (SETQ REGISTRY DEFAULTREGISTRY)) (T (SETQ SIMPLENAME (SUBSTRING USER 1 (SUB1 DOT))) (SETQ REGISTRY (SUBATOM USER (ADD1 DOT))))) (COND ((U-CASEP SIMPLENAME) (* ; "If user had the caps lock on when logging in, lowercase the name") (SETQ SIMPLENAME (L-CASE SIMPLENAME T)))) (if REGISTRY then (* ; "Silly grapevine code requires registry be a symbol. Make it lowercase to be nice") (SETQ REGISTRY (MKATOM (L-CASE REGISTRY)))) (SETQ \LAFITE.CURRENT.USER (CONS (if REGISTRY then (CONCAT SIMPLENAME "." REGISTRY) else SIMPLENAME) (CONS SIMPLENAME REGISTRY))))) (COND (UNPACKEDFLG (CDR \LAFITE.CURRENT.USER)) (T (CAR \LAFITE.CURRENT.USER)))) -) + [LAMBDA (UNPACKEDFLG RECOMPUTE) (* ; "Edited 7-Sep-88 11:49 by bvm") + + (* ;; "Return name of current logged in user. If UNPACKEDFLG return it as a gv cons, else a string fullname.reg") + + [if (OR RECOMPUTE (NULL \LAFITE.CURRENT.USER)) + then (\INTERNAL/GETPASSWORD) (* ; "Insure logged in") + (LET ((USER (USERNAME NIL NIL T)) + DOT REGISTRY SIMPLENAME) + [COND + ((NOT (SETQ DOT (STRPOS "." USER))) + (SETQ SIMPLENAME USER) + (SETQ REGISTRY DEFAULTREGISTRY)) + (T (SETQ SIMPLENAME (SUBSTRING USER 1 (SUB1 DOT))) + (SETQ REGISTRY (SUBATOM USER (ADD1 DOT] + [COND + ((U-CASEP SIMPLENAME) (* ; + "If user had the caps lock on when logging in, lowercase the name") + (SETQ SIMPLENAME (L-CASE SIMPLENAME T] + [if REGISTRY + then (* ; + "Silly grapevine code requires registry be a symbol. Make it lowercase to be nice") + (SETQ REGISTRY (MKATOM (L-CASE REGISTRY] + (SETQ \LAFITE.CURRENT.USER (CONS (if REGISTRY + then (CONCAT SIMPLENAME "." REGISTRY) + else SIMPLENAME) + (CONS SIMPLENAME REGISTRY] + (COND + (UNPACKEDFLG (CDR \LAFITE.CURRENT.USER)) + (T (CAR \LAFITE.CURRENT.USER]) (LAFITEMAILWATCH -(LAMBDA NIL (* ; "Edited 13-Jun-88 11:05 by bvm") (bind (INTERVAL _ (ITIMES MAILWATCHWAITTIME 60000)) (FIRSTTIME _ T) CONTINUANCE while (PROGN (* ; "Until killed") T) do (SETQ CONTINUANCE (WITH.MONITOR \LAFITE.MAILSERVERLOCK (POLLNEWMAIL FIRSTTIME))) (BLOCK (if (AND CONTINUANCE (< CONTINUANCE INTERVAL)) then (* ; "Some server wants to be contacted within this period") CONTINUANCE else INTERVAL)) (SETQ FIRSTTIME NIL))) -) + [LAMBDA NIL (* ; "Edited 13-Jun-88 11:05 by bvm") + (bind (INTERVAL _ (ITIMES MAILWATCHWAITTIME 60000)) + (FIRSTTIME _ T) + CONTINUANCE while (PROGN (* ; "Until killed") + T) do (SETQ CONTINUANCE (WITH.MONITOR + \LAFITE.MAILSERVERLOCK + (POLLNEWMAIL FIRSTTIME + ))) + (BLOCK (if (AND CONTINUANCE (< CONTINUANCE + INTERVAL)) + then + (* ; + "Some server wants to be contacted within this period") + CONTINUANCE + else INTERVAL)) + (SETQ FIRSTTIME NIL]) (\LAFITE.WAKE.WATCHER -(LAMBDA NIL (* ; "Edited 13-Jun-88 12:41 by bvm") (* ;; "Wakes the LAFITEMAILWATCH process in response to various actions") (PROG ((P (FIND.PROCESS (QUOTE LAFITEMAILWATCH)))) (COND (P (WAKE.PROCESS P)) ((EQ \LAFITE.ACTIVE T) (* ; "Process got killed somehow; reinstate it") (\LAFITE.PROCESS (LIST (FUNCTION LAFITEMAILWATCH)) NIL T (QUOTE HARDRESET)))))) -) + [LAMBDA NIL (* ; "Edited 13-Jun-88 12:41 by bvm") + + (* ;; "Wakes the LAFITEMAILWATCH process in response to various actions") + + (PROG [(P (FIND.PROCESS 'LAFITEMAILWATCH] + (COND + (P (WAKE.PROCESS P)) + ((EQ \LAFITE.ACTIVE T) (* ; + "Process got killed somehow; reinstate it") + (\LAFITE.PROCESS (LIST (FUNCTION LAFITEMAILWATCH)) + NIL T 'HARDRESET]) (POLLNEWMAIL -(LAMBDA (RESTARTFLG) (* ; "Edited 16-Aug-89 17:03 by bvm") (* ;; "Poll for new mail. Value returned, if non-NIL, is the %"continuance%"--the number of milliseconds within which some server would like to be contacted again.") (PROG ((ALLMODES (LAFITE.ALL.MODES.P :POLL)) PRIMARYMODE FAILEDMODES NOTUPFLG NOMAILFLG NEWMAILMODES MINCONTINUANCE STATUS) (if (OR RESTARTFLG (NULL \LAFITE.ACTIVE.MODES)) then (* ; "Need to get authenticated") (\LAFITE.GET.USER.DATA) (if ALLMODES then (* ; "Also make sure to get data for non-primary modes") (SETQ FAILEDMODES (for MODE in LAFITEMODELST unless (OR (NLISTP (CDR MODE)) (PROGN (SETQ \LAFITE.AUTHENTICATION.FAILURE NIL) (\LAFITE.GET.USER.DATA MODE))) collect (CONS \LAFITE.AUTHENTICATION.FAILURE MODE)))) (if (NULL \LAFITE.ACTIVE.MODES) then (* ; "Didn't get anywhere!") (PRINTLAFITESTATUS (COND (\LAFITEMODE (QUOTE NO.MAILSERVER)) (LAFITEMODELST (QUOTE MODE.NOT.SET)) (T (QUOTE NO.MODE)))) (RETURN NIL) else (for PAIR in FAILEDMODES do (* ; "Show which modes failed") (PRINTOUT PROMPTWINDOW T "Lafite " (fetch (LAFITEOPS LAFITEMODE) of (CDR PAIR)) " mode suspended") (if (CAR PAIR) then (PRINTOUT PROMPTWINDOW " because: " (CAR PAIR)))) (for MODE in \LAFITE.ACTIVE.MODES when (NULL (fetch (LAFITEMODEDATA MAILSERVERS) of MODE)) do (* ; "This mode has no mail servers, so will not be able to check/retrieve mail. Print this info just the first time we fail") (PRINTOUT PROMPTWINDOW T "There are no " (fetch (LAFITEMODEDATA LAFITEMODE) of MODE) " mail servers for " (fetch (LAFITEMODEDATA SHORTUSERNAME) of MODE)))) else (* ; "Make sure we at least have data for primary mode") (\LAFITE.GET.USER.DATA)) (SETQ NEWMAILMODES (for *LAFITE-MODE-DATA* in \LAFITE.ACTIVE.MODES bind N INFO when (AND (OR ALLMODES (EQ (fetch (LAFITEMODEDATA LAFITEOPS) of *LAFITE-MODE-DATA*) \LAFITEMODE)) (PROGN (SETQ N 0) (for MAILSERVER in (fetch (LAFITEMODEDATA MAILSERVERS) of *LAFITE-MODE-DATA*) bind CONT NEWMAILP do (SETQ STATUS (CL:FUNCALL (fetch (MAILSERVER POLLNEWMAIL) of MAILSERVER) (fetch (MAILSERVER MAILPORT) of MAILSERVER) (fetch (LAFITEMODEDATA FULLUSERNAME) of *LAFITE-MODE-DATA*) (fetch (LAFITEMODEDATA CREDENTIALS) of *LAFITE-MODE-DATA*) MAILSERVER)) (COND ((AND (SETQ CONT (fetch (MAILSERVER CONTINUANCE) of MAILSERVER)) (OR (NULL MINCONTINUANCE) (< CONT MINCONTINUANCE))) (SETQ MINCONTINUANCE CONT))) (replace (MAILSERVER NEWMAILP) of MAILSERVER with (if (FIXP STATUS) then (* ; "Number of messages") (add N STATUS) (SETQ NEWMAILP N) else (SELECTQ STATUS (T (SETQ NEWMAILP T)) (NIL (SETQ NOMAILFLG T) NIL) (? (* ; "I guess the server is down") (SETQ NOTUPFLG T) NIL) (SHOULDNT)))) finally (RETURN NEWMAILP)))) collect (SETQ INFO (LIST *LAFITE-MODE-DATA* (AND (> N 0) N))) (if (EQ (fetch (LAFITEMODEDATA LAFITEOPS) of *LAFITE-MODE-DATA*) \LAFITEMODE) then (SETQ PRIMARYMODE INFO)) INFO)) (if NEWMAILMODES then (if (NOT (EQUAL NEWMAILMODES \LAFITE.LAST.STATUS)) then (* ; "only do this if something has changed") (LET ((HOWNEW "New") N) (if (NULL PRIMARYMODE) then (* ; "There's new mail, but not in the advertised mode") (SETQ PRIMARYMODE (CAR NEWMAILMODES)) (if (NOT (LAFITE.ALL.MODES.P :GETMAIL)) then (* ; "Since GetMail won't retrieve this mode, make clear which one we're talking about") (SETQ HOWNEW (CONCAT HOWNEW " " (fetch (LAFITEMODEDATA LAFITEMODE) of (CAR PRIMARYMODE)))))) (PRINTLAFITESTATUS (CONCATLIST (NCONC (if (SETQ N (CADR PRIMARYMODE)) then (LIST* N " " HOWNEW " Msg" (AND (> N 1) (LIST "s"))) else (LIST HOWNEW " Mail")) (LIST* " for " (fetch (LAFITEMODEDATA SHORTUSERNAME) of (CAR PRIMARYMODE)) (if (CDR NEWMAILMODES) then (* ; "Identify the other modes with new mail") (LET ((LST (QUOTE (")"))) N) (for MODE in NEWMAILMODES unless (EQ MODE PRIMARYMODE) do (push LST (fetch (LAFITEMODEDATA LAFITEMODE) of (CAR MODE))) (if (SETQ N (CADR MODE)) then (push LST " " N " ")) (push LST ",")) (CONS " (+" (CDR LST)))))))) (if NIL then (* ; "That might have been clearer as follows, but it's 30 times slower (over 1/10 sec on Dorado), which I'd rather not do in the background") (CL:FORMAT NIL "New ~@[~A ~]Mail for ~A~@[ (~{+~A~})~]" (COND ((NOT (OR (SETQ PRIMARYMODE (ASSOC \LAFITEMODE NEWMAILMODES)) (LAFITE.ALL.MODES.P :GETMAIL))) (* ; "Make clear the mode we're talking about, since this is not the mode GetMail will retrieve in") (fetch (LAFITEMODEDATA LAFITEMODE) of (CAR NEWMAILMODES)))) (fetch (LAFITEMODEDATA SHORTUSERNAME) of (OR PRIMARYMODE (CAR NEWMAILMODES))) (for MODE in NEWMAILMODES unless (EQ MODE PRIMARYMODE) collect (fetch (LAFITEMODEDATA LAFITEMODE) of MODE)))) (SETQ \LAFITE.LAST.STATUS NEWMAILMODES) (\LAFITE.NEW.MAIL.EXISTS))) else (* ; "Nobody reported new mail. Reason could be one of several") (PRINTLAFITESTATUS (if NOTUPFLG then (if NOMAILFLG then (* ; "Somebody responded") (QUOTE SOME.UP) else (QUOTE NONE.UP)) elseif NOMAILFLG then (* ; "every server reports no new mail") (QUOTE NO.MAIL) else (* ; "No server reported anything") (QUOTE NO.MAILBOX)))) (RETURN MINCONTINUANCE))) -) + [LAMBDA (RESTARTFLG) (* ; "Edited 16-Aug-89 17:03 by bvm") + + (* ;; "Poll for new mail. Value returned, if non-NIL, is the %"continuance%"--the number of milliseconds within which some server would like to be contacted again.") + + (PROG ((ALLMODES (LAFITE.ALL.MODES.P :POLL)) + PRIMARYMODE FAILEDMODES NOTUPFLG NOMAILFLG NEWMAILMODES MINCONTINUANCE STATUS) + (if (OR RESTARTFLG (NULL \LAFITE.ACTIVE.MODES)) + then (* ; "Need to get authenticated") + (\LAFITE.GET.USER.DATA) + [if ALLMODES + then (* ; + "Also make sure to get data for non-primary modes") + (SETQ FAILEDMODES (for MODE in LAFITEMODELST + unless (OR (NLISTP (CDR MODE)) + (PROGN (SETQ + \LAFITE.AUTHENTICATION.FAILURE + NIL) + (\LAFITE.GET.USER.DATA + MODE))) + collect (CONS \LAFITE.AUTHENTICATION.FAILURE + MODE] + [if (NULL \LAFITE.ACTIVE.MODES) + then (* ; "Didn't get anywhere!") + [PRINTLAFITESTATUS (COND + (\LAFITEMODE 'NO.MAILSERVER) + (LAFITEMODELST 'MODE.NOT.SET) + (T 'NO.MODE] + (RETURN NIL) + else [for PAIR in FAILEDMODES + do (* ; "Show which modes failed") + (PRINTOUT PROMPTWINDOW T "Lafite " (fetch (LAFITEOPS + LAFITEMODE) + of (CDR PAIR)) + " mode suspended") + (if (CAR PAIR) + then (PRINTOUT PROMPTWINDOW " because: " (CAR PAIR] + (for MODE in \LAFITE.ACTIVE.MODES + when (NULL (fetch (LAFITEMODEDATA MAILSERVERS) of MODE)) + do (* ; "This mode has no mail servers, so will not be able to check/retrieve mail. Print this info just the first time we fail") + (PRINTOUT PROMPTWINDOW T "There are no " (fetch ( + LAFITEMODEDATA + LAFITEMODE) + of MODE) + " mail servers for " + (fetch (LAFITEMODEDATA SHORTUSERNAME) of MODE] + else (* ; + "Make sure we at least have data for primary mode") + (\LAFITE.GET.USER.DATA)) + (SETQ NEWMAILMODES + (for *LAFITE-MODE-DATA* in \LAFITE.ACTIVE.MODES bind N INFO + when [AND (OR ALLMODES (EQ (fetch (LAFITEMODEDATA LAFITEOPS) of + *LAFITE-MODE-DATA* + ) + \LAFITEMODE)) + (PROGN (SETQ N 0) + (for MAILSERVER in (fetch (LAFITEMODEDATA MAILSERVERS) + of *LAFITE-MODE-DATA*) + bind CONT NEWMAILP + do (SETQ STATUS (CL:FUNCALL (fetch (MAILSERVER + POLLNEWMAIL) + of MAILSERVER) + (fetch (MAILSERVER MAILPORT) + of MAILSERVER) + (fetch (LAFITEMODEDATA + FULLUSERNAME) + of *LAFITE-MODE-DATA*) + (fetch (LAFITEMODEDATA + CREDENTIALS) + of *LAFITE-MODE-DATA*) + MAILSERVER)) + (COND + ((AND (SETQ CONT (fetch (MAILSERVER CONTINUANCE) + of MAILSERVER)) + (OR (NULL MINCONTINUANCE) + (< CONT MINCONTINUANCE))) + (SETQ MINCONTINUANCE CONT))) + [replace (MAILSERVER NEWMAILP) of MAILSERVER + with (if (FIXP STATUS) + then + (* ; "Number of messages") + (add N STATUS) + (SETQ NEWMAILP N) + else (SELECTQ STATUS + (T (SETQ NEWMAILP T)) + (NIL (SETQ NOMAILFLG T) + NIL) + (? + (* ; "I guess the server is down") + (SETQ NOTUPFLG T) + NIL) + (SHOULDNT] + finally (RETURN NEWMAILP] + collect (SETQ INFO (LIST *LAFITE-MODE-DATA* (AND (> N 0) + N))) + (if (EQ (fetch (LAFITEMODEDATA LAFITEOPS) of *LAFITE-MODE-DATA*) + \LAFITEMODE) + then (SETQ PRIMARYMODE INFO)) + INFO)) + [if NEWMAILMODES + then + (if (NOT (EQUAL NEWMAILMODES \LAFITE.LAST.STATUS)) + then (* ; + "only do this if something has changed") + (LET + ((HOWNEW "New") + N) + [if (NULL PRIMARYMODE) + then (* ; + "There's new mail, but not in the advertised mode") + (SETQ PRIMARYMODE (CAR NEWMAILMODES)) + (if (NOT (LAFITE.ALL.MODES.P :GETMAIL)) + then (* ; + "Since GetMail won't retrieve this mode, make clear which one we're talking about") + (SETQ HOWNEW (CONCAT HOWNEW " " (fetch (LAFITEMODEDATA + LAFITEMODE) + of (CAR PRIMARYMODE] + [PRINTLAFITESTATUS + (CONCATLIST + (NCONC (if (SETQ N (CADR PRIMARYMODE)) + then (LIST* N " " HOWNEW " Msg" (AND (> N 1) + (LIST "s"))) + else (LIST HOWNEW " Mail")) + (LIST* " for " (fetch (LAFITEMODEDATA SHORTUSERNAME) + of (CAR PRIMARYMODE)) + (if (CDR NEWMAILMODES) + then (* ; + "Identify the other modes with new mail") + (LET ((LST '(")")) + N) + (for MODE in NEWMAILMODES + unless (EQ MODE PRIMARYMODE) + do (push LST (fetch (LAFITEMODEDATA + LAFITEMODE) + of (CAR MODE))) + (if (SETQ N (CADR MODE)) + then (push LST " " N " ")) + (push LST ",")) + (CONS " (+" (CDR LST] + [if NIL + then (* ; "That might have been clearer as follows, but it's 30 times slower (over 1/10 sec on Dorado), which I'd rather not do in the background") + (CL:FORMAT NIL "New ~@[~A ~]Mail for ~A~@[ (~{+~A~})~]" + [COND + ((NOT (OR (SETQ PRIMARYMODE (ASSOC \LAFITEMODE NEWMAILMODES)) + (LAFITE.ALL.MODES.P :GETMAIL))) + (* ; + "Make clear the mode we're talking about, since this is not the mode GetMail will retrieve in") + (fetch (LAFITEMODEDATA LAFITEMODE) of (CAR + NEWMAILMODES + ] + (fetch (LAFITEMODEDATA SHORTUSERNAME) + of (OR PRIMARYMODE (CAR NEWMAILMODES))) + (for MODE in NEWMAILMODES unless (EQ MODE PRIMARYMODE + ) + collect (fetch (LAFITEMODEDATA LAFITEMODE) + of MODE] + (SETQ \LAFITE.LAST.STATUS NEWMAILMODES) + (\LAFITE.NEW.MAIL.EXISTS))) + else (* ; + "Nobody reported new mail. Reason could be one of several") + (PRINTLAFITESTATUS (if NOTUPFLG + then (if NOMAILFLG + then + (* ; "Somebody responded") + 'SOME.UP + else 'NONE.UP) + elseif NOMAILFLG + then (* ; + "every server reports no new mail") + 'NO.MAIL + else (* ; "No server reported anything") + 'NO.MAILBOX] + (RETURN MINCONTINUANCE]) (\LAFITE.NEW.MAIL.EXISTS -(LAMBDA NIL (* ; "Edited 8-Jun-88 12:10 by bvm") (* ;; "Called when the Poll function has discovered new mail.") (COND (LAFITENEWMAILTUNE (PLAYTUNE LAFITENEWMAILTUNE))) (COND (LAFITENEWMAILFN (CL:FUNCALL LAFITENEWMAILFN)))) -) + [LAMBDA NIL (* ; "Edited 8-Jun-88 12:10 by bvm") + + (* ;; "Called when the Poll function has discovered new mail.") + + (COND + (LAFITENEWMAILTUNE (PLAYTUNE LAFITENEWMAILTUNE))) + (COND + (LAFITENEWMAILFN (CL:FUNCALL LAFITENEWMAILFN]) (PRINTLAFITESTATUS -(LAMBDA (STATUS) (* ; "Edited 13-Jun-88 11:16 by bvm") (PROG ((WINDOW (WINDOWP LAFITESTATUSWINDOW)) STR EXCESSWIDTH REG) (OR WINDOW (RETURN)) (SETQ STR (OR (STRINGP STATUS) (SELECTQ STATUS ((NO.MAILBOX NO.MAILSERVER NO.MODE MODE.NOT.SET) (COND ((EQ STATUS \LAFITE.LAST.STATUS) (* ; "No change to prompt") (RETURN)) (T (SELECTQ STATUS (NO.MAILBOX "No Accessible Mail Boxes") (NO.MODE "No Mail Handler Loaded") (MODE.NOT.SET "Mode Not Set") (CONCAT "Not Logged In: " \LAFITE.AUTHENTICATION.FAILURE))))) (LAFITE.STATUS.WITH.TIME (SELECTQ STATUS (NO.MAIL "No New Mail") (SOME.UP "Some Servers Unavailable") (NONE.UP "No Mail Servers Responding") (SHOULDNT)))))) (SETQ \LAFITE.LAST.STATUS NIL) (CLEARW WINDOW) (COND ((> (SETQ EXCESSWIDTH (- (ADD1 (STRINGWIDTH STR WINDOW)) (WINDOWPROP WINDOW (QUOTE WIDTH)))) 0) (SETQ REG (WINDOWREGION WINDOW)) (* ; "String wider than window, so widen window. The extra +1 is because it seems that printing a string exactly the width of the window still tries to wrap the last character.") (add (fetch WIDTH of REG) EXCESSWIDTH) (MAKEWITHINREGION REG) (RESHAPEALLWINDOWS WINDOW REG) (SETQ EXCESSWIDTH 0))) (MOVETO (IQUOTIENT (- EXCESSWIDTH) 2) (WINDOWPROP WINDOW (QUOTE YPOS)) WINDOW) (PRIN3 STR WINDOW) (SETQ \LAFITE.LAST.STATUS STATUS))) -) + [LAMBDA (STATUS) (* ; "Edited 13-Jun-88 11:16 by bvm") + (PROG ((WINDOW (WINDOWP LAFITESTATUSWINDOW)) + STR EXCESSWIDTH REG) + (OR WINDOW (RETURN)) + [SETQ STR (OR (STRINGP STATUS) + (SELECTQ STATUS + ((NO.MAILBOX NO.MAILSERVER NO.MODE MODE.NOT.SET) + [COND + ((EQ STATUS \LAFITE.LAST.STATUS) + (* ; "No change to prompt") + (RETURN)) + (T (SELECTQ STATUS + (NO.MAILBOX "No Accessible Mail Boxes") + (NO.MODE "No Mail Handler Loaded") + (MODE.NOT.SET "Mode Not Set") + (CONCAT "Not Logged In: " \LAFITE.AUTHENTICATION.FAILURE]) + (LAFITE.STATUS.WITH.TIME (SELECTQ STATUS + (NO.MAIL "No New Mail") + (SOME.UP "Some Servers Unavailable") + (NONE.UP "No Mail Servers Responding") + (SHOULDNT] + (SETQ \LAFITE.LAST.STATUS NIL) + (CLEARW WINDOW) + (COND + ((> [SETQ EXCESSWIDTH (- (ADD1 (STRINGWIDTH STR WINDOW)) + (WINDOWPROP WINDOW 'WIDTH] + 0) + (SETQ REG (WINDOWREGION WINDOW)) (* ; "String wider than window, so widen window. The extra +1 is because it seems that printing a string exactly the width of the window still tries to wrap the last character.") + (add (fetch WIDTH of REG) + EXCESSWIDTH) + (MAKEWITHINREGION REG) + (RESHAPEALLWINDOWS WINDOW REG) + (SETQ EXCESSWIDTH 0))) + (MOVETO (IQUOTIENT (- EXCESSWIDTH) + 2) + (WINDOWPROP WINDOW 'YPOS) + WINDOW) + (PRIN3 STR WINDOW) + (SETQ \LAFITE.LAST.STATUS STATUS]) (LAFITE.STATUS.WITH.TIME -(LAMBDA (STR) (* ; "Edited 9-May-88 15:41 by bvm") (* ; "Add current time to STR") (CONCAT STR " at " (DATE (DATEFORMAT NO.DATE NO.SECONDS CIVILIAN.TIME)))) -) + [LAMBDA (STR) (* ; "Edited 9-May-88 15:41 by bvm") + (* ; "Add current time to STR") + (CONCAT STR " at " (DATE (DATEFORMAT NO.DATE NO.SECONDS CIVILIAN.TIME]) (\LAFITE.REINITIALIZING -(LAMBDA (FIRSTTIME) (* ; "Edited 9-May-88 15:51 by bvm") (* ;; "This guy alters status to show we're (re)initializing") (PRINTLAFITESTATUS (LAFITE.STATUS.WITH.TIME (if FIRSTTIME then "Initializing" else "Reinitializing")))) -) + [LAMBDA (FIRSTTIME) (* ; "Edited 9-May-88 15:51 by bvm") + + (* ;; "This guy alters status to show we're (re)initializing") + + (PRINTLAFITESTATUS (LAFITE.STATUS.WITH.TIME (if FIRSTTIME + then "Initializing" + else "Reinitializing"]) ) @@ -172,170 +786,1098 @@ Copyright (c) 1984-1989, 1991-1993, 2021 by Xerox Corporation. (DEFINEQ (\LAFITE.PARSE.FOLDER -(LAMBDA (FOLDER) (* ; "Edited 1-May-89 14:35 by bvm") (LET* ((STREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE INPUT) :IGNORE)) (END (GETEOFPTR STREAM)) MESSAGES) (COND ((OR (EQ END 0) (SETQ MESSAGES (\LAFITE.PARSE.FOLDER1 FOLDER STREAM END 0 1))) (replace (MAILFOLDER %#OFMESSAGES) of FOLDER with (COND (MESSAGES (CAR MESSAGES)) (T 0))) (replace (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER with (AND MESSAGES (\LAFITE.ADDMESSAGES.TO.ARRAY NIL (CDR MESSAGES) 1 (CAR MESSAGES)))) (replace (MAILFOLDER TOCLASTMESSAGE#) of FOLDER with 0) (replace (MAILFOLDER BROWSERREADY) of FOLDER with T) FOLDER) (T (\LAFITE.CLOSE.FOLDER FOLDER T) NIL)))) -) + [LAMBDA (FOLDER) (* ; "Edited 1-May-89 14:35 by bvm") + (LET* ((STREAM (\LAFITE.OPEN.FOLDER FOLDER 'INPUT :IGNORE)) + (END (GETEOFPTR STREAM)) + MESSAGES) + (COND + ((OR (EQ END 0) + (SETQ MESSAGES (\LAFITE.PARSE.FOLDER1 FOLDER STREAM END 0 1))) + (replace (MAILFOLDER %#OFMESSAGES) of FOLDER with (COND + (MESSAGES (CAR + MESSAGES + )) + (T 0))) + [replace (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER + with (AND MESSAGES (\LAFITE.ADDMESSAGES.TO.ARRAY NIL (CDR MESSAGES) + 1 + (CAR MESSAGES] + (replace (MAILFOLDER TOCLASTMESSAGE#) of FOLDER with 0) + (replace (MAILFOLDER BROWSERREADY) of FOLDER with T) + FOLDER) + (T (\LAFITE.CLOSE.FOLDER FOLDER T) + NIL]) (\LAFITE.PARSE.FOLDER1 -(LAMBDA (FOLDER STREAM EOFPTR START FIRSTMSG# NOERROR) (* ; "Edited 1-May-89 15:48 by bvm") (DECLARE (SPECVARS FOLDER STREAM EOFPTR START HERE LASTMSG)) (* ; "Strictly for debugging") (* ;;; "Parse MAILFOLDER starting at byte START until end of file at EOFPTR. FIRSTMSG# is the ordinal to assign to the first message. Returns (lastmsg# . messagedescriptors), or NIL if there was any problem. If NOERROR is true, does not publicly complain about errors, but quietly returns NIL") (LAB.PROMPTPRINT FOLDER "Parsing " (COND ((EQ START 0) "folder") (T "additional msgs")) (QUOTE ...)) (LET* ((HERE START) (WINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER)) (XPOS (AND WINDOW (DSPXPOSITION NIL WINDOW))) MSGLENGTH STAMPCOUNT MARK SEEN DELETED LASTMSG MINHEADER DUPLICATES) (for MSG# from FIRSTMSG# while (< HERE EOFPTR) collect (SETFILEPTR STREAM HERE) (* ;; "the format of the stamp field of a laurel message is:") (* ;; "*start* ") (* ;; "U or D means Undeleted or Deleted; S or U means Seen or Unseen") (if (NOT (LA.READSTAMP STREAM)) then (* ; "Length of previous message must be wrong") (RETURN (if (> HERE START) then (BADMAILFILE FOLDER LASTMSG (SUB1 MSG#) "Message length is incorrect" NOERROR $$VAL) else (* ; "First message is wrong") (BADMAILFILE FOLDER LASTMSG MSG# "File does not appear to be in mail format" NOERROR $$VAL)))) (COND ((NOT (AND (SETQ MSGLENGTH (LA.READCOUNT STREAM)) (SETQ STAMPCOUNT (LA.READCOUNT STREAM)) (>= MSGLENGTH STAMPCOUNT) (PROGN (* ; "Read the 3 flag bytes") (SETQ DELETED (SELECTC (BIN STREAM) (UNDELETEDFLAG NIL) (DELETEDFLAG T) (BADMAILFILE.FLAGBYTE FOLDER MSG#))) (* ; "read the U for Undeleted") (SETQ SEEN (SELECTC (BIN STREAM) (UNSEENFLAG NIL) (SEENFLAG T) ((CHARCODE N) (* ; "For some reason, there are files with this for the Seen mark, so allow it") T) (BADMAILFILE.FLAGBYTE FOLDER MSG#))) (* ; "read the U for unseen") (SETQ MARK (BIN STREAM)) (* ; "read the mark char") (EQ (BIN STREAM) (CHARCODE CR))) (>= STAMPCOUNT (SETQ MINHEADER (- (GETFILEPTR STREAM) HERE))))) (* ; "Expected to see msglength headerlength DSM.") (RETURN (BADMAILFILE FOLDER LASTMSG MSG# "Header is malformed" NOERROR $$VAL)))) (PROG1 (SETQ LASTMSG (create LAFITEMSG %# _ MSG# BEGIN _ HERE MESSAGELENGTH _ MSGLENGTH MARKCHAR _ (OR (AND (NOT SEEN) UNSEENMARK) MARK) SEEN? _ SEEN DELETED? _ DELETED STAMPLENGTH _ STAMPCOUNT)) (if (AND (> STAMPCOUNT MINHEADER) (EQ (BIN STREAM) (CHARCODE *))) then (* ; "Duplicate junk?") (LET ((INFO (CL:READ-LINE STREAM))) (if (AND (STRPOS "duplicate*" INFO 1 NIL T) (FIXP (SETQ INFO (SUBATOM INFO 11)))) then (push DUPLICATES (LIST INFO LASTMSG))))) (LAFITE.PARSE.MSG.FOR.TOC LASTMSG FOLDER) (add HERE MSGLENGTH) (COND (XPOS (DSPXPOSITION XPOS WINDOW) (printout WINDOW .I1 MSG#)))) finally (COND (XPOS (* ; "Prepare to overwrite counter with 'done'") (DSPXPOSITION XPOS WINDOW))) (COND ((NOT (= HERE EOFPTR)) (LAB.FORMAT FOLDER T "Warning: last message truncated from ~D to ~D bytes. " (fetch (LAFITEMSG MESSAGELENGTH) of LASTMSG) (replace (LAFITEMSG MESSAGELENGTH) of LASTMSG with (- (fetch (LAFITEMSG MESSAGELENGTH) of LASTMSG) (- HERE EOFPTR)))) (replace (LAFITEMSG MESSAGELENGTHCHANGED?) of LASTMSG with (replace (LAFITEMSG MARKSCHANGED?) of LASTMSG with T)) (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with T))) (if DUPLICATES then (\LAFITE.HANDLE.DUPLICATES FOLDER STREAM DUPLICATES $$VAL)) (RETURN (CONS (fetch (LAFITEMSG %#) of LASTMSG) $$VAL))))) -) + [LAMBDA (FOLDER STREAM EOFPTR START FIRSTMSG# NOERROR) (* ; "Edited 1-May-89 15:48 by bvm") + (DECLARE (SPECVARS FOLDER STREAM EOFPTR START HERE LASTMSG)) + (* ; "Strictly for debugging") + +(* ;;; "Parse MAILFOLDER starting at byte START until end of file at EOFPTR. FIRSTMSG# is the ordinal to assign to the first message. Returns (lastmsg# . messagedescriptors), or NIL if there was any problem. If NOERROR is true, does not publicly complain about errors, but quietly returns NIL") + + (LAB.PROMPTPRINT FOLDER "Parsing " (COND + ((EQ START 0) + "folder") + (T "additional msgs")) + '|...|) + (LET* ((HERE START) + (WINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER)) + (XPOS (AND WINDOW (DSPXPOSITION NIL WINDOW))) + MSGLENGTH STAMPCOUNT MARK SEEN DELETED LASTMSG MINHEADER DUPLICATES) + (for MSG# from FIRSTMSG# while (< HERE EOFPTR) + collect (SETFILEPTR STREAM HERE) + + (* ;; "the format of the stamp field of a laurel message is:") + + (* ;; "*start* ") + + (* ;; "U or D means Undeleted or Deleted; S or U means Seen or Unseen") + + [if (NOT (LA.READSTAMP STREAM)) + then (* ; + "Length of previous message must be wrong") + (RETURN (if (> HERE START) + then (BADMAILFILE FOLDER LASTMSG (SUB1 MSG#) + "Message length is incorrect" NOERROR $$VAL) + else (* ; "First message is wrong") + (BADMAILFILE FOLDER LASTMSG MSG# + "File does not appear to be in mail format" + NOERROR $$VAL] + [COND + ([NOT (AND (SETQ MSGLENGTH (LA.READCOUNT STREAM)) + (SETQ STAMPCOUNT (LA.READCOUNT STREAM)) + (>= MSGLENGTH STAMPCOUNT) + (PROGN (* ; "Read the 3 flag bytes") + (SETQ DELETED (SELECTC (BIN STREAM) + (UNDELETEDFLAG NIL) + (DELETEDFLAG T) + (BADMAILFILE.FLAGBYTE FOLDER MSG#))) + (* ; "read the U for Undeleted") + (SETQ SEEN (SELECTC (BIN STREAM) + (UNSEENFLAG NIL) + (SEENFLAG T) + ((CHARCODE N) + (* ; + "For some reason, there are files with this for the Seen mark, so allow it") + T) + (BADMAILFILE.FLAGBYTE FOLDER MSG#))) + (* ; "read the U for unseen") + (SETQ MARK (BIN STREAM)) + (* ; "read the mark char") + (EQ (BIN STREAM) + (CHARCODE CR))) + (>= STAMPCOUNT (SETQ MINHEADER (- (GETFILEPTR STREAM) + HERE] + (* ; + "Expected to see msglength headerlength DSM.") + (RETURN (BADMAILFILE FOLDER LASTMSG MSG# "Header is malformed" NOERROR + $$VAL] + (PROG1 (SETQ LASTMSG + (create LAFITEMSG + %# _ MSG# + BEGIN _ HERE + MESSAGELENGTH _ MSGLENGTH + MARKCHAR _ (OR (AND (NOT SEEN) + UNSEENMARK) + MARK) + SEEN? _ SEEN + DELETED? _ DELETED + STAMPLENGTH _ STAMPCOUNT)) + [if (AND (> STAMPCOUNT MINHEADER) + (EQ (BIN STREAM) + (CHARCODE *))) + then (* ; "Duplicate junk?") + (LET ((INFO (CL:READ-LINE STREAM))) + (if [AND (STRPOS "duplicate*" INFO 1 NIL T) + (FIXP (SETQ INFO (SUBATOM INFO 11] + then (push DUPLICATES (LIST INFO LASTMSG] + (LAFITE.PARSE.MSG.FOR.TOC LASTMSG FOLDER) + (add HERE MSGLENGTH) + (COND + (XPOS (DSPXPOSITION XPOS WINDOW) + (printout WINDOW .I1 MSG#)))) + finally (COND + (XPOS (* ; + "Prepare to overwrite counter with 'done'") + (DSPXPOSITION XPOS WINDOW))) + (COND + ((NOT (= HERE EOFPTR)) + [LAB.FORMAT FOLDER T "Warning: last message truncated from ~D to ~D bytes. " + (fetch (LAFITEMSG MESSAGELENGTH) of LASTMSG) + (replace (LAFITEMSG MESSAGELENGTH) of LASTMSG + with (- (fetch (LAFITEMSG MESSAGELENGTH) of LASTMSG) + (- HERE EOFPTR] + (replace (LAFITEMSG MESSAGELENGTHCHANGED?) of LASTMSG + with (replace (LAFITEMSG MARKSCHANGED?) of LASTMSG with + T)) + (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with T))) + (if DUPLICATES + then (\LAFITE.HANDLE.DUPLICATES FOLDER STREAM DUPLICATES $$VAL)) + (RETURN (CONS (fetch (LAFITEMSG %#) of LASTMSG) + $$VAL]) (\LAFITE.HANDLE.DUPLICATES -(LAMBDA (FOLDER FOLDERSTREAM DUPLICATES MESSAGES) (* ; "Edited 2-May-89 12:02 by bvm") (SORT DUPLICATES T) (* ; "Sort by increasing file address") (PROG* ((NEXT (CAR DUPLICATES)) (NEXTMSG (CADR NEXT)) FOUND NOTFOUND SCRATCH OLDSTART) (for OLDMSG in MESSAGES do (while (>= (SETQ OLDSTART (fetch (LAFITEMSG BEGIN) of OLDMSG)) (CAR NEXT)) do (if (AND (= OLDSTART (CAR NEXT)) (\LAFITE.CHECK.DUPLICATE FOLDERSTREAM (OR SCRATCH (SETQ SCRATCH (OPENSTREAM "{nodircore}" (QUOTE BOTH)))) OLDSTART (fetch (LAFITEMSG STAMPLENGTH) of OLDMSG) (fetch (LAFITEMSG MESSAGELENGTH) of OLDMSG) (fetch (LAFITEMSG BEGIN) of NEXTMSG) (fetch (LAFITEMSG STAMPLENGTH) of NEXTMSG) (fetch (LAFITEMSG MESSAGELENGTH) of NEXTMSG))) then (push FOUND NEXTMSG) else (push NOTFOUND NEXTMSG)) (if (NULL (SETQ DUPLICATES (CDR DUPLICATES))) then (GO DONE) else (SETQ NEXTMSG (CADR (SETQ NEXT (CAR DUPLICATES))))))) DONE (if FOUND then (\LAFITE.REPORT.DUPLICATES FOLDER FOUND T)) (if NOTFOUND then (\LAFITE.REPORT.DUPLICATES FOLDER NOTFOUND) (for MSG in NOTFOUND when (fetch (LAFITEMSG DELETED?) of MSG) do (* ; "Undelete these guys, since they may not really be duplicates any more") (replace (LAFITEMSG DELETED?) of MSG with NIL) (replace (LAFITEMSG MARKSCHANGED?) of MSG with T) (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with T))))) -) + [LAMBDA (FOLDER FOLDERSTREAM DUPLICATES MESSAGES) (* ; "Edited 2-May-89 12:02 by bvm") + (SORT DUPLICATES T) (* ; "Sort by increasing file address") + (PROG* ((NEXT (CAR DUPLICATES)) + (NEXTMSG (CADR NEXT)) + FOUND NOTFOUND SCRATCH OLDSTART) + [for OLDMSG in MESSAGES + do (while (>= (SETQ OLDSTART (fetch (LAFITEMSG BEGIN) of OLDMSG)) + (CAR NEXT)) + do (if (AND (= OLDSTART (CAR NEXT)) + (\LAFITE.CHECK.DUPLICATE FOLDERSTREAM + [OR SCRATCH (SETQ SCRATCH (OPENSTREAM + "{nodircore}" + 'BOTH] + OLDSTART + (fetch (LAFITEMSG STAMPLENGTH) of OLDMSG) + (fetch (LAFITEMSG MESSAGELENGTH) of OLDMSG + ) + (fetch (LAFITEMSG BEGIN) of NEXTMSG) + (fetch (LAFITEMSG STAMPLENGTH) of NEXTMSG) + (fetch (LAFITEMSG MESSAGELENGTH) of + NEXTMSG + ))) + then (push FOUND NEXTMSG) + else (push NOTFOUND NEXTMSG)) + (if (NULL (SETQ DUPLICATES (CDR DUPLICATES))) + then (GO DONE) + else (SETQ NEXTMSG (CADR (SETQ NEXT (CAR DUPLICATES] + DONE + (if FOUND + then (\LAFITE.REPORT.DUPLICATES FOLDER FOUND T)) + (if NOTFOUND + then (\LAFITE.REPORT.DUPLICATES FOLDER NOTFOUND) + (for MSG in NOTFOUND when (fetch (LAFITEMSG DELETED?) + of MSG) + do (* ; + "Undelete these guys, since they may not really be duplicates any more") + (replace (LAFITEMSG DELETED?) of MSG with NIL) + (replace (LAFITEMSG MARKSCHANGED?) of MSG with T) + (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with + T]) (\LAFITE.CHECK.DUPLICATE -(LAMBDA (FOLDERSTREAM SCRATCH START1 STAMP1 LENGTH1 START2 STAMP2 LENGTH2) (* ; "Edited 2-May-89 11:58 by bvm") (* ;; "True if the messages in FOLDERSTREAM starting at START1 and START2 are identical, given their respective STAMP counts and LENGTHs. SCRATCH is a scratch stream to use for the comparison, since we can't have 2 file pointers in a stream at once.") (AND (= (- LENGTH1 STAMP1) (- LENGTH2 STAMP2)) (PROGN (SETFILEPTR SCRATCH 0) (COPYBYTES FOLDERSTREAM SCRATCH (+ START1 STAMP1) (+ START1 LENGTH1)) (SETFILEPTR SCRATCH 0) (SETFILEPTR FOLDERSTREAM (+ START2 STAMP2)) (to (- LENGTH1 STAMP1) always (EQ (BIN SCRATCH) (BIN FOLDERSTREAM)))))) -) + [LAMBDA (FOLDERSTREAM SCRATCH START1 STAMP1 LENGTH1 START2 STAMP2 LENGTH2) + (* ; "Edited 2-May-89 11:58 by bvm") + + (* ;; "True if the messages in FOLDERSTREAM starting at START1 and START2 are identical, given their respective STAMP counts and LENGTHs. SCRATCH is a scratch stream to use for the comparison, since we can't have 2 file pointers in a stream at once.") + + (AND (= (- LENGTH1 STAMP1) + (- LENGTH2 STAMP2)) + (PROGN (SETFILEPTR SCRATCH 0) + (COPYBYTES FOLDERSTREAM SCRATCH (+ START1 STAMP1) + (+ START1 LENGTH1)) + (SETFILEPTR SCRATCH 0) + (SETFILEPTR FOLDERSTREAM (+ START2 STAMP2)) + (to (- LENGTH1 STAMP1) always (EQ (BIN SCRATCH) + (BIN FOLDERSTREAM]) (\LAFITE.REPORT.DUPLICATES -(LAMBDA (FOLDER MESSAGES FOUNDP) (* ; "Edited 1-May-89 15:52 by bvm") (* ;; "Return a string naming the messages in list NUMBERS, e.g., %"Messages 23-39%"") (LET ((DESCR (if (NULL (CDR MESSAGES)) then (CL:FORMAT NIL "Message ~D" (fetch (LAFITEMSG %#) of (CAR MESSAGES))) else (LET ((NUMBERS (for MSG in MESSAGES collect (fetch (LAFITEMSG %#) of MSG)))) (if (for F in (CDR (SORT NUMBERS)) as I from (ADD1 (CAR NUMBERS)) always (EQ F I)) then (* ; "Consecutive") (CL:FORMAT NIL "Messages ~D-~D" (CAR NUMBERS) (CAR (LAST NUMBERS))) else (* ; "Disconnected") (CONCATLIST (CONS "Messages " (CDR (for F in NUMBERS join (LIST ", " F))))))))) (ISARE (if (CDR MESSAGES) then "are" else "is"))) (LAB.FORMAT FOLDER (if FOUNDP then "~A are duplicates left over from an aborted Expunge." else "~A appear to be duplicates from an aborted Expunge, but the corresponding original messages were not found") DESCR))) -) + [LAMBDA (FOLDER MESSAGES FOUNDP) (* ; "Edited 1-May-89 15:52 by bvm") + + (* ;; "Return a string naming the messages in list NUMBERS, e.g., %"Messages 23-39%"") + + (LET ([DESCR (if (NULL (CDR MESSAGES)) + then (CL:FORMAT NIL "Message ~D" (fetch (LAFITEMSG %#) + of (CAR MESSAGES))) + else (LET [(NUMBERS (for MSG in MESSAGES + collect (fetch (LAFITEMSG %#) of MSG] + (if (for F in (CDR (SORT NUMBERS)) as I + from (ADD1 (CAR NUMBERS)) + always (EQ F I)) + then (* ; "Consecutive") + (CL:FORMAT NIL "Messages ~D-~D" (CAR NUMBERS) + (CAR (LAST NUMBERS))) + else (* ; "Disconnected") + (CONCATLIST (CONS "Messages " + (CDR (for F in NUMBERS + join (LIST ", " F] + (ISARE (if (CDR MESSAGES) + then "are" + else "is"))) + (LAB.FORMAT FOLDER (if FOUNDP + then "~A are duplicates left over from an aborted Expunge." + else "~A appear to be duplicates from an aborted Expunge, but the corresponding original messages were not found" + ) + DESCR]) (BADMAILFILE -(LAMBDA (FOLDER LASTMSG MSG# ERRSTR NOERROR MSGSOFAR) (* ; "Edited 1-May-89 14:32 by bvm") (COND ((OR (NOT NOERROR) LAFITEDEBUGFLG) (LET* ((BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (LASTLENGTHWRONG) (GOODPTR (AND LASTMSG (if (EQ MSG# (fetch (LAFITEMSG %#) of LASTMSG)) then (* ; "File only good up to previous message") (SETQ LASTLENGTHWRONG T) (fetch (LAFITEMSG BEGIN) of LASTMSG) else (* ; "Have a *start* here but header garbled") (fetch (LAFITEMSG END) of LASTMSG))))) (CLEARW BROWSERWINDOW) (DSPRIGHTMARGIN (fetch (REGION RIGHT) of (DSPCLIPPINGREGION NIL BROWSERWINDOW)) BROWSERWINDOW) (* ; "In case it had been big from earlier") (LINELENGTH T BROWSERWINDOW) (CL:FORMAT BROWSERWINDOW "Cannot parse file ~A ~%% at message ~D~@[, byte ~D~] because ~A~%%" (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER) MSG# GOODPTR ERRSTR) (COND (LASTMSG (printout BROWSERWINDOW T (if LASTLENGTHWRONG then "M" else "Last m") "essage was:" T "Date: " (fetch (LAFITEMSG DATE) of LASTMSG) T "From: " (fetch (LAFITEMSG FROM) of LASTMSG) T "Subject: " (fetch (LAFITEMSG SUBJECT) of LASTMSG)))) (COND (NOERROR (* ; "Only here for debugging intervention") (HELP "Mail file parsing error" ERRSTR) NIL) (T (* ; "Disable browser and prepare for scavenge") (LAB.PROMPTPRINT FOLDER " Failed.") (LET* ((MENUW (fetch (MAILFOLDER BROWSERMENUWINDOW) of FOLDER)) (ITEMS (QUOTE (("Scavenge Folder" T "Attempt to repair the folder by scanning for message boundaries") ("Just Close" NIL "Abort: Close this browser")))) (SCAVMENU (create MENU ITEMS _ ITEMS MENUFONT _ LAFITEMENUFONT CENTERFLG _ T MENUROWS _ 1 ITEMWIDTH _ (MAX (IQUOTIENT (WINDOWPROP BROWSERWINDOW (QUOTE WIDTH)) 2) (STRINGWIDTH (CAAR ITEMS) LAFITEMENUFONT)) WHENSELECTEDFN _ (FUNCTION (LAMBDA (ITEM MENU BUTTON) (LET ((WINDOW (MAINWINDOW (WFROMMENU MENU)))) (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE) (if (CADR ITEM) then (* ; "Do scavenge") (WINDOWPROP WINDOW (QUOTE DO-SCAVENGE) T) (WAKE.PROCESS (WINDOWPROP WINDOW (QUOTE PROCESS))) else (CLOSEW WINDOW))))) MENUBORDERSIZE _ 0 MENUOUTLINESIZE _ 0))) (DELETEMENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER) NIL MENUW) (* ; "Get rid of menu to avoid temptation") (replace (MAILFOLDER BROWSERSTATUS) of FOLDER with LAS.OUT.OF.DATE) (WINDOWPROP BROWSERWINDOW (QUOTE PROCESS) (THIS.PROCESS)) (WINDOWDELPROP BROWSERWINDOW (QUOTE CLOSEFN) (FUNCTION LAB.CLOSEFN)) (WINDOWDELPROP BROWSERWINDOW (QUOTE SHRINKFN) (FUNCTION LAB.SHRINKFN)) (WINDOWADDPROP BROWSERWINDOW (QUOTE CLOSEFN) (FUNCTION BADMAILFILE.CLOSEFN)) (PRINTOUT BROWSERWINDOW T T "Select 'Scavenge' to attempt repair.") (CL:UNWIND-PROTECT (PROGN (ADDMENU SCAVMENU MENUW (QUOTE (0 . 0))) (until (WINDOWPROP BROWSERWINDOW (QUOTE DO-SCAVENGE)) do (BLOCK 60000))) (WINDOWPROP BROWSERWINDOW (QUOTE PROCESS) NIL) (WINDOWDELPROP BROWSERWINDOW (QUOTE CLOSEFN) (FUNCTION BADMAILFILE.CLOSEFN)) (if (NOT (WINDOWPROP BROWSERWINDOW (QUOTE DO-SCAVENGE))) then (* ; "Getting rid of browser") (\LAFITE.FINISH.UPDATE BROWSERWINDOW FOLDER :EXIT))) (if (AND (WINDOWPROP BROWSERWINDOW (QUOTE DO-SCAVENGE) NIL) (PROGN (* ; "Run the scavenger") (DELETEMENU SCAVMENU NIL MENUW) (replace (MAILFOLDER BROWSERSTATUS) of FOLDER with LAS.PARSING) (WINDOWADDPROP BROWSERWINDOW (QUOTE CLOSEFN) (FUNCTION LAB.CLOSEFN) T) (WINDOWADDPROP BROWSERWINDOW (QUOTE SHRINKFN) (FUNCTION LAB.SHRINKFN) T) (\MAILSCAVENGE.INTERNAL FOLDER NIL GOODPTR MSG#))) then (* ; "Scavenge succeeded. Put browser back together") (ADDMENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER) MENUW (QUOTE (0 . 0))) (LET* ((NEWSTREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE INPUT) :IGNORE)) (NEWPARSE (\LAFITE.PARSE.FOLDER1 FOLDER NEWSTREAM (GETEOFPTR NEWSTREAM) (OR GOODPTR 0) MSG# T))) (if NEWPARSE then (* ; "Return (last# . msgs)") (CONS (CAR NEWPARSE) (NCONC (if LASTLENGTHWRONG then (* ; "Throw away the last message") (CL:NBUTLAST MSGSOFAR) else MSGSOFAR) (CDR NEWPARSE))))) else (LAB.PROMPTPRINT FOLDER " Aborted."))))))))) -) + [LAMBDA (FOLDER LASTMSG MSG# ERRSTR NOERROR MSGSOFAR) (* ; "Edited 1-May-89 14:32 by bvm") + (COND + ((OR (NOT NOERROR) + LAFITEDEBUGFLG) + (LET* + [(BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) + (LASTLENGTHWRONG) + (GOODPTR (AND LASTMSG (if (EQ MSG# (fetch (LAFITEMSG %#) of LASTMSG)) + then (* ; + "File only good up to previous message") + (SETQ LASTLENGTHWRONG T) + (fetch (LAFITEMSG BEGIN) of LASTMSG) + else (* ; + "Have a *start* here but header garbled") + (fetch (LAFITEMSG END) of LASTMSG] + (CLEARW BROWSERWINDOW) + (DSPRIGHTMARGIN (fetch (REGION RIGHT) of (DSPCLIPPINGREGION NIL BROWSERWINDOW)) + BROWSERWINDOW) (* ; + "In case it had been big from earlier") + (LINELENGTH T BROWSERWINDOW) + (CL:FORMAT BROWSERWINDOW + "Cannot parse file ~A ~%% at message ~D~@[, byte ~D~] because ~A~%%" + (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER) + MSG# GOODPTR ERRSTR) + [COND + (LASTMSG (printout BROWSERWINDOW T (if LASTLENGTHWRONG + then "M" + else "Last m") + "essage was:" T "Date: " (fetch (LAFITEMSG DATE) of LASTMSG) + T "From: " (fetch (LAFITEMSG FROM) of LASTMSG) + T "Subject: " (fetch (LAFITEMSG SUBJECT) of LASTMSG] + (COND + (NOERROR (* ; + "Only here for debugging intervention") + (HELP "Mail file parsing error" ERRSTR) + NIL) + (T (* ; + "Disable browser and prepare for scavenge") + (LAB.PROMPTPRINT FOLDER " Failed.") + (LET* ((MENUW (fetch (MAILFOLDER BROWSERMENUWINDOW) of FOLDER)) + [ITEMS '(("Scavenge Folder" T + "Attempt to repair the folder by scanning for message boundaries" + ) + ("Just Close" NIL "Abort: Close this browser"] + (SCAVMENU (create MENU + ITEMS _ ITEMS + MENUFONT _ LAFITEMENUFONT + CENTERFLG _ T + MENUROWS _ 1 + ITEMWIDTH _ (MAX (IQUOTIENT (WINDOWPROP BROWSERWINDOW + 'WIDTH) + 2) + (STRINGWIDTH (CAAR ITEMS) + LAFITEMENUFONT)) + WHENSELECTEDFN _ + [FUNCTION (LAMBDA (ITEM MENU BUTTON) + (LET [(WINDOW (MAINWINDOW (WFROMMENU MENU] + (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE) + (if (CADR ITEM) + then + (* ; "Do scavenge") + (WINDOWPROP WINDOW 'DO-SCAVENGE T) + (WAKE.PROCESS (WINDOWPROP + WINDOW + 'PROCESS)) + else (CLOSEW WINDOW] + MENUBORDERSIZE _ 0 + MENUOUTLINESIZE _ 0))) + (DELETEMENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER) + NIL MENUW) (* ; + "Get rid of menu to avoid temptation") + (replace (MAILFOLDER BROWSERSTATUS) of FOLDER with LAS.OUT.OF.DATE) + (WINDOWPROP BROWSERWINDOW 'PROCESS (THIS.PROCESS)) + (WINDOWDELPROP BROWSERWINDOW 'CLOSEFN (FUNCTION LAB.CLOSEFN)) + (WINDOWDELPROP BROWSERWINDOW 'SHRINKFN (FUNCTION LAB.SHRINKFN)) + (WINDOWADDPROP BROWSERWINDOW 'CLOSEFN (FUNCTION BADMAILFILE.CLOSEFN)) + (PRINTOUT BROWSERWINDOW T T "Select 'Scavenge' to attempt repair.") + (CL:UNWIND-PROTECT + (PROGN (ADDMENU SCAVMENU MENUW '(0 . 0)) + (until (WINDOWPROP BROWSERWINDOW 'DO-SCAVENGE) + do (BLOCK 60000))) + (WINDOWPROP BROWSERWINDOW 'PROCESS NIL) + (WINDOWDELPROP BROWSERWINDOW 'CLOSEFN (FUNCTION BADMAILFILE.CLOSEFN)) + (if (NOT (WINDOWPROP BROWSERWINDOW 'DO-SCAVENGE)) + then (* ; "Getting rid of browser") + (\LAFITE.FINISH.UPDATE BROWSERWINDOW FOLDER :EXIT))) + (if (AND (WINDOWPROP BROWSERWINDOW 'DO-SCAVENGE NIL) + (PROGN (* ; "Run the scavenger") + (DELETEMENU SCAVMENU NIL MENUW) + (replace (MAILFOLDER BROWSERSTATUS) of FOLDER + with LAS.PARSING) + (WINDOWADDPROP BROWSERWINDOW 'CLOSEFN (FUNCTION LAB.CLOSEFN) + T) + (WINDOWADDPROP BROWSERWINDOW 'SHRINKFN + (FUNCTION LAB.SHRINKFN) + T) + (\MAILSCAVENGE.INTERNAL FOLDER NIL GOODPTR MSG#))) + then (* ; + "Scavenge succeeded. Put browser back together") + (ADDMENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER) + MENUW + '(0 . 0)) + [LET* ((NEWSTREAM (\LAFITE.OPEN.FOLDER FOLDER 'INPUT :IGNORE)) + (NEWPARSE (\LAFITE.PARSE.FOLDER1 FOLDER NEWSTREAM + (GETEOFPTR NEWSTREAM) + (OR GOODPTR 0) + MSG# T))) + (if NEWPARSE + then (* ; "Return (last# . msgs)") + (CONS (CAR NEWPARSE) + (NCONC (if LASTLENGTHWRONG + then + (* ; "Throw away the last message") + (CL:NBUTLAST MSGSOFAR) + else MSGSOFAR) + (CDR NEWPARSE] + else (LAB.PROMPTPRINT FOLDER " Aborted."]) (BADMAILFILE.CLOSEFN -(LAMBDA (WINDOW) (* ; "Edited 3-May-89 19:16 by bvm") (* ;; "If user closes browser instead of selecting %"scavenge%" or %"close%", blow away the process waiting to scavenge") (PROCESS.EVAL (WINDOWPROP WINDOW (QUOTE PROCESS)) (QUOTE (ERROR!)))) -) + [LAMBDA (WINDOW) (* ; "Edited 3-May-89 19:16 by bvm") + + (* ;; "If user closes browser instead of selecting %"scavenge%" or %"close%", blow away the process waiting to scavenge") + + (PROCESS.EVAL (WINDOWPROP WINDOW 'PROCESS) + '(ERROR!]) (BADMAILFILE.FLAGBYTE -(LAMBDA (MAILFOLDER MSG#) (* bvm%: "24-Feb-86 12:08") (LAB.PROMPTPRINT MAILFOLDER " [at msg " MSG# ": bad flag byte] ") NIL) -) + [LAMBDA (MAILFOLDER MSG#) (* bvm%: "24-Feb-86 12:08") + (LAB.PROMPTPRINT MAILFOLDER " [at msg " MSG# ": bad flag byte] ") + NIL]) (VERIFYMAILFOLDER -(LAMBDA (MAILFOLDER) (* ; "Edited 23-Aug-88 15:47 by bvm") (DECLARE (SPECVARS MSG# MSG HERE CHCOUNT)) (COND ((NOT (type? MAILFOLDER MAILFOLDER)) (SETQ MAILFOLDER (\DTEST (COND ((WINDOWP MAILFOLDER) (WINDOWPROP MAILFOLDER (QUOTE MAILFOLDER))) ((OR (LITATOM MAILFOLDER) (STRINGP MAILFOLDER)) (LAFITE.OBTAIN.FOLDER MAILFOLDER (QUOTE INPUT)))) (QUOTE MAILFOLDER))))) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (PROG (STREAM END) (SETQ STREAM (\LAFITE.OPEN.FOLDER MAILFOLDER (QUOTE INPUT) :OK)) (COND ((NOT (= (SETQ END (GETEOFPTR STREAM)) (fetch (MAILFOLDER FOLDEREOFPTR) of MAILFOLDER))) (HELP "Length of file does not match Folder's idea of length" (LIST END)))) (bind CHCOUNT STAMPCOUNT MARK MSG (HERE _ 0) (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) (LASTMSG# _ (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) for MSG# from 1 while (< HERE END) do (SETFILEPTR STREAM HERE) (COND ((> MSG# LASTMSG#) (RETURN (VERIFYFAILED MSG# "More messages in file than in core")))) (SETQ MSG (NTHMESSAGE MESSAGES MSG#)) (* ;; "the format of the stamp field of a laurel message is:") (* ;; "*start* ") (* ;; "U or D means Undeleted or Deleted; S or U means Seen or Unseen") (COND ((NOT (= (fetch (LAFITEMSG BEGIN) of MSG) HERE)) (VERIFYFAILED MSG# "Message beginning pointer wrong")) ((NOT (LA.READSTAMP STREAM)) (VERIFYFAILED MSG# "Bad Stamp")) ((OR (NOT (SETQ CHCOUNT (LA.READCOUNT STREAM))) (NOT (= CHCOUNT (fetch (LAFITEMSG MESSAGELENGTH) of MSG)))) (VERIFYFAILED MSG# "Bad Message Length")) ((OR (NOT (SETQ STAMPCOUNT (LA.READCOUNT STREAM))) (NOT (= STAMPCOUNT (fetch (LAFITEMSG STAMPLENGTH) of MSG)))) (VERIFYFAILED MSG# "Bad Message Length")) ((fetch (LAFITEMSG MARKSCHANGED?) of MSG)) ((NOT (EQ (SELECTC (BIN STREAM) (UNDELETEDFLAG NIL) (DELETEDFLAG T) (QUOTE ?)) (fetch (LAFITEMSG DELETED?) of MSG))) (VERIFYFAILED MSG# "Disagreement in delete mark")) ((NOT (EQ (SELECTC (BIN STREAM) (UNSEENFLAG NIL) (SEENFLAG T) (QUOTE ?)) (fetch (LAFITEMSG SEEN?) of MSG))) (* ; "Figure out how to handle seen from me") (VERIFYFAILED MSG# "Disagreement in seen mark")) ((NOT (OR (EQ (SETQ MARK (BIN STREAM)) (fetch (LAFITEMSG MARKCHAR) of MSG)) (NOT (fetch (LAFITEMSG SEEN?) of MSG)))) (VERIFYFAILED MSG# "Disagreement in mark byte"))) (add HERE CHCOUNT) finally (COND ((NOT (= HERE END)) (VERIFYFAILED MSG# "Last message too short")))) (RETURN T)))) -) + [LAMBDA (MAILFOLDER) (* ; "Edited 23-Aug-88 15:47 by bvm") + (DECLARE (SPECVARS MSG# MSG HERE CHCOUNT)) + [COND + ((NOT (type? MAILFOLDER MAILFOLDER)) + (SETQ MAILFOLDER (\DTEST [COND + ((WINDOWP MAILFOLDER) + (WINDOWPROP MAILFOLDER 'MAILFOLDER)) + ((OR (LITATOM MAILFOLDER) + (STRINGP MAILFOLDER)) + (LAFITE.OBTAIN.FOLDER MAILFOLDER 'INPUT] + 'MAILFOLDER] + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + (PROG (STREAM END) + (SETQ STREAM (\LAFITE.OPEN.FOLDER MAILFOLDER 'INPUT :OK)) + [COND + ((NOT (= (SETQ END (GETEOFPTR STREAM)) + (fetch (MAILFOLDER FOLDEREOFPTR) of MAILFOLDER))) + (HELP "Length of file does not match Folder's idea of length" (LIST END] + [bind CHCOUNT STAMPCOUNT MARK MSG (HERE _ 0) + (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) + (LASTMSG# _ (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) + for MSG# from 1 while (< HERE END) + do (SETFILEPTR STREAM HERE) + [COND + ((> MSG# LASTMSG#) + (RETURN (VERIFYFAILED MSG# "More messages in file than in core"] + (SETQ MSG (NTHMESSAGE MESSAGES MSG#)) + + (* ;; "the format of the stamp field of a laurel message is:") + + (* ;; "*start* ") + + (* ;; "U or D means Undeleted or Deleted; S or U means Seen or Unseen") + + (COND + ((NOT (= (fetch (LAFITEMSG BEGIN) of MSG) + HERE)) + (VERIFYFAILED MSG# "Message beginning pointer wrong")) + ((NOT (LA.READSTAMP STREAM)) + (VERIFYFAILED MSG# "Bad Stamp")) + ([OR (NOT (SETQ CHCOUNT (LA.READCOUNT STREAM))) + (NOT (= CHCOUNT (fetch (LAFITEMSG MESSAGELENGTH) of MSG] + (VERIFYFAILED MSG# "Bad Message Length")) + ([OR (NOT (SETQ STAMPCOUNT (LA.READCOUNT STREAM))) + (NOT (= STAMPCOUNT (fetch (LAFITEMSG STAMPLENGTH) of MSG] + (VERIFYFAILED MSG# "Bad Message Length")) + ((fetch (LAFITEMSG MARKSCHANGED?) of MSG)) + ((NOT (EQ (SELECTC (BIN STREAM) + (UNDELETEDFLAG NIL) + (DELETEDFLAG T) + '?) + (fetch (LAFITEMSG DELETED?) of MSG))) + (VERIFYFAILED MSG# "Disagreement in delete mark")) + ((NOT (EQ (SELECTC (BIN STREAM) + (UNSEENFLAG NIL) + (SEENFLAG T) + '?) + (fetch (LAFITEMSG SEEN?) of MSG))) + (* ; + "Figure out how to handle seen from me") + (VERIFYFAILED MSG# "Disagreement in seen mark")) + ([NOT (OR (EQ (SETQ MARK (BIN STREAM)) + (fetch (LAFITEMSG MARKCHAR) of MSG)) + (NOT (fetch (LAFITEMSG SEEN?) of MSG] + (VERIFYFAILED MSG# "Disagreement in mark byte"))) + (add HERE CHCOUNT) finally (COND + ((NOT (= HERE END)) + (VERIFYFAILED MSG# + "Last message too short"] + (RETURN T)))]) (VERIFYFAILED -(LAMBDA (MSG# ERRMSG) (* ; "Edited 6-May-88 15:47 by bvm") (HELP (CONCAT "Error in message " MSG# ": ") ERRMSG)) -) + [LAMBDA (MSG# ERRMSG) (* ; "Edited 6-May-88 15:47 by bvm") + (HELP (CONCAT "Error in message " MSG# ": ") + ERRMSG]) (\LAFITE.READ.TOC.FILE -(LAMBDA (FOLDER TOCFILE) (* ; "Edited 2-Nov-89 15:58 by bvm") (DECLARE (SPECVARS FOLDER)) (* ; "For \lafite.toceof") (* ;;; "Read table of contents file for FOLDER") (* ;;; "Header of toc file: ") (* ;;; "Body of toc file: one entry per message, of the form: ") (* ;; "Version history:") (* ;; "(8) Flags = 3 bits: parsed, deleted, seen. Date = 6 ascii bytes. Flag & Mark after stamplength.") (* ;; "(9) Flags = entire flag byte.") (* ;; "(10) Flag & Mark moved to front. Date conditional on flags: {If datefetched, then 4 bytes of idate} + {if ~dateknown, then 6 ascii bytes}. Also, msglength can be > 24 bits, in which case it is encoded as <255><4 bytes>. Not an incompatibility with older versions, since greatest msglength back then was 99999.") (LET ((TOCSTREAM (IGNORE-ERRORS (\LAFITE.OPENSTREAM (TOCFILENAME FOLDER) (QUOTE INPUT) (QUOTE OLD) (FUNCTION \LAFITE.TOCEOF))))) (if TOCSTREAM then (CL:UNWIND-PROTECT (PROG ((MSGCOUNTGUESS 0) FOLDERSTREAM FOLDEREOFPTR END MESSAGES EXTRAMESSAGES LASTMSG# READMORE TOCVERSION PASSWORD) (LAB.PROMPTPRINT FOLDER "Reading table of contents...") (if (NEQ (SETQ PASSWORD (WORDIN TOCSTREAM)) LAFITETOCPASSWORD) then (RETURN (BADTOCFILE FOLDER TOCSTREAM (if (EQ PASSWORD (LOGXOR 65535 LAFITETOCPASSWORD)) then (* ; "Caught during an Expunge") "inconsistent" else "bad format"))) elseif (< (SETQ TOCVERSION (WORDIN TOCSTREAM)) LAFITEVERSION#) then (if (AND TOCVERSION (>= TOCVERSION 8)) then (* ; "A slightly different format, still readable") (LAB.PROMPTPRINT FOLDER "(older format)") else (RETURN (BADTOCFILE FOLDER TOCSTREAM "obsolete format"))) elseif (> TOCVERSION LAFITEVERSION#) then (* ; "New format, can't read") (RETURN (BADTOCFILE FOLDER TOCSTREAM "newer format"))) (SETQ FOLDERSTREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE INPUT) :IGNORE)) (if (NOT (= (SETQ END (FIXPIN TOCSTREAM)) (SETQ FOLDEREOFPTR (GETEOFPTR FOLDERSTREAM)))) then (* ; "Maybe new messages have been added to file") (SETFILEPTR FOLDERSTREAM END) (if (NOT (LA.READSTAMP FOLDERSTREAM)) then (RETURN (BADTOCFILE FOLDER TOCSTREAM "inconsistent with mail folder")) else (SETQ READMORE T) (SETQ MSGCOUNTGUESS (IQUOTIENT (- FOLDEREOFPTR END) 500)))) (add MSGCOUNTGUESS (SETQ LASTMSG# (WORDIN TOCSTREAM))) (SETQ MESSAGES (\LAFITE.MAKE.MSGARRAY MSGCOUNTGUESS)) (for I from 1 to LASTMSG# bind MSG LENGTH (START _ (GETFILEPTR TOCSTREAM)) (MESSAGESTART _ 0) do (SETQ MSG (create LAFITEMSG %# _ I BEGIN _ MESSAGESTART)) (if (>= TOCVERSION 10) then (* ; "These bytes are up front to make it easier to find them for update") (replace (LAFITEMSG MSGFLAGBITS) of MSG with (BIN TOCSTREAM)) (replace (LAFITEMSG MARKCHAR) of MSG with (BIN TOCSTREAM))) (* ;; "Message length is 3 bytes long because it can be greater than MAX.SMALLP, though uncommon. In fact, we even permit it to be greater than 24 bits, though that is exceedingly unlikely.") (replace (LAFITEMSG MESSAGELENGTH) of MSG with (SETQ LENGTH (if (EQ (SETQ LENGTH (BIN TOCSTREAM)) 0) then (* ; "Normal 16-bit length") (WORDIN TOCSTREAM) else (\MAKENUMBER (if (EQ LENGTH 255) then (* ; "Very long length") (WORDIN TOCSTREAM) else LENGTH) (WORDIN TOCSTREAM))))) (add MESSAGESTART LENGTH) (replace (LAFITEMSG STAMPLENGTH) of MSG with (BIN TOCSTREAM)) (if (< TOCVERSION 10) then (* ; "Flags and mark stuck in the middle here") (if (EQ TOCVERSION 8) then (replace (LAFITEMSG PARSED&DELETED&SEENBITS) of MSG with (BIN TOCSTREAM)) else (replace (LAFITEMSG MSGFLAGBITS) of MSG with (BIN TOCSTREAM))) (replace (LAFITEMSG MARKCHAR) of MSG with (BIN TOCSTREAM)) (* ; "Clear datebits, since we once used a %"formatted%" bit in this area") (replace (LAFITEMSG DATEBITS) of MSG with 0) elseif (fetch (LAFITEMSG DATEFETCHED?) of MSG) then (* ; "Read 4 bytes of idate") (\BINS TOCSTREAM MSG (UNFOLD (INDEXF (FETCH (LAFITEMSG IDATE))) BYTESPERWORD) 4)) (if (NOT (fetch (LAFITEMSG DATEKNOWN?) of MSG)) then (* ; "Read 6 bytes of ascii string") (replace (LAFITEMSG DATE) of MSG with (LA.READSTRING TOCSTREAM 6))) (replace (LAFITEMSG SUBJECT) of MSG with (LA.READSHORTSTRING TOCSTREAM)) (replace (LAFITEMSG FROM) of MSG with (LA.READSHORTSTRING TOCSTREAM)) (replace (LAFITEMSG TO) of MSG with (LA.READSHORTSTRING TOCSTREAM)) (replace (LAFITEMSG TOCLENGTH) of MSG with (- (- START (SETQ START (GETFILEPTR TOCSTREAM))))) (SETA MESSAGES I MSG)) (replace (MAILFOLDER TOCLASTMESSAGE#) of FOLDER with (if (EQ TOCVERSION LAFITEVERSION#) then LASTMSG# else (* ; "Will have to rewrite toc next time") 0)) (if READMORE then (* ; "Parse new messages") (if (SETQ EXTRAMESSAGES (\LAFITE.PARSE.FOLDER1 FOLDER FOLDERSTREAM FOLDEREOFPTR END (ADD1 LASTMSG#) T)) then (SETQ MESSAGES (\LAFITE.ADDMESSAGES.TO.ARRAY MESSAGES (CDR EXTRAMESSAGES) (ADD1 LASTMSG#) (SETQ LASTMSG# (CAR EXTRAMESSAGES)))) else (RETURN (BADTOCFILE FOLDER TOCSTREAM "Couldn't parse new messages, have to start from scratch..." T)))) (replace (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER with MESSAGES) (replace (MAILFOLDER %#OFMESSAGES) of FOLDER with LASTMSG#) (replace (MAILFOLDER FOLDEREOFPTR) of FOLDER with FOLDEREOFPTR) (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with NIL) (replace (MAILFOLDER BROWSERREADY) of FOLDER with T) (RETURN T)) (* ;; "Cleanups...") (CLOSEF? TOCSTREAM))))) -) + [LAMBDA (FOLDER TOCFILE) (* ; "Edited 2-Nov-89 15:58 by bvm") + (DECLARE (SPECVARS FOLDER)) (* ; "For \lafite.toceof") + +(* ;;; "Read table of contents file for FOLDER") + +(* ;;; "Header of toc file: ") + +(* ;;; "Body of toc file: one entry per message, of the form: ") + + (* ;; "Version history:") + + (* ;; +"(8) Flags = 3 bits: parsed, deleted, seen. Date = 6 ascii bytes. Flag & Mark after stamplength.") + + (* ;; "(9) Flags = entire flag byte.") + + (* ;; "(10) Flag & Mark moved to front. Date conditional on flags: {If datefetched, then 4 bytes of idate} + {if ~dateknown, then 6 ascii bytes}. Also, msglength can be > 24 bits, in which case it is encoded as <255><4 bytes>. Not an incompatibility with older versions, since greatest msglength back then was 99999.") + + (LET + [(TOCSTREAM (IGNORE-ERRORS (\LAFITE.OPENSTREAM (TOCFILENAME FOLDER) + 'INPUT + 'OLD + (FUNCTION \LAFITE.TOCEOF] + (if TOCSTREAM + then (CL:UNWIND-PROTECT + (PROG ((MSGCOUNTGUESS 0) + FOLDERSTREAM FOLDEREOFPTR END MESSAGES EXTRAMESSAGES LASTMSG# READMORE + TOCVERSION PASSWORD) + (LAB.PROMPTPRINT FOLDER "Reading table of contents...") + (if (NEQ (SETQ PASSWORD (WORDIN TOCSTREAM)) + LAFITETOCPASSWORD) + then (RETURN (BADTOCFILE FOLDER TOCSTREAM + (if (EQ PASSWORD (LOGXOR 65535 + LAFITETOCPASSWORD + )) + then + (* ; "Caught during an Expunge") + "inconsistent" + else "bad format"))) + elseif (< (SETQ TOCVERSION (WORDIN TOCSTREAM)) + LAFITEVERSION#) + then (if (AND TOCVERSION (>= TOCVERSION 8)) + then (* ; + "A slightly different format, still readable") + (LAB.PROMPTPRINT FOLDER "(older format)") + else (RETURN (BADTOCFILE FOLDER TOCSTREAM + "obsolete format"))) + elseif (> TOCVERSION LAFITEVERSION#) + then (* ; "New format, can't read") + (RETURN (BADTOCFILE FOLDER TOCSTREAM "newer format"))) + (SETQ FOLDERSTREAM (\LAFITE.OPEN.FOLDER FOLDER 'INPUT :IGNORE)) + [if [NOT (= (SETQ END (FIXPIN TOCSTREAM)) + (SETQ FOLDEREOFPTR (GETEOFPTR FOLDERSTREAM] + then (* ; + "Maybe new messages have been added to file") + (SETFILEPTR FOLDERSTREAM END) + (if (NOT (LA.READSTAMP FOLDERSTREAM)) + then (RETURN (BADTOCFILE FOLDER TOCSTREAM + "inconsistent with mail folder")) + else (SETQ READMORE T) + (SETQ MSGCOUNTGUESS (IQUOTIENT (- FOLDEREOFPTR END) + 500] + (add MSGCOUNTGUESS (SETQ LASTMSG# (WORDIN TOCSTREAM))) + (SETQ MESSAGES (\LAFITE.MAKE.MSGARRAY MSGCOUNTGUESS)) + (for I from 1 to LASTMSG# bind MSG LENGTH + (START _ (GETFILEPTR + TOCSTREAM)) + (MESSAGESTART _ 0) + do (SETQ MSG (create LAFITEMSG + %# _ I + BEGIN _ MESSAGESTART)) + (if (>= TOCVERSION 10) + then (* ; + "These bytes are up front to make it easier to find them for update") + (replace (LAFITEMSG MSGFLAGBITS) of MSG + with (BIN TOCSTREAM)) + (replace (LAFITEMSG MARKCHAR) of MSG + with (BIN TOCSTREAM))) + + (* ;; "Message length is 3 bytes long because it can be greater than MAX.SMALLP, though uncommon. In fact, we even permit it to be greater than 24 bits, though that is exceedingly unlikely.") + + [replace (LAFITEMSG MESSAGELENGTH) of MSG + with (SETQ LENGTH + (if (EQ (SETQ LENGTH (BIN TOCSTREAM)) + 0) + then + (* ; "Normal 16-bit length") + (WORDIN TOCSTREAM) + else (\MAKENUMBER (if (EQ LENGTH 255) + then + (* ; "Very long length") + (WORDIN TOCSTREAM + ) + else LENGTH) + (WORDIN TOCSTREAM] + (add MESSAGESTART LENGTH) + (replace (LAFITEMSG STAMPLENGTH) of MSG + with (BIN TOCSTREAM)) + (if (< TOCVERSION 10) + then (* ; + "Flags and mark stuck in the middle here") + (if (EQ TOCVERSION 8) + then (replace (LAFITEMSG + PARSED&DELETED&SEENBITS + ) of MSG + with (BIN TOCSTREAM)) + else (replace (LAFITEMSG MSGFLAGBITS) + of MSG with (BIN TOCSTREAM))) + (replace (LAFITEMSG MARKCHAR) of MSG + with (BIN TOCSTREAM)) + (* ; + "Clear datebits, since we once used a %"formatted%" bit in this area") + (replace (LAFITEMSG DATEBITS) of MSG + with 0) + elseif (fetch (LAFITEMSG DATEFETCHED?) of MSG) + then (* ; "Read 4 bytes of idate") + (\BINS TOCSTREAM MSG (UNFOLD + (INDEXF (FETCH (LAFITEMSG + IDATE))) + BYTESPERWORD) + 4)) + (if (NOT (fetch (LAFITEMSG DATEKNOWN?) of MSG)) + then (* ; "Read 6 bytes of ascii string") + (replace (LAFITEMSG DATE) of MSG + with (LA.READSTRING TOCSTREAM 6))) + (replace (LAFITEMSG SUBJECT) of MSG with + ( + LA.READSHORTSTRING + TOCSTREAM)) + (replace (LAFITEMSG FROM) of MSG with ( + LA.READSHORTSTRING + TOCSTREAM)) + (replace (LAFITEMSG TO) of MSG with ( + LA.READSHORTSTRING + TOCSTREAM)) + [replace (LAFITEMSG TOCLENGTH) of MSG + with (- (- START (SETQ START (GETFILEPTR TOCSTREAM] + (SETA MESSAGES I MSG)) + (replace (MAILFOLDER TOCLASTMESSAGE#) of FOLDER + with (if (EQ TOCVERSION LAFITEVERSION#) + then LASTMSG# + else (* ; + "Will have to rewrite toc next time") + 0)) + [if READMORE + then (* ; "Parse new messages") + (if (SETQ EXTRAMESSAGES (\LAFITE.PARSE.FOLDER1 + FOLDER FOLDERSTREAM FOLDEREOFPTR + END (ADD1 LASTMSG#) + T)) + then [SETQ MESSAGES (\LAFITE.ADDMESSAGES.TO.ARRAY + MESSAGES + (CDR EXTRAMESSAGES) + (ADD1 LASTMSG#) + (SETQ LASTMSG# (CAR EXTRAMESSAGES] + else (RETURN (BADTOCFILE FOLDER TOCSTREAM + "Couldn't parse new messages, have to start from scratch..." + T] + (replace (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER with + MESSAGES) + (replace (MAILFOLDER %#OFMESSAGES) of FOLDER with LASTMSG#) + (replace (MAILFOLDER FOLDEREOFPTR) of FOLDER with + FOLDEREOFPTR) + (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with NIL) + (replace (MAILFOLDER BROWSERREADY) of FOLDER with T) + (RETURN T)) + + (* ;; "Cleanups...") + + (CLOSEF? TOCSTREAM))]) (BADTOCFILE -(LAMBDA (FOLDER TOCSTREAM ERRMSG CLEARFLG) (* ; "Edited 1-May-89 14:26 by bvm") (COND (CLEARFLG (LAB.PROMPTPRINT FOLDER T ERRMSG)) (T (LAB.PROMPTPRINT FOLDER ERRMSG ", discarding..."))) (COND (LAFITEDEBUGFLG (HELP "TOC file error" ERRMSG))) (DELFILE (CLOSEF TOCSTREAM)) (* ; "Return NIL to tell loader to parse from scratch") NIL) -) + [LAMBDA (FOLDER TOCSTREAM ERRMSG CLEARFLG) (* ; "Edited 1-May-89 14:26 by bvm") + (COND + (CLEARFLG (LAB.PROMPTPRINT FOLDER T ERRMSG)) + (T (LAB.PROMPTPRINT FOLDER ERRMSG ", discarding..."))) + (COND + (LAFITEDEBUGFLG (HELP "TOC file error" ERRMSG))) + (DELFILE (CLOSEF TOCSTREAM)) (* ; + "Return NIL to tell loader to parse from scratch") + NIL]) (\LAFITE.TOCEOF -(LAMBDA (STREAM) (* ; "Edited 2-Nov-89 15:58 by bvm") (* ;;; "Unexpected end of file on TOC, flush it") (RETFROM (QUOTE \LAFITE.READ.TOC.FILE) (BADTOCFILE FOLDER STREAM "Malformed table of contents, discarding..."))) -) + [LAMBDA (STREAM) (* ; "Edited 2-Nov-89 15:58 by bvm") + +(* ;;; "Unexpected end of file on TOC, flush it") + + (RETFROM '\LAFITE.READ.TOC.FILE (BADTOCFILE FOLDER STREAM + "Malformed table of contents, discarding..."]) (LA.READCOUNT -(LAMBDA (STREAM NOVAL) (* ; "Edited 21-Apr-89 14:49 by bvm") (* ;; "Read an integer terminated by a space. On success, return the integer, else NIL. If NOVAL is true, call is for test or effect, so we don't actually compute the integer, but return NOVAL instead on success. File pointer is left following the terminating space.") (bind VAL CH do (if (AND (<= (SETQ CH (BIN STREAM)) (CHARCODE 9)) (>= CH (CHARCODE 0))) then (SETQ VAL (OR NOVAL (+ (- CH (CHARCODE 0)) (if VAL then (ITIMES 10 VAL) else 0)))) else (* ; "Non-digit, so done. Note that if we found no digits at all, VAL is NIL") (RETURN (AND (EQ CH (CHARCODE SPACE)) VAL))))) -) + [LAMBDA (STREAM NOVAL) (* ; "Edited 21-Apr-89 14:49 by bvm") + + (* ;; "Read an integer terminated by a space. On success, return the integer, else NIL. If NOVAL is true, call is for test or effect, so we don't actually compute the integer, but return NOVAL instead on success. File pointer is left following the terminating space.") + + (bind VAL CH do (if (AND (<= (SETQ CH (BIN STREAM)) + (CHARCODE 9)) + (>= CH (CHARCODE 0))) + then [SETQ VAL (OR NOVAL (+ (- CH (CHARCODE 0)) + (if VAL + then (ITIMES 10 VAL) + else 0] + else (* ; + "Non-digit, so done. Note that if we found no digits at all, VAL is NIL") + (RETURN (AND (EQ CH (CHARCODE SPACE)) + VAL]) (LA.READSTAMP -(LAMBDA (STREAM) (* bvm%: "22-Dec-83 18:23") (AND (EQ (BIN STREAM) (CHARCODE *)) (EQ (BIN STREAM) (CHARCODE s)) (EQ (BIN STREAM) (CHARCODE t)) (EQ (BIN STREAM) (CHARCODE a)) (EQ (BIN STREAM) (CHARCODE r)) (EQ (BIN STREAM) (CHARCODE t)) (EQ (BIN STREAM) (CHARCODE *)) (EQ (BIN STREAM) (CHARCODE CR)))) -) + [LAMBDA (STREAM) (* bvm%: "22-Dec-83 18:23") + (AND (EQ (BIN STREAM) + (CHARCODE *)) + (EQ (BIN STREAM) + (CHARCODE s)) + (EQ (BIN STREAM) + (CHARCODE t)) + (EQ (BIN STREAM) + (CHARCODE a)) + (EQ (BIN STREAM) + (CHARCODE r)) + (EQ (BIN STREAM) + (CHARCODE t)) + (EQ (BIN STREAM) + (CHARCODE *)) + (EQ (BIN STREAM) + (CHARCODE CR]) (LA.PRINTHEADER -(LAMBDA (OUTPUTSTREAM BODYLENGTH MSG EXTRAHEADERLENGTH) (* ; "Edited 25-Apr-89 12:39 by bvm") (* ;; "Print the header part of a Lafite msg up to but not including the flag/mark bytes, i.e., the part that reads %"*start*nnnnn 000mm %" for total length nnnnn and header length mm. The message exclusive of the header is BODYLENGTH bytes long. If EXTRAHEADERLENGTH is given, it tells how many bytes caller will write beyond the standard header. We will figure out the right header format to use. If MSG is supplied and its STAMPLENGTH disagrees with the format we choose, we'll update it. Returns STAMPLENGTH.") (* ;; "Note that if the original message was from a Hardy file or other tool that sticks stuff in the header, we are now throwing that info away") (POSITION OUTPUTSTREAM 0) (* ; "So that LA.PRINTCOUNT doesn't screw up") (LA.PRINTSTAMP OUTPUTSTREAM) (LET* ((TOTALLENGTH (+ BODYLENGTH LAFITESTAMPLENGTH)) (FIELDWIDTH (if (< TOTALLENGTH 100000) then (* ;; "We prefer to print the length as 5 digits, since that's Laurel/Hardy/MailTool format, but we'll use more if we need to.") 5 else (NCHARS TOTALLENGTH))) (STAMPLENGTH (+ FIELDWIDTH LAFITEBASICSTAMPLENGTH (OR EXTRAHEADERLENGTH 0))) FIELDDESC) (if (> STAMPLENGTH LAFITESTAMPLENGTH) then (add TOTALLENGTH (- STAMPLENGTH LAFITESTAMPLENGTH)) (* ; "Add the larger stamp's size to the total length. Problem: did this just make the total length overflow a power of 10, so we need another digit?") (if (> (NCHARS TOTALLENGTH) FIELDWIDTH) then (* ; "Yes, it's bigger than the space we allotted, so bump up by 1. This can't happen more than once (assuming EXTRAHEADERLENGTH is small), so no need to loop") (add STAMPLENGTH 1) (add TOTALLENGTH 1) (add FIELDWIDTH 1)) (* ; "Now compute the format to print TOTALLENGTH") (SETQ FIELDDESC (BQUOTE (FIX (\, FIELDWIDTH) 10 T)))) (LA.PRINTCOUNT TOTALLENGTH OUTPUTSTREAM FIELDDESC) (* ; "total message length") (LA.PRINTCOUNT STAMPLENGTH OUTPUTSTREAM) (* ; "length of this header") (if (AND MSG (NEQ (fetch (LAFITEMSG STAMPLENGTH) of MSG) STAMPLENGTH)) then (* ; "Stamp size changed, so update MSG object") (replace (LAFITEMSG STAMPLENGTH) of MSG with STAMPLENGTH) (replace (LAFITEMSG MESSAGELENGTH) of MSG with TOTALLENGTH)) STAMPLENGTH)) -) + [LAMBDA (OUTPUTSTREAM BODYLENGTH MSG EXTRAHEADERLENGTH)(* ; "Edited 25-Apr-89 12:39 by bvm") + + (* ;; "Print the header part of a Lafite msg up to but not including the flag/mark bytes, i.e., the part that reads %"*start*nnnnn 000mm %" for total length nnnnn and header length mm. The message exclusive of the header is BODYLENGTH bytes long. If EXTRAHEADERLENGTH is given, it tells how many bytes caller will write beyond the standard header. We will figure out the right header format to use. If MSG is supplied and its STAMPLENGTH disagrees with the format we choose, we'll update it. Returns STAMPLENGTH.") + + (* ;; "Note that if the original message was from a Hardy file or other tool that sticks stuff in the header, we are now throwing that info away") + + (POSITION OUTPUTSTREAM 0) (* ; + "So that LA.PRINTCOUNT doesn't screw up") + (LA.PRINTSTAMP OUTPUTSTREAM) + (LET* ((TOTALLENGTH (+ BODYLENGTH LAFITESTAMPLENGTH)) + (FIELDWIDTH (if (< TOTALLENGTH 100000) + then + + (* ;; "We prefer to print the length as 5 digits, since that's Laurel/Hardy/MailTool format, but we'll use more if we need to.") + + 5 + else (NCHARS TOTALLENGTH))) + (STAMPLENGTH (+ FIELDWIDTH LAFITEBASICSTAMPLENGTH (OR EXTRAHEADERLENGTH 0))) + FIELDDESC) + [if (> STAMPLENGTH LAFITESTAMPLENGTH) + then (add TOTALLENGTH (- STAMPLENGTH LAFITESTAMPLENGTH)) + (* ; "Add the larger stamp's size to the total length. Problem: did this just make the total length overflow a power of 10, so we need another digit?") + (if (> (NCHARS TOTALLENGTH) + FIELDWIDTH) + then (* ; "Yes, it's bigger than the space we allotted, so bump up by 1. This can't happen more than once (assuming EXTRAHEADERLENGTH is small), so no need to loop") + (add STAMPLENGTH 1) + (add TOTALLENGTH 1) + (add FIELDWIDTH 1)) (* ; + "Now compute the format to print TOTALLENGTH") + (SETQ FIELDDESC `(FIX ,FIELDWIDTH 10 T] + (LA.PRINTCOUNT TOTALLENGTH OUTPUTSTREAM FIELDDESC) + (* ; "total message length") + (LA.PRINTCOUNT STAMPLENGTH OUTPUTSTREAM) (* ; "length of this header") + (if (AND MSG (NEQ (fetch (LAFITEMSG STAMPLENGTH) of MSG) + STAMPLENGTH)) + then (* ; + "Stamp size changed, so update MSG object") + (replace (LAFITEMSG STAMPLENGTH) of MSG with STAMPLENGTH) + (replace (LAFITEMSG MESSAGELENGTH) of MSG with TOTALLENGTH)) + STAMPLENGTH]) (LA.PRINTCOUNT -(LAMBDA (COUNT STREAM FORMAT) (* ; "Edited 17-Apr-89 16:48 by bvm") (OR FORMAT (SETQ FORMAT (QUOTE (FIX 5 10 T)))) (PRINTNUM FORMAT COUNT STREAM) (BOUT STREAM (CHARCODE SPACE))) -) + [LAMBDA (COUNT STREAM FORMAT) (* ; "Edited 17-Apr-89 16:48 by bvm") + [OR FORMAT (SETQ FORMAT '(FIX 5 10 T] + (PRINTNUM FORMAT COUNT STREAM) + (BOUT STREAM (CHARCODE SPACE]) (LA.PRINTSTAMP -(LAMBDA (STREAM) (* bvm%: "27-Dec-83 12:54") (PROGN (BOUT STREAM (CHARCODE *)) (BOUT STREAM (CHARCODE s)) (BOUT STREAM (CHARCODE t)) (BOUT STREAM (CHARCODE a)) (BOUT STREAM (CHARCODE r)) (BOUT STREAM (CHARCODE t)) (BOUT STREAM (CHARCODE *)) (BOUT STREAM (CHARCODE CR)))) -) + [LAMBDA (STREAM) (* bvm%: "27-Dec-83 12:54") + (PROGN (BOUT STREAM (CHARCODE *)) + (BOUT STREAM (CHARCODE s)) + (BOUT STREAM (CHARCODE t)) + (BOUT STREAM (CHARCODE a)) + (BOUT STREAM (CHARCODE r)) + (BOUT STREAM (CHARCODE t)) + (BOUT STREAM (CHARCODE *)) + (BOUT STREAM (CHARCODE CR]) (LA.READSHORTSTRING -(LAMBDA (STREAM) (* ; "Edited 10-Sep-87 14:21 by bvm:") (* ;;; "Read from STREAM a string written by LA.PRINTSHORTSTRING whose length is stored as the first byte.") (LET ((NBYTES (BIN STREAM))) (COND ((NEQ NBYTES 0) (LA.READSTRING STREAM NBYTES (if (EQ (\PEEKBIN STREAM) 255) then (* ; "a fat string. It is stored on the file in non-runcoded format.") (BIN STREAM) T)))))) -) + [LAMBDA (STREAM) (* ; "Edited 10-Sep-87 14:21 by bvm:") + +(* ;;; +"Read from STREAM a string written by LA.PRINTSHORTSTRING whose length is stored as the first byte.") + + (LET ((NBYTES (BIN STREAM))) + (COND + ((NEQ NBYTES 0) + (LA.READSTRING STREAM NBYTES (if (EQ (\PEEKBIN STREAM) + 255) + then (* ; + "a fat string. It is stored on the file in non-runcoded format.") + (BIN STREAM) + T]) (LA.PRINTSHORTSTRING -(LAMBDA (STREAM STRING) (* ; "Edited 10-Sep-87 14:02 by bvm:") (* ;; "Store string on toc file. Format is: number of chars (as a byte), followed by chars. If string is fat, then chars are two bytes per char and are prefixed by a 255 (impossible thin char).") (COND ((NULL STRING) (BOUT STREAM 0) 1) (T (LET ((NBYTES (NCHARS STRING)) (BASE (fetch (STRINGP BASE) of STRING)) (OFF (fetch (STRINGP OFFST) of STRING))) (COND ((> NBYTES 255) (* ; "truncate string") (SETQ NBYTES 255))) (BOUT STREAM NBYTES) (if (fetch (STRINGP FATSTRINGP) of STRING) then (BOUT STREAM 255) (\BOUTS STREAM BASE (UNFOLD OFF 2) (UNFOLD NBYTES 2)) (+ 2 (UNFOLD NBYTES 2)) else (\BOUTS STREAM BASE OFF NBYTES) (+ 1 NBYTES)))))) -) + [LAMBDA (STREAM STRING) (* ; "Edited 10-Sep-87 14:02 by bvm:") + + (* ;; "Store string on toc file. Format is: number of chars (as a byte), followed by chars. If string is fat, then chars are two bytes per char and are prefixed by a 255 (impossible thin char).") + + (COND + ((NULL STRING) + (BOUT STREAM 0) + 1) + (T (LET ((NBYTES (NCHARS STRING)) + (BASE (fetch (STRINGP BASE) of STRING)) + (OFF (fetch (STRINGP OFFST) of STRING))) + (COND + ((> NBYTES 255) (* ; "truncate string") + (SETQ NBYTES 255))) + (BOUT STREAM NBYTES) + (if (fetch (STRINGP FATSTRINGP) of STRING) + then (BOUT STREAM 255) + (\BOUTS STREAM BASE (UNFOLD OFF 2) + (UNFOLD NBYTES 2)) + (+ 2 (UNFOLD NBYTES 2)) + else (\BOUTS STREAM BASE OFF NBYTES) + (+ 1 NBYTES]) (LA.READSTRING -(LAMBDA (STREAM NC FATP) (* ; "Edited 10-Sep-87 14:22 by bvm:") (* ;;; "Returns a string of length NC composed of the next NC (or 2*NC if fatp) bytes of STREAM") (LET ((STR (ALLOCSTRING NC NIL NIL FATP))) (\BINS STREAM (fetch (STRINGP BASE) of STR) 0 (if FATP then (UNFOLD NC 2) else NC)) STR)) -) + [LAMBDA (STREAM NC FATP) (* ; "Edited 10-Sep-87 14:22 by bvm:") + +(* ;;; "Returns a string of length NC composed of the next NC (or 2*NC if fatp) bytes of STREAM") + + (LET ((STR (ALLOCSTRING NC NIL NIL FATP))) + (\BINS STREAM (fetch (STRINGP BASE) of STR) + 0 + (if FATP + then (UNFOLD NC 2) + else NC)) + STR]) (\LAFITE.VERIFYMSG -(LAMBDA (MSG FOLDER) (* ; "Edited 18-Jul-88 13:02 by bvm") (* ;; "Verify that this message starts points at an actual message start in the folder. If not, something is wrong with the toc--rebrowse, or take the action given by *LAFITE-VERIFY-ACTION*.") (PROG ((STREAM (fetch (MAILFOLDER FOLDERSTREAM) of FOLDER))) (SETFILEPTR STREAM (fetch (LAFITEMSG BEGIN) of MSG)) (COND ((NOT (LA.READSTAMP STREAM)) (if *LAFITE-VERIFY-ACTION* then (* ; "Caller anticipated this, and has provided an action") (CL:FUNCALL *LAFITE-VERIFY-ACTION* MSG FOLDER STREAM) else (LET ((CHANGED (fetch (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER))) (ALLOW.BUTTON.EVENTS) (* ; "Don't hoard mouse") (LAB.FORMAT FOLDER "Lafite's table of contents is inconsistent at message #~D; the folder will have to be reparsed.~@[ However, you have unsaved changes.~]" (fetch (LAFITEMSG %#) of MSG) CHANGED) (\LAFITE.REBROWSE.FOLDER FOLDER STREAM (OR CHANGED (AND LAFITEDEBUGFLG (HELP "TOC inconsistent"))) NIL NIL :ABORT T))))))) -) + [LAMBDA (MSG FOLDER) (* ; "Edited 18-Jul-88 13:02 by bvm") + + (* ;; "Verify that this message starts points at an actual message start in the folder. If not, something is wrong with the toc--rebrowse, or take the action given by *LAFITE-VERIFY-ACTION*.") + + (PROG ((STREAM (fetch (MAILFOLDER FOLDERSTREAM) of FOLDER))) + (SETFILEPTR STREAM (fetch (LAFITEMSG BEGIN) of MSG)) + (COND + ((NOT (LA.READSTAMP STREAM)) + (if *LAFITE-VERIFY-ACTION* + then (* ; + "Caller anticipated this, and has provided an action") + (CL:FUNCALL *LAFITE-VERIFY-ACTION* MSG FOLDER STREAM) + else (LET ((CHANGED (fetch (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER))) + (ALLOW.BUTTON.EVENTS) (* ; "Don't hoard mouse") + (LAB.FORMAT FOLDER "Lafite's table of contents is inconsistent at message #~D; the folder will have to be reparsed.~@[ However, you have unsaved changes.~]" + (fetch (LAFITEMSG %#) of MSG) + CHANGED) + (\LAFITE.REBROWSE.FOLDER FOLDER STREAM (OR CHANGED (AND LAFITEDEBUGFLG + (HELP + "TOC inconsistent" + ))) + NIL NIL :ABORT T]) (LA.MSGFROMMEP -(LAMBDA (MSG) (* ; "Edited 6-Jun-88 15:50 by bvm") (* ;; "True if the message is from the current user.") (AND \LAFITE.ACTIVE.MODES (PROG ((MODE (fetch (LAFITEMSG MODE) of MSG)) *LAFITE-MODE-DATA*) (if MODE then (if (NULL (SETQ *LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA MODE T))) then (* ; "We know the mode, but haven't gotten authenticated yet, so say NIL for now but be willing to change later") (RETURN NIL)) elseif (SETQ MODE (\LAFITE.GUESS.MODE MSG)) then (SETQ *LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA MODE T))) (RETURN (replace (LAFITEMSG MSGFROMMEP) of MSG with (AND *LAFITE-MODE-DATA* (CL:FUNCALL (fetch (LAFITEMODEDATA MESSAGE-FROM-SELFP) of *LAFITE-MODE-DATA*) MSG))))))) -) + [LAMBDA (MSG) (* ; "Edited 6-Jun-88 15:50 by bvm") + + (* ;; "True if the message is from the current user.") + + (AND \LAFITE.ACTIVE.MODES (PROG ((MODE (fetch (LAFITEMSG MODE) of MSG)) + *LAFITE-MODE-DATA*) + (if MODE + then (if (NULL (SETQ *LAFITE-MODE-DATA* + (\LAFITE.GET.USER.DATA MODE T))) + then + (* ; "We know the mode, but haven't gotten authenticated yet, so say NIL for now but be willing to change later") + (RETURN NIL)) + elseif (SETQ MODE (\LAFITE.GUESS.MODE MSG)) + then (SETQ *LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA + MODE T))) + (RETURN (replace (LAFITEMSG MSGFROMMEP) of MSG + with (AND *LAFITE-MODE-DATA* + (CL:FUNCALL (fetch (LAFITEMODEDATA + + MESSAGE-FROM-SELFP + ) of + *LAFITE-MODE-DATA* + ) + MSG]) ) (DEFINEQ (LAFITE.PARSE.MSG.FOR.TOC -(LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* ; "Edited 25-Jun-91 14:25 by bvm") (COND ((NULL (fetch (LAFITEMSG PARSED?) of MSGDESCRIPTOR)) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (PROG ((FOLDERSTREAM (\LAFITE.OPEN.FOLDER MAILFOLDER (QUOTE INPUT) :ABORT)) ORIGINAL-FROM) (for PAIR in (LAFITE.PARSE.HEADER FOLDERSTREAM \LAPARSE.TOCFIELDS (fetch (LAFITEMSG START) of MSGDESCRIPTOR) (fetch (LAFITEMSG END) of MSGDESCRIPTOR)) do (SELECTQ (CAR PAIR) (From (replace (LAFITEMSG FROM) of MSGDESCRIPTOR with (CADR PAIR))) (Original-From (SETQ ORIGINAL-FROM (CADR PAIR))) (Subject (replace (LAFITEMSG SUBJECT) of MSGDESCRIPTOR with (CADR PAIR))) (Date (replace (LAFITEMSG DATE) of MSGDESCRIPTOR with (CADR PAIR))) (IDATE (replace (LAFITEMSG IDATE) of MSGDESCRIPTOR with (CADR PAIR)) (replace (LAFITEMSG DATEBITS) of MSGDESCRIPTOR with 3) (* ; "Date fetched and known")) NIL)) (replace (LAFITEMSG PARSED?) of MSGDESCRIPTOR with T) (COND ((fetch (LAFITEMSG MSGFROMMEP) of MSGDESCRIPTOR) (* ; "Get the TO field while we're at it, since TOC display will want it") (LAFITE.FETCH.TO.FIELD MSGDESCRIPTOR MAILFOLDER) (COND ((AND LAFITEIFFROMMETHENSEENFLG (NOT (fetch (LAFITEMSG SEEN?) of MSGDESCRIPTOR))) (replace (LAFITEMSG SEEN?) of MSGDESCRIPTOR with T) (replace (LAFITEMSG MARKCHAR) of MSGDESCRIPTOR with SEENMARK) (replace (LAFITEMSG MARKSCHANGED?) of MSGDESCRIPTOR with T))))) (* ;; "Finally turn the From field into something more presentable. ORIGINAL-FROM is a perhaps more interesting address occurring on messages via gateway. We didn't do this until now, because we wanted the mode to be guessed correctly.") (replace (LAFITEMSG FROM) of MSGDESCRIPTOR with (LAFITE-EXTRACT-REAL-NAME (OR ORIGINAL-FROM (fetch (LAFITEMSG FROM) of MSGDESCRIPTOR))))))))) -) + [LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* ; "Edited 25-Jun-91 14:25 by bvm") + (COND + ((NULL (fetch (LAFITEMSG PARSED?) of MSGDESCRIPTOR)) + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + [PROG ((FOLDERSTREAM (\LAFITE.OPEN.FOLDER MAILFOLDER 'INPUT :ABORT)) + ORIGINAL-FROM) + (for PAIR in (LAFITE.PARSE.HEADER FOLDERSTREAM \LAPARSE.TOCFIELDS + (fetch (LAFITEMSG START) of MSGDESCRIPTOR) + (fetch (LAFITEMSG END) of MSGDESCRIPTOR)) + do (SELECTQ (CAR PAIR) + (From (replace (LAFITEMSG FROM) of MSGDESCRIPTOR + with (CADR PAIR))) + (Original-From (SETQ ORIGINAL-FROM (CADR PAIR))) + (Subject (replace (LAFITEMSG SUBJECT) of MSGDESCRIPTOR + with (CADR PAIR))) + (Date (replace (LAFITEMSG DATE) of MSGDESCRIPTOR + with (CADR PAIR))) + (IDATE (replace (LAFITEMSG IDATE) of MSGDESCRIPTOR + with (CADR PAIR)) + (replace (LAFITEMSG DATEBITS) of MSGDESCRIPTOR + with 3) (* ; "Date fetched and known") + ) + NIL)) + (replace (LAFITEMSG PARSED?) of MSGDESCRIPTOR with T) + [COND + ((fetch (LAFITEMSG MSGFROMMEP) of MSGDESCRIPTOR) + (* ; + "Get the TO field while we're at it, since TOC display will want it") + (LAFITE.FETCH.TO.FIELD MSGDESCRIPTOR MAILFOLDER) + (COND + ((AND LAFITEIFFROMMETHENSEENFLG (NOT (fetch (LAFITEMSG SEEN?) + of MSGDESCRIPTOR))) + (replace (LAFITEMSG SEEN?) of MSGDESCRIPTOR with T) + (replace (LAFITEMSG MARKCHAR) of MSGDESCRIPTOR with SEENMARK) + (replace (LAFITEMSG MARKSCHANGED?) of MSGDESCRIPTOR with T] + + (* ;; "Finally turn the From field into something more presentable. ORIGINAL-FROM is a perhaps more interesting address occurring on messages via gateway. We didn't do this until now, because we wanted the mode to be guessed correctly.") + + (replace (LAFITEMSG FROM) of MSGDESCRIPTOR + with (LAFITE-EXTRACT-REAL-NAME (OR ORIGINAL-FROM (fetch (LAFITEMSG + FROM) + of MSGDESCRIPTOR + ])]) (LAFITE-EXTRACT-REAL-NAME -(LAMBDA (FROMFIELD) (* ; "Edited 6-May-92 09:48 by bvm") (* ;; "Called with (probably) an rfc822 From field. Return what we believe to be the user's %"real name%" for presentation purposes.") (AND FROMFIELD (LET ((WHITESPACE (QUOTE (#\Space #\Tab))) END OPEN CLOSE) (if (OR (CL:MEMBER (CL:CHAR FROMFIELD 0) WHITESPACE) (CL:MEMBER (CL:CHAR FROMFIELD (SETQ END (SUB1 (NCHARS FROMFIELD)))) WHITESPACE)) then (* ; "get rid of whitespace to avoid confusing us") (SETQ FROMFIELD (CL:STRING-TRIM WHITESPACE FROMFIELD)) (SETQ END (SUB1 (NCHARS FROMFIELD)))) (if (AND (SETQ OPEN (CL:POSITION #\< FROMFIELD)) (> OPEN 0) (SETQ CLOSE (CL:POSITION #\> FROMFIELD :START OPEN)) (EQ CLOSE END)) then (* ; "Real name ") (CL:STRING-TRIM (QUOTE (#\Space #\Tab #\")) (CL:SUBSEQ FROMFIELD 0 OPEN)) elseif (AND (SETQ OPEN (CL:POSITION #\( FROMFIELD)) (> OPEN 0) (SETQ CLOSE (CL:POSITION #\) FROMFIELD :START OPEN)) (EQ CLOSE END) (NOT (CL:POSITION #\Space (CL:STRING-TRIM WHITESPACE (CL:SUBSEQ FROMFIELD 0 OPEN))))) then (* ;; "mail name (real name). Extra test is being careful about there maybe being more info in the rest of the field") (CL:STRING-TRIM WHITESPACE (CL:SUBSEQ FROMFIELD (ADD1 OPEN) CLOSE)) elseif (AND (CL:POSITION #\: FROMFIELD) (NOT (CL:POSITION #\, FROMFIELD)) (NOT (CL:POSITION #\; FROMFIELD)) (SETQ OPEN (PARSE.NSNAME FROMFIELD))) then (* ;; "A single ns name (the semi-colon test rules out rfc822 groups). Abbreviate it per local defaults. Note that this requires reparsing the mail file if user changes domains, but that should be a rare event") (NSNAME.TO.STRING OPEN) else FROMFIELD)))) -) + [LAMBDA (FROMFIELD) (* ; "Edited 6-May-92 09:48 by bvm") + + (* ;; "Called with (probably) an rfc822 From field. Return what we believe to be the user's %"real name%" for presentation purposes.") + + (AND FROMFIELD (LET ((WHITESPACE '(#\Space #\Tab)) + END OPEN CLOSE) + [if (OR (CL:MEMBER (CL:CHAR FROMFIELD 0) + WHITESPACE) + (CL:MEMBER [CL:CHAR FROMFIELD (SETQ END (SUB1 (NCHARS FROMFIELD] + WHITESPACE)) + then (* ; + "get rid of whitespace to avoid confusing us") + (SETQ FROMFIELD (CL:STRING-TRIM WHITESPACE FROMFIELD)) + (SETQ END (SUB1 (NCHARS FROMFIELD] + (if (AND (SETQ OPEN (CL:POSITION #\< FROMFIELD)) + (> OPEN 0) + (SETQ CLOSE (CL:POSITION #\> FROMFIELD :START OPEN)) + (EQ CLOSE END)) + then (* ; "Real name ") + (CL:STRING-TRIM '(#\Space #\Tab #\") + (CL:SUBSEQ FROMFIELD 0 OPEN)) + elseif [AND (SETQ OPEN (CL:POSITION #\( FROMFIELD)) + (> OPEN 0) + (SETQ CLOSE (CL:POSITION #\) FROMFIELD :START OPEN)) + (EQ CLOSE END) + (NOT (CL:POSITION #\Space (CL:STRING-TRIM WHITESPACE + (CL:SUBSEQ FROMFIELD 0 + OPEN] + then + + (* ;; "mail name (real name). Extra test is being careful about there maybe being more info in the rest of the field") + + (CL:STRING-TRIM WHITESPACE (CL:SUBSEQ FROMFIELD (ADD1 OPEN) + CLOSE)) + elseif (AND (CL:POSITION #\: FROMFIELD) + (NOT (CL:POSITION #\, FROMFIELD)) + (NOT (CL:POSITION #\; FROMFIELD)) + (SETQ OPEN (PARSE.NSNAME FROMFIELD))) + then + + (* ;; "A single ns name (the semi-colon test rules out rfc822 groups). Abbreviate it per local defaults. Note that this requires reparsing the mail file if user changes domains, but that should be a rare event") + + (NSNAME.TO.STRING OPEN) + else FROMFIELD]) (LAFITE.FETCH.TO.FIELD -(LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* ; "Edited 23-Sep-87 18:35 by bvm:") (* ;; "Fetch just the TO field of a message") (OR (fetch (LAFITEMSG TO) of MSGDESCRIPTOR) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (replace (LAFITEMSG TO) of MSGDESCRIPTOR with (OR (LAFITE.PARSE.HEADER (\LAFITE.OPEN.FOLDER MAILFOLDER (QUOTE INPUT) :ABORT) \LAPARSE.TOFIELD (fetch (LAFITEMSG START) of MSGDESCRIPTOR) (fetch (LAFITEMSG END) of MSGDESCRIPTOR) T) UNSUPPLIEDFIELDSTR))))) -) + [LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* ; "Edited 23-Sep-87 18:35 by bvm:") + + (* ;; "Fetch just the TO field of a message") + + (OR (fetch (LAFITEMSG TO) of MSGDESCRIPTOR) + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + (replace (LAFITEMSG TO) of MSGDESCRIPTOR with + (OR (LAFITE.PARSE.HEADER + (\LAFITE.OPEN.FOLDER MAILFOLDER + 'INPUT :ABORT) + \LAPARSE.TOFIELD + (fetch (LAFITEMSG START) + of MSGDESCRIPTOR) + (fetch (LAFITEMSG END) + of MSGDESCRIPTOR) + T) + UNSUPPLIEDFIELDSTR)))]) (LAFITE.PARSE.HEADER -(LAMBDA (STREAM PARSETABLE START END ONCEONLY CHECKEOF) (* ; "Edited 3-Feb-89 17:29 by bvm") (PROG (PARSERESULT PARSEBEGIN TABLE CH CHOICE) (DECLARE (SPECVARS PARSERESULT PARSEBEGIN)) (* ; "For Parse result functions to access") (COND (START (SETFILEPTR STREAM START))) TOP (SETQ TABLE PARSETABLE) (SETQ PARSEBEGIN (GETFILEPTR STREAM)) LP (SELECTQ (CAR TABLE) (CHOICE (SETQ CH (UCASECODE (READCCODE STREAM))) (COND ((find old CHOICE in (CDR TABLE) suchthat (EQ (CAR CHOICE) CH)) (SETQ TABLE (CDR CHOICE)) (GO LP)))) (RESULT (SETQ TABLE (CDR TABLE)) (LAFITE.SKIP.WHITE.SPACE STREAM) (COND ((OR (EQ (CL:FUNCALL (CAR TABLE) STREAM (CDR TABLE)) (QUOTE STOP)) ONCEONLY) (GO EXIT)) (T (GO NEXTLINE)))) (STOP (COND ((AND CHECKEOF (EQ CH (CHARCODE EOL))) (push PARSERESULT (LIST (QUOTE EOF) PARSEBEGIN)))) (GO EXIT)) (COND ((EQ (SETQ CH (UCASECODE (READCCODE STREAM))) (CAR TABLE)) (SETQ TABLE (CDR TABLE)) (GO LP)))) (* ;; "Get here if parse of current line failed") (COND (CHECKEOF (* ; "See if current line is end of header") (COND ((do (SELCHARQ CH ((CR TAB SPACE) (* ; "Whitespace before a colon is illegal") (push PARSERESULT (LIST (QUOTE EOF) PARSEBEGIN T)) (RETURN T)) (%: (LA.SKIP.TO.EOL STREAM CH) (RETURN NIL)) (SETQ CH (READCCODE STREAM)))) (GO EXIT)))) (T (LA.SKIP.TO.EOL STREAM CH))) 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))) -) + [LAMBDA (STREAM PARSETABLE START END ONCEONLY CHECKEOF)(* ; "Edited 3-Feb-89 17:29 by bvm") + (PROG (PARSERESULT PARSEBEGIN TABLE CH CHOICE) + (DECLARE (SPECVARS PARSERESULT PARSEBEGIN)) (* ; + "For Parse result functions to access") + (COND + (START (SETFILEPTR STREAM START))) + TOP (SETQ TABLE PARSETABLE) + (SETQ PARSEBEGIN (GETFILEPTR STREAM)) + LP [SELECTQ (CAR TABLE) + (CHOICE (SETQ CH (UCASECODE (READCCODE STREAM))) + (COND + ((find old CHOICE in (CDR TABLE) + suchthat (EQ (CAR CHOICE) + CH)) + (SETQ TABLE (CDR CHOICE)) + (GO LP)))) + (RESULT (SETQ TABLE (CDR TABLE)) + (LAFITE.SKIP.WHITE.SPACE STREAM) + (COND + ((OR (EQ (CL:FUNCALL (CAR TABLE) + STREAM + (CDR TABLE)) + 'STOP) + ONCEONLY) + (GO EXIT)) + (T (GO NEXTLINE)))) + (STOP [COND + ((AND CHECKEOF (EQ CH (CHARCODE EOL))) + (push PARSERESULT (LIST 'EOF PARSEBEGIN] + (GO EXIT)) + (COND + ((EQ (SETQ CH (UCASECODE (READCCODE STREAM))) + (CAR TABLE)) + (SETQ TABLE (CDR TABLE)) + (GO LP] + + (* ;; "Get here if parse of current line failed") + + (COND + [CHECKEOF (* ; + "See if current line is end of header") + (COND + ([do (SELCHARQ CH + ((CR TAB SPACE) (* ; + "Whitespace before a colon is illegal") + (push PARSERESULT (LIST 'EOF PARSEBEGIN T)) + (RETURN T)) + (%: (LA.SKIP.TO.EOL STREAM CH) + (RETURN NIL)) + (SETQ CH (READCCODE STREAM] + (GO EXIT] + (T (LA.SKIP.TO.EOL STREAM CH))) + 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.GRAB.DATE -(LAMBDA (STREAM) (* ; "Edited 28-Apr-89 13:55 by bvm") (DECLARE (USEDFREE PARSERESULT)) (push PARSERESULT (LET ((DT (LAFITE.PARSE.DATE.FIELD STREAM))) (if (FIXP DT) then (LIST (QUOTE IDATE) DT) else (LIST (QUOTE Date) DT))))) -) + [LAMBDA (STREAM) (* ; "Edited 28-Apr-89 13:55 by bvm") + (DECLARE (USEDFREE PARSERESULT)) + (push PARSERESULT (LET ((DT (LAFITE.PARSE.DATE.FIELD STREAM))) + (if (FIXP DT) + then (LIST 'IDATE DT) + else (LIST 'Date DT]) (LAFITE.READ.LINE.FOR.TOC -(LAMBDA (STREAM ARGS) (* bvm%: "19-Dec-83 14:08") (DECLARE (USEDFREE PARSERESULT)) (PROG ((STR (LAFITE.READ.TO.EOL STREAM))) (COND ((IGREATERP (NCHARS STR) 255) (SETQ STR (SUBSTRING STR 1 255 STR)))) (push PARSERESULT (LIST (CAR ARGS) STR)))) -) + [LAMBDA (STREAM ARGS) (* bvm%: "19-Dec-83 14:08") + (DECLARE (USEDFREE PARSERESULT)) + (PROG ((STR (LAFITE.READ.TO.EOL STREAM))) + [COND + ((IGREATERP (NCHARS STR) + 255) + (SETQ STR (SUBSTRING STR 1 255 STR] + (push PARSERESULT (LIST (CAR ARGS) + STR]) (LAFITE.READ.FORMAT -(LAMBDA (STREAM) (* bvm%: "12-Nov-84 17:21") (DECLARE (USEDFREE PARSERESULT)) (PROG ((STR (LAFITE.READ.TO.EOL STREAM))) (while (EQ (NTHCHARCODE STR -1) (CHARCODE SPACE)) do (GLC STR)) (push PARSERESULT (LIST (QUOTE Format) (MKATOM (U-CASE STR)))))) -) + [LAMBDA (STREAM) (* bvm%: "12-Nov-84 17:21") + (DECLARE (USEDFREE PARSERESULT)) + (PROG ((STR (LAFITE.READ.TO.EOL STREAM))) + (while (EQ (NTHCHARCODE STR -1) + (CHARCODE SPACE)) do (GLC STR)) + (push PARSERESULT (LIST 'Format (MKATOM (U-CASE STR]) (LAFITE.READ.NAME.FIELD -(LAMBDA (STREAM ARGS) (DECLARE (USEDFREE PARSERESULT)) (* ; "Edited 11-Jun-88 17:54 by bvm") (* ;; "For reading FROM, TO, etc. Just read the line, trim blanks, and return string. Can be more than one occurrence, so PARSERESULT value is a list.") (PROG ((LINE (LAFITE.READ.TO.EOL STREAM))) (do (SELCHARQ (NTHCHARCODE LINE -1) ((SPACE TAB %,) (* ; "Strip off trailing spaces") (GLC LINE)) (RETURN NIL))) (if (> (NCHARS LINE) 0) then (* ; "Ignore empty fields") (for PAIR in PARSERESULT bind (FIELD _ (CAR ARGS)) when (EQ (CAR PAIR) FIELD) do (RETURN (NCONC1 PAIR LINE)) finally (push PARSERESULT (LIST FIELD LINE)))))) -) + [LAMBDA (STREAM ARGS) + (DECLARE (USEDFREE PARSERESULT)) (* ; "Edited 11-Jun-88 17:54 by bvm") + + (* ;; "For reading FROM, TO, etc. Just read the line, trim blanks, and return string. Can be more than one occurrence, so PARSERESULT value is a list.") + + (PROG ((LINE (LAFITE.READ.TO.EOL STREAM))) + (do (SELCHARQ (NTHCHARCODE LINE -1) + ((SPACE TAB %,) (* ; "Strip off trailing spaces") + (GLC LINE)) + (RETURN NIL))) + (if (> (NCHARS LINE) + 0) + then (* ; "Ignore empty fields") + (for PAIR in PARSERESULT bind (FIELD _ (CAR ARGS)) + when (EQ (CAR PAIR) + FIELD) do (RETURN (NCONC1 PAIR LINE)) + finally (push PARSERESULT (LIST FIELD LINE]) (LAFITE.READ.ONE.LINE.FOR.TOC -(LAMBDA (STREAM) (* bvm%: "19-Dec-83 14:10") (SETQ PARSERESULT (LAFITE.READ.TO.EOL STREAM)))) + [LAMBDA (STREAM) (* bvm%: "19-Dec-83 14:10") + (SETQ PARSERESULT (LAFITE.READ.TO.EOL STREAM]) (LAFITE.READ.TO.EOL -(LAMBDA (STREAM) (* ; "Edited 22-Aug-88 16:24 by bvm") (* ;;; "Reads everything in STREAM up to next EOL and returns it as a string. If the next line starts with whitespace, it is assumed to be a continuation line, and it is returned as part of the result as well. See RFC 822") (PROG (RESULT LINE) LP (SETQ LINE (CL:READ-LINE STREAM)) (SETQ RESULT (COND (RESULT (* ; "EOL and leading whitespace are considered to be syntactically a single space.") (CONCAT RESULT " " LINE)) (T LINE))) (SELCHARQ (PEEKCCODE STREAM T) ((SPACE TAB) (LAFITE.SKIP.WHITE.SPACE STREAM) (GO LP)) NIL) (RETURN RESULT))) -) + [LAMBDA (STREAM) (* ; "Edited 22-Aug-88 16:24 by bvm") + +(* ;;; "Reads everything in STREAM up to next EOL and returns it as a string. If the next line starts with whitespace, it is assumed to be a continuation line, and it is returned as part of the result as well. See RFC 822") + + (PROG (RESULT LINE) + LP (SETQ LINE (CL:READ-LINE STREAM)) + (SETQ RESULT (COND + (RESULT (* ; + "EOL and leading whitespace are considered to be syntactically a single space.") + (CONCAT RESULT " " LINE)) + (T LINE))) + (SELCHARQ (PEEKCCODE STREAM T) + ((SPACE TAB) + (LAFITE.SKIP.WHITE.SPACE STREAM) + (GO LP)) + NIL) + (RETURN RESULT]) (LA.SKIP.TO.EOL - [LAMBDA (STREAM LASTCH) (* ; "Edited 22-Jun-2021 10:15 by rmk:") + [LAMBDA (STREAM LASTCH) (* ; "Edited 22-Jun-2021 10:15 by rmk:") -(* ;;; "Flush to end of this field. LASTCH is the last char read before this") +(* ;;; "Flush to end of this field. LASTCH is the last char read before this") (PROG* [(EOLC (fetch (STREAM EOLCONVENTION) of STREAM)) (EOLCHAR (SELECTC EOLC (LF.EOLC (CHARCODE LF)) (CHARCODE CR] (if (EQ LASTCH (CHARCODE EOL)) - then (* ; "We're already there") + then (* ; "We're already there") (GO PEEK)) LP - (* ;; "Eat chars til eol. ") + (* ;; "Eat chars til eol. ") (repeatuntil (EQ EOLCHAR (\INCCODE STREAM))) (if (AND (EQ EOLC CRLF.EOLC) (EQ (\PEEKBIN STREAM T) (CHARCODE LF))) - then (* ; "Eat the lf after the cr") - (* ; - "\INCHAR would do that internally") + then (* ; "Eat the lf after the cr") + (* ; + "\INCHAR would do that internally") (\BIN STREAM)) PEEK (SELCHARQ (\PEEKCCODE STREAM T) - ((SPACE TAB) (* ; "Continuation line, keep eating") + ((SPACE TAB) (* ; "Continuation line, keep eating") (GO LP)) NIL]) (LAFITE.SKIP.WHITE.SPACE - [LAMBDA (STREAM) (* ; "Edited 22-Jun-2021 10:18 by rmk:") + [LAMBDA (STREAM) (* ; "Edited 22-Jun-2021 10:18 by rmk:") (do (SELCHARQ (\PEEKCCODE STREAM T) ((SPACE TAB) (\INCCODE STREAM)) @@ -344,8 +1886,15 @@ Copyright (c) 1984-1989, 1991-1993, 2021 by Xerox Corporation. (DEFINEQ (\LAFITE.PARSE.MESSAGE -(LAMBDA (MAILFOLDER MSGDESCRIPTOR TABLE) (* ; "Edited 23-Sep-87 18:20 by bvm:") (* ;; "Return an alist of the header fields of MSGDESCRIPTOR specified by TABLE, which defaults to \LAPARSE.FULL. Aborts if folder has changed out from under.") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (LAFITE.PARSE.HEADER (\LAFITE.OPEN.FOLDER MAILFOLDER (QUOTE INPUT) :ABORT) (OR TABLE \LAPARSE.FULL) (fetch (LAFITEMSG START) of MSGDESCRIPTOR) (fetch (LAFITEMSG END) of MSGDESCRIPTOR)))) -) + [LAMBDA (MAILFOLDER MSGDESCRIPTOR TABLE) (* ; "Edited 23-Sep-87 18:20 by bvm:") + + (* ;; "Return an alist of the header fields of MSGDESCRIPTOR specified by TABLE, which defaults to \LAPARSE.FULL. Aborts if folder has changed out from under.") + + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + (LAFITE.PARSE.HEADER (\LAFITE.OPEN.FOLDER MAILFOLDER 'INPUT :ABORT) + (OR TABLE \LAPARSE.FULL) + (fetch (LAFITEMSG START) of MSGDESCRIPTOR) + (fetch (LAFITEMSG END) of MSGDESCRIPTOR)))]) ) (RPAQQ LA.FULLPARSEFIELDS @@ -372,16 +1921,64 @@ Copyright (c) 1984-1989, 1991-1993, 2021 by Xerox Corporation. (DEFINEQ (LAFITE.INIT.PARSETABLES -(LAMBDA NIL (* ; "Edited 26-Apr-89 14:09 by bvm") (SETQ \LAPARSE.FULL (LAFITE.MAKE.PARSE.TABLE LA.FULLPARSEFIELDS)) (SETQ \LAPARSE.TOCFIELDS (LAFITE.MAKE.PARSE.TABLE LA.TOCFIELDS)) (SETQ \LAPARSE.TOFIELD (LAFITE.MAKE.PARSE.TABLE LA.TOFIELDONLY)) (SETQ \LAPARSE.SUBJECTFIELD (LAFITE.MAKE.PARSE.TABLE LA.SUBJECTFIELDONLY)) (SETQ \LAPARSE.DATEFIELD (LAFITE.MAKE.PARSE.TABLE LA.DATEFIELDONLY))) -) + [LAMBDA NIL (* ; "Edited 26-Apr-89 14:09 by bvm") + (SETQ \LAPARSE.FULL (LAFITE.MAKE.PARSE.TABLE LA.FULLPARSEFIELDS)) + (SETQ \LAPARSE.TOCFIELDS (LAFITE.MAKE.PARSE.TABLE LA.TOCFIELDS)) + (SETQ \LAPARSE.TOFIELD (LAFITE.MAKE.PARSE.TABLE LA.TOFIELDONLY)) + (SETQ \LAPARSE.SUBJECTFIELD (LAFITE.MAKE.PARSE.TABLE LA.SUBJECTFIELDONLY)) + (SETQ \LAPARSE.DATEFIELD (LAFITE.MAKE.PARSE.TABLE LA.DATEFIELDONLY]) (LAFITE.MAKE.PARSE.TABLE -(LAMBDA (TABLE) (* ; "Edited 23-Sep-87 12:44 by bvm:") (* ;;; "Take a list of entries (string resultfn resultargs) and make a table usable by LAFITE.PARSE.HEADER") (LET ((PARSETABLE (LAFITE.MAKE.PARSE.TABLE1 (for ENTRY in TABLE collect (CONS (CL:STRING-UPCASE (CAR ENTRY)) (CDR ENTRY))) 1))) (CONS (QUOTE CHOICE) (NCONC PARSETABLE (CONSTANT (BQUOTE (((\, (CHARCODE CR)) STOP) ((\,@ (CHARCODE (* S T A R T *))) STOP)))))))) -) + [LAMBDA (TABLE) (* ; "Edited 23-Sep-87 12:44 by bvm:") + +(* ;;; +"Take a list of entries (string resultfn resultargs) and make a table usable by LAFITE.PARSE.HEADER") + + (LET ((PARSETABLE (LAFITE.MAKE.PARSE.TABLE1 (for ENTRY in TABLE + collect (CONS (CL:STRING-UPCASE + (CAR ENTRY)) + (CDR ENTRY))) + 1))) + (CONS 'CHOICE (NCONC PARSETABLE (CONSTANT `((,(CHARCODE CR) + STOP) + (,@(CHARCODE + (* S T A R T *)) + STOP]) (LAFITE.MAKE.PARSE.TABLE1 -(LAMBDA (TABLE I) (* bvm%: "30-Dec-83 11:12") (* ;;; "Subfunction of LAFITE.MAKE.PARSE.TABLE that builds a parsetable from the entries in TABLE splitting on character I") (PROG (ENTRY OTHERENTRIES DONE CHOICELIST CH) (for TAIL on TABLE unless (FMEMB (CAR TAIL) DONE) do (SETQ CH (NTHCHARCODE (CAR (SETQ ENTRY (CAR TAIL))) I)) (COND ((NULL CH) (* ; "Shouldn't happen: can't distinguish two them") (ERROR (CAR ENTRY) "is an initial prefix of another entry"))) (push CHOICELIST (CONS CH (COND ((NOT (SETQ OTHERENTRIES (for X in (CDR TAIL) collect X when (EQ (NTHCHARCODE (CAR X) I) CH)))) (* ; "This is the only choice") (NCONC (for J from (ADD1 I) while (SETQ CH (NTHCHARCODE (CAR ENTRY) J)) collect CH) (CONS (QUOTE RESULT) (CDR ENTRY)))) (T (SETQ DONE (APPEND OTHERENTRIES DONE)) (CONS (QUOTE CHOICE) (LAFITE.MAKE.PARSE.TABLE1 (CONS ENTRY OTHERENTRIES) (ADD1 I)))))))) (RETURN CHOICELIST))) -) + [LAMBDA (TABLE I) (* bvm%: "30-Dec-83 11:12") + +(* ;;; "Subfunction of LAFITE.MAKE.PARSE.TABLE that builds a parsetable from the entries in TABLE splitting on character I") + + (PROG (ENTRY OTHERENTRIES DONE CHOICELIST CH) + [for TAIL on TABLE unless (FMEMB (CAR TAIL) + DONE) + do (SETQ CH (NTHCHARCODE (CAR (SETQ ENTRY (CAR TAIL))) + I)) + (COND + ((NULL CH) (* ; + "Shouldn't happen: can't distinguish two them") + (ERROR (CAR ENTRY) + "is an initial prefix of another entry"))) + (push CHOICELIST (CONS CH (COND + [[NOT (SETQ OTHERENTRIES + (for X in (CDR TAIL) collect + X + when (EQ (NTHCHARCODE (CAR X) + I) + CH] + (* ; "This is the only choice") + (NCONC (for J from (ADD1 I) + while (SETQ CH (NTHCHARCODE + (CAR ENTRY) + J)) collect + CH) + (CONS 'RESULT (CDR ENTRY] + (T (SETQ DONE (APPEND OTHERENTRIES DONE)) + (CONS 'CHOICE (LAFITE.MAKE.PARSE.TABLE1 + (CONS ENTRY OTHERENTRIES) + (ADD1 I] + (RETURN CHOICELIST]) ) @@ -391,13 +1988,83 @@ Copyright (c) 1984-1989, 1991-1993, 2021 by Xerox Corporation. (DEFINEQ (LAFITE.NEW.PARSE.HEADER -(LAMBDA (STREAM PARSETABLE START END ONCEONLY CHECKEOF) (* ; "Edited 6-Aug-93 18:18 by bvm") (DECLARE (SPECVARS PARSETABLE PARSERESULT PARSEBEGIN)) (PROG ((FIELD (OR *LAFITE-PARSE-HEADER-STRING-RESOURCE* (SETQ *LAFITE-PARSE-HEADER-STRING-RESOURCE* (ALLOCSTRING *LAFITE-MAX-FIELD-WIDTH*)))) PARSERESULT PARSEBEGIN CH I PATLEN) (* ; "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))) -) + [LAMBDA (STREAM PARSETABLE START END ONCEONLY CHECKEOF)(* ; "Edited 6-Aug-93 18:18 by bvm") + (DECLARE (SPECVARS PARSETABLE PARSERESULT PARSEBEGIN)) + (PROG ([FIELD (OR *LAFITE-PARSE-HEADER-STRING-RESOURCE* (SETQ + *LAFITE-PARSE-HEADER-STRING-RESOURCE* + (ALLOCSTRING *LAFITE-MAX-FIELD-WIDTH*] + PARSERESULT PARSEBEGIN CH I PATLEN) (* ; + "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 'EOF PARSEBEGIN T))) + [if (EQ CH (CHARCODE CR)) + then (for CHOICE in PARSETABLE + when (EQ (CAR CHOICE) + '% +) 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)) + '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) -) + [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]) ) (RPAQ? *LAFITE-MAX-FIELD-WIDTH* 100) @@ -453,28 +2120,29 @@ Copyright (c) 1984-1989, 1991-1993, 2021 by Xerox Corporation. (PUTPROPS LAFITEMAIL COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988 1989 1991 1992 1993 2021) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4499 13702 (\LAFITE.GETMAIL 4509 . 4741) (\LAFITE.GETMAIL.FROM.ICON 4743 . 5000) ( -\LAFITE.GETMAIL.PROC 5002 . 5345) (\LAFITE.GETNEWMAIL 5347 . 8008) (\LAFITE.GETNEWMAIL1 8010 . 9372) ( -\LAFITE.GETNEWMAIL# 9374 . 9562) (\LAFITE.RETRIEVEMESSAGES 9564 . 13700)) (13749 27003 ( -\LAFITE.GET.USER.DATA 13759 . 15147) (\LAFITE.GUESS.MODE 15149 . 16132) (\LAFITE.REGISTER.MODE 16134 - . 16861) (LAFITECLEARCACHE 16863 . 17337) (FULLUSERNAME 17339 . 18108) (LAFITE.USER.NAME.FROM.LOGIN -18110 . 19189) (LAFITEMAILWATCH 19191 . 19635) (\LAFITE.WAKE.WATCHER 19637 . 20019) (POLLNEWMAIL 20021 - . 25002) (\LAFITE.NEW.MAIL.EXISTS 25004 . 25259) (PRINTLAFITESTATUS 25261 . 26555) ( -LAFITE.STATUS.WITH.TIME 26557 . 26745) (\LAFITE.REINITIALIZING 26747 . 27001)) (27039 54246 ( -\LAFITE.PARSE.FOLDER 27049 . 27707) (\LAFITE.PARSE.FOLDER1 27709 . 31305) (\LAFITE.HANDLE.DUPLICATES -31307 . 32644) (\LAFITE.CHECK.DUPLICATE 32646 . 33328) (\LAFITE.REPORT.DUPLICATES 33330 . 34262) ( -BADMAILFILE 34264 . 38197) (BADMAILFILE.CLOSEFN 38199 . 38471) (BADMAILFILE.FLAGBYTE 38473 . 38625) ( -VERIFYMAILFOLDER 38627 . 41158) (VERIFYFAILED 41160 . 41293) (\LAFITE.READ.TOC.FILE 41295 . 46741) ( -BADTOCFILE 46743 . 47092) (\LAFITE.TOCEOF 47094 . 47333) (LA.READCOUNT 47335 . 47995) (LA.READSTAMP -47997 . 48317) (LA.PRINTHEADER 48319 . 50582) (LA.PRINTCOUNT 50584 . 50782) (LA.PRINTSTAMP 50784 . -51075) (LA.READSHORTSTRING 51077 . 51476) (LA.PRINTSHORTSTRING 51478 . 52206) (LA.READSTRING 52208 . -52523) (\LAFITE.VERIFYMSG 52525 . 53536) (LA.MSGFROMMEP 53538 . 54244)) (54247 63666 ( -LAFITE.PARSE.MSG.FOR.TOC 54257 . 56047) (LAFITE-EXTRACT-REAL-NAME 56049 . 57688) ( -LAFITE.FETCH.TO.FIELD 57690 . 58195) (LAFITE.PARSE.HEADER 58197 . 59843) (LAFITE.GRAB.DATE 59845 . -60094) (LAFITE.READ.LINE.FOR.TOC 60096 . 60370) (LAFITE.READ.FORMAT 60372 . 60646) ( -LAFITE.READ.NAME.FIELD 60648 . 61296) (LAFITE.READ.ONE.LINE.FOR.TOC 61298 . 61425) (LAFITE.READ.TO.EOL - 61427 . 62049) (LA.SKIP.TO.EOL 62051 . 63386) (LAFITE.SKIP.WHITE.SPACE 63388 . 63664)) (63667 64197 ( -\LAFITE.PARSE.MESSAGE 63677 . 64195)) (65157 66969 (LAFITE.INIT.PARSETABLES 65167 . 65588) ( -LAFITE.MAKE.PARSE.TABLE 65590 . 66043) (LAFITE.MAKE.PARSE.TABLE1 66045 . 66967)) (67004 69515 ( -LAFITE.NEW.PARSE.HEADER 67014 . 68835) (LAFITE.HANDLE.ORIGINAL.FIELD 68837 . 69513))))) + (FILEMAP (NIL (4395 22354 (\LAFITE.GETMAIL 4405 . 4776) (\LAFITE.GETMAIL.FROM.ICON 4778 . 5126) ( +\LAFITE.GETMAIL.PROC 5128 . 5575) (\LAFITE.GETNEWMAIL 5577 . 11919) (\LAFITE.GETNEWMAIL1 11921 . 14653 +) (\LAFITE.GETNEWMAIL# 14655 . 15044) (\LAFITE.RETRIEVEMESSAGES 15046 . 22352)) (22401 51381 ( +\LAFITE.GET.USER.DATA 22411 . 25245) (\LAFITE.GUESS.MODE 25247 . 27467) (\LAFITE.REGISTER.MODE 27469 + . 28728) (LAFITECLEARCACHE 28730 . 29484) (FULLUSERNAME 29486 . 30585) (LAFITE.USER.NAME.FROM.LOGIN +30587 . 32370) (LAFITEMAILWATCH 32372 . 33702) (\LAFITE.WAKE.WATCHER 33704 . 34293) (POLLNEWMAIL 34295 + . 47918) (\LAFITE.NEW.MAIL.EXISTS 47920 . 48256) (PRINTLAFITESTATUS 48258 . 50624) ( +LAFITE.STATUS.WITH.TIME 50626 . 50930) (\LAFITE.REINITIALIZING 50932 . 51379)) (51417 106191 ( +\LAFITE.PARSE.FOLDER 51427 . 52795) (\LAFITE.PARSE.FOLDER1 52797 . 60252) (\LAFITE.HANDLE.DUPLICATES +60254 . 63290) (\LAFITE.CHECK.DUPLICATE 63292 . 64227) (\LAFITE.REPORT.DUPLICATES 64229 . 66114) ( +BADMAILFILE 66116 . 74672) (BADMAILFILE.CLOSEFN 74674 . 75002) (BADMAILFILE.FLAGBYTE 75004 . 75202) ( +VERIFYMAILFOLDER 75204 . 79775) (VERIFYFAILED 79777 . 79965) (\LAFITE.READ.TOC.FILE 79967 . 93470) ( +BADTOCFILE 93472 . 93966) (\LAFITE.TOCEOF 93968 . 94303) (LA.READCOUNT 94305 . 95533) (LA.READSTAMP +95535 . 96078) (LA.PRINTHEADER 96080 . 99402) (LA.PRINTCOUNT 99404 . 99637) (LA.PRINTSTAMP 99639 . +100063) (LA.READSHORTSTRING 100065 . 100832) (LA.PRINTSHORTSTRING 100834 . 101963) (LA.READSTRING +101965 . 102436) (\LAFITE.VERIFYMSG 102438 . 104219) (LA.MSGFROMMEP 104221 . 106189)) (106192 122077 ( +LAFITE.PARSE.MSG.FOR.TOC 106202 . 109562) (LAFITE-EXTRACT-REAL-NAME 109564 . 112693) ( +LAFITE.FETCH.TO.FIELD 112695 . 113970) (LAFITE.PARSE.HEADER 113972 . 117081) (LAFITE.GRAB.DATE 117083 + . 117488) (LAFITE.READ.LINE.FOR.TOC 117490 . 117926) (LAFITE.READ.FORMAT 117928 . 118310) ( +LAFITE.READ.NAME.FIELD 118312 . 119345) (LAFITE.READ.ONE.LINE.FOR.TOC 119347 . 119528) ( +LAFITE.READ.TO.EOL 119530 . 120460) (LA.SKIP.TO.EOL 120462 . 121797) (LAFITE.SKIP.WHITE.SPACE 121799 + . 122075)) (122078 122719 (\LAFITE.PARSE.MESSAGE 122088 . 122717)) (123679 127667 ( +LAFITE.INIT.PARSETABLES 123689 . 124200) (LAFITE.MAKE.PARSE.TABLE 124202 . 125172) ( +LAFITE.MAKE.PARSE.TABLE1 125174 . 127665)) (127702 132269 (LAFITE.NEW.PARSE.HEADER 127712 . 131321) ( +LAFITE.HANDLE.ORIGINAL.FIELD 131323 . 132267))))) STOP diff --git a/library/lafite/LAFITEMAIL.LCOM b/library/lafite/LAFITEMAIL.LCOM index 7bfdb1aa86805c0d6d9fa395ce7f1c88ff298659..c687d4bb056558474cb1d9b611a9e2dcaeaddabf 100644 GIT binary patch delta 724 zcmZvZ%TE(g6vo5E2Az!yE3FXBWe`FatuuEtv=gx%+Zk+gDfERH(NJx{npmn(7p{$q zy0G=O^xaNz;o2x0-MH|vc4Z>!UtmJm8WTOY1wx{;_~pCjeD^yicbcELmmj(Oyjd3Q zkz~e>MJypKE25;F$AvqKR@sIG>^juL3U(?IF8r|EOs}rrPNi2+Dvbm^MhH4=bT}LW zO2pTbiT?&T1sgx1`-$caYid;UA>rQ*&P~!Ojz}_+WO-6@qRjo|gVbtvts6V0AYQ=O z9>}J9TT7xMxfIbUAnM`#efU+5i|6}z`tw-=7@~7P&ybbAp#e~);w@mRcnx?DS?Twp z8`N;=I`Fq|kd{h1sBfiZpm&3LUu-M_kCa2e^dk$sTV^-hk1h0lnI#^tgn@r@R{F5w z0rj@B1S}Zi^imar%2wmRFIAR!vBtDfy9)eOW9c{Qtp1_SrWTAbDm7G4YmFpu>B#`y zX#`I2WY(*ac{LnC4ivS)$5Yar1xKcNif%P8fMS~+Yx(wSE3Fw&Tdgy|uPyct%(>8J z{bqX#xZP%RhK=cdej+@lhTL?wK4_9e5wdfJ{h<1}W;F%<1ghJ{(CIxdBC76>YC4HU zF3+fbqLXRZi>Kz!=+S)(eOEP)?;m>ppmv41qp_fdx|zMni0)JeV3~Yp6!^M>4u+4o j%pAn-cFsa$WOJd*ll19k5LBkl{)qT|xu3W35Xb)op7q-= delta 734 zcmZvZZ%7ky7{@t5ti@qg>eQ5n8G!K|$|| z*!DQL-P}BV)r(#x)O+l{dI`kyzh2hL5*~kh|wZt~gANQcMy*Q~+NTWxV~siF`>RCsvvxJ}I3i9xPiq zpUgJATb^j<1pz!-RMV%Gcmh1wVzlCy@)^qT8#Ba*hBfcAVa=YYSbLZiOE+z&iPyI0 zj`A!vqAkR5g4_v$z)t=3D-)Ka$Fi(hL2Qqs;4ae2qu zx4tuafcL~Fl*wVhY^j^99@9%?rprn)yNLJAPc9pl+uXxeuV8?A?Uj}i*$F}e@r4L7wm=|yG@8Gr1y*wG|j-aA5S V>_#W{R0c@B+*@ek1)loxzW_*j;sO8w diff --git a/library/lafite/LAFITESEND b/library/lafite/LAFITESEND index 92f4df5a..a6b7fdda 100644 --- a/library/lafite/LAFITESEND +++ b/library/lafite/LAFITESEND @@ -1,128 +1,1786 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 3-Dec-2000 14:53:30" {DSK}medley3.5>library>LAFITESEND.;6 62302 changes to%: (VARS LAFITEFORWARDSTRINGS) previous date%: "18-Jul-2000 03:10:16" {DSK}medley3.5>library>LAFITESEND.;5) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1993, 1999, 2000 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LAFITESENDCOMS) (RPAQQ LAFITESENDCOMS ((COMS (* ; "Sending mail") (FNS DOLAFITESENDINGCOMMAND \SENDMESSAGE.INITIATE \SENDMSG.DELIVER \SENDMSG.EXIT.TEDIT \SENDMSG.SAVE.FORM \LAFITE.HEADER.EOF \LAFITE.INSERT.REPLYTO \SENDMSG.REPLYTO \SENDMSG.CHANGE.MODE \SENDMSG.FIND.FIELD \SENDMESSAGE.PARSE \LAFITE.PREPARE.SEND \LAFITE.PREPARE.ERROR \LAFITE.CHOOSE.MSG.FORMAT LAFITE.MAKE.PLAIN.TEXTSTREAM \SENDMESSAGE.MENUPROMPT \SENDMESSAGE.PROMPT \SENDMESSAGEFAIL) (FNS \SENDMESSAGE \SENDMESSAGE.RESTARTABLE \SENDMESSAGE.CLEANUP \SENDMESSAGE.MAKEWINDOW MAKELAFITEDELIVERMENU \LAFITE.CLOSEMSG? \LAFITE.AFTER.DELIVER \LAFITE.UNSENT.ICON \LAFITE.FETCH.SUBJECT LAFITE.SENDMESSAGE \SENDMESSAGE0 LA.ASSURE.PROMPT.WINDOW \LAFITE.SEND.FAIL \LAFITE.INVALID.RECIPIENTS \SENDMESSAGE.ABORT)) (COMS (* ; "Outbox hacking") (FNS \OUTBOX.CREATE \OUTBOX.RESET \OUTBOX.CLOSEFN \OUTBOX.REPAINTFN \OUTBOX.RESHAPEFN \OUTBOX.SHADEITEM \OUTBOX.BUTTONFN \OUTBOX.DISPLAYLINE \OUTBOX.ADD.ITEM) (INITVARS (LAFITEOUTBOXSIZE 2) (\LAFITE.OUTBOX)) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS OUTBOXITEM) (GLOBALVARS LAFITEOUTBOXSIZE))) (COMS (* ; "Built-in message forms") (FNS \LAFITE.MESSAGEFORM MAKELAFITESUPPORTFORM MAKELISPSUPPORTFORM MAKEXXXSUPPORTFORM MAKENEWMESSAGEFORM MAKELAFITEPRIVATEFORMSITEMS \LAFITE.UNCACHE.MESSAGEFORM \LAFITE.DELETE.MESSAGEFORM \LAFITE.SELECT.FORM \LAFITE.DELETE.FORM.INTERNAL \LAFITE.READ.FORM \LAFITE.FIND.TEMPLATE)) (COMS (* ; "ANSWER") (FNS \LAFITE.ANSWER \LAFITE.ANSWER.PROC MAKEANSWERFORM LA.PRINT.COMMA.LIST LAFITE.FILL.IN.ANSWER.FORM)) (COMS (* ; "FORWARD") (FNS \LAFITE.FORWARD \LAFITE.FORWARD.PROC MAKEFORWARDFORM)) [COMS (VARS LAFITESENDINGMENUITEMS LAFITEFORMSMENUITEMS LAFITEFORMATMENUITEMS LAFITEFORWARDSTRINGS) (ADDVARS (\SYSTEMCACHEVARS \LAFITE.REPORT.MACHINE) (LAFITESPECIALFORMS ("Lisp Report" (FUNCTION MAKELISPSUPPORTFORM) "A form to report a Lisp bug or suggestion") ("Lafite Report" (FUNCTION MAKELAFITESUPPORTFORM) "A form to report a Lafite bug or suggestion")) (LAFITEMENUVARS LAFITEFORMSMENU LAFITEFORMATMENU)) (INITVARS (\LAFITE.REPORT.MACHINE) (LAFITECURRENTEDITORWINDOWS) (LAFITEFORMFILES) (LAFITEFORMSMENU) (LAFITEFORMATMENU)) (INITVARS (LAFITEEDITORFONT LAFITEDISPLAYFONT) (LAFITEFORM.EXT "Lafite-form") (LAFITEFORMDIRECTORIES NIL) (LAFITE.EDITOR.SIZE '(470 . 300)) (LAFITE.EDITOR.LAYOUTS NIL) (LAFITEFORWARDSUBJECTSTR NIL) (LAFITESUPPORT NIL) (LISPSUPPORT NIL) (MESSAGESTR ">>Message<<") (RECIPIENTSSTR ">>Recipients<<") (SUBJECTSTR ">>Subject<<") (LAFITE.SEND.FORMATTED '((NSCHARS :ASK) (CHARLOOKS :ASK) (PARALOOKS :ASK) (IMAGEOBJ :ASK] (COMS (* ; "Obsolete") (INITVARS (LAFITEEDITORREGION NIL))) (COMS (* ; "ICON stuff") (VARS LAFITE.MSG.ICON)) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SENDINGCOMMAND) (GLOBALVARS \LAFITE.REPORT.MACHINE LAFITECURRENTEDITORWINDOWS LAFITEEDITORFONT LAFITEEDITORREGION LAFITEFORMATMENU LAFITEFORMSMENUITEMS LAFITEFORMATMENUITEMS LAFITEFORWARDSTRINGS LAFITEFORWARDSUBJECTSTR LAFITESENDINGMENUITEMS LAFITESPECIALFORMS LAFITESUPPORT LISPSUPPORT MAKESYSDATE MESSAGESTR RECIPIENTSSTR SUBJECTSTR LAFITE.MSG.ICON LAFITEFORMDIRECTORIES LAFITE.SEND.FORMATTED) (FILES (SOURCE) LAFITEDECLS) (LOCALVARS . T)))) (* ; "Sending mail") (DEFINEQ (DOLAFITESENDINGCOMMAND -(LAMBDA (ITEM MENU KEY) (* bvm%: "31-Jul-84 15:03") (* ;;; "this function is invoked by buttoning the menu on top of the 'sending' window") (PROG ((WINDOW (WINDOWPROP (WFROMMENU MENU) (QUOTE MAINWINDOW))) PROC) (AND (SETQ PROC (WINDOWPROP WINDOW (QUOTE PROCESS))) (PROCESS.APPLY PROC (FUNCTION \SENDMESSAGE.INITIATE) (LIST WINDOW MENU ITEM))))) -) (\SENDMESSAGE.INITIATE -(LAMBDA (WINDOW MENU ITEM) (* ; "Edited 31-Jan-89 16:59 by bvm") (* ;; "Called by selecting a menu command from a message composition window") (ERSETQ (RESETLST (LET ((COMMAND (EXTRACTMENUCOMMAND ITEM))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (ITEM MENU) (COND (RESETSTATE (* ; "In case of error/abort, set menu & proc back to normal") (SHADEITEM ITEM MENU WHITESHADE) (replace (MENU WHENSELECTEDFN) of MENU with (FUNCTION DOLAFITESENDINGCOMMAND)) (PROCESSPROP (THIS.PROCESS) (QUOTE BEFOREEXIT) NIL))))) ITEM MENU)) (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE) (* ; "Now disable the menu") (replace (MENU WHENSELECTEDFN) of MENU with (FUNCTION NILL)) (PROCESSPROP (THIS.PROCESS) (QUOTE BEFOREEXIT) (QUOTE DON'T)) (* ; "Don't let anyone logout now!") (CL:FUNCALL COMMAND WINDOW (WINDOWPROP WINDOW (QUOTE TEXTSTREAM)) MENU ITEM))))) -) (\SENDMSG.DELIVER -(LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 31-Jan-89 16:41 by bvm") (LET (PARSE) (printout (GETPROMPTWINDOW WINDOW) T "Parsing...") (OR (SETQ PARSE (\SENDMESSAGE.PARSE TEXTSTREAM WINDOW)) (ERROR!)) (\SENDMSG.EXIT.TEDIT WINDOW TEXTSTREAM (create SENDINGCOMMAND COMMAND _ (QUOTE %##SEND##) ITEM _ ITEM MENU _ MENU MESSAGE _ TEXTSTREAM MESSAGEPARSE _ PARSE)))) -) (\SENDMSG.EXIT.TEDIT -(LAMBDA (WINDOW TEXTSTREAM VALUE) (* ; "Edited 31-Jan-89 16:39 by bvm") (WINDOWADDPROP WINDOW (QUOTE CLOSEFN) (QUOTE DON'T)) (* ; "Keep TEDIT.QUIT from closing the window") (TEDIT.QUIT TEXTSTREAM VALUE) (LA.DETACH.TEDIT TEXTSTREAM)) -) (\SENDMSG.SAVE.FORM -(LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 3-Nov-89 15:33 by bvm") (* ;; "Shortcut to TEdit Put that saves on mail directory and remembers it as a %"Saved Form%"") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (PROMPT "Save under name: ") (FORMNAME (WINDOWPROP WINDOW (QUOTE LAFITEFORM))) PWINDOW FORMFILE) (COND (FORMNAME (SETQ FORMNAME (LA.SHORTFILENAME FORMNAME LAFITEFORM.EXT)))) (SETQ PWINDOW (LA.ASSURE.PROMPT.WINDOW WINDOW PROMPT (OR FORMNAME "XXX"))) (* ; "Kludge to keep it small") (CLEARW PWINDOW) (COND ((SETQ FORMFILE (PROMPTFORFILENAME PWINDOW FORMNAME PROMPT)) (SETQ FORMNAME (LA.SHORTFILENAME (TEDIT.PUT TEXTSTREAM (LA.LONGFILENAME FORMFILE LAFITEFORM.EXT) NIL (if (EQ (TEDIT.FORMATTEDFILEP TEXTSTREAM) (QUOTE NSCHARS)) then (* ; "Force no formatting--TEdit defaultly saves formatting even if only ns chars") T)) LAFITEFORM.EXT)) (WINDOWPROP WINDOW (QUOTE LAFITEFORM) FORMNAME) (COND ((NOT (CL:MEMBER FORMNAME LAFITEFORMFILES :TEST (QUOTE STRING-EQUAL))) (SETQ LAFITEFORMFILES (APPEND LAFITEFORMFILES (LIST FORMNAME))) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFORMSMENU))))) (* ;; "Exit with error to restore window state (what a kludge)") (ERROR!))) -) (\LAFITE.HEADER.EOF -(LAMBDA (TEXTSTREAM) (* ; "Edited 3-Nov-89 14:29 by bvm") (* ;; "Return the character number in TEXTSTREAM of the blank line following the header") (ADD1 (CADAR (LAFITE.PARSE.HEADER TEXTSTREAM NIL 0 NIL NIL T)))) -) (\LAFITE.INSERT.REPLYTO -(LAMBDA (TEXTSTREAM NAME HIGHLIGHT HEADEREOF) (* ; "Edited 3-Nov-89 12:57 by bvm") (* ;; "Insert a %"Reply-to: name%" field in this message. If HIGHLIGHT, leave the name pending-delete selected for potential replacement.") (TEDIT.INSERT TEXTSTREAM (CONCAT "Reply-to: " NAME LAFITEEOL) (OR HEADEREOF (SETQ HEADEREOF (\LAFITE.HEADER.EOF TEXTSTREAM)))) (if HIGHLIGHT then (TEDIT.SETSEL TEXTSTREAM (+ HEADEREOF (CONSTANT (NCHARS "Reply-to: "))) (NCHARS NAME) (QUOTE RIGHT) T))) -) (\SENDMSG.REPLYTO -(LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 3-Nov-89 14:03 by bvm") (* ;; "Add a Reply-to field to the message") (\LAFITE.INSERT.REPLYTO TEXTSTREAM (fetch (LAFITEMODEDATA FULLUSERNAME) of (\LAFITE.GET.USER.DATA (TEXTPROP TEXTSTREAM (QUOTE LAFITEMODE)))) T) (* ;; "Exit with error to restore window state (what a kludge)") (ERROR!)) -) (\SENDMSG.CHANGE.MODE -(LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 5-Jan-90 18:06 by bvm") (LET* ((OLDMODE (TEXTPROP TEXTSTREAM (QUOTE LAFITEMODE))) (OTHERMODES (for MODE in LAFITEMODELST unless (OR (EQ (fetch (LAFITEOPS LAFITEMODE) of MODE) OLDMODE) (NLISTP (CDR MODE))) collect (fetch (LAFITEOPS LAFITEMODE) of MODE))) (NEWMODE (if (NULL OTHERMODES) then (\SENDMESSAGE.PROMPT WINDOW "There are no other modes") elseif (CDR OTHERMODES) then (MENU (\LAFITE.CREATE.MENU OTHERMODES "New mode")) else (CAR OTHERMODES)))) (if NEWMODE then (LET* ((TITLE (WINDOWPROP WINDOW (QUOTE TITLE))) (OLDMODEDATA (\LAFITE.GET.USER.DATA OLDMODE)) (NEWMODEDATA (\LAFITE.GET.USER.DATA NEWMODE)) N N2) (if (NULL NEWMODEDATA) then (\SENDMESSAGE.PROMPT WINDOW (CL:FORMAT NIL "Can't authenticate user in ~A mode" NEWMODE)) else (LET ((OLDNAME (fetch (LAFITEMODEDATA FULLUSERNAME) of OLDMODEDATA)) (END (TEDIT.FIND TEXTSTREAM " +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "30-Sep-2021 22:58:58"  +{DSK}KAPLAN>LOCAL>MEDLEY3.5>GIT-MEDLEY>LIBRARY>LAFITE>LAFITESEND.;1 99805 -" 1)) START N LEN NEW OLDSEL) (if END then (add END 1)) (* ; "Don't search past end of header. END now points at second cr.") (for FIELD in (QUOTE ("cc" "Reply-to")) when (AND (SETQ N (\SENDMSG.FIND.FIELD TEXTSTREAM FIELD END)) (PROGN (SETQ LEN (CADR N)) (SETQ N (CAR N)) (SETQ START (STRPOS OLDNAME (SETQ OLDSEL (TEDIT.SEL.AS.STRING TEXTSTREAM (create SELECTION CH# _ N DCH _ LEN))) NIL NIL NIL NIL UPPERCASEARRAY)))) do (* ; "Change field containing old user name to new. This is much more complicated than it needs to be because TEDIT.FIND is case sensitive.") (TEDIT.DELETE TEXTSTREAM N LEN) (TEDIT.INSERT TEXTSTREAM (SETQ NEW (CONCAT (OR (SUBSTRING OLDSEL 1 (SUB1 START)) "") (fetch (LAFITEMODEDATA FULLUSERNAME) of NEWMODEDATA) (OR (SUBSTRING OLDSEL (+ START (NCHARS OLDNAME))) ""))) N) (AND END (add END (- (NCHARS NEW) LEN)))) (if (SETQ N (\SENDMSG.FIND.FIELD TEXTSTREAM "To" END)) then (* ; "Leave the To field selected for address modification") (TEDIT.SETSEL TEXTSTREAM (CAR N) (CADR N) (QUOTE RIGHT) T)) (TEXTPROP TEXTSTREAM (QUOTE LAFITEMODE) NEWMODE) (if (SETQ N (STRPOS (CONCAT "(" OLDMODE ")") TITLE)) then (WINDOWPROP WINDOW (QUOTE TITLE) (CONCAT (SUBSTRING TITLE 1 N) NEWMODE ")"))) (\SENDMESSAGE.PROMPT WINDOW "Message mode is now " NEWMODE))))) (* ;; "Exit with error so that the window is restored to previous state") (ERROR!))) -) (\SENDMSG.FIND.FIELD -(LAMBDA (TEXTSTREAM FIELD END) (* ; "Edited 5-Jan-90 17:54 by bvm") (* ;; "Find and select the header field beginning with %"FIELD:%". Return starting index.") (LET* ((STR (CONCAT " -" FIELD ": ")) (N (TEDIT.FIND TEXTSTREAM STR 1 END)) N2) (if (AND N (SETQ N2 (TEDIT.FIND TEXTSTREAM " -" (add N (NCHARS STR)) END))) then (LIST N (- N2 N)))))) (\SENDMESSAGE.PARSE -(LAMBDA (MSG EDITORWINDOW) (* ; "Edited 10-Aug-89 17:25 by bvm") (* ;; "Parse MSG in the current mode, returning a parse structure that the corresponding sender will be happy with") (LET* ((MODE (TEXTPROP MSG (QUOTE LAFITEMODE))) (*LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA MODE))) (if *LAFITE-MODE-DATA* then (CL:FUNCALL (fetch (LAFITEMODEDATA SENDPARSER) of *LAFITE-MODE-DATA*) MSG EDITORWINDOW) else (\SENDMESSAGE.PROMPT EDITORWINDOW (CL:FORMAT NIL "Can't authenticate user in ~A mode" MODE))))) -) (\LAFITE.PREPARE.SEND -(LAMBDA (MSG EDITORWINDOW PARSETABLE) (* bvm%: "13-Nov-84 12:50") (* ;; "Does generic things to MSG, a textstream about to be sent as a message: makes sure it ends in a CR, has no leading CRs, and parses it according to PARSETABLE which defaults to \LAPARSE.FULL -- returns a parse, whose first element tries to be (EOF end-of-header-position)") (PROG (MSGEOF HEADEREOF MSGFIELDS EOFINFO) (COND ((NOT (TYPENAMEP MSG (QUOTE STREAM))) (RETURN (LISPERROR "ILLEGAL ARG" MSG)))) (COND (EDITORWINDOW (* ; "Scroll so that beginning of message is visible") (TEDIT.SETSEL MSG 1 0 (QUOTE LEFT)) (TEDIT.NORMALIZECARET MSG) (first (SETFILEPTR MSG 0) until (NEQ (BIN MSG) (CHARCODE EOL)) do (* ; "hack to get rid of leading CRs") (TEDIT.DELETE MSG 1 1)) (SETFILEPTR MSG (SUB1 (SETQ MSGEOF (GETEOFPTR MSG)))) (COND ((NEQ (BIN MSG) (CHARCODE EOL)) (* ; "Make sure message ends in eol") (TEDIT.INSERT MSG LAFITEEOL (ADD1 MSGEOF) NIL T))))) (SETFILEINFO MSG (QUOTE ENDOFSTREAMOP) (FUNCTION \LAFITE.EOF)) (* ; "Avoid parsing failure if header-only message") (SETQ MSGFIELDS (LAFITE.PARSE.HEADER MSG (OR PARSETABLE \LAPARSE.FULL) 0 (SETQ MSGEOF (GETEOFPTR MSG)) NIL T)) (COND ((EQ (CAR (SETQ EOFINFO (CAR MSGFIELDS))) (QUOTE EOF)) (SETQ HEADEREOF (CADR EOFINFO)) (COND ((CADDR EOFINFO) (* ; "Error") (RETURN (\LAFITE.PREPARE.ERROR MSG EDITORWINDOW HEADEREOF)))) (COND ((= HEADEREOF MSGEOF) (* ; "Parse ended at eof, so message does not end in double CR -- add another") (SETFILEPTR MSG MSGEOF) (BOUT MSG (CHARCODE CR)))) (RPLACA (CDR EOFINFO) (SETQ HEADEREOF (ADD1 HEADEREOF))) (* ; "Add one for tedit fileptr one-based nonsense"))) (RETURN MSGFIELDS))) -) (\LAFITE.PREPARE.ERROR -(LAMBDA (MSG EDITORWINDOW HEADEREOF) (* bvm%: "13-Nov-84 12:53") (* ;;; "Called when header of MSG contained a line not conforming to spec. Most likely cause is user deleted the blank line between header and message. Print a suitable error message") (PROG (LINE) (SETFILEPTR MSG HEADEREOF) (SETQ LINE (LAFITE.READ.TO.EOL MSG)) (SETFILEPTR MSG HEADEREOF) (BOUT MSG (CHARCODE CR)) (\SENDMESSAGEFAIL EDITORWINDOW (CONCAT "Header not understood: %"" (COND ((> (NCHARS LINE) 30) (CONCAT (SUBSTRING LINE 1 30) (QUOTE ...))) (T LINE))) "%". Assumed this was not part of header, and inserted blank line before it. If this is correct, press 'Deliver' again, else edit the message appropriately."))) -) (\LAFITE.CHOOSE.MSG.FORMAT -(LAMBDA (TEXTSTREAM HEADEREOF EDITORWINDOW) (* ; "Edited 3-Feb-89 18:36 by bvm") (* ;; "Ask if user intends to retain formatting info, and if so, send formatted") (LET ((FORMATTING (TEDIT.FORMATTEDFILEP TEXTSTREAM)) TMP) (COND ((NULL FORMATTING) (* ; "It's just plain text") (QUOTE TEXT)) ((AND (TEXTSTREAMP TEXTSTREAM) (TEXTPROP TEXTSTREAM (QUOTE LAFITEFORMAT)))) ((NULL EDITORWINDOW) (* ; "Nobody to interact with") (QUOTE TEDIT)) (T (SELECTQ (COND ((NLISTP LAFITE.SEND.FORMATTED) LAFITE.SEND.FORMATTED) ((SETQ TMP (ASSOC FORMATTING LAFITE.SEND.FORMATTED)) (CADR TMP)) (T :ASK)) (T (* ; "Send formatted") (QUOTE TEDIT)) (NIL (* ; "Send unformatted") (QUOTE TEXT)) (SELECTQ (SETQ TMP (\SENDMESSAGE.MENUPROMPT EDITORWINDOW (OR LAFITEFORMATMENU (SETQ LAFITEFORMATMENU (\LAFITE.CREATE.MENU LAFITEFORMATMENUITEMS "Retain formatting information?" T))) (CONCAT "Message " (SELECTQ FORMATTING (CHARLOOKS "has font information") (PARALOOKS "has paragraph formatting") (NSCHARS "uses extended character set") (IMAGEOBJ "contains images") "has unknown formatting") ".") (QUOTE LAFITEFORMATMENU))) (ABORT NIL) TMP)))))) -) (LAFITE.MAKE.PLAIN.TEXTSTREAM -(LAMBDA (TEXTSTREAM START) (* ; "Edited 24-Sep-87 16:48 by bvm:") (* ;; "Coerces TEXTSTREAM to a %"plain text%" stream, returning the new stream. If START is specified, only copies from that file pointer onward.") (LET ((PLAIN (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) (SETFILEPTR TEXTSTREAM (OR START (SETQ START 0))) (* ;; "TEXT streams return character codes on BIN, so we have to translate to bytes on output side to handle fat chars correctly and avoid image objects") (to (- (GETEOFPTR TEXTSTREAM) START) do (\OUTCHAR PLAIN (OR (FIXP (BIN TEXTSTREAM)) (CHARCODE *)))) (* ; "Reopen to avoid core bug") (OPENSTREAM (CLOSEF PLAIN) (QUOTE INPUT)))) -) (\SENDMESSAGE.MENUPROMPT -(LAMBDA (EDITWINDOW MENU PROMPT MENUVAR) (* ; "Edited 20-Apr-89 19:37 by bvm") (* ;; "Prompt with MENU at the upper left corner of EDITWINDOW, printing PROMPT in the prompt window. If MENUVAR is specified, it is the global variable that holds this menu, which we smash to NIL while inside MENU, lest someone else try to use it") (LET ((PWINDOW (GETPROMPTWINDOW EDITWINDOW)) RESULT) (CLEARW PWINDOW) (printout PWINDOW PROMPT) (if MENUVAR then (SET MENUVAR NIL)) (SETQ RESULT (MENU MENU (LA.POSITION.FROM.REGION (WINDOWPROP PWINDOW (QUOTE REGION)) NIL T) T)) (CLEARW PWINDOW) (if MENUVAR then (SET MENUVAR MENU)) RESULT)) -) (\SENDMESSAGE.PROMPT -(LAMBDA (EDITORWINDOW MESS1 MESS2) (* ; "Edited 31-Jan-89 17:03 by bvm") (* ;; "Display message MESS1 & optionally MESS2 in the prompt window of EDITORWINDOW. Returns NIL always") (LET ((PWINDOW (COND (EDITORWINDOW (LA.ASSURE.PROMPT.WINDOW EDITORWINDOW MESS1 MESS2)) (T PROMPTWINDOW)))) (CLEARW PWINDOW) (PRIN3 MESS1 PWINDOW) (COND (MESS2 (PRIN3 MESS2 PWINDOW))) NIL)) -) (\SENDMESSAGEFAIL -(LAMBDA (EDITORWINDOW MESS1 MESS2) (* ; "Edited 31-Jan-89 17:02 by bvm") (\SENDMESSAGE.PROMPT EDITORWINDOW MESS1 MESS2) (RETFROM (QUOTE \SENDMESSAGE.PARSE))) -) ) (DEFINEQ (\SENDMESSAGE -(LAMBDA (FORM TEDITPROPS FORMNAME) (* ; "Edited 10-Feb-89 12:22 by bvm") (* ;;; "FORM can be a string, file, or stream --- The value of \SENDMESSAGE is T only if the message was actually sent") (OR (TEXTSTREAMP FORM) (SETQ FORM (OPENTEXTSTREAM FORM NIL NIL NIL TEDITPROPS))) (TEDIT.STREAMCHANGEDP FORM T) (* ; "Clear the changed bit") (if (NOT (LISTGET TEDITPROPS (QUOTE LEAVETTY))) then (* ; "Take control of the keyboard") (TTY.PROCESS (THIS.PROCESS))) (PROG ((MODE (LISTGET TEDITPROPS (QUOTE LAFITEMODE)))) (* ; "Old way of specifying mode") (if MODE then (TEXTPROP FORM (QUOTE LAFITEMODE) MODE) elseif (TEXTPROP FORM (QUOTE LAFITEMODE)) elseif (SETQ MODE (fetch LAFITEMODE of \LAFITEMODE)) then (TEXTPROP FORM (QUOTE LAFITEMODE) MODE) else (PRINTOUT PROMPTWINDOW T "Can't send mail without a Lafite mode.") (RETURN NIL)) (RETURN (\SENDMESSAGE.RESTARTABLE FORM TEDITPROPS NIL FORMNAME)))) -) (\SENDMESSAGE.RESTARTABLE -(LAMBDA (FORM TEDITPROPS EDITORWINDOW FORMNAME) (* ; "Edited 3-Nov-89 15:06 by bvm") (bind (CURRENTMESSAGE _ FORM) (FIRSTTIME _ T) EDITORRESULT DONE SENTOK PARSE do (PROCESSPROP (THIS.PROCESS) (QUOTE BEFOREEXIT) NIL) (* ; "Allow LOGOUT until delivery is attempted. Need to do this if we loop or restart") (COND ((NULL (PROG1 EDITORWINDOW (SETQ EDITORWINDOW (\SENDMESSAGE.MAKEWINDOW CURRENTMESSAGE NIL EDITORWINDOW (TEXTPROP FORM (QUOTE LAFITEMODE)))))) (* ; "First time thru. Fix it so that we can restart if aborted") (PROCESSPROP (THIS.PROCESS) (QUOTE RESTARTFORM) (LIST (FUNCTION \SENDMESSAGE.RESTARTABLE) (KWOTE FORM) (KWOTE TEDITPROPS) (KWOTE EDITORWINDOW))) (* ; "If process is reset or aborted, this is how to resurrect") (PROCESSPROP (THIS.PROCESS) (QUOTE RESTARTABLE) T) (WINDOWPROP EDITORWINDOW (QUOTE LAFITEFORM) FORMNAME))) (COND (FIRSTTIME (RESETSAVE NIL (LIST (FUNCTION \SENDMESSAGE.CLEANUP) EDITORWINDOW)) (push LAFITECURRENTEDITORWINDOWS EDITORWINDOW) (SETQ FIRSTTIME))) (SETQ EDITORRESULT (TEDIT FORM EDITORWINDOW T (APPEND TEDITPROPS (LIST (QUOTE FONT) LAFITEEDITORFONT)))) (COND ((TTY.PROCESSP) (* ; "give back the keyboard") (TTY.PROCESS T))) (WINDOWDELPROP EDITORWINDOW (QUOTE CLOSEFN) (QUOTE DON'T)) (* ; "let the window close") (COND ((NOT (type? SENDINGCOMMAND EDITORRESULT)) (* ; "get out anyway since the user used the TEDIT `quit' command instead of one of the sending commands") (SETQ DONE T)) (T (* ; "the user used the lafite menu to get out rather than the TEDIT menu so we have to do something") (* ; "make sure CURRENTMESSAGE is always a string") (SETQ CURRENTMESSAGE (fetch (SENDINGCOMMAND MESSAGE) of EDITORRESULT)) (SETQ DONE (SELECTQ (AND EDITORRESULT (fetch (SENDINGCOMMAND COMMAND) of EDITORRESULT)) (%##SEND## (SETQ SENTOK (\SENDMESSAGE0 CURRENTMESSAGE EDITORWINDOW (SETQ PARSE (fetch (SENDINGCOMMAND MESSAGEPARSE) of EDITORRESULT))))) (SHOULDNT))) (SHADEITEM (fetch (SENDINGCOMMAND ITEM) of EDITORRESULT) (fetch (SENDINGCOMMAND MENU) of EDITORRESULT) WHITESHADE) (* ; "Unshade command. DOLAFITESENDINGCOMMAND shaded it to begin with"))) (COND (DONE (* ; "Message successfully dispatched") (PROCESSPROP (THIS.PROCESS) (QUOTE RESTARTABLE) NIL) (* ; "Don't try to restart if there's any sort of error now") (COND (CURRENTMESSAGE (* ; "Mark text unchanged now, so no trouble closing icon") (TEDIT.STREAMCHANGEDP CURRENTMESSAGE T))) (COND ((NULL SENTOK) (CLOSEW EDITORWINDOW)) (T (* ; "shrink the window") (\LAFITE.AFTER.DELIVER EDITORWINDOW CURRENTMESSAGE PARSE))) (RETURN SENTOK)) (T (* ; "Loop if deliver failed or \LAFITE.SAVE.FORM was aborted."))))) -) (\SENDMESSAGE.CLEANUP -(LAMBDA (EDITORWINDOW) (* ; "Edited 6-Oct-87 15:58 by bvm:") (SETQ LAFITECURRENTEDITORWINDOWS (REMOVE EDITORWINDOW LAFITECURRENTEDITORWINDOWS))) -) (\SENDMESSAGE.MAKEWINDOW -(LAMBDA (MESSAGEFORM TITLE WINDOW MODE) (* ; "Edited 3-Nov-89 16:16 by bvm") (* ;;; "Editor for Mail system Lafite -- Handles the process mechanism right") (* ;;; "Assumes that it's running in a separate process created above") (PROG ((MENU (MAKELAFITEDELIVERMENU)) EDITWINDOW LAYOUT REGION) (COND ((NOT TITLE) (SETQ TITLE "Message Editor") (if (AND MODE (LAFITE.SHOW.MODE.P)) then (SETQ TITLE (CONCAT TITLE " (" MODE ")"))))) (COND ((WINDOWP (SETQ EDITWINDOW WINDOW)) (WINDOWPROP EDITWINDOW (QUOTE TITLE) TITLE) (for W in (ATTACHEDWINDOWS EDITWINDOW) when (WINDOWPROP W (QUOTE MENUWINDOW)) do (* ; "there's already an attached window menu, make sure we have a delivery menu in it.") (LET ((OLDMENU (CAR (WINDOWPROP W (QUOTE MENU))))) (if (if (NULL OLDMENU) then (* ; "E.g., after ABORT got removed") T elseif (NOT (EQUAL (fetch (MENU ITEMS) of MENU) (fetch (MENU ITEMS) of OLDMENU))) then (DELETEMENU OLDMENU NIL W) (* ; "Get rid of different menu") T else (SETQ MENU OLDMENU) (* ; "They're the same, don't fuss") NIL) else (ADDMENU MENU W (QUOTE (0 . 0))) (* ; "Now make it fit") (MENUWRESHAPEFN W))) (RETURN) finally (* ; "No attached menu yet") (ATTACHWINDOW (SETQ W (MENUWINDOW MENU)) EDITWINDOW (QUOTE TOP)) (WINDOWPROP W (QUOTE MENUWINDOW) T))) (T (SETQ REGION (if (for old LAYOUT in LAFITE.EDITOR.LAYOUTS unless (for WINDOW in LAFITECURRENTEDITORWINDOWS thereis (EQ (WINDOWPROP WINDOW (QUOTE LAFITE.LAYOUT)) LAYOUT)) do (* ; "Use first layout not already in use") (RETURN (CAR LAYOUT))) elseif (AND (NULL LAFITECURRENTEDITORWINDOWS) (type? REGION LAFITEEDITORREGION)) then (* ; "Old way of doing this for a single window") LAFITEEDITORREGION elseif LAFITE.EDITOR.SIZE then (* ; "Get window of appropriate size") (GETBOXREGION (CAR LAFITE.EDITOR.SIZE) (CDR LAFITE.EDITOR.SIZE)) else (GETREGION))) (SETQ EDITWINDOW (CREATEMENUEDWINDOW MENU TITLE (QUOTE TOP) (create REGION using REGION HEIGHT _ (- (fetch (REGION HEIGHT) of REGION) (HEIGHTIFWINDOW (FONTPROP LAFITEEDITORFONT (QUOTE HEIGHT))))))) (WINDOWPROP (CAR (ATTACHEDWINDOWS EDITWINDOW)) (QUOTE MENUWINDOW) T) (if LAYOUT then (WINDOWPROP EDITWINDOW (QUOTE LAFITE.LAYOUT) LAYOUT) (WINDOWPROP EDITWINDOW (QUOTE ICONPOSITION) (CADR LAYOUT))))) (GETPROMPTWINDOW EDITWINDOW 1 LAFITEEDITORFONT) (COND (NIL (* ; "don't let TEDIT close the window") (WINDOWADDPROP EDITWINDOW (QUOTE CLOSEFN) (QUOTE DON'T)))) (PROGN (WINDOWDELPROP EDITWINDOW (QUOTE CLOSEFN) (FUNCTION CLOSEATTACHEDWINDOWS)) (* ; "On closing, get rid of attachments, don't just close them") (WINDOWADDPROP EDITWINDOW (QUOTE CLOSEFN) (FUNCTION DETACHALLWINDOWS)) (WINDOWADDPROP EDITWINDOW (QUOTE CLOSEFN) (FUNCTION \LAFITE.CLOSEMSG?) T)) (WINDOWPROP EDITWINDOW (QUOTE ICONFN) (FUNCTION \LAFITE.UNSENT.ICON)) (WINDOWPROP EDITWINDOW (QUOTE PROCESS) (THIS.PROCESS)) (* ; "Associate this process with the edit window") (replace (MENU WHENSELECTEDFN) of MENU with (FUNCTION DOLAFITESENDINGCOMMAND)) (* ; "Enable the menu") (RETURN EDITWINDOW))) -) (MAKELAFITEDELIVERMENU -(LAMBDA NIL (* bvm%: "28-Mar-84 12:47") (create MENU ITEMS _ LAFITESENDINGMENUITEMS CENTERFLG _ T MENUFONT _ LAFITEMENUFONT WHENSELECTEDFN _ (FUNCTION DOLAFITESENDINGCOMMAND))) -) (\LAFITE.CLOSEMSG? -(LAMBDA (WINDOW) (* ; "Edited 3-Sep-87 17:21 by bvm:") (* ;; "This is the first CLOSEFN on a message sending window. If contents have changed, get confirmation") (LET ((TEXTSTREAM (WINDOWPROP WINDOW (QUOTE TEXTSTREAM)))) (COND ((OR (NULL TEXTSTREAM) (NOT (TEDIT.STREAMCHANGEDP TEXTSTREAM))) (* ; "TEXTSTREAM is null once TEdit's gotten thru with it.") NIL) ((MOUSECONFIRM "Message has been edited -- LEFT to flush anyway" T (GETPROMPTWINDOW WINDOW)) (TEDIT.STREAMCHANGEDP TEXTSTREAM T) (* ; "Reset bit so question doesn't get asked a second time") NIL) (T (QUOTE DON'T))))) -) (\LAFITE.AFTER.DELIVER -(LAMBDA (EDITORWINDOW TEXTSTREAM PARSE) (* ; "Edited 30-May-90 16:25 by bvm") (TEDIT.ASSURE.NO.BACKING.FILE TEXTSTREAM) (* ; "In case the backing file gets deleted") (\OUTBOX.ADD.ITEM TEXTSTREAM (OR (CAR PARSE) UNSUPPLIEDFIELDSTR)) (LET ((FORMNAME (WINDOWPROP EDITORWINDOW (QUOTE LAFITEFORM) NIL))) (if (AND FORMNAME (EQ (CAR (UNPACKFILENAME.STRING FORMNAME)) (QUOTE NAME))) then (* ;; "See if user wants to keep the form, or if it was saved just as a checkpoint. Do this only for files saved in primary directory") (LET* ((PWINDOW (GETPROMPTWINDOW EDITORWINDOW)) (MENUW (find W in (ATTACHEDWINDOWS EDITORWINDOW) suchthat (WINDOWPROP W (QUOTE MENUWINDOW)))) (MENU (create MENU ITEMS _ (QUOTE (("Delete File" T "Delete the file(s) in which this message was earlier saved.") ("Retain Saved Form" NIL "Don't delete the saved form, I want to use it again."))) WHENSELECTEDFN _ (FUNCTION (LAMBDA (ITEM MENU KEY) (LET ((W (WFROMMENU MENU))) (WINDOWPROP W (QUOTE RESULT) ITEM) (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE)))) MENUFONT _ LAFITEMENUFONT CENTERFLG _ T ITEMWIDTH _ (IQUOTIENT (WINDOWPROP PWINDOW (QUOTE WIDTH)) 2) MENUROWS _ 1)) RESULT (MSG (CONCAT "Delivery complete. Do you want to delete the saved form of this message (" FORMNAME ")?"))) (LA.ASSURE.PROMPT.WINDOW EDITORWINDOW MSG) (TERPRI PWINDOW) (PRIN3 MSG PWINDOW) (ADDMENU MENU MENUW (QUOTE (0 . 0))) (until (SETQ RESULT (WINDOWPROP MENUW (QUOTE RESULT))) do (BLOCK 500)) (if (CADR RESULT) then (PRINTOUT PWINDOW T "Deleting file(s)... " (if (\LAFITE.DELETE.FORM.INTERNAL FORMNAME) then "done." else "failed.")))))) (DETACHALLWINDOWS EDITORWINDOW) (CLOSEW EDITORWINDOW)) -) (\LAFITE.UNSENT.ICON -(LAMBDA (WINDOW OLDICON) (* ; "Edited 24-Sep-87 16:58 by bvm:") (TITLEDICONW LAFITE.MSG.ICON (\LAFITE.FETCH.SUBJECT (WINDOWPROP WINDOW (QUOTE TEXTSTREAM))) LAFITEMSGICONFONT (WINDOWPROP WINDOW (QUOTE ICONPOSITION)) T)) -) (\LAFITE.FETCH.SUBJECT -(LAMBDA (TEXTSTREAM) (* bvm%: " 2-Mar-86 16:27") (COND (TEXTSTREAM (RESETLST (RESETSAVE NIL (LIST (FUNCTION SETFILEINFO) TEXTSTREAM (QUOTE ENDOFSTREAMOP) (GETFILEINFO TEXTSTREAM (QUOTE ENDOFSTREAMOP)))) (SETFILEINFO TEXTSTREAM (QUOTE ENDOFSTREAMOP) (FUNCTION \LAFITE.EOF)) (LET ((STR (LAFITE.PARSE.HEADER TEXTSTREAM \LAPARSE.SUBJECTFIELD 0 NIL T))) (COND ((STRING-EQUAL STR SUBJECTSTR) UNSUPPLIEDFIELDSTR) (T STR))))))) -) (LAFITE.SENDMESSAGE -(LAMBDA (MESSAGEFORM) (* ; "Edited 12-Sep-88 14:07 by bvm") (* ;;; "this is the external interface to sending a message") (SETQ MESSAGEFORM (OPENTEXTSTREAM MESSAGEFORM)) (LET* ((MODE (TEXTPROP MESSAGEFORM (QUOTE LAFITEMODE))) (*LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA MODE)) PARSE) (AND *LAFITE-MODE-DATA* (SETQ PARSE (CL:FUNCALL (fetch (LAFITEMODEDATA SENDPARSER) of *LAFITE-MODE-DATA*) MESSAGEFORM)) (CL:FUNCALL (fetch (LAFITEMODEDATA SENDER) of *LAFITE-MODE-DATA*) MESSAGEFORM PARSE)))) -) (\SENDMESSAGE0 -(LAMBDA (TEXTSTREAM WINDOW PARSE) (* ; "Edited 12-Sep-88 14:04 by bvm") (PROG ((PWINDOW (GETPROMPTWINDOW WINDOW)) *LAFITE-MODE-DATA* MENUW OLDMENU ABORTMENU RESULT) (for W in (ATTACHEDWINDOWS WINDOW) when (SETQ OLDMENU (CAR (WINDOWPROP W (QUOTE MENU)))) do (SETQ MENUW W) (DELETEMENU OLDMENU NIL MENUW) (* ; "Remove Deliver menu, add Abort menu") (ADDMENU (SETQ ABORTMENU (create MENU ITEMS _ (QUOTE (("Abort" NIL "Abort delivery of this message"))) WHENSELECTEDFN _ (FUNCTION \SENDMESSAGE.ABORT) MENUFONT _ LAFITEMENUFONT CENTERFLG _ T ITEMWIDTH _ (fetch ITEMWIDTH of OLDMENU))) MENUW (QUOTE (0 . 0))) (RETURN)) (if (NULL (SETQ *LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA (TEXTPROP TEXTSTREAM (QUOTE LAFITEMODE))))) then (printout PWINDOW "Failed to authenticate user.") else (SETQ RESULT (ERSETQ (RESETLST (CL:FUNCALL (fetch (LAFITEMODEDATA SENDER) of *LAFITE-MODE-DATA*) TEXTSTREAM PARSE WINDOW MENUW)))) (COND ((NULL RESULT) (printout PWINDOW "aborted.")) ((SETQ RESULT (CAR RESULT)) (printout PWINDOW "done.")))) (RETURN (COND (RESULT (* ; "Success") (CLOSEF TEXTSTREAM) (* ; "Explicit Close here after successful delivery so that TEdit can close any files it might have open") RESULT) (T (* ; "Restore Deliver menu") (COND ((WINDOWPROP MENUW (QUOTE MENU)) (DELETEMENU ABORTMENU NIL MENUW))) (ADDMENU OLDMENU MENUW (QUOTE (0 . 0)) NIL) (WINDOWPROP MENUW (QUOTE ABORT) NIL) NIL))))) -) (LA.ASSURE.PROMPT.WINDOW -(LAMBDA (MAINWINDOW MESS1 MESS2) (* bvm%: "24-Feb-85 18:33") (* ;;; "Returns prompt window for MAINWINDOW assuring that it is big enough to print MESS1 and MESS2") (LET ((PWINDOW (GETPROMPTWINDOW MAINWINDOW)) %#LINES) (COND ((> (SETQ %#LINES (QUOTIENT (+ (STRINGWIDTH MESS1 PWINDOW) (COND (MESS2 (STRINGWIDTH MESS2 PWINDOW)) (T 0))) (WINDOWPROP PWINDOW (QUOTE WIDTH)))) 0) (* ; "Make sure prompt window is big enough") (GETPROMPTWINDOW MAINWINDOW (ADD1 %#LINES))) (T PWINDOW)))) -) (\LAFITE.SEND.FAIL -(LAMBDA (EDITORWINDOW ERRMSG) (* bvm%: "24-Feb-85 18:38") (* ;; "Print a message explaining why delivery failed") (LET ((FULLMSG (CONCAT "Delivery failed -- " ERRMSG)) PWINDOW) (COND (EDITORWINDOW (CLEARW (SETQ PWINDOW (LA.ASSURE.PROMPT.WINDOW EDITORWINDOW FULLMSG)))) (T (TERPRI (SETQ PWINDOW PROMPTWINDOW)))) (PRIN3 FULLMSG PWINDOW) NIL)) -) (\LAFITE.INVALID.RECIPIENTS -(LAMBDA (NAMES) (* bvm%: " 5-Nov-84 15:26") (* ;;; "Returns an 'invalid recipients' error string") (PROG (NAME) (SETQ NAME (for RECIPIENT in NAMES join (LIST ", " RECIPIENT))) (RPLACA NAME ": ") (COND ((CDR NAMES) (push NAME "s"))) (RETURN (CONCATLIST (CONS "Invalid recipient" NAME))))) -) (\SENDMESSAGE.ABORT -(LAMBDA (ITEM MENU KEY) (* bvm%: " 1-Jun-84 12:21") (* ; "The WHENSELECTEDFN for the Abort menu") (PROG ((W (WFROMMENU MENU))) (WINDOWPROP W (QUOTE ABORT) T) (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE))) -) ) (* ; "Outbox hacking") (DEFINEQ (\OUTBOX.CREATE -(LAMBDA NIL (* bvm%: "21-Dec-84 22:35") (PROG (FONT NLINES W FONTHEIGHT) (OR (AND LAFITESTATUSWINDOW (FIXP (SETQ NLINES LAFITEOUTBOXSIZE)) (IGREATERP NLINES 0)) (RETURN)) (SETQ FONTHEIGHT (FONTPROP (SETQ FONT LAFITEBROWSERFONT) (QUOTE HEIGHT))) (SETQ W (CREATEW (CREATEREGION 0 0 (WINDOWPROP LAFITESTATUSWINDOW (QUOTE WIDTH)) (HEIGHTIFWINDOW (ITIMES NLINES FONTHEIGHT) T)) "Delivered Messages" NIL T)) (ATTACHWINDOW W LAFITESTATUSWINDOW (QUOTE BOTTOM) (QUOTE JUSTIFY) (QUOTE LOCALCLOSE)) (DSPFONT FONT W) (WINDOWADDPROP W (QUOTE CLOSEFN) (FUNCTION \OUTBOX.CLOSEFN)) (WINDOWPROP W (QUOTE REPAINTFN) (FUNCTION \OUTBOX.REPAINTFN)) (WINDOWPROP W (QUOTE BUTTONEVENTFN) (FUNCTION \OUTBOX.BUTTONFN)) (WINDOWPROP W (QUOTE RESHAPEFN) (FUNCTION \OUTBOX.RESHAPEFN)) (WINDOWPROP W (QUOTE MINSIZE) (CONS 0 (HEIGHTIFWINDOW FONTHEIGHT T))) (RETURN (SETQ \LAFITE.OUTBOX (\OUTBOX.RESET (create OUTBOX OBWINDOW _ W OBSIZE _ NLINES OBHEIGHT _ FONTHEIGHT OBDESCENT _ (FONTPROP FONT (QUOTE DESCENT)))))))) -) (\OUTBOX.RESET -(LAMBDA (OUTBOX) (* bvm%: " 9-Nov-84 16:29") (PROG ((WINDOW (fetch OBWINDOW of OUTBOX))) (CLEARW WINDOW) (LINELENGTH MAX.SMALLP WINDOW) (DSPRIGHTMARGIN MAX.SMALLP WINDOW) (replace OBORIGIN of OUTBOX with (IPLUS (DSPYPOSITION NIL WINDOW) (fetch OBHEIGHT of OUTBOX))) (RETURN OUTBOX))) -) (\OUTBOX.CLOSEFN -(LAMBDA (WINDOW) (* bvm%: " 8-Nov-84 16:02") (SETQ \LAFITE.OUTBOX))) (\OUTBOX.REPAINTFN -(LAMBDA (WINDOW REGION) (* bvm%: "13-Nov-84 10:57") (PROG ((OUTBOX \LAFITE.OUTBOX)) (OR (EQ WINDOW (fetch OBWINDOW of OUTBOX)) (RETURN)) (MOVETO 0 (IDIFFERENCE (fetch OBORIGIN of OUTBOX) (fetch OBHEIGHT of OUTBOX)) WINDOW) (for ITEM in (fetch OBITEMS of OUTBOX) do (\OUTBOX.DISPLAYLINE OUTBOX ITEM) (TERPRI WINDOW)))) -) (\OUTBOX.RESHAPEFN -(LAMBDA (WINDOW OLDIMAGE IMAGEREGION OLDSCREENREGION) (* bvm%: "13-Nov-84 10:57") (COND ((EQ WINDOW (fetch OBWINDOW of \LAFITE.OUTBOX)) (PROG ((NLINES (IQUOTIENT (WINDOWPROP WINDOW (QUOTE HEIGHT)) (fetch OBHEIGHT of \LAFITE.OUTBOX))) (OLDSIZE (fetch OBSIZE of \LAFITE.OUTBOX)) N ITEMS) (COND ((NEQ NLINES OLDSIZE) (replace OBSIZE of \LAFITE.OUTBOX with NLINES) (COND ((AND (ILESSP NLINES OLDSIZE) (IGREATERP (SETQ N (IDIFFERENCE (LENGTH (SETQ ITEMS (fetch OBITEMS of \LAFITE.OUTBOX))) NLINES)) 0)) (replace OBITEMS of \LAFITE.OUTBOX with (CDR (NTH ITEMS N))))))) (\OUTBOX.RESET \LAFITE.OUTBOX) (REDISPLAYW WINDOW))))) -) (\OUTBOX.SHADEITEM -(LAMBDA (OUTBOX ITEM N SHADE OPERATION) (* ; "Edited 3-Sep-87 17:24 by bvm:") (* ;;; "Shade the indicated ITEM in OUTBOX using texture SHADE blted with OPERATION") (PROG ((W (fetch OBWINDOW of OUTBOX)) HEIGHT) (BLTSHADE SHADE W 0 (- (fetch OBORIGIN of OUTBOX) (+ (ITIMES N (SETQ HEIGHT (fetch OBHEIGHT of OUTBOX))) (fetch OBDESCENT of OUTBOX))) NIL HEIGHT OPERATION) (COND ((EQ OPERATION (QUOTE REPLACE)) (\OUTBOX.DISPLAYLINE OUTBOX ITEM N))))) -) (\OUTBOX.BUTTONFN -(LAMBDA (WINDOW) (* bvm%: "13-Nov-84 10:58") (* ;;; "BUTTONEVENTFN for the outbox. If a message is selected, edit it") (PROG ((SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) (OUTBOX \LAFITE.OUTBOX) SELECTED SEL# NEWSEL# ITEMS HEIGHT ORIGIN DESCENT LASTX LASTY MAXITEM) (COND ((OR (NOT (SETQ ITEMS (fetch OBITEMS of OUTBOX))) (NEQ WINDOW (fetch OBWINDOW of OUTBOX))) (* ; "Nothing to select") (RETURN))) (SETQ MAXITEM (LENGTH ITEMS)) (SETQ HEIGHT (fetch OBHEIGHT of OUTBOX)) (SETQ DESCENT (fetch OBDESCENT of OUTBOX)) (SETQ ORIGIN (fetch OBORIGIN of OUTBOX)) (* ;; "keep looping until all mouse buttons are up") (do (GETMOUSESTATE) (COND ((OR (NOT (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW)))) (> (SETQ NEWSEL# (ADD1 (QUOTIENT (- ORIGIN (+ LASTY DESCENT)) HEIGHT))) MAXITEM)) (* ;; "I would like to just return here and let the next window take over, but current mouse arrangement means I'll never get control back unless user lets up on mouse") (COND (SELECTED (\OUTBOX.SHADEITEM OUTBOX SELECTED SEL# BLACKSHADE (QUOTE INVERT)) (SETQ SELECTED (SETQ SEL# NIL)))) (COND ((LASTMOUSESTATE UP) (RETURN)) (T (BLOCK)))) ((LASTMOUSESTATE UP) (* ; "Let mouse up while over a selection. Do it") (COND (SELECTED (\LAFITE.PROCESS (LIST (FUNCTION \SENDMESSAGE) (KWOTE (COPYTEXTSTREAM (fetch OBITEXT of SELECTED)))) (QUOTE MESSAGESENDER) T (QUOTE NO)) (\OUTBOX.SHADEITEM OUTBOX SELECTED SEL# BLACKSHADE (QUOTE INVERT)))) (RETURN)) ((NEQ NEWSEL# SEL#) (COND (SELECTED (\OUTBOX.SHADEITEM OUTBOX SELECTED SEL# BLACKSHADE (QUOTE INVERT)))) (\OUTBOX.SHADEITEM OUTBOX (SETQ SELECTED (CAR (NTH ITEMS (SETQ SEL# NEWSEL#)))) SEL# BLACKSHADE (QUOTE INVERT))))))) -) (\OUTBOX.DISPLAYLINE -(LAMBDA (OUTBOX ITEM N) (* bvm%: " 8-Nov-84 21:35") (PROG ((W (fetch OBWINDOW of OUTBOX))) (COND (N (MOVETO 0 (IDIFFERENCE (fetch OBORIGIN of OUTBOX) (ITIMES N (fetch OBHEIGHT of OUTBOX))) W))) (printout W (fetch OBIDATE of ITEM) %,, (fetch OBISUBJECT of ITEM)))) -) (\OUTBOX.ADD.ITEM -(LAMBDA (TEXTSTREAM SUBJECT) (* ; "Edited 3-Sep-87 18:08 by bvm:") (PROG ((OUTBOX (OR \LAFITE.OUTBOX (\OUTBOX.CREATE))) W N ITEM BOTTOM HEIGHT ITEMS) (OR OUTBOX (RETURN)) (COND ((>= (SETQ N (LENGTH (SETQ ITEMS (fetch OBITEMS of OUTBOX)))) (fetch OBSIZE of OUTBOX)) (replace OBITEMS of OUTBOX with (SETQ ITEMS (CDR ITEMS))) (BITBLT (SETQ W (fetch OBWINDOW of OUTBOX)) 0 (SETQ BOTTOM (- (fetch OBORIGIN of OUTBOX) (+ (ITIMES N (SETQ HEIGHT (fetch OBHEIGHT of OUTBOX))) (fetch OBDESCENT of OUTBOX)))) W 0 (+ BOTTOM HEIGHT) NIL (ITIMES HEIGHT (SUB1 N)) (QUOTE INPUT) (QUOTE REPLACE)) (BLTSHADE WHITESHADE W 0 BOTTOM NIL HEIGHT (QUOTE REPLACE))) (T (SETQ N (ADD1 N)))) (replace OBITEMS of OUTBOX with (NCONC1 ITEMS (SETQ ITEM (create OUTBOXITEM OBITEXT _ TEXTSTREAM OBIDATE _ (DATE (DATEFORMAT NO.DATE NO.SECONDS)) OBISUBJECT _ SUBJECT)))) (\OUTBOX.DISPLAYLINE OUTBOX ITEM N))) -) ) (RPAQ? LAFITEOUTBOXSIZE 2) (RPAQ? \LAFITE.OUTBOX ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD OUTBOXITEM (OBITEXT OBIDATE OBISUBJECT OBIWINDOW)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS LAFITEOUTBOXSIZE) ) ) (* ; "Built-in message forms") (DEFINEQ (\LAFITE.MESSAGEFORM -(LAMBDA (ITEM MENU BUTTON) (* ; "Edited 23-Feb-89 12:50 by bvm") (COND ((NULL (OR \LAFITEMODE (\LAFITE.INFER.MODE))) (printout PROMPTWINDOW T "Must set Lafite Mode before sending mail")) (T (RESETLST (AND ITEM (LA.RESETSHADE ITEM MENU)) (PROG ((*UPPER-CASE-FILE-NAMES* NIL) FORM FORMNAME FULLFORMNAME) (COND ((EQ BUTTON (QUOTE LEFT)) (SETQ FORM (MAKENEWMESSAGEFORM))) ((NOT (SETQ FORM (MENU (.LAFITEMENU. LAFITEFORMSMENU (APPEND (MAKELAFITEPRIVATEFORMSITEMS "Use the form defined in this file.") LAFITESPECIALFORMS LAFITEFORMSMENUITEMS) "Message Forms")))) (RETURN)) ((EQ FORM (QUOTE %##ANOTHERFORM##)) (* ; "user buttoned 'Another Form'") (OR (SETQ FORMNAME (PROMPTFORFILENAME)) (RETURN))) ((DEFINEDP FORM) (OR (SETQ FORM (CL:FUNCALL FORM)) (RETURN))) ((BOUNDP FORM) (SETQ FORM (OR (EVALV FORM) (MAKENEWMESSAGEFORM)))) (T (* ; "other private form") (SETQ FORMNAME FORM))) (COND ((NULL FORMNAME) (* ; "Have form already")) ((OR (SETQ FULLFORMNAME (INFILEP (LA.LONGFILENAME FORMNAME LAFITEFORM.EXT))) (AND LAFITEFORMDIRECTORIES (SETQ FULLFORMNAME (FINDFILE (PACKFILENAME.STRING (QUOTE BODY) FORMNAME (QUOTE EXTENSION) LAFITEFORM.EXT) T LAFITEFORMDIRECTORIES)))) (* ; "read the form and return it") (COND ((NOT (CL:MEMBER (SETQ FORMNAME (LA.SHORTFILENAME FULLFORMNAME LAFITEFORM.EXT)) LAFITEFORMFILES :TEST (QUOTE STRING-EQUAL))) (push LAFITEFORMFILES FORMNAME) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFORMSMENU))) (SETQ FORM (\LAFITE.READ.FORM FULLFORMNAME))) (T (printout PROMPTWINDOW T FORMNAME " not found.") (RETURN))) (ADD.PROCESS (LIST (FUNCTION \SENDMESSAGE) (KWOTE FORM) NIL (KWOTE FORMNAME)) (QUOTE NAME) (QUOTE MESSAGESENDER) (QUOTE RESTARTABLE) (QUOTE NO)) (* ; "Finally, start authenticating if we haven't yet.") (\LAFITE.GET.USER.DATA (AND (TEXTSTREAMP FORM) (TEXTPROP FORM (QUOTE LAFITEMODE))))))))) -) (MAKELAFITESUPPORTFORM -(LAMBDA NIL (* bvm%: "12-Mar-85 00:39") (MAKEXXXSUPPORTFORM "Lafite" LAFITESUPPORT LAFITESYSTEMDATE))) (MAKELISPSUPPORTFORM -(LAMBDA NIL (* bvm%: "12-Mar-85 00:39") (MAKEXXXSUPPORTFORM "Lisp" LISPSUPPORT))) (MAKEXXXSUPPORTFORM -(LAMBDA (SYSTEMNAME ADDRESS SYSTEMDATE) (* ; "Edited 3-May-89 18:37 by bvm") (PROG ((SUBJFIELD ">>Terse summary of problem<<") (UCODEVERSION (MICROCODEVERSION)) (SCRATCH (OPENSTREAM "{nodircore}" (QUOTE BOTH))) TEXTSTREAM SELECTPOSITION MODE) (COND ((LISTP ADDRESS) (* ; "Mode-dependent address. Pick the first address that's in a mode we know how to send") (SETQ ADDRESS (for PAIR in ADDRESS when (\LAFITE.GET.USER.DATA (SETQ MODE (CAR PAIR))) do (RETURN (CADR PAIR))))) (T (* ; "Just send in current mode") (SETQ MODE (fetch LAFITEMODE of \LAFITEMODE)))) (COND ((NOT ADDRESS) (printout PROMPTWINDOW T "Can't -- no address known for " SYSTEMNAME " report.") (RETURN))) (SETQ TEXTSTREAM (OPENTEXTSTREAM (CONCAT "Subject: " SYSTEMNAME ": ") NIL NIL NIL (LIST (QUOTE FONT) LAFITEEDITORFONT))) (SETQ SELECTPOSITION (ADD1 (GETEOFPTR TEXTSTREAM))) (PROGN (* ; "Now write the main stuff to a scratch stream. faster than bouting a byte at a time to tedit") (printout SCRATCH SUBJFIELD T) (printout SCRATCH "To: " ADDRESS T) (printout SCRATCH "cc: " (FULLUSERNAME NIL MODE) T T) (COND (SYSTEMDATE (printout SCRATCH SYSTEMNAME " System Date: " SYSTEMDATE T))) (printout SCRATCH "Lisp System Date: " MAKESYSDATE " (" (L-CASE (MKSTRING MAKESYSNAME) T) ")" T) (printout SCRATCH "Machine: " (OR \LAFITE.REPORT.MACHINE (PROGN (SETQ \LAFITE.REPORT.MACHINE (L-CASE (MACHINETYPE) T)) (COND ((EQ \PUP.READY T) (SETQ \LAFITE.REPORT.MACHINE (CONCAT \LAFITE.REPORT.MACHINE " (" (ETHERHOSTNAME NIL T) ")")))) \LAFITE.REPORT.MACHINE)) T) (printout SCRATCH "Microcode version: " .I1.8 (fetch HIBYTE of UCODEVERSION) "," .I1.8 (fetch LOBYTE of UCODEVERSION) T) (printout SCRATCH "Memory size: " .I4.8 (REALMEMORYSIZE) T) (printout SCRATCH "Frequency: >> Always, Intermittent, Once << -Impact: >> Fatal, Serious, Moderate, Annoying, Minor <<" T T) (printout SCRATCH ">>detailed problem description<<" T)) (TEDIT.SETSEL TEXTSTREAM SELECTPOSITION 0 (QUOTE RIGHT)) (TEDIT.INCLUDE TEXTSTREAM SCRATCH) (TEDIT.SETSEL TEXTSTREAM SELECTPOSITION (NCHARS SUBJFIELD) (QUOTE RIGHT) T) (TEXTPROP TEXTSTREAM (QUOTE LAFITEMODE) MODE) (RETURN TEXTSTREAM))) -) (MAKENEWMESSAGEFORM -(LAMBDA NIL (* ; "Edited 6-Jun-88 12:22 by bvm") (LET ((OUTSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (LIST (QUOTE FONT) LAFITEEDITORFONT))) SELECTPOSITION) (printout OUTSTREAM "Subject: ") (SETQ SELECTPOSITION (ADD1 (GETFILEPTR OUTSTREAM))) (printout OUTSTREAM SUBJECTSTR T) (printout OUTSTREAM "To: " RECIPIENTSSTR T) (printout OUTSTREAM "cc: " (FULLUSERNAME) T T) (printout OUTSTREAM MESSAGESTR T) (if LAFITE.SIGNATURE then (* ; "Pre-sign it") (PRIN3 LAFITE.SIGNATURE OUTSTREAM)) (TEDIT.SETSEL OUTSTREAM SELECTPOSITION (NCHARS SUBJECTSTR) (QUOTE RIGHT) T) OUTSTREAM)) -) (MAKELAFITEPRIVATEFORMSITEMS -(LAMBDA (HELPSTR) (* ; "Edited 23-Feb-89 12:38 by bvm") (for FORMFILE in (SORT LAFITEFORMFILES) when FORMFILE collect (BQUOTE ((\, (if (U-CASEP FORMFILE) then (CL:STRING-CAPITALIZE FORMFILE) else FORMFILE)) (QUOTE (\, FORMFILE)) (\, HELPSTR))))) -) (\LAFITE.UNCACHE.MESSAGEFORM -(LAMBDA (ITEM MENU) (* ; "Edited 8-Nov-89 12:38 by bvm") (LET ((FORM (\LAFITE.SELECT.FORM "Forget about this message form"))) (COND (FORM (SETQ LAFITEFORMFILES (DREMOVE FORM LAFITEFORMFILES)) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFORMSMENU) (printout PROMPTWINDOW T FORM " forgotten."))))) -) (\LAFITE.DELETE.MESSAGEFORM -(LAMBDA (ITEM MENU) (* ; "Edited 8-Nov-89 12:38 by bvm") (LET ((FORM (\LAFITE.SELECT.FORM "Delete this saved message"))) (if (AND FORM (PROGN (CLRPROMPT) (MOUSECONFIRM (CL:FORMAT NIL "Click LEFT to confirm deleting saved message '~A'" FORM) T PROMPTWINDOW))) then (\LAFITE.DELETE.FORM.INTERNAL FORM)))) -) (\LAFITE.SELECT.FORM -(LAMBDA (MSG) (* ; "Edited 8-Nov-89 12:37 by bvm") (COND ((NULL LAFITEFORMFILES) (printout PROMPTWINDOW T "You have no private message forms")) (T (MENU (\LAFITE.CREATE.MENU (MAKELAFITEPRIVATEFORMSITEMS MSG) "Private Forms"))))) -) (\LAFITE.DELETE.FORM.INTERNAL -(LAMBDA (FORMNAME) (* ; "Edited 8-Nov-89 12:34 by bvm") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (LONGNAME (LA.LONGFILENAME FORMNAME LAFITEFORM.EXT)) FULL) (while (SETQ FULL (FULLNAME LONGNAME (QUOTE OLDEST))) do (if (NOT (DELFILE FULL)) then (PRINTOUT PROMPTWINDOW T "Could not delete " FULL) (RETURN NIL)) finally (SETQ LAFITEFORMFILES (CL:DELETE FORMNAME LAFITEFORMFILES :TEST (QUOTE STRING-EQUAL))) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFORMSMENU) (PRINTOUT PROMPTWINDOW T FORMNAME " deleted.") (RETURN T)))) -) (\LAFITE.READ.FORM [LAMBDA (FILE) (* ;  "Edited 18-Jul-2000 03:09 by rmk:") (* ;  "Edited 18-Jul-2000 03:08 by rmk:") (* ; "Edited 2-Nov-89 15:55 by bvm") (* ;;; "copies the messaage form in the FILE into a text stream") (PROG ((TEXTSTREAM (OPENTEXTSTREAM [OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT] NIL NIL NIL (LIST 'FONT LAFITEEDITORFONT))) NAME CH) (SETFILEPTR TEXTSTREAM 0) (COND ([OR (EQ (SETQ CH (BIN TEXTSTREAM)) (CHARCODE %")) (AND (EQ CH (CHARCODE CR)) (EQ (BIN TEXTSTREAM) (CHARCODE %"] (* ;  "Old-style form, get rid of surrounding double quotes") (TEDIT.DELETE TEXTSTREAM 1 (ADD1 (GETFILEPTR TEXTSTREAM))) (TEDIT.DELETE TEXTSTREAM (GETEOFPTR TEXTSTREAM) 1))) [bind [OPENMARKER _ (CONSTANT (ALLOCSTRING 1 (CHARCODE ^A] J (I _ 1) while (SETQ I (TEDIT.FIND TEXTSTREAM OPENMARKER I)) do (* ;  "Change Laurel forms into Lafite forms") (COND ((AND (SETQ J (TEDIT.FIND TEXTSTREAM (CONSTANT (ALLOCSTRING 1 (CHARCODE ^B))) (ADD1 I) (IPLUS I 70))) (NOT (TEDIT.FIND TEXTSTREAM OPENMARKER (ADD1 I) J))) (TEDIT.DELETE TEXTSTREAM J 1) (TEDIT.INSERT TEXTSTREAM "<<" J) (TEDIT.DELETE TEXTSTREAM I 1) (TEDIT.INSERT TEXTSTREAM ">>" I) (SETQ I J)) (T (RETURN] (bind (I _ 1) while (SETQ I (TEDIT.FIND TEXTSTREAM ">>Self<<" I)) do (* ;  "Replace '>>Self<<' with user name") (OR NAME (SETQ NAME (FULLUSERNAME))) (TEDIT.DELETE TEXTSTREAM I 8) (TEDIT.INSERT TEXTSTREAM NAME I) (SETFILEPTR TEXTSTREAM I) (* ; "Patch around tedit bug...")) (\LAFITE.FIND.TEMPLATE TEXTSTREAM) (RETURN TEXTSTREAM]) (\LAFITE.FIND.TEMPLATE -(LAMBDA (TEXTSTREAM) (* bvm%: "22-Apr-84 23:59") (LET (SELECTSTART) (COND ((SETQ SELECTSTART (TEDIT.FIND TEXTSTREAM ">>*<<" 1 NIL T)) (* ; "Wait until TEDIT.FIND gets fixed") (* ; "highlight the first 'blank' to fill in") (COND ((LISTP SELECTSTART) (SETQ SELECTSTART (CAR SELECTSTART)))) (TEDIT.SETSEL TEXTSTREAM SELECTSTART (+ 2 (- (TEDIT.FIND TEXTSTREAM "<<" SELECTSTART) SELECTSTART)) (QUOTE RIGHT) T) T) (T (TEDIT.SETSEL TEXTSTREAM 1 0 (QUOTE LEFT)))))) -) ) (* ; "ANSWER") (DEFINEQ (\LAFITE.ANSWER -(LAMBDA (WINDOW FOLDERDATA ITEM MENU) (* bvm%: " 1-Feb-84 15:08") (ADD.PROCESS (LIST (FUNCTION \LAFITE.ANSWER.PROC) (KWOTE WINDOW) (KWOTE FOLDERDATA) (KWOTE ITEM) (KWOTE MENU)) (QUOTE NAME) (QUOTE MESSAGEANSWERER) (QUOTE RESTARTABLE) (QUOTE NO))) -) (\LAFITE.ANSWER.PROC -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* bvm%: "29-May-84 15:59") (PROG (MSGDESCRIPTOR FORM) (SETQ FORM (RESETLST (LA.RESETSHADE ITEM MENU) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (COND ((NOT (LAB.ASSURE.SELECTIONS MAILFOLDER)) (MAKEANSWERFORM (SETQ MSGDESCRIPTOR (find MSGDESCRIPTOR selectedin MAILFOLDER suchthat T)) MAILFOLDER)))))) (COND ((AND FORM (\SENDMESSAGE FORM)) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (PROG ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER))) (COND ((AND MESSAGES (EQ MSGDESCRIPTOR (NTHMESSAGE MESSAGES (fetch (LAFITEMSG %#) of MSGDESCRIPTOR)))) (* ; "If message got expunged since we constructed the answer form, we can't do anything") (MARKMESSAGE MSGDESCRIPTOR MAILFOLDER ANSWERMARK))))))))) -) (MAKEANSWERFORM -(LAMBDA (MSGDESCRIPTORS MAILFOLDER) (* ; "Edited 10-Aug-89 17:28 by bvm") (LET* ((FIRSTMSG (if (LISTP MSGDESCRIPTORS) then (CAR MSGDESCRIPTORS) else MSGDESCRIPTORS)) (MODEBITS (fetch (LAFITEMSG MODEBITS) of FIRSTMSG)) (MODE (CL:NTH MODEBITS *LAFITE-WELL-KNOWN-MODES*))) (if (NULL MODE) then (if (OR (NEQ MODEBITS 0) (NULL (SETQ MODE (\LAFITE.GUESS.MODE FIRSTMSG)))) then (LAB.PROMPTPRINT MAILFOLDER (if (EQ MODEBITS 0) then "Message of unknown protocol." else "Warning: This message was retrieved under a protocol not currently enabled.")) (LAB.PROMPTPRINT MAILFOLDER "Will answer in " (SETQ MODE (fetch (LAFITEOPS LAFITEMODE) of \LAFITEMODE)) " mode; this may not work. "))) (* ;; "Currently we only pay attention to the first message. If we ever do otherwise, we'll want to notice whether the other messages are in the same mode") (LET ((*LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA MODE)) MSG) (* ;; "Before returning the form, tag it with a mail mode") (if (NULL *LAFITE-MODE-DATA*) then (LAB.FORMAT MAILFOLDER "Failed: can't authenticate user in ~A mode" MODE) elseif (SETQ MSG (CL:FUNCALL (fetch (LAFITEMODEDATA ANSWERER) of *LAFITE-MODE-DATA*) MSGDESCRIPTORS MAILFOLDER)) then (if (TEXTSTREAMP MSG) then (TEXTPROP MSG (QUOTE LAFITEMODE) MODE) MSG else (OPENTEXTSTREAM MSG NIL NIL NIL (BQUOTE (LAFITEMODE (\, MODE))))))))) -) (LA.PRINT.COMMA.LIST -(LAMBDA (STRINGS STREAM) (* ; "Edited 6-Jun-88 12:50 by bvm") (for STR in STRINGS bind NTHTIME when STR do (COND (NTHTIME (PRIN3 ", " STREAM)) (T (SETQ NTHTIME T))) (PRIN3 STR STREAM))) -) (LAFITE.FILL.IN.ANSWER.FORM -(LAMBDA (SUBJECT FROM DATE TO CC ADDRESSPRINTFN) (* ; "Edited 10-Jun-88 17:19 by bvm") (* ;; "Construct an answer form replying to a message from FROM on DATE with specified SUBJECT. Reply should go to the lists of names TO and CC. ADDRESSPRINTFN is a function that prints a list of names suitably for the protocol in question.") (LET ((OUTSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (LIST (QUOTE FONT) LAFITEEDITORFONT))) SELECTPOSITION) (LINELENGTH MAX.SMALLP OUTSTREAM) (* ; "Sigh, apparently text streams have linelength") (PROGN (printout OUTSTREAM "Subject: ") (if SUBJECT then (COND ((NOT (STRING-EQUAL (SUBSTRING SUBJECT 1 3) "Re:")) (printout OUTSTREAM "Re: "))) (printout OUTSTREAM SUBJECT) else (printout OUTSTREAM "(reply to message)"))) (PROGN (printout OUTSTREAM T "In-reply-to: ") (if (NULL FROM) then (printout OUTSTREAM "your") else (printout OUTSTREAM FROM "'s")) (printout OUTSTREAM " message of " DATE T)) (PROGN (printout OUTSTREAM "To: ") (if TO then (CL:FUNCALL ADDRESSPRINTFN TO OUTSTREAM) else (* ; "No to, so ask to fill in") (printout OUTSTREAM RECIPIENTSSTR T)) (TERPRI OUTSTREAM)) (COND (CC (printout OUTSTREAM "cc: ") (CL:FUNCALL ADDRESSPRINTFN CC OUTSTREAM) (TERPRI OUTSTREAM))) (TERPRI OUTSTREAM) (SETQ SELECTPOSITION (ADD1 (GETFILEPTR OUTSTREAM))) (printout OUTSTREAM MESSAGESTR T) (if LAFITE.SIGNATURE then (* ; "Pre-sign it") (PRIN3 LAFITE.SIGNATURE OUTSTREAM)) (TEDIT.SETSEL OUTSTREAM SELECTPOSITION (NCHARS MESSAGESTR) (QUOTE RIGHT) T) OUTSTREAM)) -) ) (* ; "FORWARD") (DEFINEQ (\LAFITE.FORWARD -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* bvm%: " 1-Feb-84 15:05") (ADD.PROCESS (LIST (FUNCTION \LAFITE.FORWARD.PROC) (KWOTE WINDOW) (KWOTE MAILFOLDER) (KWOTE ITEM) (KWOTE MENU)) (QUOTE NAME) (QUOTE MESSAGEFORWARDER) (QUOTE RESTARTABLE) (QUOTE NO))) -) (\LAFITE.FORWARD.PROC -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* ; "Edited 14-Oct-87 16:20 by bvm:") (PROG (FORWARDEDMSGS FORM) (* ;; "the reason to get the MSG#S first is that they may have changed by the time \SENDMESSAGE finishes and then we would have marked the wrong ones") (RESETLST (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) NIL T) (LA.RESETSHADE ITEM MENU) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (COND ((NOT (LAB.ASSURE.SELECTIONS MAILFOLDER)) (SETQ FORM (MAKEFORWARDFORM WINDOW MAILFOLDER (SETQ FORWARDEDMSGS (LAB.SELECTED.MESSAGES MAILFOLDER))))))) (COND ((AND FORM (\SENDMESSAGE FORM)) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (PROG ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER))) (COND (MESSAGES (* ; "Make sure folder hasn't been closed since") (for MSG in FORWARDEDMSGS when (EQ MSG (NTHMESSAGE MESSAGES (fetch (LAFITEMSG %#) of MSG))) do (* ; "If message got expunged since we constructed the forward form, we can't do anything") (MARKMESSAGE MSG MAILFOLDER FORWARDMARK)))))))))) -) (MAKEFORWARDFORM -(LAMBDA (WINDOW FOLDER MESSAGELIST) (* ; "Edited 5-Jan-90 17:46 by bvm") (* ;; "Make a message form that forwards each of the messages in MESSAGELIST") (PROG ((FOLDERSTREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE INPUT) :ABORT)) (TEXTSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (LIST (QUOTE FONT) LAFITEEDITORFONT))) (CURMSG (CAR MESSAGELIST)) SUBJECT SELECTPOSITION SELECTLEN) (OR (fetch (LAFITEMSG PARSED?) of CURMSG) (LAFITE.PARSE.MSG.FOR.TOC CURMSG FOLDER)) (LINELENGTH MAX.SMALLP TEXTSTREAM) (PRIN3 "Subject: " TEXTSTREAM) (COND ((OR LAFITEFORWARDSUBJECTSTR (NULL (SETQ SUBJECT (fetch (LAFITEMSG SUBJECT) of CURMSG)))) (SETQ SELECTPOSITION (ADD1 (GETFILEPTR TEXTSTREAM))) (SETQ SELECTLEN (NCHARS (SETQ SUBJECT (OR LAFITEFORWARDSUBJECTSTR SUBJECTSTR)))) (PRIN3 SUBJECT TEXTSTREAM)) (T (CL:FORMAT TEXTSTREAM "[~@[~A: ~]~A]" (fetch (LAFITEMSG FROM) of CURMSG) SUBJECT))) (TERPRI TEXTSTREAM) (PRIN3 "To: " TEXTSTREAM) (COND ((NOT SELECTPOSITION) (SETQ SELECTPOSITION (ADD1 (GETFILEPTR TEXTSTREAM))) (SETQ SELECTLEN (NCHARS RECIPIENTSSTR)))) (CL:FORMAT TEXTSTREAM "~A + previous date%: " 3-Dec-2000 14:53:30" +{DSK}KAPLAN>LOCAL>MEDLEY3.5>GIT-MEDLEY>LIBRARY>LAFITE>LAFITESEND.;1) + + +(* ; " +Copyright (c) 1984-1990, 1993, 1999-2000, 2021 by Xerox Corporation. +") + +(PRETTYCOMPRINT LAFITESENDCOMS) + +(RPAQQ LAFITESENDCOMS + ((COMS (* ; "Sending mail") + (FNS DOLAFITESENDINGCOMMAND \SENDMESSAGE.INITIATE \SENDMSG.DELIVER \SENDMSG.EXIT.TEDIT + \SENDMSG.SAVE.FORM \LAFITE.HEADER.EOF \LAFITE.INSERT.REPLYTO \SENDMSG.REPLYTO + \SENDMSG.CHANGE.MODE \SENDMSG.FIND.FIELD \SENDMESSAGE.PARSE \LAFITE.PREPARE.SEND + \LAFITE.PREPARE.ERROR \LAFITE.CHOOSE.MSG.FORMAT LAFITE.MAKE.PLAIN.TEXTSTREAM + \SENDMESSAGE.MENUPROMPT \SENDMESSAGE.PROMPT \SENDMESSAGEFAIL) + (FNS \SENDMESSAGE \SENDMESSAGE.RESTARTABLE \SENDMESSAGE.CLEANUP \SENDMESSAGE.MAKEWINDOW + MAKELAFITEDELIVERMENU \LAFITE.CLOSEMSG? \LAFITE.AFTER.DELIVER \LAFITE.UNSENT.ICON + \LAFITE.FETCH.SUBJECT LAFITE.SENDMESSAGE \SENDMESSAGE0 LA.ASSURE.PROMPT.WINDOW + \LAFITE.SEND.FAIL \LAFITE.INVALID.RECIPIENTS \SENDMESSAGE.ABORT)) + (COMS (* ; "Outbox hacking") + (FNS \OUTBOX.CREATE \OUTBOX.RESET \OUTBOX.CLOSEFN \OUTBOX.REPAINTFN \OUTBOX.RESHAPEFN + \OUTBOX.SHADEITEM \OUTBOX.BUTTONFN \OUTBOX.DISPLAYLINE \OUTBOX.ADD.ITEM) + (INITVARS (LAFITEOUTBOXSIZE 2) + (\LAFITE.OUTBOX)) + (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS OUTBOXITEM) + (GLOBALVARS LAFITEOUTBOXSIZE))) + (COMS (* ; "Built-in message forms") + (FNS \LAFITE.MESSAGEFORM MAKELAFITESUPPORTFORM MAKELISPSUPPORTFORM MAKEXXXSUPPORTFORM + MAKENEWMESSAGEFORM MAKELAFITEPRIVATEFORMSITEMS \LAFITE.UNCACHE.MESSAGEFORM + \LAFITE.DELETE.MESSAGEFORM \LAFITE.SELECT.FORM \LAFITE.DELETE.FORM.INTERNAL + \LAFITE.READ.FORM \LAFITE.FIND.TEMPLATE)) + (COMS (* ; "ANSWER") + (FNS \LAFITE.ANSWER \LAFITE.ANSWER.PROC MAKEANSWERFORM LA.PRINT.COMMA.LIST + LAFITE.FILL.IN.ANSWER.FORM)) + (COMS (* ; "FORWARD") + (FNS \LAFITE.FORWARD \LAFITE.FORWARD.PROC MAKEFORWARDFORM)) + [COMS (VARS LAFITESENDINGMENUITEMS LAFITEFORMSMENUITEMS LAFITEFORMATMENUITEMS + LAFITEFORWARDSTRINGS) + (ADDVARS (\SYSTEMCACHEVARS \LAFITE.REPORT.MACHINE) + (LAFITESPECIALFORMS ("Lisp Report" (FUNCTION MAKELISPSUPPORTFORM) + "A form to report a Lisp bug or suggestion") + ("Lafite Report" (FUNCTION MAKELAFITESUPPORTFORM) + "A form to report a Lafite bug or suggestion")) + (LAFITEMENUVARS LAFITEFORMSMENU LAFITEFORMATMENU)) + (INITVARS (\LAFITE.REPORT.MACHINE) + (LAFITECURRENTEDITORWINDOWS) + (LAFITEFORMFILES) + (LAFITEFORMSMENU) + (LAFITEFORMATMENU)) + (INITVARS (LAFITEEDITORFONT LAFITEDISPLAYFONT) + (LAFITEFORM.EXT "Lafite-form") + (LAFITEFORMDIRECTORIES NIL) + (LAFITE.EDITOR.SIZE '(470 . 300)) + (LAFITE.EDITOR.LAYOUTS NIL) + (LAFITEFORWARDSUBJECTSTR NIL) + (LAFITESUPPORT NIL) + (LISPSUPPORT NIL) + (MESSAGESTR ">>Message<<") + (RECIPIENTSSTR ">>Recipients<<") + (SUBJECTSTR ">>Subject<<") + (LAFITE.SEND.FORMATTED '((NSCHARS :ASK) + (CHARLOOKS :ASK) + (PARALOOKS :ASK) + (IMAGEOBJ :ASK] + (COMS (* ; "Obsolete") + (INITVARS (LAFITEEDITORREGION NIL))) + (COMS (* ; "ICON stuff") + (VARS LAFITE.MSG.ICON)) + (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SENDINGCOMMAND) + (GLOBALVARS \LAFITE.REPORT.MACHINE LAFITECURRENTEDITORWINDOWS LAFITEEDITORFONT + LAFITEEDITORREGION LAFITEFORMATMENU LAFITEFORMSMENUITEMS LAFITEFORMATMENUITEMS + LAFITEFORWARDSTRINGS LAFITEFORWARDSUBJECTSTR LAFITESENDINGMENUITEMS + LAFITESPECIALFORMS LAFITESUPPORT LISPSUPPORT MAKESYSDATE MESSAGESTR + RECIPIENTSSTR SUBJECTSTR LAFITE.MSG.ICON LAFITEFORMDIRECTORIES + LAFITE.SEND.FORMATTED) + (FILES (SOURCE) + LAFITEDECLS) + (LOCALVARS . T)))) + + + +(* ; "Sending mail") + +(DEFINEQ + +(DOLAFITESENDINGCOMMAND + [LAMBDA (ITEM MENU KEY) (* bvm%: "31-Jul-84 15:03") + +(* ;;; "this function is invoked by buttoning the menu on top of the 'sending' window") + + (PROG ((WINDOW (WINDOWPROP (WFROMMENU MENU) + 'MAINWINDOW)) + PROC) + (AND (SETQ PROC (WINDOWPROP WINDOW 'PROCESS)) + (PROCESS.APPLY PROC (FUNCTION \SENDMESSAGE.INITIATE) + (LIST WINDOW MENU ITEM]) + +(\SENDMESSAGE.INITIATE + [LAMBDA (WINDOW MENU ITEM) (* ; "Edited 31-Jan-89 16:59 by bvm") + + (* ;; "Called by selecting a menu command from a message composition window") + + (ERSETQ (RESETLST + (LET ((COMMAND (EXTRACTMENUCOMMAND ITEM))) + (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (ITEM MENU) + (COND + (RESETSTATE + (* ; + "In case of error/abort, set menu & proc back to normal") + (SHADEITEM ITEM MENU WHITESHADE) + (replace (MENU WHENSELECTEDFN) + of MENU + with (FUNCTION + DOLAFITESENDINGCOMMAND)) + (PROCESSPROP (THIS.PROCESS) + 'BEFOREEXIT NIL] + ITEM MENU)) + (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE) + (* ; "Now disable the menu") + (replace (MENU WHENSELECTEDFN) of MENU with (FUNCTION NILL)) + (PROCESSPROP (THIS.PROCESS) + 'BEFOREEXIT + 'DON'T) (* ; "Don't let anyone logout now!") + (CL:FUNCALL COMMAND WINDOW (WINDOWPROP WINDOW 'TEXTSTREAM) + MENU ITEM)))]) + +(\SENDMSG.DELIVER + [LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 31-Jan-89 16:41 by bvm") + (LET (PARSE) + (printout (GETPROMPTWINDOW WINDOW) + T "Parsing...") + (OR (SETQ PARSE (\SENDMESSAGE.PARSE TEXTSTREAM WINDOW)) + (ERROR!)) + (\SENDMSG.EXIT.TEDIT WINDOW TEXTSTREAM + (create SENDINGCOMMAND + COMMAND _ '%##SEND## + ITEM _ ITEM + MENU _ MENU + MESSAGE _ TEXTSTREAM + MESSAGEPARSE _ PARSE]) + +(\SENDMSG.EXIT.TEDIT + [LAMBDA (WINDOW TEXTSTREAM VALUE) (* ; "Edited 31-Jan-89 16:39 by bvm") + (WINDOWADDPROP WINDOW 'CLOSEFN 'DON'T) (* ; + "Keep TEDIT.QUIT from closing the window") + (TEDIT.QUIT TEXTSTREAM VALUE) + (LA.DETACH.TEDIT TEXTSTREAM]) + +(\SENDMSG.SAVE.FORM + [LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 3-Nov-89 15:33 by bvm") + + (* ;; "Shortcut to TEdit Put that saves on mail directory and remembers it as a %"Saved Form%"") + + (LET ((*UPPER-CASE-FILE-NAMES* NIL) + (PROMPT "Save under name: ") + (FORMNAME (WINDOWPROP WINDOW 'LAFITEFORM)) + PWINDOW FORMFILE) + [COND + (FORMNAME (SETQ FORMNAME (LA.SHORTFILENAME FORMNAME LAFITEFORM.EXT] + (SETQ PWINDOW (LA.ASSURE.PROMPT.WINDOW WINDOW PROMPT (OR FORMNAME "XXX"))) + (* ; "Kludge to keep it small") + (CLEARW PWINDOW) + [COND + ((SETQ FORMFILE (PROMPTFORFILENAME PWINDOW FORMNAME PROMPT)) + (SETQ FORMNAME (LA.SHORTFILENAME (TEDIT.PUT TEXTSTREAM (LA.LONGFILENAME FORMFILE + LAFITEFORM.EXT) + NIL + (if (EQ (TEDIT.FORMATTEDFILEP TEXTSTREAM) + 'NSCHARS) + then + (* ; + "Force no formatting--TEdit defaultly saves formatting even if only ns chars") + T)) + LAFITEFORM.EXT)) + (WINDOWPROP WINDOW 'LAFITEFORM FORMNAME) + (COND + ((NOT (CL:MEMBER FORMNAME LAFITEFORMFILES :TEST 'STRING-EQUAL)) + (SETQ LAFITEFORMFILES (APPEND LAFITEFORMFILES (LIST FORMNAME))) + (SETQ \LAFITEPROFILECHANGED T) + (SETQ LAFITEFORMSMENU] + + (* ;; "Exit with error to restore window state (what a kludge)") + + (ERROR!]) + +(\LAFITE.HEADER.EOF + [LAMBDA (TEXTSTREAM) (* ; "Edited 3-Nov-89 14:29 by bvm") + + (* ;; "Return the character number in TEXTSTREAM of the blank line following the header") + + (ADD1 (CADAR (LAFITE.PARSE.HEADER TEXTSTREAM NIL 0 NIL NIL T]) + +(\LAFITE.INSERT.REPLYTO + [LAMBDA (TEXTSTREAM NAME HIGHLIGHT HEADEREOF) (* ; "Edited 3-Nov-89 12:57 by bvm") + + (* ;; "Insert a %"Reply-to: name%" field in this message. If HIGHLIGHT, leave the name pending-delete selected for potential replacement.") + + [TEDIT.INSERT TEXTSTREAM (CONCAT "Reply-to: " NAME LAFITEEOL) + (OR HEADEREOF (SETQ HEADEREOF (\LAFITE.HEADER.EOF TEXTSTREAM] + (if HIGHLIGHT + then (TEDIT.SETSEL TEXTSTREAM (+ HEADEREOF (CONSTANT (NCHARS "Reply-to: "))) + (NCHARS NAME) + 'RIGHT T]) + +(\SENDMSG.REPLYTO + [LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 3-Nov-89 14:03 by bvm") + + (* ;; "Add a Reply-to field to the message") + + (\LAFITE.INSERT.REPLYTO TEXTSTREAM [fetch (LAFITEMODEDATA FULLUSERNAME) + of (\LAFITE.GET.USER.DATA (TEXTPROP TEXTSTREAM + 'LAFITEMODE] + T) + + (* ;; "Exit with error to restore window state (what a kludge)") + + (ERROR!]) + +(\SENDMSG.CHANGE.MODE + [LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 5-Jan-90 18:06 by bvm") + (LET* + [(OLDMODE (TEXTPROP TEXTSTREAM 'LAFITEMODE)) + (OTHERMODES (for MODE in LAFITEMODELST unless (OR (EQ (fetch (LAFITEOPS + LAFITEMODE) + of MODE) + OLDMODE) + (NLISTP (CDR MODE))) + collect (fetch (LAFITEOPS LAFITEMODE) of MODE))) + (NEWMODE (if (NULL OTHERMODES) + then (\SENDMESSAGE.PROMPT WINDOW "There are no other modes") + elseif (CDR OTHERMODES) + then (MENU (\LAFITE.CREATE.MENU OTHERMODES "New mode")) + else (CAR OTHERMODES] + [if NEWMODE + then + (LET* ((TITLE (WINDOWPROP WINDOW 'TITLE)) + (OLDMODEDATA (\LAFITE.GET.USER.DATA OLDMODE)) + (NEWMODEDATA (\LAFITE.GET.USER.DATA NEWMODE)) + N N2) + (if (NULL NEWMODEDATA) + then (\SENDMESSAGE.PROMPT WINDOW (CL:FORMAT NIL + "Can't authenticate user in ~A mode" + NEWMODE)) + else (LET ((OLDNAME (fetch (LAFITEMODEDATA FULLUSERNAME) of OLDMODEDATA) + ) + (END (TEDIT.FIND TEXTSTREAM " + +" 1)) + START N LEN NEW OLDSEL) + (if END + then (add END 1)) (* ; + "Don't search past end of header. END now points at second cr.") + [for FIELD in '("cc" "Reply-to") + when [AND (SETQ N (\SENDMSG.FIND.FIELD TEXTSTREAM FIELD END + )) + (PROGN (SETQ LEN (CADR N)) + (SETQ N (CAR N)) + (SETQ START + (STRPOS OLDNAME + (SETQ OLDSEL + (TEDIT.SEL.AS.STRING TEXTSTREAM + (create SELECTION + CH# _ N + DCH _ LEN))) + NIL NIL NIL NIL UPPERCASEARRAY] + do (* ; "Change field containing old user name to new. This is much more complicated than it needs to be because TEDIT.FIND is case sensitive.") + (TEDIT.DELETE TEXTSTREAM N LEN) + (TEDIT.INSERT TEXTSTREAM + (SETQ NEW (CONCAT (OR (SUBSTRING OLDSEL 1 (SUB1 START) + ) + "") + (fetch (LAFITEMODEDATA + FULLUSERNAME) + of NEWMODEDATA) + (OR (SUBSTRING OLDSEL + (+ START (NCHARS OLDNAME)) + ) + ""))) + N) + (AND END (add END (- (NCHARS NEW) + LEN] + (if (SETQ N (\SENDMSG.FIND.FIELD TEXTSTREAM "To" END)) + then (* ; + "Leave the To field selected for address modification") + (TEDIT.SETSEL TEXTSTREAM (CAR N) + (CADR N) + 'RIGHT T)) + (TEXTPROP TEXTSTREAM 'LAFITEMODE NEWMODE) + (if (SETQ N (STRPOS (CONCAT "(" OLDMODE ")") + TITLE)) + then (WINDOWPROP WINDOW 'TITLE (CONCAT (SUBSTRING TITLE 1 N) + NEWMODE ")"))) + (\SENDMESSAGE.PROMPT WINDOW "Message mode is now " NEWMODE] + + (* ;; "Exit with error so that the window is restored to previous state") + + (ERROR!]) + +(\SENDMSG.FIND.FIELD + [LAMBDA (TEXTSTREAM FIELD END) (* ; "Edited 5-Jan-90 17:54 by bvm") + + (* ;; "Find and select the header field beginning with %"FIELD:%". Return starting index.") + + (LET* ((STR (CONCAT " +" FIELD ": ")) + (N (TEDIT.FIND TEXTSTREAM STR 1 END)) + N2) + (if (AND N (SETQ N2 (TEDIT.FIND TEXTSTREAM " +" (add N (NCHARS STR)) + END))) + then (LIST N (- N2 N]) + +(\SENDMESSAGE.PARSE + [LAMBDA (MSG EDITORWINDOW) (* ; "Edited 10-Aug-89 17:25 by bvm") + + (* ;; "Parse MSG in the current mode, returning a parse structure that the corresponding sender will be happy with") + + (LET* ((MODE (TEXTPROP MSG 'LAFITEMODE)) + (*LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA MODE))) + (if *LAFITE-MODE-DATA* + then (CL:FUNCALL (fetch (LAFITEMODEDATA SENDPARSER) of *LAFITE-MODE-DATA*) + MSG EDITORWINDOW) + else (\SENDMESSAGE.PROMPT EDITORWINDOW (CL:FORMAT NIL + "Can't authenticate user in ~A mode" + MODE]) + +(\LAFITE.PREPARE.SEND + [LAMBDA (MSG EDITORWINDOW PARSETABLE) (* bvm%: "13-Nov-84 12:50") + + (* ;; "Does generic things to MSG, a textstream about to be sent as a message: makes sure it ends in a CR, has no leading CRs, and parses it according to PARSETABLE which defaults to \LAPARSE.FULL -- returns a parse, whose first element tries to be (EOF end-of-header-position)") + + (PROG (MSGEOF HEADEREOF MSGFIELDS EOFINFO) + [COND + ((NOT (TYPENAMEP MSG 'STREAM)) + (RETURN (LISPERROR "ILLEGAL ARG" MSG] + [COND + (EDITORWINDOW (* ; + "Scroll so that beginning of message is visible") + (TEDIT.SETSEL MSG 1 0 'LEFT) + (TEDIT.NORMALIZECARET MSG) + (first (SETFILEPTR MSG 0) until (NEQ (BIN MSG) + (CHARCODE EOL)) + do (* ; "hack to get rid of leading CRs") + (TEDIT.DELETE MSG 1 1)) + [SETFILEPTR MSG (SUB1 (SETQ MSGEOF (GETEOFPTR MSG] + (COND + ((NEQ (BIN MSG) + (CHARCODE EOL)) (* ; "Make sure message ends in eol") + (TEDIT.INSERT MSG LAFITEEOL (ADD1 MSGEOF) + NIL T] + (SETFILEINFO MSG 'ENDOFSTREAMOP (FUNCTION \LAFITE.EOF)) + (* ; + "Avoid parsing failure if header-only message") + (SETQ MSGFIELDS (LAFITE.PARSE.HEADER MSG (OR PARSETABLE \LAPARSE.FULL) + 0 + (SETQ MSGEOF (GETEOFPTR MSG)) + NIL T)) + (COND + ((EQ (CAR (SETQ EOFINFO (CAR MSGFIELDS))) + 'EOF) + (SETQ HEADEREOF (CADR EOFINFO)) + [COND + ((CADDR EOFINFO) (* ; "Error") + (RETURN (\LAFITE.PREPARE.ERROR MSG EDITORWINDOW HEADEREOF] + [COND + ((= HEADEREOF MSGEOF) (* ; + "Parse ended at eof, so message does not end in double CR -- add another") + (SETFILEPTR MSG MSGEOF) + (BOUT MSG (CHARCODE CR] + (RPLACA (CDR EOFINFO) + (SETQ HEADEREOF (ADD1 HEADEREOF))) (* ; + "Add one for tedit fileptr one-based nonsense") + )) + (RETURN MSGFIELDS]) + +(\LAFITE.PREPARE.ERROR + [LAMBDA (MSG EDITORWINDOW HEADEREOF) (* bvm%: "13-Nov-84 12:53") + +(* ;;; "Called when header of MSG contained a line not conforming to spec. Most likely cause is user deleted the blank line between header and message. Print a suitable error message") + + (PROG (LINE) + (SETFILEPTR MSG HEADEREOF) + (SETQ LINE (LAFITE.READ.TO.EOL MSG)) + (SETFILEPTR MSG HEADEREOF) + (BOUT MSG (CHARCODE CR)) + (\SENDMESSAGEFAIL EDITORWINDOW (CONCAT "Header not understood: %"" + (COND + ((> (NCHARS LINE) + 30) + (CONCAT (SUBSTRING LINE 1 30) + '|...|)) + (T LINE))) + "%". Assumed this was not part of header, and inserted blank line before it. If this is correct, press 'Deliver' again, else edit the message appropriately." + ]) + +(\LAFITE.CHOOSE.MSG.FORMAT + [LAMBDA (TEXTSTREAM HEADEREOF EDITORWINDOW) (* ; "Edited 3-Feb-89 18:36 by bvm") + + (* ;; "Ask if user intends to retain formatting info, and if so, send formatted") + + (LET ((FORMATTING (TEDIT.FORMATTEDFILEP TEXTSTREAM)) + TMP) + (COND + ((NULL FORMATTING) (* ; "It's just plain text") + 'TEXT) + [(AND (TEXTSTREAMP TEXTSTREAM) + (TEXTPROP TEXTSTREAM 'LAFITEFORMAT] + ((NULL EDITORWINDOW) (* ; "Nobody to interact with") + 'TEDIT) + (T (SELECTQ (COND + ((NLISTP LAFITE.SEND.FORMATTED) + LAFITE.SEND.FORMATTED) + ((SETQ TMP (ASSOC FORMATTING LAFITE.SEND.FORMATTED)) + (CADR TMP)) + (T :ASK)) + (T (* ; "Send formatted") + 'TEDIT) + (NIL (* ; "Send unformatted") + 'TEXT) + (SELECTQ (SETQ TMP (\SENDMESSAGE.MENUPROMPT EDITORWINDOW + (OR LAFITEFORMATMENU (SETQ LAFITEFORMATMENU + (\LAFITE.CREATE.MENU + LAFITEFORMATMENUITEMS + "Retain formatting information?" + T))) + (CONCAT "Message " (SELECTQ FORMATTING + (CHARLOOKS "has font information") + (PARALOOKS + "has paragraph formatting") + (NSCHARS + "uses extended character set") + (IMAGEOBJ "contains images") + "has unknown formatting") + ".") + 'LAFITEFORMATMENU)) + (ABORT NIL) + TMP]) + +(LAFITE.MAKE.PLAIN.TEXTSTREAM + [LAMBDA (TEXTSTREAM START) (* ; "Edited 24-Sep-87 16:48 by bvm:") + + (* ;; "Coerces TEXTSTREAM to a %"plain text%" stream, returning the new stream. If START is specified, only copies from that file pointer onward.") + + (LET [(PLAIN (OPENSTREAM '{NODIRCORE} 'BOTH] + (SETFILEPTR TEXTSTREAM (OR START (SETQ START 0))) + + (* ;; "TEXT streams return character codes on BIN, so we have to translate to bytes on output side to handle fat chars correctly and avoid image objects") + + [to (- (GETEOFPTR TEXTSTREAM) + START) do (\OUTCHAR PLAIN (OR (FIXP (BIN TEXTSTREAM)) + (CHARCODE *] + (* ; "Reopen to avoid core bug") + (OPENSTREAM (CLOSEF PLAIN) + 'INPUT]) + +(\SENDMESSAGE.MENUPROMPT + [LAMBDA (EDITWINDOW MENU PROMPT MENUVAR) (* ; "Edited 20-Apr-89 19:37 by bvm") + + (* ;; "Prompt with MENU at the upper left corner of EDITWINDOW, printing PROMPT in the prompt window. If MENUVAR is specified, it is the global variable that holds this menu, which we smash to NIL while inside MENU, lest someone else try to use it") + + (LET ((PWINDOW (GETPROMPTWINDOW EDITWINDOW)) + RESULT) + (CLEARW PWINDOW) + (printout PWINDOW PROMPT) + (if MENUVAR + then (SET MENUVAR NIL)) + (SETQ RESULT (MENU MENU (LA.POSITION.FROM.REGION (WINDOWPROP PWINDOW 'REGION) + NIL T) + T)) + (CLEARW PWINDOW) + (if MENUVAR + then (SET MENUVAR MENU)) + RESULT]) + +(\SENDMESSAGE.PROMPT + [LAMBDA (EDITORWINDOW MESS1 MESS2) (* ; "Edited 31-Jan-89 17:03 by bvm") + + (* ;; +"Display message MESS1 & optionally MESS2 in the prompt window of EDITORWINDOW. Returns NIL always") + + (LET [(PWINDOW (COND + (EDITORWINDOW (LA.ASSURE.PROMPT.WINDOW EDITORWINDOW MESS1 MESS2)) + (T PROMPTWINDOW] + (CLEARW PWINDOW) + (PRIN3 MESS1 PWINDOW) + (COND + (MESS2 (PRIN3 MESS2 PWINDOW))) + NIL]) + +(\SENDMESSAGEFAIL + [LAMBDA (EDITORWINDOW MESS1 MESS2) (* ; "Edited 31-Jan-89 17:02 by bvm") + (\SENDMESSAGE.PROMPT EDITORWINDOW MESS1 MESS2) + (RETFROM '\SENDMESSAGE.PARSE]) +) +(DEFINEQ + +(\SENDMESSAGE + [LAMBDA (FORM TEDITPROPS FORMNAME) (* ; "Edited 10-Feb-89 12:22 by bvm") + +(* ;;; "FORM can be a string, file, or stream --- The value of \SENDMESSAGE is T only if the message was actually sent") + + (OR (TEXTSTREAMP FORM) + (SETQ FORM (OPENTEXTSTREAM FORM NIL NIL NIL TEDITPROPS))) + (TEDIT.STREAMCHANGEDP FORM T) (* ; "Clear the changed bit") + (if (NOT (LISTGET TEDITPROPS 'LEAVETTY)) + then (* ; "Take control of the keyboard") + (TTY.PROCESS (THIS.PROCESS))) + (PROG [(MODE (LISTGET TEDITPROPS 'LAFITEMODE] (* ; "Old way of specifying mode") + (if MODE + then (TEXTPROP FORM 'LAFITEMODE MODE) + elseif (TEXTPROP FORM 'LAFITEMODE) + elseif (SETQ MODE (fetch LAFITEMODE of \LAFITEMODE)) + then (TEXTPROP FORM 'LAFITEMODE MODE) + else (PRINTOUT PROMPTWINDOW T "Can't send mail without a Lafite mode.") + (RETURN NIL)) + (RETURN (\SENDMESSAGE.RESTARTABLE FORM TEDITPROPS NIL FORMNAME]) + +(\SENDMESSAGE.RESTARTABLE + [LAMBDA (FORM TEDITPROPS EDITORWINDOW FORMNAME) (* ; "Edited 3-Nov-89 15:06 by bvm") + (bind (CURRENTMESSAGE _ FORM) + (FIRSTTIME _ T) + EDITORRESULT DONE SENTOK PARSE + do (PROCESSPROP (THIS.PROCESS) + 'BEFOREEXIT NIL) (* ; + "Allow LOGOUT until delivery is attempted. Need to do this if we loop or restart") + (COND + ([NULL (PROG1 EDITORWINDOW + [SETQ EDITORWINDOW (\SENDMESSAGE.MAKEWINDOW CURRENTMESSAGE NIL + EDITORWINDOW (TEXTPROP FORM 'LAFITEMODE])] + (* ; + "First time thru. Fix it so that we can restart if aborted") + (PROCESSPROP (THIS.PROCESS) + 'RESTARTFORM + (LIST (FUNCTION \SENDMESSAGE.RESTARTABLE) + (KWOTE FORM) + (KWOTE TEDITPROPS) + (KWOTE EDITORWINDOW))) (* ; + "If process is reset or aborted, this is how to resurrect") + (PROCESSPROP (THIS.PROCESS) + 'RESTARTABLE T) + (WINDOWPROP EDITORWINDOW 'LAFITEFORM FORMNAME))) + (COND + (FIRSTTIME (RESETSAVE NIL (LIST (FUNCTION \SENDMESSAGE.CLEANUP) + EDITORWINDOW)) + (push LAFITECURRENTEDITORWINDOWS EDITORWINDOW) + (SETQ FIRSTTIME))) + [SETQ EDITORRESULT (TEDIT FORM EDITORWINDOW T (APPEND TEDITPROPS (LIST 'FONT + LAFITEEDITORFONT] + (COND + ((TTY.PROCESSP) (* ; "give back the keyboard") + (TTY.PROCESS T))) + (WINDOWDELPROP EDITORWINDOW 'CLOSEFN 'DON'T) (* ; "let the window close") + (COND + ((NOT (type? SENDINGCOMMAND EDITORRESULT)) + (* ; +"get out anyway since the user used the TEDIT `quit' command instead of one of the sending commands") + (SETQ DONE T)) + (T (* ; + "the user used the lafite menu to get out rather than the TEDIT menu so we have to do something") + (* ; + "make sure CURRENTMESSAGE is always a string") + (SETQ CURRENTMESSAGE (fetch (SENDINGCOMMAND MESSAGE) of EDITORRESULT)) + (SETQ DONE (SELECTQ (AND EDITORRESULT (fetch (SENDINGCOMMAND COMMAND) + of EDITORRESULT)) + (%##SEND## [SETQ SENTOK (\SENDMESSAGE0 CURRENTMESSAGE + EDITORWINDOW (SETQ PARSE + (fetch + (SENDINGCOMMAND + MESSAGEPARSE) + of EDITORRESULT + ]) + (SHOULDNT))) + (SHADEITEM (fetch (SENDINGCOMMAND ITEM) of EDITORRESULT) + (fetch (SENDINGCOMMAND MENU) of EDITORRESULT) + WHITESHADE) (* ; + "Unshade command. DOLAFITESENDINGCOMMAND shaded it to begin with") + )) + (COND + (DONE (* ; "Message successfully dispatched") + (PROCESSPROP (THIS.PROCESS) + 'RESTARTABLE NIL) (* ; + "Don't try to restart if there's any sort of error now") + (COND + (CURRENTMESSAGE (* ; + "Mark text unchanged now, so no trouble closing icon") + (TEDIT.STREAMCHANGEDP CURRENTMESSAGE T))) + (COND + ((NULL SENTOK) + (CLOSEW EDITORWINDOW)) + (T (* ; "shrink the window") + (\LAFITE.AFTER.DELIVER EDITORWINDOW CURRENTMESSAGE PARSE))) + (RETURN SENTOK)) + (T (* ; + "Loop if deliver failed or \LAFITE.SAVE.FORM was aborted.") + ]) + +(\SENDMESSAGE.CLEANUP + [LAMBDA (EDITORWINDOW) (* ; "Edited 6-Oct-87 15:58 by bvm:") + (SETQ LAFITECURRENTEDITORWINDOWS (REMOVE EDITORWINDOW LAFITECURRENTEDITORWINDOWS]) + +(\SENDMESSAGE.MAKEWINDOW + [LAMBDA (MESSAGEFORM TITLE WINDOW MODE) (* ; "Edited 3-Nov-89 16:16 by bvm") + +(* ;;; "Editor for Mail system Lafite -- Handles the process mechanism right") + +(* ;;; "Assumes that it's running in a separate process created above") + + (PROG ((MENU (MAKELAFITEDELIVERMENU)) + EDITWINDOW LAYOUT REGION) + [COND + ((NOT TITLE) + (SETQ TITLE "Message Editor") + (if (AND MODE (LAFITE.SHOW.MODE.P)) + then (SETQ TITLE (CONCAT TITLE " (" MODE ")"] + [COND + ((WINDOWP (SETQ EDITWINDOW WINDOW)) + (WINDOWPROP EDITWINDOW 'TITLE TITLE) + (for W in (ATTACHEDWINDOWS EDITWINDOW) when (WINDOWPROP W 'MENUWINDOW) + do (* ; + "there's already an attached window menu, make sure we have a delivery menu in it.") + (LET [(OLDMENU (CAR (WINDOWPROP W 'MENU] + (if (if (NULL OLDMENU) + then (* ; "E.g., after ABORT got removed") + T + elseif (NOT (EQUAL (fetch (MENU ITEMS) of MENU) + (fetch (MENU ITEMS) of OLDMENU)) + ) + then (DELETEMENU OLDMENU NIL W) + (* ; "Get rid of different menu") + T + else (SETQ MENU OLDMENU) + (* ; "They're the same, don't fuss") + NIL) + else (ADDMENU MENU W '(0 . 0)) + (* ; "Now make it fit") + (MENUWRESHAPEFN W))) + (RETURN) finally (* ; "No attached menu yet") + (ATTACHWINDOW (SETQ W (MENUWINDOW MENU)) + EDITWINDOW + 'TOP) + (WINDOWPROP W 'MENUWINDOW T))) + (T (SETQ REGION (if (for old LAYOUT in LAFITE.EDITOR.LAYOUTS + unless (for WINDOW in LAFITECURRENTEDITORWINDOWS + thereis (EQ (WINDOWPROP WINDOW + 'LAFITE.LAYOUT) + LAYOUT)) + do (* ; + "Use first layout not already in use") + (RETURN (CAR LAYOUT))) + elseif (AND (NULL LAFITECURRENTEDITORWINDOWS) + (type? REGION LAFITEEDITORREGION)) + then (* ; + "Old way of doing this for a single window") + LAFITEEDITORREGION + elseif LAFITE.EDITOR.SIZE + then (* ; "Get window of appropriate size") + (GETBOXREGION (CAR LAFITE.EDITOR.SIZE) + (CDR LAFITE.EDITOR.SIZE)) + else (GETREGION))) + [SETQ EDITWINDOW (CREATEMENUEDWINDOW MENU TITLE 'TOP + (create REGION using + REGION HEIGHT _ + (- (fetch (REGION HEIGHT) of + REGION) + (HEIGHTIFWINDOW (FONTPROP + LAFITEEDITORFONT + 'HEIGHT] + (WINDOWPROP (CAR (ATTACHEDWINDOWS EDITWINDOW)) + 'MENUWINDOW T) + (if LAYOUT + then (WINDOWPROP EDITWINDOW 'LAFITE.LAYOUT LAYOUT) + (WINDOWPROP EDITWINDOW 'ICONPOSITION (CADR LAYOUT] + (GETPROMPTWINDOW EDITWINDOW 1 LAFITEEDITORFONT) + [COND + (NIL (* ; + "don't let TEDIT close the window") + (WINDOWADDPROP EDITWINDOW 'CLOSEFN 'DON'T] + (PROGN (WINDOWDELPROP EDITWINDOW 'CLOSEFN (FUNCTION CLOSEATTACHEDWINDOWS)) + (* ; + "On closing, get rid of attachments, don't just close them") + (WINDOWADDPROP EDITWINDOW 'CLOSEFN (FUNCTION DETACHALLWINDOWS)) + (WINDOWADDPROP EDITWINDOW 'CLOSEFN (FUNCTION \LAFITE.CLOSEMSG?) + T)) + (WINDOWPROP EDITWINDOW 'ICONFN (FUNCTION \LAFITE.UNSENT.ICON)) + (WINDOWPROP EDITWINDOW 'PROCESS (THIS.PROCESS)) (* ; + "Associate this process with the edit window") + (replace (MENU WHENSELECTEDFN) of MENU with (FUNCTION DOLAFITESENDINGCOMMAND)) + (* ; "Enable the menu") + (RETURN EDITWINDOW]) + +(MAKELAFITEDELIVERMENU + [LAMBDA NIL (* bvm%: "28-Mar-84 12:47") + (create MENU + ITEMS _ LAFITESENDINGMENUITEMS + CENTERFLG _ T + MENUFONT _ LAFITEMENUFONT + WHENSELECTEDFN _ (FUNCTION DOLAFITESENDINGCOMMAND]) + +(\LAFITE.CLOSEMSG? + [LAMBDA (WINDOW) (* ; "Edited 3-Sep-87 17:21 by bvm:") + + (* ;; +"This is the first CLOSEFN on a message sending window. If contents have changed, get confirmation") + + (LET [(TEXTSTREAM (WINDOWPROP WINDOW 'TEXTSTREAM] + (COND + ((OR (NULL TEXTSTREAM) + (NOT (TEDIT.STREAMCHANGEDP TEXTSTREAM))) (* ; + "TEXTSTREAM is null once TEdit's gotten thru with it.") + NIL) + ((MOUSECONFIRM "Message has been edited -- LEFT to flush anyway" T (GETPROMPTWINDOW + WINDOW)) + (TEDIT.STREAMCHANGEDP TEXTSTREAM T) (* ; + "Reset bit so question doesn't get asked a second time") + NIL) + (T 'DON'T]) + +(\LAFITE.AFTER.DELIVER + [LAMBDA (EDITORWINDOW TEXTSTREAM PARSE) (* ; "Edited 30-May-90 16:25 by bvm") + (TEDIT.ASSURE.NO.BACKING.FILE TEXTSTREAM) (* ; + "In case the backing file gets deleted") + (\OUTBOX.ADD.ITEM TEXTSTREAM (OR (CAR PARSE) + UNSUPPLIEDFIELDSTR)) + [LET ((FORMNAME (WINDOWPROP EDITORWINDOW 'LAFITEFORM NIL))) + (if (AND FORMNAME (EQ (CAR (UNPACKFILENAME.STRING FORMNAME)) + 'NAME)) + then + + (* ;; "See if user wants to keep the form, or if it was saved just as a checkpoint. Do this only for files saved in primary directory") + + (LET* ((PWINDOW (GETPROMPTWINDOW EDITORWINDOW)) + [MENUW (find W in (ATTACHEDWINDOWS EDITORWINDOW) + suchthat (WINDOWPROP W 'MENUWINDOW] + (MENU (create MENU + ITEMS _ '(("Delete File" T + "Delete the file(s) in which this message was earlier saved." + ) + ("Retain Saved Form" NIL + "Don't delete the saved form, I want to use it again." + )) + WHENSELECTEDFN _ [FUNCTION (LAMBDA (ITEM MENU KEY) + (LET ((W (WFROMMENU MENU))) + (WINDOWPROP W 'RESULT ITEM) + (SHADEITEM ITEM MENU + LAFITEITEMBUSYSHADE] + MENUFONT _ LAFITEMENUFONT + CENTERFLG _ T + ITEMWIDTH _ (IQUOTIENT (WINDOWPROP PWINDOW 'WIDTH) + 2) + MENUROWS _ 1)) + RESULT + (MSG (CONCAT + "Delivery complete. Do you want to delete the saved form of this message (" + FORMNAME ")?"))) + (LA.ASSURE.PROMPT.WINDOW EDITORWINDOW MSG) + (TERPRI PWINDOW) + (PRIN3 MSG PWINDOW) + (ADDMENU MENU MENUW '(0 . 0)) + (until (SETQ RESULT (WINDOWPROP MENUW 'RESULT)) + do (BLOCK 500)) + (if (CADR RESULT) + then (PRINTOUT PWINDOW T "Deleting file(s)... " + (if (\LAFITE.DELETE.FORM.INTERNAL FORMNAME) + then "done." + else "failed."] + (DETACHALLWINDOWS EDITORWINDOW) + (CLOSEW EDITORWINDOW]) + +(\LAFITE.UNSENT.ICON + [LAMBDA (WINDOW OLDICON) (* ; "Edited 24-Sep-87 16:58 by bvm:") + (TITLEDICONW LAFITE.MSG.ICON (\LAFITE.FETCH.SUBJECT (WINDOWPROP WINDOW 'TEXTSTREAM)) + LAFITEMSGICONFONT + (WINDOWPROP WINDOW 'ICONPOSITION) + T]) + +(\LAFITE.FETCH.SUBJECT + [LAMBDA (TEXTSTREAM) (* bvm%: " 2-Mar-86 16:27") + (COND + (TEXTSTREAM (RESETLST + [RESETSAVE NIL (LIST (FUNCTION SETFILEINFO) + TEXTSTREAM + 'ENDOFSTREAMOP + (GETFILEINFO TEXTSTREAM 'ENDOFSTREAMOP] + (SETFILEINFO TEXTSTREAM 'ENDOFSTREAMOP (FUNCTION \LAFITE.EOF)) + (LET ((STR (LAFITE.PARSE.HEADER TEXTSTREAM \LAPARSE.SUBJECTFIELD 0 NIL T))) + (COND + ((STRING-EQUAL STR SUBJECTSTR) + UNSUPPLIEDFIELDSTR) + (T STR))))]) + +(LAFITE.SENDMESSAGE + [LAMBDA (MESSAGEFORM) (* ; "Edited 12-Sep-88 14:07 by bvm") + +(* ;;; "this is the external interface to sending a message") + + (SETQ MESSAGEFORM (OPENTEXTSTREAM MESSAGEFORM)) + (LET* ((MODE (TEXTPROP MESSAGEFORM 'LAFITEMODE)) + (*LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA MODE)) + PARSE) + (AND *LAFITE-MODE-DATA* (SETQ PARSE (CL:FUNCALL (fetch (LAFITEMODEDATA SENDPARSER) + of *LAFITE-MODE-DATA*) + MESSAGEFORM)) + (CL:FUNCALL (fetch (LAFITEMODEDATA SENDER) of *LAFITE-MODE-DATA*) + MESSAGEFORM PARSE]) + +(\SENDMESSAGE0 + [LAMBDA (TEXTSTREAM WINDOW PARSE) (* ; "Edited 12-Sep-88 14:04 by bvm") + (PROG ((PWINDOW (GETPROMPTWINDOW WINDOW)) + *LAFITE-MODE-DATA* MENUW OLDMENU ABORTMENU RESULT) + (for W in (ATTACHEDWINDOWS WINDOW) when [SETQ OLDMENU + (CAR (WINDOWPROP W 'MENU] + do (SETQ MENUW W) + (DELETEMENU OLDMENU NIL MENUW) (* ; + "Remove Deliver menu, add Abort menu") + (ADDMENU (SETQ ABORTMENU (create MENU + ITEMS _ '(("Abort" NIL + "Abort delivery of this message") + ) + WHENSELECTEDFN _ (FUNCTION \SENDMESSAGE.ABORT) + MENUFONT _ LAFITEMENUFONT + CENTERFLG _ T + ITEMWIDTH _ (fetch ITEMWIDTH of OLDMENU))) + MENUW + '(0 . 0)) + (RETURN)) + [if [NULL (SETQ *LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA (TEXTPROP TEXTSTREAM + 'LAFITEMODE] + then (printout PWINDOW "Failed to authenticate user.") + else [SETQ RESULT (ERSETQ (RESETLST + (CL:FUNCALL (fetch (LAFITEMODEDATA SENDER) + of *LAFITE-MODE-DATA*) + TEXTSTREAM PARSE WINDOW MENUW))] + (COND + ((NULL RESULT) + (printout PWINDOW "aborted.")) + ((SETQ RESULT (CAR RESULT)) + (printout PWINDOW "done."] + (RETURN (COND + (RESULT (* ; "Success") + (CLOSEF TEXTSTREAM) (* ; +"Explicit Close here after successful delivery so that TEdit can close any files it might have open") + RESULT) + (T (* ; "Restore Deliver menu") + (COND + ((WINDOWPROP MENUW 'MENU) + (DELETEMENU ABORTMENU NIL MENUW))) + (ADDMENU OLDMENU MENUW '(0 . 0) + NIL) + (WINDOWPROP MENUW 'ABORT NIL) + NIL]) + +(LA.ASSURE.PROMPT.WINDOW + [LAMBDA (MAINWINDOW MESS1 MESS2) (* bvm%: "24-Feb-85 18:33") + +(* ;;; +"Returns prompt window for MAINWINDOW assuring that it is big enough to print MESS1 and MESS2") + + (LET ((PWINDOW (GETPROMPTWINDOW MAINWINDOW)) + %#LINES) + (COND + ((> [SETQ %#LINES (QUOTIENT (+ (STRINGWIDTH MESS1 PWINDOW) + (COND + (MESS2 (STRINGWIDTH MESS2 PWINDOW)) + (T 0))) + (WINDOWPROP PWINDOW 'WIDTH] + 0) (* ; + "Make sure prompt window is big enough") + (GETPROMPTWINDOW MAINWINDOW (ADD1 %#LINES))) + (T PWINDOW]) + +(\LAFITE.SEND.FAIL + [LAMBDA (EDITORWINDOW ERRMSG) (* bvm%: "24-Feb-85 18:38") + + (* ;; "Print a message explaining why delivery failed") + + (LET ((FULLMSG (CONCAT "Delivery failed -- " ERRMSG)) + PWINDOW) + [COND + [EDITORWINDOW (CLEARW (SETQ PWINDOW (LA.ASSURE.PROMPT.WINDOW EDITORWINDOW FULLMSG] + (T (TERPRI (SETQ PWINDOW PROMPTWINDOW] + (PRIN3 FULLMSG PWINDOW) + NIL]) + +(\LAFITE.INVALID.RECIPIENTS + [LAMBDA (NAMES) (* bvm%: " 5-Nov-84 15:26") + +(* ;;; "Returns an 'invalid recipients' error string") + + (PROG (NAME) + (SETQ NAME (for RECIPIENT in NAMES join (LIST ", " RECIPIENT))) + (RPLACA NAME ": ") + (COND + ((CDR NAMES) + (push NAME "s"))) + (RETURN (CONCATLIST (CONS "Invalid recipient" NAME]) + +(\SENDMESSAGE.ABORT + [LAMBDA (ITEM MENU KEY) (* bvm%: " 1-Jun-84 12:21") + (* ; + "The WHENSELECTEDFN for the Abort menu") + (PROG ((W (WFROMMENU MENU))) + (WINDOWPROP W 'ABORT T) + (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE]) +) + + + +(* ; "Outbox hacking") + +(DEFINEQ + +(\OUTBOX.CREATE + [LAMBDA NIL (* bvm%: "21-Dec-84 22:35") + (PROG (FONT NLINES W FONTHEIGHT) + (OR (AND LAFITESTATUSWINDOW (FIXP (SETQ NLINES LAFITEOUTBOXSIZE)) + (IGREATERP NLINES 0)) + (RETURN)) + (SETQ FONTHEIGHT (FONTPROP (SETQ FONT LAFITEBROWSERFONT) + 'HEIGHT)) + (SETQ W (CREATEW (CREATEREGION 0 0 (WINDOWPROP LAFITESTATUSWINDOW 'WIDTH) + (HEIGHTIFWINDOW (ITIMES NLINES FONTHEIGHT) + T)) + "Delivered Messages" NIL T)) + (ATTACHWINDOW W LAFITESTATUSWINDOW 'BOTTOM 'JUSTIFY 'LOCALCLOSE) + (DSPFONT FONT W) + (WINDOWADDPROP W 'CLOSEFN (FUNCTION \OUTBOX.CLOSEFN)) + (WINDOWPROP W 'REPAINTFN (FUNCTION \OUTBOX.REPAINTFN)) + (WINDOWPROP W 'BUTTONEVENTFN (FUNCTION \OUTBOX.BUTTONFN)) + (WINDOWPROP W 'RESHAPEFN (FUNCTION \OUTBOX.RESHAPEFN)) + (WINDOWPROP W 'MINSIZE (CONS 0 (HEIGHTIFWINDOW FONTHEIGHT T))) + (RETURN (SETQ \LAFITE.OUTBOX + (\OUTBOX.RESET (create OUTBOX + OBWINDOW _ W + OBSIZE _ NLINES + OBHEIGHT _ FONTHEIGHT + OBDESCENT _ (FONTPROP FONT 'DESCENT]) + +(\OUTBOX.RESET + [LAMBDA (OUTBOX) (* bvm%: " 9-Nov-84 16:29") + (PROG ((WINDOW (fetch OBWINDOW of OUTBOX))) + (CLEARW WINDOW) + (LINELENGTH MAX.SMALLP WINDOW) + (DSPRIGHTMARGIN MAX.SMALLP WINDOW) + (replace OBORIGIN of OUTBOX with (IPLUS (DSPYPOSITION NIL WINDOW) + (fetch OBHEIGHT of OUTBOX))) + (RETURN OUTBOX]) + +(\OUTBOX.CLOSEFN + [LAMBDA (WINDOW) (* bvm%: " 8-Nov-84 16:02") + (SETQ \LAFITE.OUTBOX]) + +(\OUTBOX.REPAINTFN + [LAMBDA (WINDOW REGION) (* bvm%: "13-Nov-84 10:57") + (PROG ((OUTBOX \LAFITE.OUTBOX)) + (OR (EQ WINDOW (fetch OBWINDOW of OUTBOX)) + (RETURN)) + (MOVETO 0 (IDIFFERENCE (fetch OBORIGIN of OUTBOX) + (fetch OBHEIGHT of OUTBOX)) + WINDOW) + (for ITEM in (fetch OBITEMS of OUTBOX) do (\OUTBOX.DISPLAYLINE + OUTBOX ITEM) + (TERPRI WINDOW]) + +(\OUTBOX.RESHAPEFN + [LAMBDA (WINDOW OLDIMAGE IMAGEREGION OLDSCREENREGION) (* bvm%: "13-Nov-84 10:57") + (COND + ((EQ WINDOW (fetch OBWINDOW of \LAFITE.OUTBOX)) + (PROG ((NLINES (IQUOTIENT (WINDOWPROP WINDOW 'HEIGHT) + (fetch OBHEIGHT of \LAFITE.OUTBOX))) + (OLDSIZE (fetch OBSIZE of \LAFITE.OUTBOX)) + N ITEMS) + [COND + ((NEQ NLINES OLDSIZE) + (replace OBSIZE of \LAFITE.OUTBOX with NLINES) + (COND + ((AND (ILESSP NLINES OLDSIZE) + (IGREATERP (SETQ N (IDIFFERENCE (LENGTH (SETQ ITEMS (fetch OBITEMS + of + \LAFITE.OUTBOX + ))) + NLINES)) + 0)) + (replace OBITEMS of \LAFITE.OUTBOX with (CDR (NTH ITEMS N] + (\OUTBOX.RESET \LAFITE.OUTBOX) + (REDISPLAYW WINDOW]) + +(\OUTBOX.SHADEITEM + [LAMBDA (OUTBOX ITEM N SHADE OPERATION) (* ; "Edited 3-Sep-87 17:24 by bvm:") + +(* ;;; "Shade the indicated ITEM in OUTBOX using texture SHADE blted with OPERATION") + + (PROG ((W (fetch OBWINDOW of OUTBOX)) + HEIGHT) + (BLTSHADE SHADE W 0 (- (fetch OBORIGIN of OUTBOX) + (+ (ITIMES N (SETQ HEIGHT (fetch OBHEIGHT of OUTBOX))) + (fetch OBDESCENT of OUTBOX))) + NIL HEIGHT OPERATION) + (COND + ((EQ OPERATION 'REPLACE) + (\OUTBOX.DISPLAYLINE OUTBOX ITEM N]) + +(\OUTBOX.BUTTONFN + [LAMBDA (WINDOW) (* bvm%: "13-Nov-84 10:58") + +(* ;;; "BUTTONEVENTFN for the outbox. If a message is selected, edit it") + + (PROG ((SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) + (OUTBOX \LAFITE.OUTBOX) + SELECTED SEL# NEWSEL# ITEMS HEIGHT ORIGIN DESCENT LASTX LASTY MAXITEM) + (COND + ((OR (NOT (SETQ ITEMS (fetch OBITEMS of OUTBOX))) + (NEQ WINDOW (fetch OBWINDOW of OUTBOX))) + (* ; "Nothing to select") + (RETURN))) + (SETQ MAXITEM (LENGTH ITEMS)) + (SETQ HEIGHT (fetch OBHEIGHT of OUTBOX)) + (SETQ DESCENT (fetch OBDESCENT of OUTBOX)) + (SETQ ORIGIN (fetch OBORIGIN of OUTBOX)) + + (* ;; "keep looping until all mouse buttons are up") + + (do (GETMOUSESTATE) + (COND + [(OR [NOT (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) + (SETQ LASTY (LASTMOUSEY WINDOW] + (> (SETQ NEWSEL# (ADD1 (QUOTIENT (- ORIGIN (+ LASTY DESCENT)) + HEIGHT))) + MAXITEM)) + + (* ;; "I would like to just return here and let the next window take over, but current mouse arrangement means I'll never get control back unless user lets up on mouse") + + [COND + (SELECTED (\OUTBOX.SHADEITEM OUTBOX SELECTED SEL# BLACKSHADE 'INVERT) + (SETQ SELECTED (SETQ SEL# NIL] + (COND + ((LASTMOUSESTATE UP) + (RETURN)) + (T (BLOCK] + ((LASTMOUSESTATE UP) (* ; + "Let mouse up while over a selection. Do it") + [COND + (SELECTED (\LAFITE.PROCESS [LIST (FUNCTION \SENDMESSAGE) + (KWOTE (COPYTEXTSTREAM (fetch OBITEXT + of SELECTED] + 'MESSAGESENDER T 'NO) + (\OUTBOX.SHADEITEM OUTBOX SELECTED SEL# BLACKSHADE 'INVERT] + (RETURN)) + ((NEQ NEWSEL# SEL#) + [COND + (SELECTED (\OUTBOX.SHADEITEM OUTBOX SELECTED SEL# BLACKSHADE 'INVERT] + (\OUTBOX.SHADEITEM OUTBOX [SETQ SELECTED (CAR (NTH ITEMS (SETQ SEL# NEWSEL#] + SEL# BLACKSHADE 'INVERT]) + +(\OUTBOX.DISPLAYLINE + [LAMBDA (OUTBOX ITEM N) (* bvm%: " 8-Nov-84 21:35") + (PROG ((W (fetch OBWINDOW of OUTBOX))) + (COND + (N (MOVETO 0 (IDIFFERENCE (fetch OBORIGIN of OUTBOX) + (ITIMES N (fetch OBHEIGHT of OUTBOX))) + W))) + (printout W (fetch OBIDATE of ITEM) + %,, + (fetch OBISUBJECT of ITEM]) + +(\OUTBOX.ADD.ITEM + [LAMBDA (TEXTSTREAM SUBJECT) (* ; "Edited 3-Sep-87 18:08 by bvm:") + (PROG ((OUTBOX (OR \LAFITE.OUTBOX (\OUTBOX.CREATE))) + W N ITEM BOTTOM HEIGHT ITEMS) + (OR OUTBOX (RETURN)) + [COND + ((>= [SETQ N (LENGTH (SETQ ITEMS (fetch OBITEMS of OUTBOX] + (fetch OBSIZE of OUTBOX)) + (replace OBITEMS of OUTBOX with (SETQ ITEMS (CDR ITEMS))) + (BITBLT (SETQ W (fetch OBWINDOW of OUTBOX)) + 0 + [SETQ BOTTOM (- (fetch OBORIGIN of OUTBOX) + (+ (ITIMES N (SETQ HEIGHT (fetch OBHEIGHT of OUTBOX))) + (fetch OBDESCENT of OUTBOX] + W 0 (+ BOTTOM HEIGHT) + NIL + (ITIMES HEIGHT (SUB1 N)) + 'INPUT + 'REPLACE) + (BLTSHADE WHITESHADE W 0 BOTTOM NIL HEIGHT 'REPLACE)) + (T (SETQ N (ADD1 N] + [replace OBITEMS of OUTBOX with (NCONC1 ITEMS + (SETQ ITEM + (create OUTBOXITEM + OBITEXT _ TEXTSTREAM + OBIDATE _ + (DATE (DATEFORMAT NO.DATE + NO.SECONDS)) + OBISUBJECT _ SUBJECT] + (\OUTBOX.DISPLAYLINE OUTBOX ITEM N]) +) + +(RPAQ? LAFITEOUTBOXSIZE 2) + +(RPAQ? \LAFITE.OUTBOX ) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RECORD OUTBOXITEM (OBITEXT OBIDATE OBISUBJECT OBIWINDOW)) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS LAFITEOUTBOXSIZE) +) +) + + + +(* ; "Built-in message forms") + +(DEFINEQ + +(\LAFITE.MESSAGEFORM + [LAMBDA (ITEM MENU BUTTON) (* ; "Edited 23-Feb-89 12:50 by bvm") + (COND + ((NULL (OR \LAFITEMODE (\LAFITE.INFER.MODE))) + (printout PROMPTWINDOW T "Must set Lafite Mode before sending mail")) + (T (RESETLST + (AND ITEM (LA.RESETSHADE ITEM MENU)) + [PROG ((*UPPER-CASE-FILE-NAMES* NIL) + FORM FORMNAME FULLFORMNAME) + (COND + ((EQ BUTTON 'LEFT) + (SETQ FORM (MAKENEWMESSAGEFORM))) + ([NOT (SETQ FORM (MENU (.LAFITEMENU. LAFITEFORMSMENU (APPEND ( + MAKELAFITEPRIVATEFORMSITEMS + + "Use the form defined in this file." + ) + LAFITESPECIALFORMS + + LAFITEFORMSMENUITEMS + ) + "Message Forms"] + (RETURN)) + ((EQ FORM '%##ANOTHERFORM##) (* ; "user buttoned 'Another Form'") + (OR (SETQ FORMNAME (PROMPTFORFILENAME)) + (RETURN))) + ((DEFINEDP FORM) + (OR (SETQ FORM (CL:FUNCALL FORM)) + (RETURN))) + [(BOUNDP FORM) + (SETQ FORM (OR (EVALV FORM) + (MAKENEWMESSAGEFORM] + (T (* ; "other private form") + (SETQ FORMNAME FORM))) + (COND + ((NULL FORMNAME) (* ; "Have form already") + ) + ([OR (SETQ FULLFORMNAME (INFILEP (LA.LONGFILENAME FORMNAME LAFITEFORM.EXT))) + (AND LAFITEFORMDIRECTORIES (SETQ FULLFORMNAME (FINDFILE + (PACKFILENAME.STRING + 'BODY FORMNAME + 'EXTENSION LAFITEFORM.EXT + ) + T LAFITEFORMDIRECTORIES] + (* ; "read the form and return it") + (COND + ((NOT (CL:MEMBER (SETQ FORMNAME (LA.SHORTFILENAME FULLFORMNAME + LAFITEFORM.EXT)) + LAFITEFORMFILES :TEST 'STRING-EQUAL)) + (push LAFITEFORMFILES FORMNAME) + (SETQ \LAFITEPROFILECHANGED T) + (SETQ LAFITEFORMSMENU))) + (SETQ FORM (\LAFITE.READ.FORM FULLFORMNAME))) + (T (printout PROMPTWINDOW T FORMNAME " not found.") + (RETURN))) + (ADD.PROCESS (LIST (FUNCTION \SENDMESSAGE) + (KWOTE FORM) + NIL + (KWOTE FORMNAME)) + 'NAME + 'MESSAGESENDER + 'RESTARTABLE + 'NO) (* ; + "Finally, start authenticating if we haven't yet.") + (\LAFITE.GET.USER.DATA (AND (TEXTSTREAMP FORM) + (TEXTPROP FORM 'LAFITEMODE])]) + +(MAKELAFITESUPPORTFORM + [LAMBDA NIL (* bvm%: "12-Mar-85 00:39") + (MAKEXXXSUPPORTFORM "Lafite" LAFITESUPPORT LAFITESYSTEMDATE]) + +(MAKELISPSUPPORTFORM + [LAMBDA NIL (* bvm%: "12-Mar-85 00:39") + (MAKEXXXSUPPORTFORM "Lisp" LISPSUPPORT]) + +(MAKEXXXSUPPORTFORM + [LAMBDA (SYSTEMNAME ADDRESS SYSTEMDATE) (* ; "Edited 3-May-89 18:37 by bvm") + (PROG ((SUBJFIELD ">>Terse summary of problem<<") + (UCODEVERSION (MICROCODEVERSION)) + (SCRATCH (OPENSTREAM "{nodircore}" 'BOTH)) + TEXTSTREAM SELECTPOSITION MODE) + [COND + [(LISTP ADDRESS) (* ; + "Mode-dependent address. Pick the first address that's in a mode we know how to send") + (SETQ ADDRESS (for PAIR in ADDRESS when (\LAFITE.GET.USER.DATA + (SETQ MODE (CAR PAIR))) + do (RETURN (CADR PAIR] + (T (* ; "Just send in current mode") + (SETQ MODE (fetch LAFITEMODE of \LAFITEMODE] + (COND + ((NOT ADDRESS) + (printout PROMPTWINDOW T "Can't -- no address known for " SYSTEMNAME " report.") + (RETURN))) + (SETQ TEXTSTREAM (OPENTEXTSTREAM (CONCAT "Subject: " SYSTEMNAME ": ") + NIL NIL NIL (LIST 'FONT LAFITEEDITORFONT))) + (SETQ SELECTPOSITION (ADD1 (GETEOFPTR TEXTSTREAM))) + (PROGN (* ; + "Now write the main stuff to a scratch stream. faster than bouting a byte at a time to tedit") + (printout SCRATCH SUBJFIELD T) + (printout SCRATCH "To: " ADDRESS T) + (printout SCRATCH "cc: " (FULLUSERNAME NIL MODE) + T T) + (COND + (SYSTEMDATE (printout SCRATCH SYSTEMNAME " System Date: " SYSTEMDATE T))) + (printout SCRATCH "Lisp System Date: " MAKESYSDATE " (" (L-CASE (MKSTRING + MAKESYSNAME) + T) + ")" T) + (printout SCRATCH "Machine: " (OR \LAFITE.REPORT.MACHINE + (PROGN (SETQ \LAFITE.REPORT.MACHINE (L-CASE ( + MACHINETYPE + ) + T)) + [COND + ((EQ \PUP.READY T) + (SETQ \LAFITE.REPORT.MACHINE + (CONCAT \LAFITE.REPORT.MACHINE " (" + (ETHERHOSTNAME NIL T) + ")"] + \LAFITE.REPORT.MACHINE)) + T) + (printout SCRATCH "Microcode version: " .I1.8 (fetch HIBYTE of UCODEVERSION) + "," .I1.8 (fetch LOBYTE of UCODEVERSION) + T) + (printout SCRATCH "Memory size: " .I4.8 (REALMEMORYSIZE) + T) + (printout SCRATCH "Frequency: >> Always, Intermittent, Once << +Impact: >> Fatal, Serious, Moderate, Annoying, Minor <<" T T) + (printout SCRATCH ">>detailed problem description<<" T)) + (TEDIT.SETSEL TEXTSTREAM SELECTPOSITION 0 'RIGHT) + (TEDIT.INCLUDE TEXTSTREAM SCRATCH) + (TEDIT.SETSEL TEXTSTREAM SELECTPOSITION (NCHARS SUBJFIELD) + 'RIGHT T) + (TEXTPROP TEXTSTREAM 'LAFITEMODE MODE) + (RETURN TEXTSTREAM]) + +(MAKENEWMESSAGEFORM + [LAMBDA NIL (* ; "Edited 6-Jun-88 12:22 by bvm") + (LET ((OUTSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (LIST 'FONT LAFITEEDITORFONT))) + SELECTPOSITION) + (printout OUTSTREAM "Subject: ") + (SETQ SELECTPOSITION (ADD1 (GETFILEPTR OUTSTREAM))) + (printout OUTSTREAM SUBJECTSTR T) + (printout OUTSTREAM "To: " RECIPIENTSSTR T) + (printout OUTSTREAM "cc: " (FULLUSERNAME) + T T) + (printout OUTSTREAM MESSAGESTR T) + (if LAFITE.SIGNATURE + then (* ; "Pre-sign it") + (PRIN3 LAFITE.SIGNATURE OUTSTREAM)) + (TEDIT.SETSEL OUTSTREAM SELECTPOSITION (NCHARS SUBJECTSTR) + 'RIGHT T) + OUTSTREAM]) + +(MAKELAFITEPRIVATEFORMSITEMS + [LAMBDA (HELPSTR) (* ; "Edited 23-Feb-89 12:38 by bvm") + (for FORMFILE in (SORT LAFITEFORMFILES) when FORMFILE + collect `(,(if (U-CASEP FORMFILE) + then (CL:STRING-CAPITALIZE FORMFILE) + else FORMFILE) + ',FORMFILE + ,HELPSTR]) + +(\LAFITE.UNCACHE.MESSAGEFORM + [LAMBDA (ITEM MENU) (* ; "Edited 8-Nov-89 12:38 by bvm") + (LET ((FORM (\LAFITE.SELECT.FORM "Forget about this message form"))) + (COND + (FORM (SETQ LAFITEFORMFILES (DREMOVE FORM LAFITEFORMFILES)) + (SETQ \LAFITEPROFILECHANGED T) + (SETQ LAFITEFORMSMENU) + (printout PROMPTWINDOW T FORM " forgotten."]) + +(\LAFITE.DELETE.MESSAGEFORM + [LAMBDA (ITEM MENU) (* ; "Edited 8-Nov-89 12:38 by bvm") + (LET ((FORM (\LAFITE.SELECT.FORM "Delete this saved message"))) + (if (AND FORM (PROGN (CLRPROMPT) + (MOUSECONFIRM (CL:FORMAT NIL + "Click LEFT to confirm deleting saved message '~A'" + FORM) + T PROMPTWINDOW))) + then (\LAFITE.DELETE.FORM.INTERNAL FORM]) + +(\LAFITE.SELECT.FORM + [LAMBDA (MSG) (* ; "Edited 8-Nov-89 12:37 by bvm") + (COND + ((NULL LAFITEFORMFILES) + (printout PROMPTWINDOW T "You have no private message forms")) + (T (MENU (\LAFITE.CREATE.MENU (MAKELAFITEPRIVATEFORMSITEMS MSG) + "Private Forms"]) + +(\LAFITE.DELETE.FORM.INTERNAL + [LAMBDA (FORMNAME) (* ; "Edited 8-Nov-89 12:34 by bvm") + (LET ((*UPPER-CASE-FILE-NAMES* NIL) + (LONGNAME (LA.LONGFILENAME FORMNAME LAFITEFORM.EXT)) + FULL) + (while (SETQ FULL (FULLNAME LONGNAME 'OLDEST)) + do (if (NOT (DELFILE FULL)) + then (PRINTOUT PROMPTWINDOW T "Could not delete " FULL) + (RETURN NIL)) finally (SETQ LAFITEFORMFILES (CL:DELETE FORMNAME + LAFITEFORMFILES + :TEST + 'STRING-EQUAL)) + (SETQ \LAFITEPROFILECHANGED T) + (SETQ LAFITEFORMSMENU) + (PRINTOUT PROMPTWINDOW T FORMNAME " deleted.") + (RETURN T]) + +(\LAFITE.READ.FORM + [LAMBDA (FILE) (* ; "Edited 18-Jul-2000 03:09 by rmk:") + (* ; "Edited 18-Jul-2000 03:08 by rmk:") + (* ; "Edited 2-Nov-89 15:55 by bvm") + +(* ;;; "copies the messaage form in the FILE into a text stream") + + (PROG ((TEXTSTREAM (OPENTEXTSTREAM [OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT] + NIL NIL NIL (LIST 'FONT LAFITEEDITORFONT))) + NAME CH) + (SETFILEPTR TEXTSTREAM 0) + (COND + ([OR (EQ (SETQ CH (BIN TEXTSTREAM)) + (CHARCODE %")) + (AND (EQ CH (CHARCODE CR)) + (EQ (BIN TEXTSTREAM) + (CHARCODE %"] (* ; + "Old-style form, get rid of surrounding double quotes") + (TEDIT.DELETE TEXTSTREAM 1 (ADD1 (GETFILEPTR TEXTSTREAM))) + (TEDIT.DELETE TEXTSTREAM (GETEOFPTR TEXTSTREAM) + 1))) + [bind [OPENMARKER _ (CONSTANT (ALLOCSTRING 1 (CHARCODE ^A] + J + (I _ 1) while (SETQ I (TEDIT.FIND TEXTSTREAM OPENMARKER I)) + do (* ; + "Change Laurel forms into Lafite forms") + (COND + ((AND (SETQ J (TEDIT.FIND TEXTSTREAM (CONSTANT (ALLOCSTRING 1 (CHARCODE ^B))) + (ADD1 I) + (IPLUS I 70))) + (NOT (TEDIT.FIND TEXTSTREAM OPENMARKER (ADD1 I) + J))) + (TEDIT.DELETE TEXTSTREAM J 1) + (TEDIT.INSERT TEXTSTREAM "<<" J) + (TEDIT.DELETE TEXTSTREAM I 1) + (TEDIT.INSERT TEXTSTREAM ">>" I) + (SETQ I J)) + (T (RETURN] + (bind (I _ 1) while (SETQ I (TEDIT.FIND TEXTSTREAM ">>Self<<" I)) + do (* ; + "Replace '>>Self<<' with user name") + (OR NAME (SETQ NAME (FULLUSERNAME))) + (TEDIT.DELETE TEXTSTREAM I 8) + (TEDIT.INSERT TEXTSTREAM NAME I) + (SETFILEPTR TEXTSTREAM I) (* ; "Patch around tedit bug...")) + (\LAFITE.FIND.TEMPLATE TEXTSTREAM) + (RETURN TEXTSTREAM]) + +(\LAFITE.FIND.TEMPLATE + [LAMBDA (TEXTSTREAM) (* bvm%: "22-Apr-84 23:59") + (LET (SELECTSTART) + (COND + ((SETQ SELECTSTART (TEDIT.FIND TEXTSTREAM ">>*<<" 1 NIL T)) + (* ; + "Wait until TEDIT.FIND gets fixed") + (* ; + "highlight the first 'blank' to fill in") + [COND + ((LISTP SELECTSTART) + (SETQ SELECTSTART (CAR SELECTSTART] + (TEDIT.SETSEL TEXTSTREAM SELECTSTART (+ 2 (- (TEDIT.FIND TEXTSTREAM "<<" SELECTSTART) + SELECTSTART)) + 'RIGHT T) + T) + (T (TEDIT.SETSEL TEXTSTREAM 1 0 'LEFT]) +) + + + +(* ; "ANSWER") + +(DEFINEQ + +(\LAFITE.ANSWER + [LAMBDA (WINDOW FOLDERDATA ITEM MENU) (* bvm%: " 1-Feb-84 15:08") + (ADD.PROCESS (LIST (FUNCTION \LAFITE.ANSWER.PROC) + (KWOTE WINDOW) + (KWOTE FOLDERDATA) + (KWOTE ITEM) + (KWOTE MENU)) + 'NAME + 'MESSAGEANSWERER + 'RESTARTABLE + 'NO]) + +(\LAFITE.ANSWER.PROC + [LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* bvm%: "29-May-84 15:59") + (PROG (MSGDESCRIPTOR FORM) + [SETQ FORM (RESETLST + (LA.RESETSHADE ITEM MENU) + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) + (COND + ((NOT (LAB.ASSURE.SELECTIONS MAILFOLDER)) + (MAKEANSWERFORM (SETQ MSGDESCRIPTOR + (find MSGDESCRIPTOR selectedin + MAILFOLDER + suchthat T)) + MAILFOLDER)))))] + (COND + ((AND FORM (\SENDMESSAGE FORM)) + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + [PROG ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER))) + (COND + ([AND MESSAGES (EQ MSGDESCRIPTOR (NTHMESSAGE MESSAGES (fetch + (LAFITEMSG %#) + of + MSGDESCRIPTOR + ] + (* ; + "If message got expunged since we constructed the answer form, we can't do anything") + (MARKMESSAGE MSGDESCRIPTOR MAILFOLDER ANSWERMARK])]) + +(MAKEANSWERFORM + [LAMBDA (MSGDESCRIPTORS MAILFOLDER) (* ; "Edited 10-Aug-89 17:28 by bvm") + (LET* ((FIRSTMSG (if (LISTP MSGDESCRIPTORS) + then (CAR MSGDESCRIPTORS) + else MSGDESCRIPTORS)) + (MODEBITS (fetch (LAFITEMSG MODEBITS) of FIRSTMSG)) + (MODE (CL:NTH MODEBITS *LAFITE-WELL-KNOWN-MODES*))) + (if (NULL MODE) + then (if [OR (NEQ MODEBITS 0) + (NULL (SETQ MODE (\LAFITE.GUESS.MODE FIRSTMSG] + then (LAB.PROMPTPRINT MAILFOLDER (if (EQ MODEBITS 0) + then + "Message of unknown protocol." + else + "Warning: This message was retrieved under a protocol not currently enabled." + )) + (LAB.PROMPTPRINT MAILFOLDER "Will answer in " (SETQ MODE + (fetch + (LAFITEOPS + LAFITEMODE) + of \LAFITEMODE + )) + " mode; this may not work. "))) + + (* ;; "Currently we only pay attention to the first message. If we ever do otherwise, we'll want to notice whether the other messages are in the same mode") + + (LET ((*LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA MODE)) + MSG) + + (* ;; "Before returning the form, tag it with a mail mode") + + (if (NULL *LAFITE-MODE-DATA*) + then (LAB.FORMAT MAILFOLDER "Failed: can't authenticate user in ~A mode" MODE) + elseif (SETQ MSG (CL:FUNCALL (fetch (LAFITEMODEDATA ANSWERER) of + *LAFITE-MODE-DATA* + ) + MSGDESCRIPTORS MAILFOLDER)) + then (if (TEXTSTREAMP MSG) + then (TEXTPROP MSG 'LAFITEMODE MODE) + MSG + else (OPENTEXTSTREAM MSG NIL NIL NIL `(LAFITEMODE ,MODE]) + +(LA.PRINT.COMMA.LIST + [LAMBDA (STRINGS STREAM) (* ; "Edited 6-Jun-88 12:50 by bvm") + (for STR in STRINGS bind NTHTIME when STR do (COND + (NTHTIME (PRIN3 ", " STREAM)) + (T (SETQ NTHTIME T))) + (PRIN3 STR STREAM]) + +(LAFITE.FILL.IN.ANSWER.FORM + [LAMBDA (SUBJECT FROM DATE TO CC ADDRESSPRINTFN) (* ; "Edited 10-Jun-88 17:19 by bvm") + + (* ;; "Construct an answer form replying to a message from FROM on DATE with specified SUBJECT. Reply should go to the lists of names TO and CC. ADDRESSPRINTFN is a function that prints a list of names suitably for the protocol in question.") + + (LET ((OUTSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (LIST 'FONT LAFITEEDITORFONT))) + SELECTPOSITION) + (LINELENGTH MAX.SMALLP OUTSTREAM) (* ; + "Sigh, apparently text streams have linelength") + (PROGN (printout OUTSTREAM "Subject: ") + (if SUBJECT + then (COND + ((NOT (STRING-EQUAL (SUBSTRING SUBJECT 1 3) + "Re:")) + (printout OUTSTREAM "Re: "))) + (printout OUTSTREAM SUBJECT) + else (printout OUTSTREAM "(reply to message)"))) + (PROGN (printout OUTSTREAM T "In-reply-to: ") + (if (NULL FROM) + then (printout OUTSTREAM "your") + else (printout OUTSTREAM FROM "'s")) + (printout OUTSTREAM " message of " DATE T)) + (PROGN (printout OUTSTREAM "To: ") + (if TO + then (CL:FUNCALL ADDRESSPRINTFN TO OUTSTREAM) + else (* ; "No to, so ask to fill in") + (printout OUTSTREAM RECIPIENTSSTR T)) + (TERPRI OUTSTREAM)) + (COND + (CC (printout OUTSTREAM "cc: ") + (CL:FUNCALL ADDRESSPRINTFN CC OUTSTREAM) + (TERPRI OUTSTREAM))) + (TERPRI OUTSTREAM) + (SETQ SELECTPOSITION (ADD1 (GETFILEPTR OUTSTREAM))) + (printout OUTSTREAM MESSAGESTR T) + (if LAFITE.SIGNATURE + then (* ; "Pre-sign it") + (PRIN3 LAFITE.SIGNATURE OUTSTREAM)) + (TEDIT.SETSEL OUTSTREAM SELECTPOSITION (NCHARS MESSAGESTR) + 'RIGHT T) + OUTSTREAM]) +) + + + +(* ; "FORWARD") + +(DEFINEQ + +(\LAFITE.FORWARD + [LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* bvm%: " 1-Feb-84 15:05") + (ADD.PROCESS (LIST (FUNCTION \LAFITE.FORWARD.PROC) + (KWOTE WINDOW) + (KWOTE MAILFOLDER) + (KWOTE ITEM) + (KWOTE MENU)) + 'NAME + 'MESSAGEFORWARDER + 'RESTARTABLE + 'NO]) + +(\LAFITE.FORWARD.PROC + [LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* ; "Edited 14-Oct-87 16:20 by bvm:") + (PROG (FORWARDEDMSGS FORM) + + (* ;; "the reason to get the MSG#S first is that they may have changed by the time \SENDMESSAGE finishes and then we would have marked the wrong ones") + + (RESETLST + (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + NIL T) + (LA.RESETSHADE ITEM MENU) + (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) + [COND + ((NOT (LAB.ASSURE.SELECTIONS MAILFOLDER)) + (SETQ FORM (MAKEFORWARDFORM WINDOW MAILFOLDER (SETQ FORWARDEDMSGS ( + LAB.SELECTED.MESSAGES + MAILFOLDER]) + (COND + ((AND FORM (\SENDMESSAGE FORM)) + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) + [PROG ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER))) + (COND + (MESSAGES (* ; + "Make sure folder hasn't been closed since") + (for MSG in FORWARDEDMSGS + when (EQ MSG (NTHMESSAGE MESSAGES (fetch (LAFITEMSG + %#) + of MSG))) + do (* ; + "If message got expunged since we constructed the forward form, we can't do anything") + (MARKMESSAGE MSG MAILFOLDER FORWARDMARK])]) + +(MAKEFORWARDFORM + [LAMBDA (WINDOW FOLDER MESSAGELIST) (* ; "Edited 5-Jan-90 17:46 by bvm") + + (* ;; "Make a message form that forwards each of the messages in MESSAGELIST") + + (PROG ((FOLDERSTREAM (\LAFITE.OPEN.FOLDER FOLDER 'INPUT :ABORT)) + (TEXTSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (LIST 'FONT LAFITEEDITORFONT))) + (CURMSG (CAR MESSAGELIST)) + SUBJECT SELECTPOSITION SELECTLEN) + (OR (fetch (LAFITEMSG PARSED?) of CURMSG) + (LAFITE.PARSE.MSG.FOR.TOC CURMSG FOLDER)) + (LINELENGTH MAX.SMALLP TEXTSTREAM) + (PRIN3 "Subject: " TEXTSTREAM) + (COND + ([OR LAFITEFORWARDSUBJECTSTR (NULL (SETQ SUBJECT (fetch (LAFITEMSG SUBJECT) + of CURMSG] + (SETQ SELECTPOSITION (ADD1 (GETFILEPTR TEXTSTREAM))) + [SETQ SELECTLEN (NCHARS (SETQ SUBJECT (OR LAFITEFORWARDSUBJECTSTR SUBJECTSTR] + (PRIN3 SUBJECT TEXTSTREAM)) + (T (CL:FORMAT TEXTSTREAM "[~@[~A: ~]~A]" (fetch (LAFITEMSG FROM) of CURMSG) + SUBJECT))) + (TERPRI TEXTSTREAM) + (PRIN3 "To: " TEXTSTREAM) + [COND + ((NOT SELECTPOSITION) + (SETQ SELECTPOSITION (ADD1 (GETFILEPTR TEXTSTREAM))) + (SETQ SELECTLEN (NCHARS RECIPIENTSSTR] + (CL:FORMAT TEXTSTREAM "~A cc: ~A ~A -" RECIPIENTSSTR (FULLUSERNAME) (CAR LAFITEFORWARDSTRINGS)) (if LAFITE.SIGNATURE then (* ; "Sign it up here, after the user's inserted comments, if any") (PRIN3 LAFITE.SIGNATURE TEXTSTREAM) (TERPRI TEXTSTREAM)) (for MSGDESCRIPTOR in MESSAGELIST bind NTHTIME do (PRIN3 (COND (NTHTIME (* ; "%"Next message%"") (CADDR LAFITEFORWARDSTRINGS)) (T (* ; "%"Begin forwarded messages%"") (SETQ NTHTIME T) (CADR LAFITEFORWARDSTRINGS))) TEXTSTREAM) (TERPRI TEXTSTREAM) (\LAFITE.APPEND.MESSAGE.BODY TEXTSTREAM FOLDERSTREAM MSGDESCRIPTOR \LAPARSE.DONT.FORWARD.HEADERS) (TERPRI TEXTSTREAM) (TEDIT.CARETLOOKS TEXTSTREAM LAFITEEDITORFONT)) (PRIN3 (CADDDR LAFITEFORWARDSTRINGS) TEXTSTREAM) (TERPRI TEXTSTREAM) (TEDIT.SETSEL TEXTSTREAM SELECTPOSITION SELECTLEN (QUOTE RIGHT) T) (RETURN TEXTSTREAM))) -) ) (RPAQQ LAFITESENDINGMENUITEMS (("Deliver" '\SENDMSG.DELIVER "Send the message in the edit window" ) ("Reply To" '\SENDMSG.REPLYTO "Insert a Reply-to field in this message") ("Change Mode" '\SENDMSG.CHANGE.MODE "Change the mode (mail protocol) used to send this message." ) ("Save" '\SENDMSG.SAVE.FORM "Save the message in a file for later use (retrieve with middle-button SendMail)" ))) (RPAQQ LAFITEFORMSMENUITEMS (("Saved Form" '%##ANOTHERFORM## "You will be asked to specify a filename for the form") ("Standard Form" (FUNCTION MAKENEWMESSAGEFORM) "A clean message form"))) (RPAQQ LAFITEFORMATMENUITEMS (("Send Formatted Message" 'TEDIT) ("Send Plain Text" 'TEXT) ("Abort" 'ABORT))) (RPAQQ LAFITEFORWARDSTRINGS (">>CoveringMessage<<" " ----- Begin Forwarded Messages ----- " " ----- Next Message ----- " " ----- End Forwarded Messages -----")) (ADDTOVAR \SYSTEMCACHEVARS \LAFITE.REPORT.MACHINE) (ADDTOVAR LAFITESPECIALFORMS ("Lisp Report" (FUNCTION MAKELISPSUPPORTFORM) "A form to report a Lisp bug or suggestion") ("Lafite Report" (FUNCTION MAKELAFITESUPPORTFORM) "A form to report a Lafite bug or suggestion")) (ADDTOVAR LAFITEMENUVARS LAFITEFORMSMENU LAFITEFORMATMENU) (RPAQ? \LAFITE.REPORT.MACHINE ) (RPAQ? LAFITECURRENTEDITORWINDOWS ) (RPAQ? LAFITEFORMFILES ) (RPAQ? LAFITEFORMSMENU ) (RPAQ? LAFITEFORMATMENU ) (RPAQ? LAFITEEDITORFONT LAFITEDISPLAYFONT) (RPAQ? LAFITEFORM.EXT "Lafite-form") (RPAQ? LAFITEFORMDIRECTORIES NIL) (RPAQ? LAFITE.EDITOR.SIZE '(470 . 300)) (RPAQ? LAFITE.EDITOR.LAYOUTS NIL) (RPAQ? LAFITEFORWARDSUBJECTSTR NIL) (RPAQ? LAFITESUPPORT NIL) (RPAQ? LISPSUPPORT NIL) (RPAQ? MESSAGESTR ">>Message<<") (RPAQ? RECIPIENTSSTR ">>Recipients<<") (RPAQ? SUBJECTSTR ">>Subject<<") (RPAQ? LAFITE.SEND.FORMATTED '((NSCHARS :ASK) (CHARLOOKS :ASK) (PARALOOKS :ASK) (IMAGEOBJ :ASK))) (* ; "Obsolete") (RPAQ? LAFITEEDITORREGION NIL) (* ; "ICON stuff") (RPAQQ LAFITE.MSG.ICON (#*(82 72)@@@@@@@@@GO@@@@@@@@@@@@@@@@@@@@@AOOL@@@@@@@@@@@@@@@@@@@@GH@O@@@@@@@@@@@@@@@@@@@CN@@CL@@@@@@@@@@@@@@@@@@OH@@@OH@@@@@@@@@@@@@@@@CL@@@@CN@@@@@@@@@@@@@@@@O@@@@@@GH@@@@@@@@@@@@@@CL@@@@@@AN@@@@@@@@@@@@@AO@@@@@@@@GL@@@@@@@@@@@@GL@@@@@@@@AO@@@@@@@@@@@AN@@@@@@@@@@CL@@@@@@@@@@GH@@@@@@@@@@@O@@@@@@@@@CN@@@@@@@@@@@@CL@@@@@@@@OH@@@@@@@@@@@@@OH@@@@@@CL@@@@@@@@@@@@@@CN@@@@@@O@@@@@@@@@@@@@@@@GH@@@@CL@@@@@@@@@@@@@@@@AN@@@@O@@@@@@@@@@@@@@@@@@GH@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@O@@@@@@@@@@@@@@@@@@GL@@@ML@@@@@@@@@@@@@@@@ALL@@@LN@@@@@@@@@@@@@@@@CHL@@@LCH@@@@@@@@@@@@@@@N@L@@@LAL@@@@@@@@@@@@@@CL@L@@@L@G@@@@@@@@@@@@@@G@@L@@@L@CL@@@@@@@@@@@@AL@@L@@@L@@N@@@@@@@@@@@@CH@@L@@@L@@CH@@@@@@@@@@@N@@@L@@@L@@AL@@@@@@@@@@AL@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@N@@@@@@@@@@@@CH@@L@@@L@CL@@@@@@@@@@@@AL@@L@@@L@G@@@@@@@@@@@@@@G@@L@@@LAL@@@@@@@@@@@@@@CL@L@@@LCH@@@@@@@@@@@@@@@N@L@@@LN@@@@@@@@@@@@@@@@CHL@@@ML@@@@@@@@@@@@@@@@ALL@@@O@@@@@@@@@@@@@@@@@@GL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@ #*(82 72)@@@@@@@@@GO@@@@@@@@@@@@@@@@@@@@@AOOL@@@@@@@@@@@@@@@@@@@@GOOO@@@@@@@@@@@@@@@@@@@COOOOL@@@@@@@@@@@@@@@@@@OOOOOOH@@@@@@@@@@@@@@@@COOOOOON@@@@@@@@@@@@@@@@OOOOOOOOH@@@@@@@@@@@@@@COOOOOOOON@@@@@@@@@@@@@AOOOOOOOOOOL@@@@@@@@@@@@GOOOOOOOOOOO@@@@@@@@@@@AOOOOOOOOOOOOL@@@@@@@@@@GOOOOOOOOOOOOO@@@@@@@@@COOOOOOOOOOOOOOL@@@@@@@@OOOOOOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOOOH@@@@COOOOOOOOOOOOOOOOOON@@@@OOOOOOOOOOOOOOOOOOOOH@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@ (8 8 64 36))) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD SENDINGCOMMAND (COMMAND ITEM MENU MESSAGE MESSAGEPARSE) [TYPE? (AND (LISTP DATUM) (FMEMB (fetch COMMAND of DATUM) '(%##SEND## %##SAVE## %##FORGETIT##]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LAFITE.REPORT.MACHINE LAFITECURRENTEDITORWINDOWS LAFITEEDITORFONT LAFITEEDITORREGION LAFITEFORMATMENU LAFITEFORMSMENUITEMS LAFITEFORMATMENUITEMS LAFITEFORWARDSTRINGS LAFITEFORWARDSUBJECTSTR LAFITESENDINGMENUITEMS LAFITESPECIALFORMS LAFITESUPPORT LISPSUPPORT MAKESYSDATE MESSAGESTR RECIPIENTSSTR SUBJECTSTR LAFITE.MSG.ICON LAFITEFORMDIRECTORIES LAFITE.SEND.FORMATTED) ) (FILESLOAD (SOURCE) LAFITEDECLS) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS LAFITESEND COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990 1993 1999 2000) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (5338 18169 (DOLAFITESENDINGCOMMAND 5348 . 5722) (\SENDMESSAGE.INITIATE 5724 . 6580) ( \SENDMSG.DELIVER 6582 . 6971) (\SENDMSG.EXIT.TEDIT 6973 . 7232) (\SENDMSG.SAVE.FORM 7234 . 8426) ( \LAFITE.HEADER.EOF 8428 . 8667) (\LAFITE.INSERT.REPLYTO 8669 . 9174) (\SENDMSG.REPLYTO 9176 . 9539) ( \SENDMSG.CHANGE.MODE 9541 . 11810) (\SENDMSG.FIND.FIELD 11812 . 12179) (\SENDMESSAGE.PARSE 12181 . 12704) (\LAFITE.PREPARE.SEND 12706 . 14368) (\LAFITE.PREPARE.ERROR 14370 . 15093) ( \LAFITE.CHOOSE.MSG.FORMAT 15095 . 16238) (LAFITE.MAKE.PLAIN.TEXTSTREAM 16240 . 16933) ( \SENDMESSAGE.MENUPROMPT 16935 . 17586) (\SENDMESSAGE.PROMPT 17588 . 17984) (\SENDMESSAGEFAIL 17986 . 18167)) (18170 31410 (\SENDMESSAGE 18180 . 19091) (\SENDMESSAGE.RESTARTABLE 19093 . 21719) ( \SENDMESSAGE.CLEANUP 21721 . 21894) (\SENDMESSAGE.MAKEWINDOW 21896 . 24884) (MAKELAFITEDELIVERMENU 24886 . 25091) (\LAFITE.CLOSEMSG? 25093 . 25693) (\LAFITE.AFTER.DELIVER 25695 . 27356) ( \LAFITE.UNSENT.ICON 27358 . 27603) (\LAFITE.FETCH.SUBJECT 27605 . 28053) (LAFITE.SENDMESSAGE 28055 . 28571) (\SENDMESSAGE0 28573 . 29978) (LA.ASSURE.PROMPT.WINDOW 29980 . 30489) (\LAFITE.SEND.FAIL 30491 . 30856) (\LAFITE.INVALID.RECIPIENTS 30858 . 31179) (\SENDMESSAGE.ABORT 31181 . 31408)) (31442 37222 (\OUTBOX.CREATE 31452 . 32458) (\OUTBOX.RESET 32460 . 32764) (\OUTBOX.CLOSEFN 32766 . 32855) ( \OUTBOX.REPAINTFN 32857 . 33199) (\OUTBOX.RESHAPEFN 33201 . 33843) (\OUTBOX.SHADEITEM 33845 . 34315) ( \OUTBOX.BUTTONFN 34317 . 36029) (\OUTBOX.DISPLAYLINE 36031 . 36321) (\OUTBOX.ADD.ITEM 36323 . 37220)) (37518 47459 (\LAFITE.MESSAGEFORM 37528 . 39370) (MAKELAFITESUPPORTFORM 39372 . 39501) ( MAKELISPSUPPORTFORM 39503 . 39609) (MAKEXXXSUPPORTFORM 39611 . 41752) (MAKENEWMESSAGEFORM 41754 . 42346) (MAKELAFITEPRIVATEFORMSITEMS 42348 . 42628) (\LAFITE.UNCACHE.MESSAGEFORM 42630 . 42960) ( \LAFITE.DELETE.MESSAGEFORM 42962 . 43299) (\LAFITE.SELECT.FORM 43301 . 43557) ( \LAFITE.DELETE.FORM.INTERNAL 43559 . 44108) (\LAFITE.READ.FORM 44110 . 46969) (\LAFITE.FIND.TEMPLATE 46971 . 47457)) (47483 51692 (\LAFITE.ANSWER 47493 . 47761) (\LAFITE.ANSWER.PROC 47763 . 48608) ( MAKEANSWERFORM 48610 . 49959) (LA.PRINT.COMMA.LIST 49961 . 50174) (LAFITE.FILL.IN.ANSWER.FORM 50176 . 51690)) (51717 54936 (\LAFITE.FORWARD 51727 . 51998) (\LAFITE.FORWARD.PROC 52000 . 53061) ( MAKEFORWARDFORM 53063 . 54934))))) STOP \ No newline at end of file +" RECIPIENTSSTR (FULLUSERNAME) + (CAR LAFITEFORWARDSTRINGS)) + (if LAFITE.SIGNATURE + then (* ; + "Sign it up here, after the user's inserted comments, if any") + (PRIN3 LAFITE.SIGNATURE TEXTSTREAM) + (TERPRI TEXTSTREAM)) + (for MSGDESCRIPTOR in MESSAGELIST bind NTHTIME + do (PRIN3 (COND + (NTHTIME (* ; "%"Next message%"") + (CADDR LAFITEFORWARDSTRINGS)) + (T (* ; "%"Begin forwarded messages%"") + (SETQ NTHTIME T) + (CADR LAFITEFORWARDSTRINGS))) + TEXTSTREAM) + (TERPRI TEXTSTREAM) + (\LAFITE.APPEND.MESSAGE.BODY TEXTSTREAM FOLDERSTREAM MSGDESCRIPTOR + \LAPARSE.DONT.FORWARD.HEADERS) + (TERPRI TEXTSTREAM) + (TEDIT.CARETLOOKS TEXTSTREAM LAFITEEDITORFONT)) + (PRIN3 (CADDDR LAFITEFORWARDSTRINGS) + TEXTSTREAM) + (TERPRI TEXTSTREAM) + (TEDIT.SETSEL TEXTSTREAM SELECTPOSITION SELECTLEN 'RIGHT T) + (RETURN TEXTSTREAM]) +) + +(RPAQQ LAFITESENDINGMENUITEMS (("Deliver" '\SENDMSG.DELIVER "Send the message in the edit window" + ) + ("Reply To" '\SENDMSG.REPLYTO + "Insert a Reply-to field in this message") + ("Change Mode" '\SENDMSG.CHANGE.MODE + "Change the mode (mail protocol) used to send this message." + ) + ("Save" '\SENDMSG.SAVE.FORM + "Save the message in a file for later use (retrieve with middle-button SendMail)" + ))) + +(RPAQQ LAFITEFORMSMENUITEMS (("Saved Form" '%##ANOTHERFORM## + "You will be asked to specify a filename for the form") + ("Standard Form" (FUNCTION MAKENEWMESSAGEFORM) + "A clean message form"))) + +(RPAQQ LAFITEFORMATMENUITEMS (("Send Formatted Message" 'TEDIT) + ("Send Plain Text" 'TEXT) + ("Abort" 'ABORT))) + +(RPAQQ LAFITEFORWARDSTRINGS (">>CoveringMessage<<" " + ----- Begin Forwarded Messages ----- +" " + ----- Next Message ----- +" " + ----- End Forwarded Messages -----")) + +(ADDTOVAR \SYSTEMCACHEVARS \LAFITE.REPORT.MACHINE) + +(ADDTOVAR LAFITESPECIALFORMS ("Lisp Report" (FUNCTION MAKELISPSUPPORTFORM) + "A form to report a Lisp bug or suggestion") + ("Lafite Report" (FUNCTION MAKELAFITESUPPORTFORM) + "A form to report a Lafite bug or suggestion")) + +(ADDTOVAR LAFITEMENUVARS LAFITEFORMSMENU LAFITEFORMATMENU) + +(RPAQ? \LAFITE.REPORT.MACHINE ) + +(RPAQ? LAFITECURRENTEDITORWINDOWS ) + +(RPAQ? LAFITEFORMFILES ) + +(RPAQ? LAFITEFORMSMENU ) + +(RPAQ? LAFITEFORMATMENU ) + +(RPAQ? LAFITEEDITORFONT LAFITEDISPLAYFONT) + +(RPAQ? LAFITEFORM.EXT "Lafite-form") + +(RPAQ? LAFITEFORMDIRECTORIES NIL) + +(RPAQ? LAFITE.EDITOR.SIZE '(470 . 300)) + +(RPAQ? LAFITE.EDITOR.LAYOUTS NIL) + +(RPAQ? LAFITEFORWARDSUBJECTSTR NIL) + +(RPAQ? LAFITESUPPORT NIL) + +(RPAQ? LISPSUPPORT NIL) + +(RPAQ? MESSAGESTR ">>Message<<") + +(RPAQ? RECIPIENTSSTR ">>Recipients<<") + +(RPAQ? SUBJECTSTR ">>Subject<<") + +(RPAQ? LAFITE.SEND.FORMATTED '((NSCHARS :ASK) + (CHARLOOKS :ASK) + (PARALOOKS :ASK) + (IMAGEOBJ :ASK))) + + + +(* ; "Obsolete") + + +(RPAQ? LAFITEEDITORREGION NIL) + + + +(* ; "ICON stuff") + + +(RPAQQ LAFITE.MSG.ICON (#*(82 72)@@@@@@@@@GO@@@@@@@@@@@@@@@@@@@@@AOOL@@@@@@@@@@@@@@@@@@@@GH@O@@@@@@@@@@@@@@@@@@@CN@@CL@@@@@@@@@@@@@@@@@@OH@@@OH@@@@@@@@@@@@@@@@CL@@@@CN@@@@@@@@@@@@@@@@O@@@@@@GH@@@@@@@@@@@@@@CL@@@@@@AN@@@@@@@@@@@@@AO@@@@@@@@GL@@@@@@@@@@@@GL@@@@@@@@AO@@@@@@@@@@@AN@@@@@@@@@@CL@@@@@@@@@@GH@@@@@@@@@@@O@@@@@@@@@CN@@@@@@@@@@@@CL@@@@@@@@OH@@@@@@@@@@@@@OH@@@@@@CL@@@@@@@@@@@@@@CN@@@@@@O@@@@@@@@@@@@@@@@GH@@@@CL@@@@@@@@@@@@@@@@AN@@@@O@@@@@@@@@@@@@@@@@@GH@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@O@@@@@@@@@@@@@@@@@@GL@@@ML@@@@@@@@@@@@@@@@ALL@@@LN@@@@@@@@@@@@@@@@CHL@@@LCH@@@@@@@@@@@@@@@N@L@@@LAL@@@@@@@@@@@@@@CL@L@@@L@G@@@@@@@@@@@@@@G@@L@@@L@CL@@@@@@@@@@@@AL@@L@@@L@@N@@@@@@@@@@@@CH@@L@@@L@@CH@@@@@@@@@@@N@@@L@@@L@@AL@@@@@@@@@@AL@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@N@@@@@@@@@@@@CH@@L@@@L@CL@@@@@@@@@@@@AL@@L@@@L@G@@@@@@@@@@@@@@G@@L@@@LAL@@@@@@@@@@@@@@CL@L@@@LCH@@@@@@@@@@@@@@@N@L@@@LN@@@@@@@@@@@@@@@@CHL@@@ML@@@@@@@@@@@@@@@@ALL@@@O@@@@@@@@@@@@@@@@@@GL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@ + #*(82 72)@@@@@@@@@GO@@@@@@@@@@@@@@@@@@@@@AOOL@@@@@@@@@@@@@@@@@@@@GOOO@@@@@@@@@@@@@@@@@@@COOOOL@@@@@@@@@@@@@@@@@@OOOOOOH@@@@@@@@@@@@@@@@COOOOOON@@@@@@@@@@@@@@@@OOOOOOOOH@@@@@@@@@@@@@@COOOOOOOON@@@@@@@@@@@@@AOOOOOOOOOOL@@@@@@@@@@@@GOOOOOOOOOOO@@@@@@@@@@@AOOOOOOOOOOOOL@@@@@@@@@@GOOOOOOOOOOOOO@@@@@@@@@COOOOOOOOOOOOOOL@@@@@@@@OOOOOOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOOOH@@@@COOOOOOOOOOOOOOOOOON@@@@OOOOOOOOOOOOOOOOOOOOH@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@ + (8 8 64 36))) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RECORD SENDINGCOMMAND (COMMAND ITEM MENU MESSAGE MESSAGEPARSE) + [TYPE? (AND (LISTP DATUM) + (FMEMB (fetch COMMAND of DATUM) + '(%##SEND## %##SAVE## %##FORGETIT##]) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \LAFITE.REPORT.MACHINE LAFITECURRENTEDITORWINDOWS LAFITEEDITORFONT LAFITEEDITORREGION + LAFITEFORMATMENU LAFITEFORMSMENUITEMS LAFITEFORMATMENUITEMS LAFITEFORWARDSTRINGS + LAFITEFORWARDSUBJECTSTR LAFITESENDINGMENUITEMS LAFITESPECIALFORMS LAFITESUPPORT LISPSUPPORT + MAKESYSDATE MESSAGESTR RECIPIENTSSTR SUBJECTSTR LAFITE.MSG.ICON LAFITEFORMDIRECTORIES + LAFITE.SEND.FORMATTED) +) + + +(FILESLOAD (SOURCE) + LAFITEDECLS) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) +) +(PUTPROPS LAFITESEND COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990 1993 1999 2000 +2021)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (5301 28278 (DOLAFITESENDINGCOMMAND 5311 . 5801) (\SENDMESSAGE.INITIATE 5803 . 7742) ( +\SENDMSG.DELIVER 7744 . 8352) (\SENDMSG.EXIT.TEDIT 8354 . 8725) (\SENDMSG.SAVE.FORM 8727 . 10714) ( +\LAFITE.HEADER.EOF 10716 . 11009) (\LAFITE.INSERT.REPLYTO 11011 . 11619) (\SENDMSG.REPLYTO 11621 . +12180) (\SENDMSG.CHANGE.MODE 12182 . 17758) (\SENDMSG.FIND.FIELD 17760 . 18270) (\SENDMESSAGE.PARSE +18272 . 19068) (\LAFITE.PREPARE.SEND 19070 . 21903) (\LAFITE.PREPARE.ERROR 21905 . 23087) ( +\LAFITE.CHOOSE.MSG.FORMAT 23089 . 25730) (LAFITE.MAKE.PLAIN.TEXTSTREAM 25732 . 26657) ( +\SENDMESSAGE.MENUPROMPT 26659 . 27522) (\SENDMESSAGE.PROMPT 27524 . 28060) (\SENDMESSAGEFAIL 28062 . +28276)) (28279 52755 (\SENDMESSAGE 28289 . 29481) (\SENDMESSAGE.RESTARTABLE 29483 . 34790) ( +\SENDMESSAGE.CLEANUP 34792 . 35008) (\SENDMESSAGE.MAKEWINDOW 35010 . 41183) (MAKELAFITEDELIVERMENU +41185 . 41492) (\LAFITE.CLOSEMSG? 41494 . 42444) (\LAFITE.AFTER.DELIVER 42446 . 45765) ( +\LAFITE.UNSENT.ICON 45767 . 46077) (\LAFITE.FETCH.SUBJECT 46079 . 46879) (LAFITE.SENDMESSAGE 46881 . +47642) (\SENDMESSAGE0 47644 . 50508) (LA.ASSURE.PROMPT.WINDOW 50510 . 51407) (\LAFITE.SEND.FAIL 51409 + . 51880) (\LAFITE.INVALID.RECIPIENTS 51882 . 52340) (\SENDMESSAGE.ABORT 52342 . 52753)) (52787 62700 +(\OUTBOX.CREATE 52797 . 54260) (\OUTBOX.RESET 54262 . 54755) (\OUTBOX.CLOSEFN 54757 . 54897) ( +\OUTBOX.REPAINTFN 54899 . 55562) (\OUTBOX.RESHAPEFN 55564 . 56847) (\OUTBOX.SHADEITEM 56849 . 57522) ( +\OUTBOX.BUTTONFN 57524 . 60372) (\OUTBOX.DISPLAYLINE 60374 . 60868) (\OUTBOX.ADD.ITEM 60870 . 62698)) +(62996 79218 (\LAFITE.MESSAGEFORM 63006 . 67349) (MAKELAFITESUPPORTFORM 67351 . 67540) ( +MAKELISPSUPPORTFORM 67542 . 67708) (MAKEXXXSUPPORTFORM 67710 . 71690) (MAKENEWMESSAGEFORM 71692 . +72531) (MAKELAFITEPRIVATEFORMSITEMS 72533 . 72961) (\LAFITE.UNCACHE.MESSAGEFORM 72963 . 73416) ( +\LAFITE.DELETE.MESSAGEFORM 73418 . 74019) (\LAFITE.SELECT.FORM 74021 . 74376) ( +\LAFITE.DELETE.FORM.INTERNAL 74378 . 75522) (\LAFITE.READ.FORM 75524 . 78261) (\LAFITE.FIND.TEMPLATE +78263 . 79216)) (79242 87146 (\LAFITE.ANSWER 79252 . 79657) (\LAFITE.ANSWER.PROC 79659 . 81553) ( +MAKEANSWERFORM 81555 . 84367) (LA.PRINT.COMMA.LIST 84369 . 84855) (LAFITE.FILL.IN.ANSWER.FORM 84857 . +87144)) (87171 92434 (\LAFITE.FORWARD 87181 . 87589) (\LAFITE.FORWARD.PROC 87591 . 89580) ( +MAKEFORWARDFORM 89582 . 92432))))) +STOP diff --git a/library/lafite/LAFITESEND.LCOM b/library/lafite/LAFITESEND.LCOM index 9c9d3ee5ba6f5a7f02a9f902f5059cf62573a8c9..7e180958f6a9163adc75cb4c423b49d04575cf7b 100644 GIT binary patch delta 1102 zcmb`HOH30{6ovyaK*nfL+VY0uDAJm=wo^)mYDxw=HI?auPKyCiC@@77+EUPv7{g8z zQK4L(EtJ-kMk5OnO4_=5k)i0opwb7*STr_L zV})>J^wvPQ9|pp}Is%dehieT60}Fk@QOrNelV^2|*5Q=IW}hhdMLV!&4ZP6;(U@{?AaZvkyE{Av!-83FS9b97f{Iy59T z*Me#_T|x5Zsq58w+VRaitvb0tb!?#bn z5|0;QxGSN_-wm~r?!^)^lc>Sy`-FtdPhO)L$sqDW(tnUA%xDO=q{ZmG8@WfkZ;Quu%a-8!IK~vzaL(J1fPg3e)HI9SL+4A9p*Y{c5sqRFQXc zs=u@SG*^ZtFVbg`8|l*0gZ56@D+jz@JUwI$$nP{@PIcxy(vg9K7GElh$Tq;Ca)U`sJg%LI$)v@K9d|=KAbBU#}`BfT4dGScN^9Kb*-& A1poj5 delta 1034 zcma))OH30{6ox~igcK)XfkMFIWr(qZQrel)luCd?TTK^^5vg<&OMJmH+3M$90=mh zW}5C9UkvupQd)*&QWXPVe_~-u&QOS?WwjX1sO0@BT1q0}Y=m=%0%4z@^C0eC*za@u zV*aJeDuh3Gh;+UnB6SXf0iC=pkw{47amC<<@RYKQoTP+eo!+1wwQ1FMtp?#Yb)rY% zNN9m`#|8tO$ImS>lD`xYC$_Hxvnw6h&2PTM?{z0e|1-ZBgagfzF&9 zxRRsJ5+ouC{5mH(R{Obbh}7q4V1IrBShb}W^!b7cXeo36Lj`iYI{d%KV&q>Ud)#=a z_K1wEQEPIXa;~;l0(igB-B2xuXVN0*aJAS8G!`Ym<+9EfyO?Uy@k4f4EM}V>ne>KQ zbv2TBMyUGknGz$pB_1Uv11DIL}e2!#KXMs^!tJgILYkXVV7 VNFhgzf;SXD-{Bf4f+Clafite>parc-94>LAFITESORT.;2 12117 changes to%: (VARS LAFITESORTCOMS) previous date%: " 7-Oct-89 14:07:49" {DSK}lafite>parc-94>LAFITESORT.;1) (* ; " Copyright (c) 1989, 1995 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LAFITESORTCOMS) (RPAQQ LAFITESORTCOMS [(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) LAFITEDECLS)) (FNS LAFITE.ASSURE.DATE.FIELDS LAFITE.PARSE.DATE.FIELD LAFITE.PARSE.DATE.FIELD.ONLY LAFITE.SORT.BY.DATE LAFITE.SORT.MESSAGES LAFITEMSG.DATE.ORDER \LAFITE.SORT.BY.DATE.INTERACTIVE \LAFITE.SORT.BY.DATE.REGION) [APPENDVARS (LAFITEEXTRAMENUITEMS ("Sort by Date" '\LAFITE.SORT.BY.DATE.INTERACTIVE "Sort all the messages in this folder by their Date: fields." (SUBITEMS ("Sort Entire Folder" '\LAFITE.SORT.BY.DATE.INTERACTIVE "Sort all the messages in this folder by their Date: fields." ) ("Sort Selected Range" '\LAFITE.SORT.BY.DATE.REGION "Sort only the messages between the first and last selected messages." ] (COMS (* ; "Date hax") (FNS GDATE1-6) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS \4YearsDays) (GLOBALVARS \TimeZoneComp \DayLightSavings]) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) LAFITEDECLS) ) (DEFINEQ (LAFITE.ASSURE.DATE.FIELDS -(LAMBDA (FOLDER FIRST# LAST#) (* ; "Edited 5-May-89 15:46 by bvm") (* ;; "Assure that messages FIRST# thru LAST# have IDATE fields. FIRST# & LAST# default.") (for I from (OR FIRST# 1) to (OR LAST# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) bind (STREAM _ (\LAFITE.OPEN.FOLDER FOLDER (QUOTE INPUT) :ABORT)) (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (FAILURECNT _ 0) (MISSING _ 0) MSG ID PREV DATEFAILURE DATEFETCHED BABBLED do (if (fetch (LAFITEMSG DATEFETCHED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) then (* ; "Ok") (if (NOT (fetch (LAFITEMSG DATEKNOWN?) of MSG)) then (add FAILURECNT 1)) else (if (NOT BABBLED) then (* ; "Tell user what's taking so long") (LAB.PROMPTPRINT FOLDER "Collecting dates... ") (SETQ BABBLED T)) (if (FIXP (SETQ ID (LAFITE.PARSE.HEADER STREAM \LAPARSE.DATEFIELD (fetch (LAFITEMSG START) of MSG) (fetch (LAFITEMSG END) of MSG) T))) then (replace (LAFITEMSG IDATE) of MSG with ID) (replace (LAFITEMSG DATEKNOWN?) of MSG with T) (replace (LAFITEMSG DATEFETCHED?) of MSG with T) (replace (LAFITEMSG DATE) of MSG with NIL) (* ; "So it will be regenerated in canonical form") (OR DATEFETCHED (SETQ DATEFETCHED I)) else (replace (LAFITEMSG DATEKNOWN?) of MSG with NIL) (if LAFITEDEBUGFLG then (LAB.FORMAT FOLDER " ~:[Date missing for~;Could not parse date of~] msg ~D. " ID I)) (add FAILURECNT 1) (if (NULL ID) then (add MISSING 1)) (if (AND (> I 1) (fetch (LAFITEMSG DATEFETCHED?) of (SETQ PREV (NTHMESSAGE MESSAGES (SUB1 I))))) then (* ; "Guess that message i has date just after i-1") (replace (LAFITEMSG IDATE) of MSG with (ADD1 (fetch (LAFITEMSG IDATE) of PREV))) (replace (LAFITEMSG DATEFETCHED?) of MSG with T) else (SETQ DATEFAILURE I)))) finally (if (AND DATEFETCHED (< DATEFETCHED (fetch (MAILFOLDER TOCLASTMESSAGE#) of FOLDER))) then (* ; "Assure that the toc will be rewritten at least this far back so that we save the dates.") (replace (MAILFOLDER TOCLASTMESSAGE#) of FOLDER with DATEFETCHED)) (COND ((AND DATEFAILURE (NOT (for I from (ADD1 (OR FIRST# 1)) to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) when (fetch (LAFITEMSG DATEFETCHED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) do (* ; "Got a date later on") (SETQ ID (fetch (LAFITEMSG IDATE) of MSG)) (for J from DATEFAILURE to (OR FIRST# 1) by -1 do (* ; "Store guess dates for first message(s)") (replace (LAFITEMSG IDATE) of (SETQ MSG (NTHMESSAGE MESSAGES J)) with (add ID -1)) (replace (LAFITEMSG DATEFETCHED?) of MSG with T)) (RETURN T)))) (LAB.PROMPTPRINT FOLDER "Could not parse dates of ANY messages in this file.")) ((> FAILURECNT 0) (LAB.FORMAT FOLDER (if (< MISSING FAILURECNT) then " Note: Could not parse date field of ~D of these messages." else " Note: Missing date field for ~D of these messages.") FAILURECNT))))) -) (LAFITE.PARSE.DATE.FIELD -(LAMBDA (STREAM) (* ; "Edited 5-May-89 12:52 by bvm") (LET* ((DATESTR (LAFITE.READ.TO.EOL STREAM)) (ID (IDATE DATESTR))) (if (AND ID (> ID (CONSTANT (IDATE "1-jan-70 1200")))) then (* ; "Plausible date. Test is for those silly senders who didn't get the date set and have messages reading %"31-dec-00 ...%"") ID else (CONCAT (OR (SUBSTRING DATESTR 1 6 DATESTR) DATESTR) "?")))) -) (LAFITE.PARSE.DATE.FIELD.ONLY -(LAMBDA (STREAM) (DECLARE (USEDFREE PARSERESULT)) (* ; "Edited 26-Apr-89 14:35 by bvm") (SETQ PARSERESULT (LAFITE.PARSE.DATE.FIELD STREAM))) -) (LAFITE.SORT.BY.DATE -(LAMBDA (FOLDER FIRST# LAST#) (* ; "Edited 26-Apr-89 15:32 by bvm") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (LAFITE.ASSURE.DATE.FIELDS FOLDER FIRST# LAST#) (LAFITE.SORT.MESSAGES FOLDER (FUNCTION LAFITEMSG.DATE.ORDER) FIRST# LAST#))) -) (LAFITE.SORT.MESSAGES -(LAMBDA (FOLDER COMPAREFN FIRST# LAST#) (* ; "Edited 7-Oct-89 14:03 by bvm") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (OR FIRST# (SETQ FIRST# 1)) (OR LAST# (SETQ LAST# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) (LAB.PROMPTPRINT FOLDER "Sorting... ") (LET* ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (SORTED (CL:STABLE-SORT (for I from FIRST# to LAST# collect (NTHMESSAGE MESSAGES I)) COMPAREFN))) (while (AND SORTED (EQ (fetch (LAFITEMSG %#) of (CAR SORTED)) FIRST#)) do (* ; "Skip over the initial prefix of in-order messages") (add FIRST# 1) (SETQ SORTED (CDR SORTED))) (if (NULL SORTED) then (LAB.PROMPTPRINT FOLDER "already in order") else (replace (MAILFOLDER FOLDEROUTOFORDER) of FOLDER with T) (if (< FIRST# (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER)) then (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER with FIRST#)) (UNINTERRUPTABLY (for MSG in SORTED as I from FIRST# do (replace (LAFITEMSG %#) of MSG with I) (SETA MESSAGES I MSG))) (LET ((FIRSTSEL (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER)) (LASTSEL (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER))) (if (>= LASTSEL FIRSTSEL) then (if (AND (>= FIRSTSEL FIRST#) (<= FIRSTSEL LAST#)) then (* ; "Start of selection was inside here, have to recompute its number") (replace (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER with (LAB.FIND.SELECTED.MSG FOLDER FIRST# LAST#))) (if (AND (>= LASTSEL FIRST#) (<= LASTSEL LAST#)) then (* ; "End of selection was inside here, have to recompute its number") (replace (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER with (LAB.REV.FIND.SELECTED.MSG FOLDER FIRST# LAST#))))) (LAB.DISPLAYLINES FOLDER FIRST# LAST# NIL T) (LAB.PROMPTPRINT FOLDER "done"))))) -) (LAFITEMSG.DATE.ORDER -(LAMBDA (X Y) (* ; "Edited 26-Apr-89 14:53 by bvm") (* ;; "True if msg X has older date than msg Y. Since date field is stored as an unboxed 32-bit integer, we open code %"<%" here to avoid boxing.") (LET ((HIDIFF (- (LOGXOR (fetch (LAFITEMSG IDATEHI) of X) 32768) (LOGXOR (fetch (LAFITEMSG IDATEHI) of Y) 32768)))) (* ;; "HIDIFF is unsigned difference of high words") (OR (< HIDIFF 0) (AND (EQ HIDIFF 0) (< (fetch (LAFITEMSG IDATELO) of X) (fetch (LAFITEMSG IDATELO) of Y)))))) -) (\LAFITE.SORT.BY.DATE.INTERACTIVE -(LAMBDA (FOLDER FIRST# LAST#) (* ; "Edited 3-May-89 18:38 by bvm") (if (LAB.MOUSECONFIRM FOLDER "Click LEFT to confirm sorting ~D messages by date" (if LAST# then (ADD1 (- LAST# FIRST#)) else (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) then (\LAFITE.PROCESS (BQUOTE ((\, (FUNCTION LAFITE.SORT.BY.DATE)) (QUOTE (\, FOLDER)) (QUOTE (\, FIRST#)) (QUOTE (\, LAST#)))) "LafiteSort"))) -) (\LAFITE.SORT.BY.DATE.REGION -(LAMBDA (FOLDER) (* ; "Edited 28-Apr-89 16:23 by bvm") (LET ((FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER)) (LAST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER))) (if (> LAST# FIRST#) then (\LAFITE.SORT.BY.DATE.INTERACTIVE FOLDER FIRST# LAST#) else (LAB.FORMAT FOLDER "There is ~:[no~;only one~] message selected." (EQ LAST# FIRST#))))) -) ) (APPENDTOVAR LAFITEEXTRAMENUITEMS ("Sort by Date" '\LAFITE.SORT.BY.DATE.INTERACTIVE "Sort all the messages in this folder by their Date: fields." (SUBITEMS ("Sort Entire Folder" '\LAFITE.SORT.BY.DATE.INTERACTIVE "Sort all the messages in this folder by their Date: fields." ) ("Sort Selected Range" '\LAFITE.SORT.BY.DATE.REGION "Sort only the messages between the first and last selected messages." )))) (* ; "Date hax") (DEFINEQ (GDATE1-6 -(LAMBDA (D) (* ; "Edited 26-Apr-89 15:24 by bvm") (* ;; "Return a string containing the day and month given in internal date D.") (* ;; "This is an optimization by source code simplification of (SUBSTRING (GDATE IDT) 1 6)") (PROG ((CHECKDLS \DayLightSavings) (DQ (IQUOTIENT (LRSH (LISP.TO.ALTO.DATE D) 1) (CONSTANT (IQUOTIENT (TIMES 60 60) 2)))) HR DAY4 YDAY WDAY YEAR4 TOTALDAYS DLS) (* ; "DQ is number of hours since day 0, getting us past the sign bit problem.") (* ;; "Now we can adjust to the current time zone. Since this might cause DQ to go negative, first add in 4 years worth of hours, making the base date be Jan 1, 1897") (SETQ HR (IREMAINDER (SETQ DQ (- (+ DQ (CONSTANT (ITIMES 24 \4YearsDays))) \TimeZoneComp)) 24)) (SETQ TOTALDAYS (IQUOTIENT DQ 24)) DTLOOP (SETQ DAY4 (IREMAINDER TOTALDAYS \4YearsDays)) (* ; "DAY4 = number of days since last leap year day 0") (SETQ DAY4 (+ DAY4 (CDR (\DTSCAN DAY4 (QUOTE ((789 . 3) (424 . 2) (59 . 1) (0 . 0))))))) (* ; "pretend every year is a leap year, adding one for days after Feb 28") (SETQ YEAR4 (IQUOTIENT TOTALDAYS \4YearsDays)) (* ; "YEAR4 = number of years til that last leap year / 4") (SETQ YDAY (IREMAINDER DAY4 366)) (* ; "YDAY is the ordinal day in the year (jan 1 = zero)") (SETQ WDAY (IREMAINDER (+ TOTALDAYS 3) 7)) (COND ((AND CHECKDLS (SETQ DLS (\ISDST? YDAY HR WDAY))) (* ;; "This date is during daylight savings, so add 1 hour. Third arg is day of the week, which we determine by taking days mod 7 plus offset. Monday = zero in this scheme. Jan 1 1897 was actually a Friday (not Thursday=3), but we're cheating--1900 was not a leap year") (COND ((> (SETQ HR (ADD1 HR)) 23) (* ;; "overflowed into the next day. This case is too hard (we might have overflowed the month, for example), so just go back and recompute") (SETQ TOTALDAYS (ADD1 TOTALDAYS)) (SETQ HR 0) (SETQ CHECKDLS NIL) (GO DTLOOP))))) (RETURN (LET* ((MONTH (\DTSCAN YDAY (QUOTE ((335 . "Dec") (305 . "Nov") (274 . "Oct") (244 . "Sep") (213 . "Aug") (182 . "Jul") (152 . "Jun") (121 . "May") (91 . "Apr") (60 . "Mar") (31 . "Feb") (0 . "Jan"))))) (DAY (ADD1 (- YDAY (CAR MONTH)))) (RESULT (CONCAT " " (CDR MONTH)))) (\RPLRIGHT RESULT 2 DAY 1) RESULT)))) -) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \4YearsDays 1461) (CONSTANTS \4YearsDays) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TimeZoneComp \DayLightSavings) ) ) (PUTPROPS LAFITESORT COPYRIGHT ("Xerox Corporation" 1989 1995)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2004 8717 (LAFITE.ASSURE.DATE.FIELDS 2014 . 4789) (LAFITE.PARSE.DATE.FIELD 4791 . 5201) (LAFITE.PARSE.DATE.FIELD.ONLY 5203 . 5379) (LAFITE.SORT.BY.DATE 5381 . 5656) (LAFITE.SORT.MESSAGES 5658 . 7390) (LAFITEMSG.DATE.ORDER 7392 . 7899) (\LAFITE.SORT.BY.DATE.INTERACTIVE 7901 . 8323) ( \LAFITE.SORT.BY.DATE.REGION 8325 . 8715)) (9607 11828 (GDATE1-6 9617 . 11826))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "30-Sep-2021 22:58:58"  +{DSK}KAPLAN>LOCAL>MEDLEY3.5>GIT-MEDLEY>LIBRARY>LAFITE>LAFITESORT.;1 19675 + + previous date%: " 7-Feb-95 13:10:22" +{DSK}KAPLAN>LOCAL>MEDLEY3.5>GIT-MEDLEY>LIBRARY>LAFITE>LAFITESORT.;1) + + +(* ; " +Copyright (c) 1989, 1995, 2021 by Xerox Corporation. +") + +(PRETTYCOMPRINT LAFITESORTCOMS) + +(RPAQQ LAFITESORTCOMS + [(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) + LAFITEDECLS)) + (FNS LAFITE.ASSURE.DATE.FIELDS LAFITE.PARSE.DATE.FIELD LAFITE.PARSE.DATE.FIELD.ONLY + LAFITE.SORT.BY.DATE LAFITE.SORT.MESSAGES LAFITEMSG.DATE.ORDER + \LAFITE.SORT.BY.DATE.INTERACTIVE \LAFITE.SORT.BY.DATE.REGION) + [APPENDVARS (LAFITEEXTRAMENUITEMS ("Sort by Date" '\LAFITE.SORT.BY.DATE.INTERACTIVE + "Sort all the messages in this folder by their Date: fields." + (SUBITEMS ("Sort Entire Folder" + '\LAFITE.SORT.BY.DATE.INTERACTIVE + "Sort all the messages in this folder by their Date: fields." + ) + ("Sort Selected Range" + '\LAFITE.SORT.BY.DATE.REGION + "Sort only the messages between the first and last selected messages." + ] + (COMS (* ; "Date hax") + (FNS GDATE1-6) + (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS \4YearsDays) + (GLOBALVARS \TimeZoneComp \DayLightSavings]) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (SOURCE) + LAFITEDECLS) +) +(DEFINEQ + +(LAFITE.ASSURE.DATE.FIELDS + [LAMBDA (FOLDER FIRST# LAST#) (* ; "Edited 5-May-89 15:46 by bvm") + + (* ;; "Assure that messages FIRST# thru LAST# have IDATE fields. FIRST# & LAST# default.") + + (for I from (OR FIRST# 1) to (OR LAST# (fetch (MAILFOLDER %#OFMESSAGES) + of FOLDER)) + bind (STREAM _ (\LAFITE.OPEN.FOLDER FOLDER 'INPUT :ABORT)) + (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) + (FAILURECNT _ 0) + (MISSING _ 0) + MSG ID PREV DATEFAILURE DATEFETCHED BABBLED + do [if (fetch (LAFITEMSG DATEFETCHED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) + then (* ; "Ok") + (if (NOT (fetch (LAFITEMSG DATEKNOWN?) of MSG)) + then (add FAILURECNT 1)) + else (if (NOT BABBLED) + then (* ; "Tell user what's taking so long") + (LAB.PROMPTPRINT FOLDER "Collecting dates... ") + (SETQ BABBLED T)) + (if (FIXP (SETQ ID (LAFITE.PARSE.HEADER STREAM \LAPARSE.DATEFIELD + (fetch (LAFITEMSG START) of MSG) + (fetch (LAFITEMSG END) of MSG) + T))) + then (replace (LAFITEMSG IDATE) of MSG with ID) + (replace (LAFITEMSG DATEKNOWN?) of MSG with T) + (replace (LAFITEMSG DATEFETCHED?) of MSG with T) + (replace (LAFITEMSG DATE) of MSG with NIL) + (* ; + "So it will be regenerated in canonical form") + (OR DATEFETCHED (SETQ DATEFETCHED I)) + else (replace (LAFITEMSG DATEKNOWN?) of MSG with NIL) + (if LAFITEDEBUGFLG + then (LAB.FORMAT FOLDER + " ~:[Date missing for~;Could not parse date of~] msg ~D. " + ID I)) + (add FAILURECNT 1) + (if (NULL ID) + then (add MISSING 1)) + (if [AND (> I 1) + (fetch (LAFITEMSG DATEFETCHED?) + of (SETQ PREV (NTHMESSAGE MESSAGES (SUB1 I] + then (* ; + "Guess that message i has date just after i-1") + (replace (LAFITEMSG IDATE) of MSG + with (ADD1 (fetch (LAFITEMSG IDATE) of PREV))) + (replace (LAFITEMSG DATEFETCHED?) of MSG with + T) + else (SETQ DATEFAILURE I] + finally (if (AND DATEFETCHED (< DATEFETCHED (fetch (MAILFOLDER TOCLASTMESSAGE#) + of FOLDER))) + then (* ; + "Assure that the toc will be rewritten at least this far back so that we save the dates.") + (replace (MAILFOLDER TOCLASTMESSAGE#) of FOLDER with + DATEFETCHED + )) + (COND + ([AND DATEFAILURE (NOT (for I from (ADD1 (OR FIRST# 1)) + to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) + when (fetch (LAFITEMSG DATEFETCHED?) + of (SETQ MSG (NTHMESSAGE MESSAGES I))) + do (* ; "Got a date later on") + (SETQ ID (fetch (LAFITEMSG IDATE) of MSG)) + (for J from DATEFAILURE + to (OR FIRST# 1) by -1 + do (* ; + "Store guess dates for first message(s)") + (replace (LAFITEMSG IDATE) + of (SETQ MSG (NTHMESSAGE MESSAGES J)) + with (add ID -1)) + (replace (LAFITEMSG DATEFETCHED?) + of MSG with T)) + (RETURN T] + (LAB.PROMPTPRINT FOLDER "Could not parse dates of ANY messages in this file.")) + ((> FAILURECNT 0) + (LAB.FORMAT FOLDER (if (< MISSING FAILURECNT) + then + " Note: Could not parse date field of ~D of these messages." + else " Note: Missing date field for ~D of these messages.") + FAILURECNT]) + +(LAFITE.PARSE.DATE.FIELD + [LAMBDA (STREAM) (* ; "Edited 5-May-89 12:52 by bvm") + (LET* ((DATESTR (LAFITE.READ.TO.EOL STREAM)) + (ID (IDATE DATESTR))) + (if [AND ID (> ID (CONSTANT (IDATE "1-jan-70 1200"] + then (* ; "Plausible date. Test is for those silly senders who didn't get the date set and have messages reading %"31-dec-00 ...%"") + ID + else (CONCAT (OR (SUBSTRING DATESTR 1 6 DATESTR) + DATESTR) + "?"]) + +(LAFITE.PARSE.DATE.FIELD.ONLY + [LAMBDA (STREAM) + (DECLARE (USEDFREE PARSERESULT)) (* ; "Edited 26-Apr-89 14:35 by bvm") + (SETQ PARSERESULT (LAFITE.PARSE.DATE.FIELD STREAM]) + +(LAFITE.SORT.BY.DATE + [LAMBDA (FOLDER FIRST# LAST#) (* ; "Edited 26-Apr-89 15:32 by bvm") + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) + (LAFITE.ASSURE.DATE.FIELDS FOLDER FIRST# LAST#) + (LAFITE.SORT.MESSAGES FOLDER (FUNCTION LAFITEMSG.DATE.ORDER) + FIRST# LAST#))]) + +(LAFITE.SORT.MESSAGES + [LAMBDA (FOLDER COMPAREFN FIRST# LAST#) (* ; "Edited 7-Oct-89 14:03 by bvm") + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) + (OR FIRST# (SETQ FIRST# 1)) + (OR LAST# (SETQ LAST# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) + (LAB.PROMPTPRINT FOLDER "Sorting... ") + (LET* ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) + (SORTED (CL:STABLE-SORT (for I from FIRST# to LAST# + collect (NTHMESSAGE MESSAGES I)) + COMPAREFN))) + (while (AND SORTED (EQ (fetch (LAFITEMSG %#) of (CAR SORTED)) + FIRST#)) do (* ; + "Skip over the initial prefix of in-order messages") + (add FIRST# 1) + (SETQ SORTED (CDR SORTED))) + (if (NULL SORTED) + then (LAB.PROMPTPRINT FOLDER "already in order") + else (replace (MAILFOLDER FOLDEROUTOFORDER) of FOLDER with T) + (if (< FIRST# (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER)) + then (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER + with FIRST#)) + (UNINTERRUPTABLY + (for MSG in SORTED as I from FIRST# + do (replace (LAFITEMSG %#) of MSG with I) + (SETA MESSAGES I MSG))) + [LET ((FIRSTSEL (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER)) + (LASTSEL (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER))) + (if (>= LASTSEL FIRSTSEL) + then (if (AND (>= FIRSTSEL FIRST#) + (<= FIRSTSEL LAST#)) + then (* ; + "Start of selection was inside here, have to recompute its number") + (replace (MAILFOLDER FIRSTSELECTEDMESSAGE) + of FOLDER with (LAB.FIND.SELECTED.MSG + FOLDER FIRST# LAST#))) + (if (AND (>= LASTSEL FIRST#) + (<= LASTSEL LAST#)) + then (* ; + "End of selection was inside here, have to recompute its number") + (replace (MAILFOLDER LASTSELECTEDMESSAGE) + of FOLDER with (LAB.REV.FIND.SELECTED.MSG + FOLDER FIRST# LAST#] + (LAB.DISPLAYLINES FOLDER FIRST# LAST# NIL T) + (LAB.PROMPTPRINT FOLDER "done"))))]) + +(LAFITEMSG.DATE.ORDER + [LAMBDA (X Y) (* ; "Edited 26-Apr-89 14:53 by bvm") + + (* ;; "True if msg X has older date than msg Y. Since date field is stored as an unboxed 32-bit integer, we open code %"<%" here to avoid boxing.") + + (LET [(HIDIFF (- (LOGXOR (fetch (LAFITEMSG IDATEHI) of X) + 32768) + (LOGXOR (fetch (LAFITEMSG IDATEHI) of Y) + 32768] + + (* ;; "HIDIFF is unsigned difference of high words") + + (OR (< HIDIFF 0) + (AND (EQ HIDIFF 0) + (< (fetch (LAFITEMSG IDATELO) of X) + (fetch (LAFITEMSG IDATELO) of Y]) + +(\LAFITE.SORT.BY.DATE.INTERACTIVE + [LAMBDA (FOLDER FIRST# LAST#) (* ; "Edited 3-May-89 18:38 by bvm") + (if (LAB.MOUSECONFIRM FOLDER "Click LEFT to confirm sorting ~D messages by date" + (if LAST# + then (ADD1 (- LAST# FIRST#)) + else (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) + then (\LAFITE.PROCESS `(,(FUNCTION LAFITE.SORT.BY.DATE) + ',FOLDER + ',FIRST# + ',LAST#) + "LafiteSort"]) + +(\LAFITE.SORT.BY.DATE.REGION + [LAMBDA (FOLDER) (* ; "Edited 28-Apr-89 16:23 by bvm") + (LET ((FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER)) + (LAST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER))) + (if (> LAST# FIRST#) + then (\LAFITE.SORT.BY.DATE.INTERACTIVE FOLDER FIRST# LAST#) + else (LAB.FORMAT FOLDER "There is ~:[no~;only one~] message selected." + (EQ LAST# FIRST#]) +) + +(APPENDTOVAR LAFITEEXTRAMENUITEMS ("Sort by Date" '\LAFITE.SORT.BY.DATE.INTERACTIVE + "Sort all the messages in this folder by their Date: fields." + (SUBITEMS ("Sort Entire Folder" + '\LAFITE.SORT.BY.DATE.INTERACTIVE + "Sort all the messages in this folder by their Date: fields." + ) + ("Sort Selected Range" + '\LAFITE.SORT.BY.DATE.REGION + "Sort only the messages between the first and last selected messages." + )))) + + + +(* ; "Date hax") + +(DEFINEQ + +(GDATE1-6 + [LAMBDA (D) (* ; "Edited 26-Apr-89 15:24 by bvm") + + (* ;; "Return a string containing the day and month given in internal date D.") + + (* ;; "This is an optimization by source code simplification of (SUBSTRING (GDATE IDT) 1 6)") + + (PROG ((CHECKDLS \DayLightSavings) + [DQ (IQUOTIENT (LRSH (LISP.TO.ALTO.DATE D) + 1) + (CONSTANT (IQUOTIENT (TIMES 60 60) + 2] + HR DAY4 YDAY WDAY YEAR4 TOTALDAYS DLS) (* ; + "DQ is number of hours since day 0, getting us past the sign bit problem.") + + (* ;; "Now we can adjust to the current time zone. Since this might cause DQ to go negative, first add in 4 years worth of hours, making the base date be Jan 1, 1897") + + (SETQ HR (IREMAINDER (SETQ DQ (- (+ DQ (CONSTANT (ITIMES 24 \4YearsDays))) + \TimeZoneComp)) + 24)) + (SETQ TOTALDAYS (IQUOTIENT DQ 24)) + DTLOOP + (SETQ DAY4 (IREMAINDER TOTALDAYS \4YearsDays)) (* ; + "DAY4 = number of days since last leap year day 0") + [SETQ DAY4 (+ DAY4 (CDR (\DTSCAN DAY4 '((789 . 3) + (424 . 2) + (59 . 1) + (0 . 0] (* ; + "pretend every year is a leap year, adding one for days after Feb 28") + (SETQ YEAR4 (IQUOTIENT TOTALDAYS \4YearsDays)) (* ; + "YEAR4 = number of years til that last leap year / 4") + (SETQ YDAY (IREMAINDER DAY4 366)) (* ; + "YDAY is the ordinal day in the year (jan 1 = zero)") + (SETQ WDAY (IREMAINDER (+ TOTALDAYS 3) + 7)) + [COND + ((AND CHECKDLS (SETQ DLS (\ISDST? YDAY HR WDAY))) + + (* ;; "This date is during daylight savings, so add 1 hour. Third arg is day of the week, which we determine by taking days mod 7 plus offset. Monday = zero in this scheme. Jan 1 1897 was actually a Friday (not Thursday=3), but we're cheating--1900 was not a leap year") + + (COND + ((> (SETQ HR (ADD1 HR)) + 23) + + (* ;; "overflowed into the next day. This case is too hard (we might have overflowed the month, for example), so just go back and recompute") + + (SETQ TOTALDAYS (ADD1 TOTALDAYS)) + (SETQ HR 0) + (SETQ CHECKDLS NIL) + (GO DTLOOP] + (RETURN (LET* [[MONTH (\DTSCAN YDAY '((335 . "Dec") + (305 . "Nov") + (274 . "Oct") + (244 . "Sep") + (213 . "Aug") + (182 . "Jul") + (152 . "Jun") + (121 . "May") + (91 . "Apr") + (60 . "Mar") + (31 . "Feb") + (0 . "Jan"] + [DAY (ADD1 (- YDAY (CAR MONTH] + (RESULT (CONCAT " " (CDR MONTH] + (\RPLRIGHT RESULT 2 DAY 1) + RESULT]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ \4YearsDays 1461) + + +(CONSTANTS \4YearsDays) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \TimeZoneComp \DayLightSavings) +) +) +(PUTPROPS LAFITESORT COPYRIGHT ("Xerox Corporation" 1989 1995 2021)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (2020 14676 (LAFITE.ASSURE.DATE.FIELDS 2030 . 8127) (LAFITE.PARSE.DATE.FIELD 8129 . 8766 +) (LAFITE.PARSE.DATE.FIELD.ONLY 8768 . 8983) (LAFITE.SORT.BY.DATE 8985 . 9345) (LAFITE.SORT.MESSAGES +9347 . 12737) (LAFITEMSG.DATE.ORDER 12739 . 13487) (\LAFITE.SORT.BY.DATE.INTERACTIVE 13489 . 14133) ( +\LAFITE.SORT.BY.DATE.REGION 14135 . 14674)) (15566 19381 (GDATE1-6 15576 . 19379))))) +STOP diff --git a/library/lafite/LAFITESORT.LCOM b/library/lafite/LAFITESORT.LCOM index 47c6f8b6b638bd5faf7608a9583a4a6e10de9ebc..f2ac6bd93a53f526b84eb55d608399ce625a0d8f 100644 GIT binary patch delta 711 zcmexjcGFx7lbKYM zSX613lbDuSl4|GU=;m1;;u`E96ryKssHvc2WQk;{k(H5!m7x*PlBA+kxV5Pj1x3ZG zRtkCfB^jA{=?a-ZXSjv>_$VOj)zi~cQbwwCBnK$hCO` zrxGKObC2I}G7I+(AZr7s^yVAftSn%`&p`5$KqgR~ji47uUAxdLAg4%p4HJ+fFBT0X zfu>KMD&`4f-4{y(l5XO$K=PqvDv)dxSDLIN;Q(aiN>~BO6%r{xl2#0lgrQ3hYJADjKcZ= delta 615 zcmca<{>4l~!^PFj)6Z4c&C|zK*VE62L=6qB41kU@ zRYG(0UBqSUg? z{L*5uGl0sJ6wGz~lS_0hEERykVqk7%0t^{MNGKBu3PVla$s4$&Sgc$ucsE-!O=n}| zoqU<&Jdj+>nZwAtS%6E45y-IgEV~fz&-0 zdIjWM5?;dumedley2.0>library>lafitetedit.;7 12308 +(FILECREATED "30-Sep-2021 23:07:55"  +{DSK}kaplan>Local>medley3.5>git-medley>library>lafite>LAFITETEDIT.;3 12516 - changes to%: (FNS TEDIT.ASSURE.NO.BACKING.FILE) - (VARS LAFITETEDITCOMS) + changes to%: (VARS LAFITETEDITCOMS) + (FNS LA.ADJUST.FORMATTING LA.SKIP.LOOKS.LIST LA.DETACH.TEDIT LA.TEDIT.INCLUDE + LA.WINDOW.FROM.TEXTSTREAM TEDIT.ASSURE.NO.BACKING.FILE) + (FILES LAFITEDECLS) - previous date%: "29-Apr-92 13:30:23" {DSK}medley2.0>library>lafitetedit.;5) + previous date%: "30-Sep-2021 22:59:28" +{DSK}kaplan>Local>medley3.5>git-medley>library>lafite>LAFITETEDIT.;2) (* ; " -Copyright (c) 1988, 1990, 1992 by Xerox Corporation. All rights reserved. +Copyright (c) 1988, 1990, 1992, 2021 by Xerox Corporation. ") (PRETTYCOMPRINT LAFITETEDITCOMS) @@ -21,10 +25,10 @@ Copyright (c) 1988, 1990, 1992 by Xerox Corporation. All rights reserved. LA.WINDOW.FROM.TEXTSTREAM TEDIT.ASSURE.NO.BACKING.FILE) (DECLARE%: EVAL@COMPILE DONTCOPY - (* ;; "Need TEDIT internal declarations for LA.ADJUST.FORMATTING. Can't just do (FILES (SOURCE) TEDITDECLS), because there is a compiled version that is already loaded that isn't enough.") + (* ;; "Need TEDIT internal declarations for LA.ADJUST.FORMATTING. Can't just do (FILES (SOURCE) TEDITDCL), because there is a compiled version that is already loaded that isn't enough.") - (P (CL:UNLESS (GET 'TEDITDECLS 'FILE) - (FILESLOAD TEDITDECLS))) + (P (CL:UNLESS (GET 'TEDITDCL 'FILE) + (FILESLOAD TEDITDCL))) (FILES (SOURCE) LAFITEDECLS) (GLOBALVARS *TEDIT-FILE-READTABLE*) @@ -181,8 +185,8 @@ Copyright (c) 1988, 1990, 1992 by Xerox Corporation. All rights reserved. ) (DECLARE%: EVAL@COMPILE DONTCOPY -(CL:UNLESS (GET 'TEDITDECLS 'FILE) - (FILESLOAD TEDITDECLS)) +(CL:UNLESS (GET 'TEDITDCL 'FILE) + (FILESLOAD TEDITDCL)) (FILESLOAD (SOURCE) @@ -198,9 +202,9 @@ Copyright (c) 1988, 1990, 1992 by Xerox Corporation. All rights reserved. (LOCALVARS . T) ) ) -(PUTPROPS LAFITETEDIT COPYRIGHT ("Xerox Corporation" 1988 1990 1992)) +(PUTPROPS LAFITETEDIT COPYRIGHT ("Xerox Corporation" 1988 1990 1992 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1342 11940 (LA.ADJUST.FORMATTING 1352 . 7488) (LA.SKIP.LOOKS.LIST 7490 . 8064) ( -LA.DETACH.TEDIT 8066 . 8431) (LA.TEDIT.INCLUDE 8433 . 8922) (LA.WINDOW.FROM.TEXTSTREAM 8924 . 9370) ( -TEDIT.ASSURE.NO.BACKING.FILE 9372 . 11938))))) + (FILEMAP (NIL (1549 12147 (LA.ADJUST.FORMATTING 1559 . 7695) (LA.SKIP.LOOKS.LIST 7697 . 8271) ( +LA.DETACH.TEDIT 8273 . 8638) (LA.TEDIT.INCLUDE 8640 . 9129) (LA.WINDOW.FROM.TEXTSTREAM 9131 . 9577) ( +TEDIT.ASSURE.NO.BACKING.FILE 9579 . 12145))))) STOP diff --git a/library/lafite/LAFITETEDIT.LCOM b/library/lafite/LAFITETEDIT.LCOM index 0c49ba321f564eb11032599494228b1d0479f650..040f78b38f995f9c9e42953af005db88c38c165e 100644 GIT binary patch delta 1270 zcmb_c&rj2E6qmtA*_Le@k&yib zCM1oCCK_*^F&YmZ-+V2@B6-=y#DI`a%yF$ zMtq5+sz_-it}8N70_)d|lAmXJ4tOEV*)Ih?YNohQ%9}8c{W#Na_l_85on39k6otA#%^EZZmC>37Y3`3BwL8J?m20#ke(Xk@jQu)szP%OhG8hkWvh5z zvS0BaMgMzlb|5T@2bgo}z=K8v;CPV>z|35>Fl$txTEuC5SK?_6NYjl-sZosvUt&z# zJL;L5&65W8R9TT!Oe>X*JNe@6iZd&gBYXMd!(s?8lY;+27v=C3;b}ZA6PJfGn$9Fr z>Cw2ZC&z{$EC-3@b#X0Etc$MmHTWEZkGVo^XZt~6XJ>PMb29dqt8nl2*2}lCTjUTv zu?}0V{hf6!XSQxVU5m}#uoJwtSX=#IwrxH916h4Hk~7^~kJcLYE7N7Yah+&+Y;Cx{ z)j=hf_y_8*oE+cevne* zlY^5wlEwG;N19DRgds(@i5%C{z=a0(m{_GbDvDN&bhUCq$o}?nd;qi&+*28XIFdY( z90NRowp-8o)^^rSd>qeNN8H_Q#77e=PL8!X%t-E~9x|3xZ7=dCD|%eI#5g-xr|y$m zJc?izbmgj^8XU$2K|FZ6aM?u963XYED!Nuir}gIGVkLBw#KQYYAdGn#hB{|#B$Y%u@; delta 1227 zcmah}+iTNM7rqBtKu!_;PwkenpVMXBx5Y>Um>uF2GS0c#s)M_fzS33EvQ z1tEg^qTq`Pdl=%A2o?VXK@br|1Rs3rgKxfgPSU!00rPOqcl~|8@0|1H%lMCjw`W>Z zeA=>2qiCjGGXpdztmD;LO$Gt!JklkBhB#fWU9VStuL89d9I}ydvbRq9)zx~r*6@;k z>1wsVov;&oBfd5MNA1kyiVX+af3&UqEz zTL(d6(`!p4kmEQSDy1eaNpD*PSx1U4sWkHkYeXunvl;?H(2=T3N{?l|QCs%P&E)m4 z0^<0jU%k>OHP*YdXu#z6c`y6C`; z?u`7L!$7^^-Kf^qRztQphejHkuH$Yo7f}~^9f>qh(UJX+OqYwyP{Dlv{+OOosbFnD z=vxmS4;*Wa?84t-suJ!iH(zv~e^}l_Y^l)Fj~~+VAf?J77PJ{QltEmnrz1f_Lq$C)wrBvx%-JsK?&75(q9%K|S z!;ZUqnvrAgC}5Qzt>AUO-wHmC9>Nk15B85SSUNRUikXJ(1dqn%vHE?Cj?{zHkqKgF k7(8s`q#TGl`Gulk;-5$~cbPEn0;S@-JCrfRFyRUP1hU3SMgRZ+ diff --git a/library/lafite/MAILSCAVENGE b/library/lafite/MAILSCAVENGE index 95de1b1f..0e07e6d5 100644 --- a/library/lafite/MAILSCAVENGE +++ b/library/lafite/MAILSCAVENGE @@ -1 +1,664 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Jun-90 18:25:37" {DSK}local>lde>lispcore>internal>library>MAILSCAVENGE.;2 21651 changes to%: (VARS MAILSCAVENGECOMS) previous date%: " 7-Nov-89 19:34:02" {DSK}local>lde>lispcore>internal>library>MAILSCAVENGE.;1) (* ; " Copyright (c) 1985, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MAILSCAVENGECOMS) (RPAQQ MAILSCAVENGECOMS [(FNS LAFITE.SCAVENGE \MAILSCAVENGE.INTERNAL \MAILSCAVENGE.OPEN.SCRATCH \MAILSCAVENGE.LENGTHWIDTH \MAILSCAVENGE.LFCOPYBYTES \MAILSCAVENGE.READSTAMP \MAILSCAVENGE.DUPLICATE? \MAILSCAVENGE.FORMAT \MAILSCAVENGE.MAKEWINDOW \MAILSCAVENGE.ASKUSER \MAILSCAVENGE.FIX.LENGTHS \MAILSCAVENGE.CONFIRM) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (*START*LENGTH 8)) (SPECVARS *FOLDER* *ERRORMSGSTREAM* *EOL*) (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA \MAILSCAVENGE.FORMAT ]) (DEFINEQ (LAFITE.SCAVENGE (LAMBDA (FOLDERNAME ERRORMSGSTREAM FORGET?) (* ; "Edited 18-Apr-89 18:19 by bvm") (* ;; "User entry to the scavenger. If FORGET?, we won't add folder to the list of known folders.") (LET ((FOLDER (LAFITE.OBTAIN.FOLDER (LA.LONGFILENAME FOLDERNAME LAFITEMAIL.EXT) (QUOTE INPUT) T (AND FORGET? :FORGET)))) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (\MAILSCAVENGE.INTERNAL FOLDER ERRORMSGSTREAM)))) ) (\MAILSCAVENGE.INTERNAL (LAMBDA (*FOLDER* *ERRORMSGSTREAM* GOODPTR MSGNO) (* ; "Edited 3-May-89 13:05 by bvm") (* ;; "Scavenge FOLDER, which can be a mail folder, mail file name, or open stream on a mail file. Commentary goes to *ERRORMSGSTREAM*, which for folders defaults to its browser window. If GOODPTR is supplied, it is a file pointer that we assert points to the *START* corresponding to msg # MSGNO, and we guarantee we will not touch anything earlier in the file.") (LET (SCRATCHSTREAM FOLDERSTRM) (CL:UNWIND-PROTECT (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (*PRINT-BASE* 10) (BADCOUNT 0) (*START* "*start* ") (*EOL* (CHARCODE CR)) (COPYFN (FUNCTION COPYBYTES)) TRYPTR LFP PWINDOW XPOS DUPSCRATCH FOLDERNAME EOFPTR BODYSTART BADHEADER NOMOREP STAMPLENGTH MSGLENGTH ENDPTR FIELDWIDTH LENGTHFIXUPS TRUNCATEPTR TSTREAM SUCCESS CH) (DECLARE (CL:SPECIAL *FOLDER* *ERRORMSGSTREAM* *EOL*)) (* ; "Used by \mailscavenge.askuser") (if (TYPENAMEP *FOLDER* (QUOTE MAILFOLDER)) then (* ; "It's a mail folder, so play by the rules") (SETQ FOLDERSTRM (\LAFITE.OPEN.FOLDER *FOLDER* (QUOTE INPUT) :OK)) (SETQ PWINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of *FOLDER*)) elseif (TYPENAMEP *FOLDER* (QUOTE STREAM)) then (SETQ FOLDERSTRM *FOLDER*) else (SETQ FOLDERSTRM (\LAFITE.OPENSTREAM *FOLDER* (QUOTE INPUT) (QUOTE OLD) (FUNCTION \LAFITE.EOF) NIL (QUOTE LAFITE)))) (SETQ FOLDERNAME (FULLNAME FOLDERSTRM)) (SETFILEINFO FOLDERSTRM (QUOTE BUFFERS) 30) (SETQ EOFPTR (GETEOFPTR FOLDERSTRM)) (SETFILEPTR FOLDERSTRM 0) (if PWINDOW then (LAB.PROMPTPRINT *FOLDER* " Scavenging... ") (SETQ XPOS (DSPXPOSITION NIL PWINDOW))) (if (NOT *ERRORMSGSTREAM*) then (SETQ *ERRORMSGSTREAM* (if (AND (TYPENAMEP *FOLDER* (QUOTE MAILFOLDER)) (SETQ TSTREAM (\MAILSCAVENGE.MAKEWINDOW *FOLDER*))) then (* ; "We waited til here to make the window in case printing %"Scavenging... %" up there grew the window.") (TEXTSTREAM TSTREAM) else (GETSTREAM NIL (QUOTE OUTPUT))))) (\MAILSCAVENGE.FORMAT "Scavenging ~A..." FOLDERNAME) (if GOODPTR then (* ; "Somebody has already gotten us started") (GO LP) else (SETQ GOODPTR 0) (SETQ MSGNO 1) (if (LA.READSTAMP FOLDERSTRM) then (* ; "Good start") (GO PARSEMSG) elseif (PROGN (SETFILEPTR FOLDERSTRM (SUB1 *START*LENGTH)) (AND (EQ (BIN FOLDERSTRM) (CHARCODE LF)) (FILEPOS "*start*" FOLDERSTRM 0 7))) then (* ; "LF woes") (if (\MAILSCAVENGE.ASKUSER "File was apparently written with end of line convention LF. Convert to CR (Note: TEdit formatting may be corrupted by this action, or could already have been corrupted by copying the file into LF format)? ") then (SETQ *START* "*start*") (SETQ COPYFN (FUNCTION \MAILSCAVENGE.LFCOPYBYTES)) (SETQ *EOL* (CHARCODE LF)) (SETQ LFP T) (SETQ SCRATCHSTREAM (\MAILSCAVENGE.OPEN.SCRATCH FOLDERNAME)) (SETFILEINFO FOLDERSTRM (QUOTE EOL) (QUOTE LF))) elseif (\MAILSCAVENGE.ASKUSER (CL:FORMAT NIL "Alleged mail folder ~A doesn't begin with a Lafite header -- proceed anyway? " FOLDERNAME)) then (SETQ BODYSTART 0) (GO FINDSTART) else (RETURN NIL))) LP (* ;; "GOODPTR is believed to point at *start*") (SETFILEPTR FOLDERSTRM GOODPTR) (if (NOT (\MAILSCAVENGE.READSTAMP FOLDERSTRM)) then (* ; "This shouldn't happen") (CL:ERROR "Scavenger is confused at message ~D, byte ~D" MSGNO GOODPTR)) PARSEMSG (if PWINDOW then (* ; "Tell which message we're on") (DSPXPOSITION XPOS PWINDOW) (PRIN3 MSGNO PWINDOW)) (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) (if (NOT (AND (SETQ MSGLENGTH (LA.READCOUNT FOLDERSTRM)) (> MSGLENGTH 0))) then (* ; "Malformed header--not even the length exists. Will need to build a new header. Take all the stuff from BODYSTART as potential message") (SETQ BADHEADER T) (GO FINDSTART)) (SETQ BADHEADER (NOT (AND (PROGN (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) (SETQ STAMPLENGTH (LA.READCOUNT FOLDERSTRM))) (PROGN (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) (BIN FOLDERSTRM) (BIN FOLDERSTRM) (BIN FOLDERSTRM) (* ; "Read 3 status bytes") (OR (EQ (SETQ CH (BIN FOLDERSTRM)) *EOL*) (AND LFP (EQ CH (CHARCODE CR))))) (<= (- (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) GOODPTR) STAMPLENGTH)))) (* ;; "We have a plausible length. BADHEADER true means the rest of header does not parse because (a) no header length, (b) no CR after the the 3 mark bytes, or (c) header length is too short. Wait to see whether the length appears correct before deciding whether to rebuild the header or just smash it.") (* ; "Take all the stuff from BODYSTART as potential message") (if (OR (<= (SETQ ENDPTR (+ GOODPTR MSGLENGTH)) (GETFILEPTR FOLDERSTRM)) (> ENDPTR EOFPTR)) then (* ; "Length too short or points past eof.") (GO FINDSTART) elseif (AND (< ENDPTR EOFPTR) (PROGN (SETFILEPTR FOLDERSTRM ENDPTR) (NOT (\MAILSCAVENGE.READSTAMP FOLDERSTRM)))) then (* ; "Length doesn't point at next *start*, have to search for a boundary") (SETFILEPTR FOLDERSTRM ENDPTR) (if (AND (EQ (BIN FOLDERSTRM) 0) (to (- EOFPTR ENDPTR 1) always (EQ (BIN FOLDERSTRM) 0))) then (* ; "File is well-formed except for ending in a bunch of nulls. This seems to happen every once in a fhile when a file server spazzes. Throw them away.") (\MAILSCAVENGE.FORMAT "~%%Starting at byte ~D (after message #~D):~%% File ends in ~D null bytes. Will discard." ENDPTR MSGNO (- EOFPTR ENDPTR)) (if SCRATCHSTREAM then (* ; "Copy last message verbatim to scratch file") (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM GOODPTR ENDPTR) else (* ; "Note truncation here") (SETQ TRUNCATEPTR ENDPTR)) (add BADCOUNT 1) (GO DONE)) (GO FINDSTART) elseif BADHEADER then (* ; "Length ok, but header was malformed. It is likely to be safe to just overwrite the header") (add BADCOUNT 1) (\MAILSCAVENGE.FORMAT "~%%Message #~D at byte ~D: length ok, but header garbled." MSGNO GOODPTR) (SETQ FIELDWIDTH (\MAILSCAVENGE.LENGTHWIDTH FOLDERSTRM GOODPTR)) (if SCRATCHSTREAM then (* ; "Have to copy") (SETQ BODYSTART (+ GOODPTR FIELDWIDTH LAFITEBASICSTAMPLENGTH)) (SETQ MSGLENGTH (- ENDPTR BODYSTART)) (GO COPYMSG) else (* ; "Remember fixup") (push LENGTHFIXUPS (LIST GOODPTR MSGLENGTH FIELDWIDTH T)) (GO NEXT)) else (* ; "Well-formed message") (if (AND (< (- BODYSTART GOODPTR) STAMPLENGTH) (EQ (PROGN (SETFILEPTR FOLDERSTRM BODYSTART) (BIN FOLDERSTRM)) (CHARCODE *))) then (* ; "May be a funny one") (LET ((INFO (CL:READ-LINE FOLDERSTRM)) ISDUP) (if (AND (STRPOS "duplicate*" INFO 1 NIL T) (FIXP (SETQ INFO (SUBATOM INFO 11)))) then (* ; "This message claims to be a duplicate of the one at INFO") (SETQ ISDUP (\MAILSCAVENGE.DUPLICATE? FOLDERSTRM INFO GOODPTR STAMPLENGTH MSGLENGTH (OR DUPSCRATCH (SETQ DUPSCRATCH (OPENSTREAM "{nodircore}" (QUOTE BOTH)))))) (\MAILSCAVENGE.FORMAT "~%%Message #~D at byte ~D is marked as a duplicate of the one at byte~D from an aborted Expunge~A." MSGNO GOODPTR INFO (if (NOT ISDUP) then "; however, the original is not there" elseif SCRATCHSTREAM then " (not copied)" else "")) (if ISDUP then (* ; "Nothing to do.") (GO NEXT) elseif SCRATCHSTREAM then (SETQ BADHEADER T) (* ; "so that message gets undeleted") (GO COPYGOOD) else (* ; "Want to rewrite the flags") (push LENGTHFIXUPS (LIST GOODPTR NIL NIL T)) (GO NEXT))))) (if SCRATCHSTREAM then (* ; "Copy verbatim to scratch file") (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM GOODPTR ENDPTR)) (GO NEXT)) FINDSTART (* ;; "At this point, we have a malformed message starting at GOODPTR. Look for its end. If the header is also malformed, BADHEADER is true. BODYSTART points at what could be the start of text..") (SETQ TRYPTR BODYSTART) FINDSTARTLP (SETQ ENDPTR (FFILEPOS *START* FOLDERSTRM TRYPTR)) (if (NULL ENDPTR) then (* ; "Can't find next message. Maybe this is the last one") (if (AND (EQ MSGNO 1) BADHEADER) then (* ; "Never saw a single *start*") (if (NULL (\MAILSCAVENGE.ASKUSER (CL:FORMAT NIL "There are no message boundaries in this file. Do you want to turn the file into a single message of length ~D?" (- EOFPTR GOODPTR)))) then (RETURN NIL))) (SETQ ENDPTR EOFPTR) elseif (AND LFP (PROGN (* ; "Have to check that an eol follows, since we're not sure which kind.") (SETFILEPTR FOLDERSTRM (+ ENDPTR (SUB1 *START*LENGTH))) (SELCHARQ (BIN FOLDERSTRM) ((CR LF) NIL) T))) then (SETQ TRYPTR (+ ENDPTR (- *START*LENGTH 2))) (GO FINDSTARTLP)) (\MAILSCAVENGE.FORMAT "~%%Message #~D at byte ~D: length ~:[missing~%% (~;incorrect~%% (file says ~:*~D, ~]apparent length is ~D)" MSGNO GOODPTR MSGLENGTH (if BADHEADER then (* ; "Estimate based on standard header size. We'll be exact later") (+ LAFITESTAMPLENGTH (SETQ MSGLENGTH (- ENDPTR BODYSTART))) else (SETQ MSGLENGTH (- ENDPTR GOODPTR)))) (add BADCOUNT 1) (if BADHEADER then (\MAILSCAVENGE.FORMAT "~%% Need to rebuild internal header. Message body may be malformed.") (GO COPYMSG)) (* ; "Header ok, just the length was wrong") (if (NULL SCRATCHSTREAM) then (* ; "Should suffice just to change length in place") (if (<= (NCHARS MSGLENGTH) (SETQ FIELDWIDTH (\MAILSCAVENGE.LENGTHWIDTH FOLDERSTRM GOODPTR))) then (* ; "Good, the correct length fits in the available space. Save for confirmation later") (push LENGTHFIXUPS (LIST GOODPTR MSGLENGTH FIELDWIDTH)) (GO NEXT)) (* ;; "Arrrgh, the length is too big. Fall thru to copy message to scratch file.") (\MAILSCAVENGE.FORMAT "~%%New length does not fit into old header, will have to rebuild.")) COPYGOOD (* ;; "Bring MSGLENGTH down to just the body length so we compute the new header correctly") (SETQ MSGLENGTH (- MSGLENGTH STAMPLENGTH)) COPYMSG (* ;; "At this point, we want to write the current message on scratch file. MSGLENGTH is the length of the body, sans header, starting at BODYSTART. If BADHEADER is true, we rebuild whole header. Otherwise, message is believed well-formed, so we can copy flag bytes from old message.") (if (NULL SCRATCHSTREAM) then (* ; "Have to set up scratch file") (\MAILSCAVENGE.FORMAT "~%%Opening scratch file to handle rebuilt header.") (SETQ SCRATCHSTREAM (\MAILSCAVENGE.OPEN.SCRATCH FOLDERNAME)) (if (> GOODPTR 0) then (\MAILSCAVENGE.FORMAT "~%%Copying ~D previous message~:P to scratch file..." (SUB1 MSGNO)) (COPYBYTES FOLDERSTRM SCRATCHSTREAM 0 GOODPTR) (\MAILSCAVENGE.FORMAT "done."))) (LA.PRINTHEADER SCRATCHSTREAM MSGLENGTH) (if BADHEADER then (* ; "Have to create afresh, so use primordial flags") (PRIN3 "UU " SCRATCHSTREAM) else (* ; "Original header was ok, except for length info, so copy flags and mark byte from it.") (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM (- BODYSTART 4) BODYSTART) (SETQ BODYSTART (+ GOODPTR STAMPLENGTH))) (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM BODYSTART ENDPTR) NEXT (COND ((< (SETQ GOODPTR ENDPTR) EOFPTR) (* ; "Go process some more") (add MSGNO 1) (GO LP))) DONE (* ;; "All finished--shall we confirm it?") (if SCRATCHSTREAM then (* ; "Close this now (could be slow) before saying done.") (SETQ SCRATCHSTREAM (CLOSEF SCRATCHSTREAM))) (if PWINDOW then (DSPXPOSITION XPOS PWINDOW) (PRIN1 "done. " PWINDOW)) (SETQ SUCCESS (if SCRATCHSTREAM then (* ; "We had to use a scratch file.") (if LENGTHFIXUPS then (* ; "Had some length fixups before we got to a really bad spot, so go back and do them now") (SETQ SCRATCHSTREAM (OPENSTREAM SCRATCHSTREAM (QUOTE BOTH) (QUOTE OLD) (QUOTE ((TYPE LAFITE))))) (CL:UNWIND-PROTECT (\MAILSCAVENGE.FIX.LENGTHS LENGTHFIXUPS SCRATCHSTREAM) (SETQ SCRATCHSTREAM (CLOSEF SCRATCHSTREAM)))) (if (AND (\MAILSCAVENGE.CONFIRM BADCOUNT MSGNO "Replace damaged mail file with scavenged file? ") (PROGN (if *FOLDER* then (\LAFITE.CLOSE.FOLDER *FOLDER* T) else (CLOSEF FOLDERSTRM)) (CL:MULTIPLE-VALUE-BIND (RESULT CONDITION) (\LAFITE.RENAMEFILE SCRATCHSTREAM FOLDERNAME) (if RESULT then T else (\MAILSCAVENGE.FORMAT "~%%RenameFile failed~@[ because ~A~]." CONDITION) NIL)))) then T else (* ; "File not renamed, either because of error or user choice. Tell where the scavenged file is.") (\MAILSCAVENGE.FORMAT "~%%Scavenged file stored as ~A." SCRATCHSTREAM MSGNO) NIL) elseif (AND (NULL LENGTHFIXUPS) (NULL TRUNCATEPTR)) then (\MAILSCAVENGE.FORMAT "~%%~A is a well-formed message file of ~D messages." FOLDERNAME MSGNO) NIL elseif (\MAILSCAVENGE.CONFIRM BADCOUNT MSGNO "Shall I correct these messages in the file? ") then (* ; "Do fixups in place") (if *FOLDER* then (SETQ FOLDERSTRM (\LAFITE.OPEN.FOLDER *FOLDER* (QUOTE BOTH))) elseif (NOT (OPENP FOLDERSTRM (QUOTE OUTPUT))) then (SETQ FOLDERSTRM (OPENSTREAM (CLOSEF FOLDERSTRM) (QUOTE BOTH) NIL (QUOTE ((TYPE LAFITE)))))) (\MAILSCAVENGE.FIX.LENGTHS LENGTHFIXUPS FOLDERSTRM) (if TRUNCATEPTR then (* ; "Truncate file to drop nulls off end") (SETFILEINFO FOLDERSTRM (QUOTE LENGTH) TRUNCATEPTR)) (* ; "Return success") T)) (if SUCCESS then (\MAILSCAVENGE.FORMAT "done.~2%%You may want to examine the messages listed above for duplications or concatenated messages.~%%")) (if TSTREAM then (DETACHWINDOW TSTREAM) (\MAILSCAVENGE.FORMAT " (This report window is now detached from its browser. You may close it at your convenience.)")) (RETURN (AND SUCCESS FOLDERNAME))) (* ;; "Cleanup time") (if (type? MAILFOLDER *FOLDER*) then (\LAFITE.CLOSE.FOLDER *FOLDER* T) elseif (AND (STREAMP FOLDERSTRM) (OPENP FOLDERSTRM)) then (CLOSEF FOLDERSTRM)) (if (STREAMP SCRATCHSTREAM) then (* ; "Must have aborted.") (DELFILE (CLOSEF SCRATCHSTREAM)))))) ) (\MAILSCAVENGE.OPEN.SCRATCH (LAMBDA (FOLDERNAME) (* ; "Edited 3-May-89 13:03 by bvm") (OPENSTREAM (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE EXTENSION) (CONCAT (UNPACKFILENAME.STRING FOLDERNAME (QUOTE EXTENSION)) "-scavenged") (QUOTE BODY) FOLDERNAME) (QUOTE OUTPUT) (QUOTE NEW) (QUOTE ((TYPE LAFITE) (SEQUENTIAL T))))) ) (\MAILSCAVENGE.LENGTHWIDTH (LAMBDA (FOLDERSTRM STARTPTR) (* ; "Edited 3-May-89 12:42 by bvm") (* ;; "Return the actual width of the %"message length%" field in this message") (LET ((LENSTART (+ STARTPTR *START*LENGTH))) (SETFILEPTR FOLDERSTRM LENSTART) (LA.READCOUNT FOLDERSTRM T) (- (GETFILEPTR FOLDERSTRM) LENSTART 1))) ) (\MAILSCAVENGE.LFCOPYBYTES (LAMBDA (SRCFIL DSTFIL START END) (* ; "Edited 3-May-89 13:07 by bvm") (* ;; "A COPYBYTES that turns LF into CR as it goes.") (SETFILEPTR SRCFIL START) (to (- END START) bind CH do (\BOUT DSTFIL (if (EQ (SETQ CH (BIN SRCFIL)) (CHARCODE LF)) then (CHARCODE CR) else CH)))) ) (\MAILSCAVENGE.READSTAMP (LAMBDA (STREAM) (* ; "Edited 3-May-89 12:20 by bvm") (* ;; "Like LA.READSTAMP, but also succeeds if the stamp ends in LF when we're processing a LF file.") (AND (EQ (BIN STREAM) (CHARCODE *)) (EQ (BIN STREAM) (CHARCODE s)) (EQ (BIN STREAM) (CHARCODE t)) (EQ (BIN STREAM) (CHARCODE a)) (EQ (BIN STREAM) (CHARCODE r)) (EQ (BIN STREAM) (CHARCODE t)) (EQ (BIN STREAM) (CHARCODE *)) (SELCHARQ (BIN STREAM) (CR T) (LF (EQ *EOL* (CHARCODE LF))) NIL))) ) (\MAILSCAVENGE.DUPLICATE? (LAMBDA (FOLDERSTRM OLDPTR GOODPTR STAMPLENGTH MSGLENGTH SCRATCH) (* ; "Edited 2-May-89 12:06 by bvm") (* ;; "True if the message at pointer OLDPTR is a duplicate of the one starting at GOODPTR with lengths STAMPLENGTH & MSGLENGTH.") (SETFILEPTR FOLDERSTRM OLDPTR) (LET (OLDLENGTH OLDSTAMP) (AND (LA.READSTAMP FOLDERSTRM) (SETQ OLDLENGTH (LA.READCOUNT FOLDERSTRM)) (SETQ OLDSTAMP (LA.READCOUNT FOLDERSTRM)) (\LAFITE.CHECK.DUPLICATE FOLDERSTRM SCRATCH GOODPTR STAMPLENGTH MSGLENGTH OLDPTR OLDSTAMP OLDLENGTH)))) ) (\MAILSCAVENGE.FORMAT (CL:LAMBDA (&REST ARGS) (* ; "Edited 21-Apr-89 15:25 by bvm") (if (TEXTSTREAMP *ERRORMSGSTREAM*) then (* ;; "It is MUCH faster to cons the string and hand it to tedit than to print a character at a time. One difference: unless we set the %"dontscroll%" flag, the window will scroll when we run off the bottom. This is probably desirable, as it means we look like we're doing something.") (TEDIT.INSERT *ERRORMSGSTREAM* (CL:APPLY (FUNCTION CL:FORMAT) NIL ARGS) (ADD1 (GETEOFPTR *ERRORMSGSTREAM*))) else (CL:APPLY (FUNCTION CL:FORMAT) *ERRORMSGSTREAM* ARGS))) ) (\MAILSCAVENGE.MAKEWINDOW (LAMBDA (FOLDER) (* ; "Edited 21-Apr-89 15:34 by bvm") (* ;; "Return a tedit window to use for Scavenger report, or NIL if FOLDER doesn't have a browser") (LET ((BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) (if BROWSERWINDOW then (LET* ((FONT (DSPFONT NIL (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) (ERRHEIGHT (HEIGHTIFWINDOW (TIMES 10 (FONTPROP FONT (QUOTE HEIGHT))) T)) (ERRW (CREATEW (CREATEREGION 0 0 10 ERRHEIGHT) (CONCAT "Mail Scavenger Report for " (fetch (MAILFOLDER SHORTFOLDERNAME) of FOLDER)) T))) (ATTACHWINDOW ERRW BROWSERWINDOW (if (< (fetch (REGION BOTTOM) of (WINDOWPROP BROWSERWINDOW (QUOTE REGION))) ERRHEIGHT) then (* ; "Won't fit below") (QUOTE TOP) else (QUOTE BOTTOM)) (QUOTE JUSTIFY) (QUOTE LOCALCLOSE)) (OPENTEXTSTREAM "" ERRW NIL NIL (BQUOTE (FONT (\, FONT) PROMPTWINDOW DON'T))) ERRW)))) ) (\MAILSCAVENGE.ASKUSER (LAMBDA (PROMPT) (DECLARE (CL:SPECIAL *FOLDER*)) (* ; "Edited 2-May-89 11:42 by bvm") (LET (BROWSERWINDOW) (if (AND *FOLDER* (SETQ BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of *FOLDER*))) then (* ; "Use the browser for interaction") (CLEARW BROWSERWINDOW) (FLASHWINDOW BROWSERWINDOW) (if (> (STRINGWIDTH PROMPT BROWSERWINDOW) (WINDOWPROP BROWSERWINDOW (QUOTE WIDTH))) then (* ; "Sigh, too wide to centerprint. I wish we had better text layout...") (RELMOVETO 0 (- (IQUOTIENT (WINDOWPROP BROWSERWINDOW (QUOTE HEIGHT)) 2)) BROWSERWINDOW) (PRIN3 PROMPT BROWSERWINDOW) else (* ; "Nicely center the prompt") (CENTERPRINTINREGION PROMPT NIL BROWSERWINDOW)) (LET* ((MENUW (fetch (MAILFOLDER BROWSERMENUWINDOW) of *FOLDER*)) (MENUWREG (WINDOWPROP MENUW (QUOTE REGION))) (MENUWIDTH (fetch (REGION WIDTH) of MENUWREG)) (ITEMS (QUOTE (("Proceed" T "Continue the scavenge as asked") ("Abort" NIL "Abort the mail scavenge operation")))) (MENU (create MENU ITEMS _ ITEMS CENTERFLG _ T MENUFONT _ LAFITEMENUFONT MENUROWS _ 1 ITEMWIDTH _ (MAX (STRINGWIDTH (CAAR ITEMS) LAFITEMENUFONT) (IQUOTIENT MENUWIDTH 4)) MENUOUTLINESIZE _ 0 MENUBORDERSIZE _ 0))) (* ; "Position the menu in the middle of the browser's menu window") (PROG1 (MENU MENU (LA.POSITION.FROM.REGION MENUWREG (IQUOTIENT (- MENUWIDTH (fetch (MENU IMAGEWIDTH) of MENU)) 2) (WINDOWPROP MENUW (QUOTE BORDER))) T) (CLEARW BROWSERWINDOW))) else (EQ (ASKUSER NIL NIL PROMPT) (QUOTE Y))))) ) (\MAILSCAVENGE.FIX.LENGTHS (LAMBDA (FIXUPS STREAM) (* ; "Edited 3-May-89 12:42 by bvm") (* ;; "Perform length fixups. FIXUPS has entries of the form (startptr length fieldwidth fixheader)") (for ENTRY in FIXUPS do (DESTRUCTURING-BIND (START LENGTH FIELDWIDTH FIXHEADER) ENTRY (SETFILEPTR STREAM (+ START *START*LENGTH)) (if LENGTH then (LA.PRINTCOUNT LENGTH STREAM (BQUOTE (FIX (\, FIELDWIDTH) 10 T))) else (LA.READCOUNT STREAM)) (if FIXHEADER then (* ; "Write the rest of the header, too") (if LENGTH then (LA.PRINTCOUNT (+ FIELDWIDTH LAFITEBASICSTAMPLENGTH) STREAM) else (LA.READCOUNT STREAM)) (PRIN3 "UU " STREAM)))))) (\MAILSCAVENGE.CONFIRM (LAMBDA (BADNO TOTALNO PROMPT) (* ; "Edited 21-Apr-89 15:27 by bvm") (DECLARE (CL:SPECIAL *FOLDER* *ERRORMSGSTREAM*)) (* ;; "Called at end of scavenge to report results. Return T/NIL response to PROMPT") (LET ((FORMATSTRING "~2%%Finished, found ~D bad messages out of ~D total messages.~%%")) (\MAILSCAVENGE.FORMAT FORMATSTRING BADNO TOTALNO) (if (\MAILSCAVENGE.ASKUSER PROMPT) then (if *FOLDER* then (* ; "Make sure to delete any toc that might be hanging around") (DELFILE (TOCFILENAME (fetch (MAILFOLDER FULLFOLDERNAME) of *FOLDER*)))) (\MAILSCAVENGE.FORMAT "Working... ") (* ; "Show some response") T))) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ *START*LENGTH 8) (CONSTANTS (*START*LENGTH 8)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS *FOLDER* *ERRORMSGSTREAM* *EOL*) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA \MAILSCAVENGE.FORMAT) ) (PUTPROPS MAILSCAVENGE COPYRIGHT ("Venue & Xerox Corporation" 1985 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1429 21135 (LAFITE.SCAVENGE 1439 . 1871) (\MAILSCAVENGE.INTERNAL 1873 . 14946) ( \MAILSCAVENGE.OPEN.SCRATCH 14948 . 15279) (\MAILSCAVENGE.LENGTHWIDTH 15281 . 15609) ( \MAILSCAVENGE.LFCOPYBYTES 15611 . 15916) (\MAILSCAVENGE.READSTAMP 15918 . 16395) ( \MAILSCAVENGE.DUPLICATE? 16397 . 16940) (\MAILSCAVENGE.FORMAT 16942 . 17529) (\MAILSCAVENGE.MAKEWINDOW 17531 . 18396) (\MAILSCAVENGE.ASKUSER 18398 . 19864) (\MAILSCAVENGE.FIX.LENGTHS 19866 . 20494) ( \MAILSCAVENGE.CONFIRM 20496 . 21133))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "30-Sep-2021 22:57:39"  +{DSK}kaplan>Local>medley3.5>git-medley>library>lafite>MAILSCAVENGE.;2 40187 + + previous date%: "15-Jun-90 18:25:37" +{DSK}kaplan>Local>medley3.5>git-medley>library>lafite>MAILSCAVENGE.;1) + + +(* ; " +Copyright (c) 1985, 1989-1990, 2021 by Venue & Xerox Corporation. +") + +(PRETTYCOMPRINT MAILSCAVENGECOMS) + +(RPAQQ MAILSCAVENGECOMS + [(FNS LAFITE.SCAVENGE \MAILSCAVENGE.INTERNAL \MAILSCAVENGE.OPEN.SCRATCH + \MAILSCAVENGE.LENGTHWIDTH \MAILSCAVENGE.LFCOPYBYTES \MAILSCAVENGE.READSTAMP + \MAILSCAVENGE.DUPLICATE? \MAILSCAVENGE.FORMAT \MAILSCAVENGE.MAKEWINDOW + \MAILSCAVENGE.ASKUSER \MAILSCAVENGE.FIX.LENGTHS \MAILSCAVENGE.CONFIRM) + (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (*START*LENGTH 8)) + (SPECVARS *FOLDER* *ERRORMSGSTREAM* *EOL*) + (LOCALVARS . T)) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA + \MAILSCAVENGE.FORMAT + ]) +(DEFINEQ + +(LAFITE.SCAVENGE + [LAMBDA (FOLDERNAME ERRORMSGSTREAM FORGET?) (* ; "Edited 18-Apr-89 18:19 by bvm") + + (* ;; + "User entry to the scavenger. If FORGET?, we won't add folder to the list of known folders.") + + (LET [(FOLDER (LAFITE.OBTAIN.FOLDER (LA.LONGFILENAME FOLDERNAME LAFITEMAIL.EXT) + 'INPUT T (AND FORGET? :FORGET] + (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) + (\MAILSCAVENGE.INTERNAL FOLDER ERRORMSGSTREAM]) + +(\MAILSCAVENGE.INTERNAL + [LAMBDA (*FOLDER* *ERRORMSGSTREAM* GOODPTR MSGNO) (* ; "Edited 3-May-89 13:05 by bvm") + + (* ;; "Scavenge FOLDER, which can be a mail folder, mail file name, or open stream on a mail file. Commentary goes to *ERRORMSGSTREAM*, which for folders defaults to its browser window. If GOODPTR is supplied, it is a file pointer that we assert points to the *START* corresponding to msg # MSGNO, and we guarantee we will not touch anything earlier in the file.") + + (LET + (SCRATCHSTREAM FOLDERSTRM) + (CL:UNWIND-PROTECT + (PROG ((*UPPER-CASE-FILE-NAMES* NIL) + (*PRINT-BASE* 10) + (BADCOUNT 0) + (*START* "*start* +") + (*EOL* (CHARCODE CR)) + (COPYFN (FUNCTION COPYBYTES)) + TRYPTR LFP PWINDOW XPOS DUPSCRATCH FOLDERNAME EOFPTR BODYSTART BADHEADER NOMOREP + STAMPLENGTH MSGLENGTH ENDPTR FIELDWIDTH LENGTHFIXUPS TRUNCATEPTR TSTREAM SUCCESS CH) + (DECLARE (CL:SPECIAL *FOLDER* *ERRORMSGSTREAM* *EOL*)) + (* ; "Used by \mailscavenge.askuser") + [if (TYPENAMEP *FOLDER* 'MAILFOLDER) + then (* ; + "It's a mail folder, so play by the rules") + (SETQ FOLDERSTRM (\LAFITE.OPEN.FOLDER *FOLDER* 'INPUT :OK)) + (SETQ PWINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of *FOLDER*)) + elseif (TYPENAMEP *FOLDER* 'STREAM) + then (SETQ FOLDERSTRM *FOLDER*) + else (SETQ FOLDERSTRM (\LAFITE.OPENSTREAM *FOLDER* 'INPUT 'OLD + (FUNCTION \LAFITE.EOF) + NIL + 'LAFITE] + (SETQ FOLDERNAME (FULLNAME FOLDERSTRM)) + (SETFILEINFO FOLDERSTRM 'BUFFERS 30) + (SETQ EOFPTR (GETEOFPTR FOLDERSTRM)) + (SETFILEPTR FOLDERSTRM 0) + (if PWINDOW + then (LAB.PROMPTPRINT *FOLDER* " Scavenging... ") + (SETQ XPOS (DSPXPOSITION NIL PWINDOW))) + [if (NOT *ERRORMSGSTREAM*) + then (SETQ *ERRORMSGSTREAM* (if (AND (TYPENAMEP *FOLDER* 'MAILFOLDER) + (SETQ TSTREAM ( + \MAILSCAVENGE.MAKEWINDOW + *FOLDER*))) + then + (* ; "We waited til here to make the window in case printing %"Scavenging... %" up there grew the window.") + (TEXTSTREAM TSTREAM) + else (GETSTREAM NIL 'OUTPUT] + (\MAILSCAVENGE.FORMAT "Scavenging ~A..." FOLDERNAME) + (if GOODPTR + then (* ; + "Somebody has already gotten us started") + (GO LP) + else (SETQ GOODPTR 0) + (SETQ MSGNO 1) + (if (LA.READSTAMP FOLDERSTRM) + then (* ; "Good start") + (GO PARSEMSG) + elseif (PROGN (SETFILEPTR FOLDERSTRM (SUB1 *START*LENGTH)) + (AND (EQ (BIN FOLDERSTRM) + (CHARCODE LF)) + (FILEPOS "*start*" FOLDERSTRM 0 7))) + then (* ; "LF woes") + (if (\MAILSCAVENGE.ASKUSER "File was apparently written with end of line convention LF. Convert to CR (Note: TEdit formatting may be corrupted by this action, or could already have been corrupted by copying the file into LF format)? " + ) + then (SETQ *START* "*start*") + (SETQ COPYFN (FUNCTION \MAILSCAVENGE.LFCOPYBYTES)) + (SETQ *EOL* (CHARCODE LF)) + (SETQ LFP T) + (SETQ SCRATCHSTREAM (\MAILSCAVENGE.OPEN.SCRATCH + FOLDERNAME)) + (SETFILEINFO FOLDERSTRM 'EOL 'LF)) + elseif (\MAILSCAVENGE.ASKUSER (CL:FORMAT NIL + "Alleged mail folder ~A doesn't begin with a Lafite header -- proceed anyway? " + FOLDERNAME)) + then (SETQ BODYSTART 0) + (GO FINDSTART) + else (RETURN NIL))) + LP + + (* ;; "GOODPTR is believed to point at *start*") + + (SETFILEPTR FOLDERSTRM GOODPTR) + (if (NOT (\MAILSCAVENGE.READSTAMP FOLDERSTRM)) + then (* ; "This shouldn't happen") + (CL:ERROR "Scavenger is confused at message ~D, byte ~D" MSGNO GOODPTR)) + PARSEMSG + (if PWINDOW + then (* ; "Tell which message we're on") + (DSPXPOSITION XPOS PWINDOW) + (PRIN3 MSGNO PWINDOW)) + (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) + (if (NOT (AND (SETQ MSGLENGTH (LA.READCOUNT FOLDERSTRM)) + (> MSGLENGTH 0))) + then (* ; "Malformed header--not even the length exists. Will need to build a new header. Take all the stuff from BODYSTART as potential message") + (SETQ BADHEADER T) + (GO FINDSTART)) + [SETQ BADHEADER (NOT (AND (PROGN (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) + (SETQ STAMPLENGTH (LA.READCOUNT FOLDERSTRM))) + [PROGN (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) + (BIN FOLDERSTRM) + (BIN FOLDERSTRM) + (BIN FOLDERSTRM) + (* ; "Read 3 status bytes") + (OR (EQ (SETQ CH (BIN FOLDERSTRM)) + *EOL*) + (AND LFP (EQ CH (CHARCODE CR] + (<= (- (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) + GOODPTR) + STAMPLENGTH] + + (* ;; "We have a plausible length. BADHEADER true means the rest of header does not parse because (a) no header length, (b) no CR after the the 3 mark bytes, or (c) header length is too short. Wait to see whether the length appears correct before deciding whether to rebuild the header or just smash it.") + (* ; + "Take all the stuff from BODYSTART as potential message") + (if (OR (<= (SETQ ENDPTR (+ GOODPTR MSGLENGTH)) + (GETFILEPTR FOLDERSTRM)) + (> ENDPTR EOFPTR)) + then (* ; + "Length too short or points past eof.") + (GO FINDSTART) + elseif [AND (< ENDPTR EOFPTR) + (PROGN (SETFILEPTR FOLDERSTRM ENDPTR) + (NOT (\MAILSCAVENGE.READSTAMP FOLDERSTRM] + then (* ; + "Length doesn't point at next *start*, have to search for a boundary") + (SETFILEPTR FOLDERSTRM ENDPTR) + (if (AND (EQ (BIN FOLDERSTRM) + 0) + (to (- EOFPTR ENDPTR 1) always (EQ (BIN FOLDERSTRM) + 0))) + then (* ; "File is well-formed except for ending in a bunch of nulls. This seems to happen every once in a fhile when a file server spazzes. Throw them away.") + (\MAILSCAVENGE.FORMAT + "~%%Starting at byte ~D (after message #~D):~%% File ends in ~D null bytes. Will discard." + ENDPTR MSGNO (- EOFPTR ENDPTR)) + (if SCRATCHSTREAM + then (* ; + "Copy last message verbatim to scratch file") + (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM GOODPTR + ENDPTR) + else (* ; "Note truncation here") + (SETQ TRUNCATEPTR ENDPTR)) + (add BADCOUNT 1) + (GO DONE)) + (GO FINDSTART) + elseif BADHEADER + then (* ; + "Length ok, but header was malformed. It is likely to be safe to just overwrite the header") + (add BADCOUNT 1) + (\MAILSCAVENGE.FORMAT + "~%%Message #~D at byte ~D: length ok, but header garbled." MSGNO + GOODPTR) + (SETQ FIELDWIDTH (\MAILSCAVENGE.LENGTHWIDTH FOLDERSTRM GOODPTR)) + (if SCRATCHSTREAM + then (* ; "Have to copy") + (SETQ BODYSTART (+ GOODPTR FIELDWIDTH LAFITEBASICSTAMPLENGTH)) + (SETQ MSGLENGTH (- ENDPTR BODYSTART)) + (GO COPYMSG) + else (* ; "Remember fixup") + (push LENGTHFIXUPS (LIST GOODPTR MSGLENGTH FIELDWIDTH T)) + (GO NEXT)) + else (* ; "Well-formed message") + [if (AND (< (- BODYSTART GOODPTR) + STAMPLENGTH) + (EQ (PROGN (SETFILEPTR FOLDERSTRM BODYSTART) + (BIN FOLDERSTRM)) + (CHARCODE *))) + then (* ; "May be a funny one") + (LET ((INFO (CL:READ-LINE FOLDERSTRM)) + ISDUP) + (if [AND (STRPOS "duplicate*" INFO 1 NIL T) + (FIXP (SETQ INFO (SUBATOM INFO 11] + then (* ; + "This message claims to be a duplicate of the one at INFO") + [SETQ ISDUP (\MAILSCAVENGE.DUPLICATE? + FOLDERSTRM INFO GOODPTR STAMPLENGTH + MSGLENGTH (OR DUPSCRATCH + (SETQ DUPSCRATCH + (OPENSTREAM "{nodircore}" + 'BOTH] + (\MAILSCAVENGE.FORMAT + "~%%Message #~D at byte ~D is marked as a duplicate of the one at byte~D from an aborted Expunge~A." + MSGNO GOODPTR INFO + (if (NOT ISDUP) + then + "; however, the original is not there" + elseif SCRATCHSTREAM + then " (not copied)" + else "")) + (if ISDUP + then (* ; "Nothing to do.") + (GO NEXT) + elseif SCRATCHSTREAM + then (SETQ BADHEADER T) + (* ; "so that message gets undeleted") + (GO COPYGOOD) + else (* ; "Want to rewrite the flags") + (push LENGTHFIXUPS + (LIST GOODPTR NIL NIL T)) + (GO NEXT] + (if SCRATCHSTREAM + then (* ; "Copy verbatim to scratch file") + (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM GOODPTR ENDPTR)) + (GO NEXT)) + FINDSTART + + + (* ;; "At this point, we have a malformed message starting at GOODPTR. Look for its end. If the header is also malformed, BADHEADER is true. BODYSTART points at what could be the start of text..") + + (SETQ TRYPTR BODYSTART) + FINDSTARTLP + (SETQ ENDPTR (FFILEPOS *START* FOLDERSTRM TRYPTR)) + (if (NULL ENDPTR) + then (* ; + "Can't find next message. Maybe this is the last one") + (if (AND (EQ MSGNO 1) + BADHEADER) + then (* ; "Never saw a single *start*") + (if [NULL (\MAILSCAVENGE.ASKUSER (CL:FORMAT NIL "There are no message boundaries in this file. Do you want to turn the file into a single message of length ~D?" + (- EOFPTR GOODPTR] + then (RETURN NIL))) + (SETQ ENDPTR EOFPTR) + elseif (AND LFP (PROGN (* ; + "Have to check that an eol follows, since we're not sure which kind.") + (SETFILEPTR FOLDERSTRM (+ ENDPTR (SUB1 *START*LENGTH))) + (SELCHARQ (BIN FOLDERSTRM) + ((CR LF) + NIL) + T))) + then (SETQ TRYPTR (+ ENDPTR (- *START*LENGTH 2))) + (GO FINDSTARTLP)) + [\MAILSCAVENGE.FORMAT "~%%Message #~D at byte ~D: length ~:[missing~%% (~;incorrect~%% (file says ~:*~D, ~]apparent length is ~D)" + MSGNO GOODPTR MSGLENGTH (if BADHEADER + then (* ; + "Estimate based on standard header size. We'll be exact later") + (+ LAFITESTAMPLENGTH (SETQ MSGLENGTH + (- ENDPTR BODYSTART))) + else (SETQ MSGLENGTH (- ENDPTR GOODPTR] + (add BADCOUNT 1) + (if BADHEADER + then (\MAILSCAVENGE.FORMAT + "~%% Need to rebuild internal header. Message body may be malformed." + ) + (GO COPYMSG)) (* ; + "Header ok, just the length was wrong") + (if (NULL SCRATCHSTREAM) + then (* ; + "Should suffice just to change length in place") + (if (<= (NCHARS MSGLENGTH) + (SETQ FIELDWIDTH (\MAILSCAVENGE.LENGTHWIDTH FOLDERSTRM + GOODPTR))) + then (* ; + "Good, the correct length fits in the available space. Save for confirmation later") + (push LENGTHFIXUPS (LIST GOODPTR MSGLENGTH FIELDWIDTH)) + (GO NEXT)) + + (* ;; + "Arrrgh, the length is too big. Fall thru to copy message to scratch file.") + + (\MAILSCAVENGE.FORMAT + "~%%New length does not fit into old header, will have to rebuild.")) + COPYGOOD + + + (* ;; + "Bring MSGLENGTH down to just the body length so we compute the new header correctly") + + (SETQ MSGLENGTH (- MSGLENGTH STAMPLENGTH)) + COPYMSG + + + (* ;; "At this point, we want to write the current message on scratch file. MSGLENGTH is the length of the body, sans header, starting at BODYSTART. If BADHEADER is true, we rebuild whole header. Otherwise, message is believed well-formed, so we can copy flag bytes from old message.") + + (if (NULL SCRATCHSTREAM) + then (* ; "Have to set up scratch file") + (\MAILSCAVENGE.FORMAT + "~%%Opening scratch file to handle rebuilt header.") + (SETQ SCRATCHSTREAM (\MAILSCAVENGE.OPEN.SCRATCH FOLDERNAME)) + (if (> GOODPTR 0) + then (\MAILSCAVENGE.FORMAT + "~%%Copying ~D previous message~:P to scratch file..." + (SUB1 MSGNO)) + (COPYBYTES FOLDERSTRM SCRATCHSTREAM 0 GOODPTR) + (\MAILSCAVENGE.FORMAT "done."))) + (LA.PRINTHEADER SCRATCHSTREAM MSGLENGTH) + (if BADHEADER + then (* ; + "Have to create afresh, so use primordial flags") + (PRIN3 "UU +" SCRATCHSTREAM) + else (* ; + "Original header was ok, except for length info, so copy flags and mark byte from it.") + (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM (- BODYSTART 4) + BODYSTART) + (SETQ BODYSTART (+ GOODPTR STAMPLENGTH))) + (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM BODYSTART ENDPTR) + NEXT + (COND + ((< (SETQ GOODPTR ENDPTR) + EOFPTR) (* ; "Go process some more") + (add MSGNO 1) + (GO LP))) + DONE + + + (* ;; "All finished--shall we confirm it?") + + (if SCRATCHSTREAM + then (* ; + "Close this now (could be slow) before saying done.") + (SETQ SCRATCHSTREAM (CLOSEF SCRATCHSTREAM))) + (if PWINDOW + then (DSPXPOSITION XPOS PWINDOW) + (PRIN1 "done. " PWINDOW)) + (SETQ SUCCESS + (if SCRATCHSTREAM + then (* ; "We had to use a scratch file.") + [if LENGTHFIXUPS + then (* ; + "Had some length fixups before we got to a really bad spot, so go back and do them now") + [SETQ SCRATCHSTREAM (OPENSTREAM SCRATCHSTREAM 'BOTH 'OLD + '((TYPE LAFITE] + (CL:UNWIND-PROTECT + (\MAILSCAVENGE.FIX.LENGTHS LENGTHFIXUPS SCRATCHSTREAM) + (SETQ SCRATCHSTREAM (CLOSEF SCRATCHSTREAM)))] + (if [AND (\MAILSCAVENGE.CONFIRM BADCOUNT MSGNO + "Replace damaged mail file with scavenged file? ") + (PROGN (if *FOLDER* + then (\LAFITE.CLOSE.FOLDER *FOLDER* T) + else (CLOSEF FOLDERSTRM)) + (CL:MULTIPLE-VALUE-BIND (RESULT CONDITION) + (\LAFITE.RENAMEFILE SCRATCHSTREAM FOLDERNAME) + (if RESULT + then T + else (\MAILSCAVENGE.FORMAT + "~%%RenameFile failed~@[ because ~A~]." + CONDITION) + NIL] + then T + else (* ; + "File not renamed, either because of error or user choice. Tell where the scavenged file is.") + (\MAILSCAVENGE.FORMAT "~%%Scavenged file stored as ~A." + SCRATCHSTREAM MSGNO) + NIL) + elseif (AND (NULL LENGTHFIXUPS) + (NULL TRUNCATEPTR)) + then (\MAILSCAVENGE.FORMAT + "~%%~A is a well-formed message file of ~D messages." FOLDERNAME + MSGNO) + NIL + elseif (\MAILSCAVENGE.CONFIRM BADCOUNT MSGNO + "Shall I correct these messages in the file? ") + then (* ; "Do fixups in place") + [if *FOLDER* + then (SETQ FOLDERSTRM (\LAFITE.OPEN.FOLDER *FOLDER* 'BOTH)) + elseif (NOT (OPENP FOLDERSTRM 'OUTPUT)) + then (SETQ FOLDERSTRM (OPENSTREAM (CLOSEF FOLDERSTRM) + 'BOTH NIL '((TYPE LAFITE] + (\MAILSCAVENGE.FIX.LENGTHS LENGTHFIXUPS FOLDERSTRM) + (if TRUNCATEPTR + then (* ; + "Truncate file to drop nulls off end") + (SETFILEINFO FOLDERSTRM 'LENGTH TRUNCATEPTR)) + (* ; "Return success") + T)) + (if SUCCESS + then (\MAILSCAVENGE.FORMAT "done.~2%%You may want to examine the messages listed above for duplications or concatenated messages.~%%" + )) + (if TSTREAM + then (DETACHWINDOW TSTREAM) + (\MAILSCAVENGE.FORMAT + " +(This report window is now detached from its browser. + You may close it at your convenience.)")) + (RETURN (AND SUCCESS FOLDERNAME))) + + (* ;; "Cleanup time") + + (if (type? MAILFOLDER *FOLDER*) + then (\LAFITE.CLOSE.FOLDER *FOLDER* T) + elseif (AND (STREAMP FOLDERSTRM) + (OPENP FOLDERSTRM)) + then (CLOSEF FOLDERSTRM)) + (if (STREAMP SCRATCHSTREAM) + then (* ; "Must have aborted.") + (DELFILE (CLOSEF SCRATCHSTREAM))))]) + +(\MAILSCAVENGE.OPEN.SCRATCH + [LAMBDA (FOLDERNAME) (* ; "Edited 3-May-89 13:03 by bvm") + (OPENSTREAM (PACKFILENAME.STRING 'VERSION NIL 'EXTENSION (CONCAT (UNPACKFILENAME.STRING + FOLDERNAME + 'EXTENSION) + "-scavenged") + 'BODY FOLDERNAME) + 'OUTPUT + 'NEW + '((TYPE LAFITE) + (SEQUENTIAL T]) + +(\MAILSCAVENGE.LENGTHWIDTH + [LAMBDA (FOLDERSTRM STARTPTR) (* ; "Edited 3-May-89 12:42 by bvm") + + (* ;; "Return the actual width of the %"message length%" field in this message") + + (LET ((LENSTART (+ STARTPTR *START*LENGTH))) + (SETFILEPTR FOLDERSTRM LENSTART) + (LA.READCOUNT FOLDERSTRM T) + (- (GETFILEPTR FOLDERSTRM) + LENSTART 1]) + +(\MAILSCAVENGE.LFCOPYBYTES + [LAMBDA (SRCFIL DSTFIL START END) (* ; "Edited 3-May-89 13:07 by bvm") + + (* ;; "A COPYBYTES that turns LF into CR as it goes.") + + (SETFILEPTR SRCFIL START) + (to (- END START) bind CH do (\BOUT DSTFIL (if (EQ (SETQ CH (BIN SRCFIL)) + (CHARCODE LF)) + then (CHARCODE CR) + else CH]) + +(\MAILSCAVENGE.READSTAMP + [LAMBDA (STREAM) (* ; "Edited 3-May-89 12:20 by bvm") + + (* ;; + "Like LA.READSTAMP, but also succeeds if the stamp ends in LF when we're processing a LF file.") + + (AND (EQ (BIN STREAM) + (CHARCODE *)) + (EQ (BIN STREAM) + (CHARCODE s)) + (EQ (BIN STREAM) + (CHARCODE t)) + (EQ (BIN STREAM) + (CHARCODE a)) + (EQ (BIN STREAM) + (CHARCODE r)) + (EQ (BIN STREAM) + (CHARCODE t)) + (EQ (BIN STREAM) + (CHARCODE *)) + (SELCHARQ (BIN STREAM) + (CR T) + (LF (EQ *EOL* (CHARCODE LF))) + NIL]) + +(\MAILSCAVENGE.DUPLICATE? + [LAMBDA (FOLDERSTRM OLDPTR GOODPTR STAMPLENGTH MSGLENGTH SCRATCH) + (* ; "Edited 2-May-89 12:06 by bvm") + + (* ;; "True if the message at pointer OLDPTR is a duplicate of the one starting at GOODPTR with lengths STAMPLENGTH & MSGLENGTH.") + + (SETFILEPTR FOLDERSTRM OLDPTR) + (LET (OLDLENGTH OLDSTAMP) + (AND (LA.READSTAMP FOLDERSTRM) + (SETQ OLDLENGTH (LA.READCOUNT FOLDERSTRM)) + (SETQ OLDSTAMP (LA.READCOUNT FOLDERSTRM)) + (\LAFITE.CHECK.DUPLICATE FOLDERSTRM SCRATCH GOODPTR STAMPLENGTH MSGLENGTH OLDPTR + OLDSTAMP OLDLENGTH]) + +(\MAILSCAVENGE.FORMAT + (CL:LAMBDA (&REST ARGS) (* ; "Edited 21-Apr-89 15:25 by bvm") + (if (TEXTSTREAMP *ERRORMSGSTREAM*) + then + + (* ;; "It is MUCH faster to cons the string and hand it to tedit than to print a character at a time. One difference: unless we set the %"dontscroll%" flag, the window will scroll when we run off the bottom. This is probably desirable, as it means we look like we're doing something.") + + (TEDIT.INSERT *ERRORMSGSTREAM* (CL:APPLY (FUNCTION CL:FORMAT) + NIL ARGS) + (ADD1 (GETEOFPTR *ERRORMSGSTREAM*))) + else (CL:APPLY (FUNCTION CL:FORMAT) + *ERRORMSGSTREAM* ARGS)))) + +(\MAILSCAVENGE.MAKEWINDOW + [LAMBDA (FOLDER) (* ; "Edited 21-Apr-89 15:34 by bvm") + + (* ;; + "Return a tedit window to use for Scavenger report, or NIL if FOLDER doesn't have a browser") + + (LET ((BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) + (if BROWSERWINDOW + then (LET* ((FONT (DSPFONT NIL (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) + ) + (ERRHEIGHT (HEIGHTIFWINDOW (TIMES 10 (FONTPROP FONT 'HEIGHT)) + T)) + (ERRW (CREATEW (CREATEREGION 0 0 10 ERRHEIGHT) + (CONCAT "Mail Scavenger Report for " (fetch + (MAILFOLDER + SHORTFOLDERNAME + ) of + FOLDER)) + T))) + (ATTACHWINDOW ERRW BROWSERWINDOW + (if (< (fetch (REGION BOTTOM) of (WINDOWPROP + BROWSERWINDOW + 'REGION)) + ERRHEIGHT) + then (* ; "Won't fit below") + 'TOP + else 'BOTTOM) + 'JUSTIFY + 'LOCALCLOSE) + (OPENTEXTSTREAM "" ERRW NIL NIL `(FONT ,FONT PROMPTWINDOW DON'T)) + ERRW]) + +(\MAILSCAVENGE.ASKUSER + [LAMBDA (PROMPT) + (DECLARE (CL:SPECIAL *FOLDER*)) (* ; "Edited 2-May-89 11:42 by bvm") + (LET (BROWSERWINDOW) + (if (AND *FOLDER* (SETQ BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of + *FOLDER*))) + then (* ; "Use the browser for interaction") + (CLEARW BROWSERWINDOW) + (FLASHWINDOW BROWSERWINDOW) + (if (> (STRINGWIDTH PROMPT BROWSERWINDOW) + (WINDOWPROP BROWSERWINDOW 'WIDTH)) + then (* ; + "Sigh, too wide to centerprint. I wish we had better text layout...") + (RELMOVETO 0 (- (IQUOTIENT (WINDOWPROP BROWSERWINDOW 'HEIGHT) + 2)) + BROWSERWINDOW) + (PRIN3 PROMPT BROWSERWINDOW) + else (* ; "Nicely center the prompt") + (CENTERPRINTINREGION PROMPT NIL BROWSERWINDOW)) + (LET* ((MENUW (fetch (MAILFOLDER BROWSERMENUWINDOW) of *FOLDER*)) + (MENUWREG (WINDOWPROP MENUW 'REGION)) + (MENUWIDTH (fetch (REGION WIDTH) of MENUWREG)) + [ITEMS '(("Proceed" T "Continue the scavenge as asked") + ("Abort" NIL "Abort the mail scavenge operation"] + (MENU (create MENU + ITEMS _ ITEMS + CENTERFLG _ T + MENUFONT _ LAFITEMENUFONT + MENUROWS _ 1 + ITEMWIDTH _ (MAX (STRINGWIDTH (CAAR ITEMS) + LAFITEMENUFONT) + (IQUOTIENT MENUWIDTH 4)) + MENUOUTLINESIZE _ 0 + MENUBORDERSIZE _ 0))) (* ; + "Position the menu in the middle of the browser's menu window") + (PROG1 (MENU MENU (LA.POSITION.FROM.REGION MENUWREG + (IQUOTIENT (- MENUWIDTH (fetch (MENU IMAGEWIDTH + ) + of MENU)) + 2) + (WINDOWPROP MENUW 'BORDER)) + T) + (CLEARW BROWSERWINDOW))) + else (EQ (ASKUSER NIL NIL PROMPT) + 'Y]) + +(\MAILSCAVENGE.FIX.LENGTHS + [LAMBDA (FIXUPS STREAM) (* ; "Edited 3-May-89 12:42 by bvm") + + (* ;; + "Perform length fixups. FIXUPS has entries of the form (startptr length fieldwidth fixheader)") + + (for ENTRY in FIXUPS + do (DESTRUCTURING-BIND (START LENGTH FIELDWIDTH FIXHEADER) + ENTRY + (SETFILEPTR STREAM (+ START *START*LENGTH)) + (if LENGTH + then (LA.PRINTCOUNT LENGTH STREAM `(FIX ,FIELDWIDTH 10 T)) + else (LA.READCOUNT STREAM)) + (if FIXHEADER + then (* ; + "Write the rest of the header, too") + (if LENGTH + then (LA.PRINTCOUNT (+ FIELDWIDTH LAFITEBASICSTAMPLENGTH) + STREAM) + else (LA.READCOUNT STREAM)) + (PRIN3 "UU +" STREAM]) + +(\MAILSCAVENGE.CONFIRM + [LAMBDA (BADNO TOTALNO PROMPT) (* ; "Edited 21-Apr-89 15:27 by bvm") + (DECLARE (CL:SPECIAL *FOLDER* *ERRORMSGSTREAM*)) + + (* ;; "Called at end of scavenge to report results. Return T/NIL response to PROMPT") + + (LET ((FORMATSTRING "~2%%Finished, found ~D bad messages out of ~D total messages.~%%")) + (\MAILSCAVENGE.FORMAT FORMATSTRING BADNO TOTALNO) + (if (\MAILSCAVENGE.ASKUSER PROMPT) + then [if *FOLDER* + then (* ; + "Make sure to delete any toc that might be hanging around") + (DELFILE (TOCFILENAME (fetch (MAILFOLDER FULLFOLDERNAME) + of *FOLDER*] + (\MAILSCAVENGE.FORMAT "Working... ") (* ; "Show some response") + T]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ *START*LENGTH 8) + + +(CONSTANTS (*START*LENGTH 8)) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(SPECVARS *FOLDER* *ERRORMSGSTREAM* *EOL*) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA \MAILSCAVENGE.FORMAT) +) +(PUTPROPS MAILSCAVENGE COPYRIGHT ("Venue & Xerox Corporation" 1985 1989 1990 2021)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (1409 39666 (LAFITE.SCAVENGE 1419 . 1941) (\MAILSCAVENGE.INTERNAL 1943 . 28454) ( +\MAILSCAVENGE.OPEN.SCRATCH 28456 . 29059) (\MAILSCAVENGE.LENGTHWIDTH 29061 . 29474) ( +\MAILSCAVENGE.LFCOPYBYTES 29476 . 30045) (\MAILSCAVENGE.READSTAMP 30047 . 30794) ( +\MAILSCAVENGE.DUPLICATE? 30796 . 31497) (\MAILSCAVENGE.FORMAT 31499 . 32326) (\MAILSCAVENGE.MAKEWINDOW + 32328 . 34382) (\MAILSCAVENGE.ASKUSER 34384 . 37514) (\MAILSCAVENGE.FIX.LENGTHS 37516 . 38674) ( +\MAILSCAVENGE.CONFIRM 38676 . 39664))))) +STOP diff --git a/library/lafite/MAILSCAVENGE.LCOM b/library/lafite/MAILSCAVENGE.LCOM index a73235bbc64146801aea0ec8af01361d44146902..1abf12e97fb335f1d54078e297770d5f8408a67f 100644 GIT binary patch delta 670 zcmZ1&yE9fz!^PFj)6Z4c&C|zK*VE67lbKYM zSX613lbDuSl4|Gc=;@;t?Ccok>gVpNXKkdZpk!o;WUY~vk%g6^5zv~Xi96)$-9mkQ z6p$6@>FFscq$HLAU4u=dg%Vy*8CjW{TNwjAMWiR}@c07B6AC5TDm{5Bi_GK%rX`GAn^~Dl7~z6bfGjQ6 zP@r%FtGGCjGehPJkkc#M2voC~U)~I))J5Lp6lJW%O{2J|2=(Losxpx#<|UoZOw>S}B$76hmdRL9C>S%3Hku|wk|_=% zgSr$K!z|n?xDynah4?F6x%V#!E-QEwEsD5ubKc>+^Uk~He%yMsRjnGPWxJ+e*^VjL zuC)$lI;L)P_3Mra#CE%8$FaQ)GCn>(;<;*JYoVcQ8bIW_V6Z@FHb9nDg{sR90#yzA;f>$WiVheZ0Ma9Sc516ZG`7Kjfm8q&IevcGnaSmaj{aL_swg+~oP;`XoE_y24FQ&g7L!A-qGp zHhZ(=3)8o=`zMgTIrR-aFHb*4&y<{9DXh2P1>#p2BR)O%4DlHGj@R7cV&S6a_lrZk z_+$o;_k1aSzI3~IDlOeX94|4%FGuGmbApZRGP3)^8nO>UfVd! Date: Thu, 30 Sep 2021 23:59:26 -0700 Subject: [PATCH 7/8] Move UNIXMAIL.* and MAILSCAVENGE.TEDIT to library/lafite --- .../lafite/MAILSCAVENGE.TEDIT | Bin library/{ => lafite}/UNIXMAIL | 0 library/{ => lafite}/UNIXMAIL.DFASL | Bin library/{ => lafite}/UNIXMAIL.TEDIT | Bin 4 files changed, 0 insertions(+), 0 deletions(-) rename internal/library/mailscavenge.tedit => library/lafite/MAILSCAVENGE.TEDIT (100%) rename library/{ => lafite}/UNIXMAIL (100%) rename library/{ => lafite}/UNIXMAIL.DFASL (100%) rename library/{ => lafite}/UNIXMAIL.TEDIT (100%) diff --git a/internal/library/mailscavenge.tedit b/library/lafite/MAILSCAVENGE.TEDIT similarity index 100% rename from internal/library/mailscavenge.tedit rename to library/lafite/MAILSCAVENGE.TEDIT diff --git a/library/UNIXMAIL b/library/lafite/UNIXMAIL similarity index 100% rename from library/UNIXMAIL rename to library/lafite/UNIXMAIL diff --git a/library/UNIXMAIL.DFASL b/library/lafite/UNIXMAIL.DFASL similarity index 100% rename from library/UNIXMAIL.DFASL rename to library/lafite/UNIXMAIL.DFASL diff --git a/library/UNIXMAIL.TEDIT b/library/lafite/UNIXMAIL.TEDIT similarity index 100% rename from library/UNIXMAIL.TEDIT rename to library/lafite/UNIXMAIL.TEDIT From 625a5a839cc08e4960f6f71630a66463b812766c Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Thu, 30 Sep 2021 23:17:28 -0700 Subject: [PATCH 8/8] Convert UNICODE to LF Don't know why it reverted. Just a MAKEFILE NEW and recompile --- library/UNICODE | 417 +++++++++++++++++++++++++++---------------- library/UNICODE.LCOM | Bin 22194 -> 22117 bytes 2 files changed, 261 insertions(+), 156 deletions(-) diff --git a/library/UNICODE b/library/UNICODE index ad9e3b1c..e7b12cc8 100644 --- a/library/UNICODE +++ b/library/UNICODE @@ -1,18 +1,16 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "21-Aug-2021 13:13:04"  -{DSK}kaplan>Local>medley3.5>git-medley>library>UNICODE.;193 64903 +(FILECREATED "30-Sep-2021 16:03:18"  +{DSK}kaplan>Local>medley3.5>git-medley>library>UNICODE.;194 64783 - changes to%: (FNS MAKE-UNICODE-TRANSLATION-TABLES) - - previous date%: " 8-Aug-2021 13:10:17" -{DSK}kaplan>Local>medley3.5>git-medley>library>UNICODE.;192) + previous date%: "21-Aug-2021 13:13:04" +{DSK}kaplan>Local>medley3.5>git-medley>library>UNICODE.;193) (PRETTYCOMPRINT UNICODECOMS) (RPAQQ UNICODECOMS [(COMS - (* ;; "External formats") + (* ;; "External formats") (FNS UTF8.OUTCHARFN UTF8.INCCODEFN UTF8.PEEKCCODEFN \UTF8.BACKCCODEFN) (FNS UTF16BE.OUTCHARFN UTF16BE.INCCODEFN UTF16BE.PEEKCCODEFN \UTF16.BACKCCODEFN) @@ -25,14 +23,14 @@ (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE)) (FNS XTOUCODE UTOXCODE)) [COMS - (* ;; "Unicode mapping files") + (* ;; "Unicode mapping files") (FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING WRITE-UNICODE-MAPPING WRITE-UNICODE-INCLUDED WRITE-UNICODE-MAPPING-HEADER WRITE-UNICODE-MAPPING-FILENAME ) (VARS XCCS-SET-NAMES) - (* ;; "Automate dumping of a documentation prefix") + (* ;; "Automate dumping of a documentation prefix") [DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16)) @@ -43,7 +41,7 @@ (P (PUSHNEW UNICODEDIRECTORIES (PACK* (UNIX-GETENV "MEDLEYDIR") '/unicode/xerox/] (COMS - (* ;; "Set up translation tables for UTF8 and UTFBE external formats") + (* ;; "Set up translation tables for UTF8 and UTFBE external formats") (FNS MAKE-UNICODE-TRANSLATION-TABLES) [INITVARS (DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS @@ -63,7 +61,7 @@ "NOTE: UNICODE requires EXPORTS.ALL for compilation" T))) - (* ;; "These control the layout of the translation tables. Since many of the upper panels are sparse, doing it per-panel (128) seems more space-efficient, and residual alists can be shorter") + (* ;; "These control the layout of the translation tables. Since many of the upper panels are sparse, doing it per-panel (128) seems more space-efficient, and residual alists can be shorter") (CONSTANTS (TRANSLATION-SEGMENT-SIZE 128) (MAX-ALIST-LENGTH 10) @@ -78,13 +76,13 @@ (DEFINEQ (UTF8.OUTCHARFN - [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 8-Aug-2021 13:02 by rmk:") - (* ; "Edited 17-Aug-2020 08:45 by rmk:") - (* ; "Edited 30-Jan-2020 23:08 by rmk:") + [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 8-Aug-2021 13:02 by rmk:") + (* ; "Edited 17-Aug-2020 08:45 by rmk:") + (* ; "Edited 30-Jan-2020 23:08 by rmk:") - (* ;; "Perhaps the translation table should already do the mapping for EOL to LF, but that seems to be a separate property of the stream. Also, CRLF=2 bytes.") + (* ;; "Perhaps the translation table should already do the mapping for EOL to LF, but that seems to be a separate property of the stream. Also, CRLF=2 bytes.") - (* ;; "Print UTF8 sequence for CHARCODE. Do not do XCCS to Unicode translation if RAW.") + (* ;; "Print UTF8 sequence for CHARCODE. Do not do XCCS to Unicode translation if RAW.") (IF (EQ CHARCODE (CHARCODE EOL)) THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0) @@ -97,13 +95,13 @@ DO (IF (ILESSP C 128) THEN (\BOUT STREAM C) ELSEIF (ILESSP C 2048) - THEN (* ; "x800") + THEN (* ; "x800") (\BOUT STREAM (LOGOR (LLSH 3 6) (LRSH C 6))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE C 0 6))) ELSEIF (ILESSP C 65536) - THEN (* ; "x10000") + THEN (* ; "x10000") (\BOUT STREAM (LOGOR (LLSH 7 5) (LRSH C 12))) (\BOUT STREAM (LOGOR (LLSH 2 6) @@ -111,7 +109,7 @@ (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE C 0 6))) ELSEIF (ILESSP C 2097152) - THEN (* ; "x200000") + THEN (* ; "x200000") (\BOUT STREAM (LOGOR (LLSH 15 4) (LRSH C 18))) (\BOUT STREAM (LOGOR (LLSH 2 6) @@ -123,29 +121,29 @@ ELSE (ERROR "CHARCODE too big for UTF8" C]) (UTF8.INCCODEFN - [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 6-Aug-2021 16:02 by rmk:") - (* ; "Edited 6-Aug-2020 17:13 by rmk:") + [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 6-Aug-2021 16:02 by rmk:") + (* ; "Edited 6-Aug-2020 17:13 by rmk:") - (* ;; "Do not do UNICODE to XCSS translation if RAW.") + (* ;; "Do not do UNICODE to XCSS translation if RAW.") - (* ;; "Test for smallp because the stream's End-of-file operation may suppress the error") + (* ;; "Test for smallp because the stream's End-of-file operation may suppress the error") (DECLARE (USEDFREE *BYTECOUNTER*)) (LET (BYTE1 BYTE2 BYTE3 BYTE4 CODE (COUNT 1)) (SETQ BYTE1 (\BIN STREAM)) - (* ;; "Distinguish on header bytes (modulo peculiar EOF behavior--the caller will get whatever ended up in BYTE1") + (* ;; "Distinguish on header bytes (modulo peculiar EOF behavior--the caller will get whatever ended up in BYTE1") (CL:WHEN (SMALLP BYTE1) [SETQ CODE (IF (ILESSP BYTE1 128) THEN - (* ;; - "Test first: Ascii is the common case. EOL requires its own translation") + (* ;; + "Test first: Ascii is the common case. EOL requires its own translation") (SELCHARQ BYTE1 (CR (SELECTC (FETCH (STREAM EOLCONVENTION) OF STREAM) - (CR.EOLC (* ; "Also eq BYTE1") + (CR.EOLC (* ; "Also eq BYTE1") (CHARCODE EOL)) (CRLF.EOLC (IF (EQ (CHARCODE LF) (\PEEKBIN STREAM T)) @@ -160,7 +158,7 @@ BYTE1)) BYTE1) ELSEIF (IGEQ BYTE1 (LLSH 15 4)) - THEN (* ; "4 bytes") + THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE2)) (ILESSP BYTE2 128)) @@ -182,7 +180,7 @@ 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) - THEN (* ; "3 bytes") + THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE2)) (ILESSP BYTE2 128)) @@ -197,7 +195,7 @@ (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) - ELSE (* ; "Must be 2 bytes") + ELSE (* ; "Must be 2 bytes") (SETQ COUNT 2) (SETQ BYTE2 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE2)) @@ -211,12 +209,97 @@ (CL:WHEN COUNTP (SETQ *BYTECOUNTER* COUNT)) CODE]) -(UTF8.PEEKCCODEFN [LAMBDA (STREAM NOERROR RAW) (* ; "Edited 14-Jun-2021 22:53 by rmk:") (* ;; "Modeled this after \EUCPEEK on LLREAD. In the multi-byte (non-ASCII) case, backs the file pointer to the beginning by the proper number of \BACKFILEPTRs, and returns a count of 0. Returns NIL if NOERROR and either invalid UTF8 or end of file.") (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.") (* ;; "Do not do UNICODE to XCCS translation if RAW") (PROG (BYTE1 BYTE2 BYTE3 BYTE4 CODE) (SETQ BYTE1 (\PEEKBIN STREAM NOERROR)) (* ;; "Distinguish on header bytex") (CL:UNLESS BYTE1 (RETURN NIL)) [IF (ILESSP BYTE1 128) THEN (* ;;  "Test first: Ascii is the common case. No need to back up, since we peeked.") (SETQ CODE BYTE1) ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (\BIN STREAM) (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (IGEQ BYTE2 128)) (\BACKFILEPTR STREAM) (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (RETURN CODE)) (\BIN STREAM) (CL:UNLESS (AND (SETQ BYTE3 (\PEEKBIN STREAM NOERROR)) (IGEQ BYTE3 128)) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (RETURN CODE)) (\BIN STREAM) (SETQ BYTE4 (\PEEKBIN STREAM NOERROR)) (* ;  "PEEK the last, no need to back it up") (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (IF (AND BYTE4 (IGEQ BYTE4 128)) THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6))) ELSEIF NOERROR ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (\BIN STREAM) (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (IGEQ BYTE2 128)) (\BACKFILEPTR STREAM) (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (RETURN CODE)) (\BIN STREAM) (SETQ BYTE3 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (IF (AND BYTE3 (IGEQ BYTE3 128)) THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6))) ELSEIF NOERROR ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) ELSE (* ; "Must be 2 bytes") (\BIN STREAM) (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (IF (AND BYTE2 (IGEQ BYTE2 128)) THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6))) ELSEIF NOERROR ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2] (CL:WHEN (AND CODE (NOT RAW)) (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*))) (RETURN CODE]) +(UTF8.PEEKCCODEFN + [LAMBDA (STREAM NOERROR RAW) (* ; "Edited 14-Jun-2021 22:53 by rmk:") + + (* ;; "Modeled this after \EUCPEEK on LLREAD. In the multi-byte (non-ASCII) case, backs the file pointer to the beginning by the proper number of \BACKFILEPTRs, and returns a count of 0. Returns NIL if NOERROR and either invalid UTF8 or end of file.") + + (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.") + + (* ;; "Do not do UNICODE to XCCS translation if RAW") + + (PROG (BYTE1 BYTE2 BYTE3 BYTE4 CODE) + (SETQ BYTE1 (\PEEKBIN STREAM NOERROR)) + + (* ;; "Distinguish on header bytex") + + (CL:UNLESS BYTE1 (RETURN NIL)) + [IF (ILESSP BYTE1 128) + THEN + + (* ;; + "Test first: Ascii is the common case. No need to back up, since we peeked.") + + (SETQ CODE BYTE1) + ELSEIF (IGEQ BYTE1 (LLSH 15 4)) + THEN (* ; "4 bytes") + (\BIN STREAM) + (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) + (IGEQ BYTE2 128)) + (\BACKFILEPTR STREAM) + (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) + (RETURN CODE)) + (\BIN STREAM) + (CL:UNLESS (AND (SETQ BYTE3 (\PEEKBIN STREAM NOERROR)) + (IGEQ BYTE3 128)) + (\BACKFILEPTR STREAM) + (\BACKFILEPTR STREAM) + (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) + (RETURN CODE)) + (\BIN STREAM) + (SETQ BYTE4 (\PEEKBIN STREAM NOERROR)) (* ; + "PEEK the last, no need to back it up") + (\BACKFILEPTR STREAM) + (\BACKFILEPTR STREAM) + (\BACKFILEPTR STREAM) + (IF (AND BYTE4 (IGEQ BYTE4 128)) + THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 3) + 18) + (LLSH (LOADBYTE BYTE2 0 6) + 12) + (LLSH (LOADBYTE BYTE3 0 6) + 6) + (LOADBYTE BYTE4 0 6))) + ELSEIF NOERROR + ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) + ELSEIF (IGEQ BYTE1 (LLSH 7 5)) + THEN (* ; "3 bytes") + (\BIN STREAM) + (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) + (IGEQ BYTE2 128)) + (\BACKFILEPTR STREAM) + (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) + (RETURN CODE)) + (\BIN STREAM) + (SETQ BYTE3 (\PEEKBIN STREAM NOERROR)) + (\BACKFILEPTR STREAM) + (\BACKFILEPTR STREAM) + (IF (AND BYTE3 (IGEQ BYTE3 128)) + THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 4) + 12) + (LLSH (LOADBYTE BYTE2 0 6) + 6) + (LOADBYTE BYTE3 0 6))) + ELSEIF NOERROR + ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) + ELSE (* ; "Must be 2 bytes") + (\BIN STREAM) + (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) + (\BACKFILEPTR STREAM) + (IF (AND BYTE2 (IGEQ BYTE2 128)) + THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 5) + 6) + (LOADBYTE BYTE2 0 6))) + ELSEIF NOERROR + ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2] + (CL:WHEN (AND CODE (NOT RAW)) + (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*))) + (RETURN CODE]) (\UTF8.BACKCCODEFN - [LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:04 by rmk:") + [LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:04 by rmk:") - (* ;; "\BACKFILEPTR is NIL at beginning of FILE, just return COUNT") + (* ;; "\BACKFILEPTR is NIL at beginning of FILE, just return COUNT") (DECLARE (USEDFREE *BYTECOUNTER*)) (BIND (C _ 0) WHILE (CL:WHEN (\BACKFILEPTR STREAM) @@ -228,12 +311,12 @@ (DEFINEQ (UTF16BE.OUTCHARFN - [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 8-Aug-2021 13:09 by rmk:") - (* ; "Edited 30-Jan-2020 23:08 by rmk:") + [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 8-Aug-2021 13:09 by rmk:") + (* ; "Edited 30-Jan-2020 23:08 by rmk:") - (* ;; "PRINT UTF16 sequence for CHARCODE. Do not do XCCS to UNICODE translation if RAW.") + (* ;; "PRINT UTF16 sequence for CHARCODE. Do not do XCCS to UNICODE translation if RAW.") - (* ;; "Not sure about EOL conversion if truly %"raw%"") + (* ;; "Not sure about EOL conversion if truly %"raw%"") (IF (EQ CHARCODE (CHARCODE EOL)) THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0) @@ -245,10 +328,10 @@ DO (\WOUT STREAM C]) (UTF16BE.INCCODEFN - [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 6-Aug-2021 16:05 by rmk:") + [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 6-Aug-2021 16:05 by rmk:") - (* ;; - "Do not do UNICODE to XCCS translation if RAW. Test for SMALLPin case of funky EOF behavior") + (* ;; + "Do not do UNICODE to XCCS translation if RAW. Test for SMALLPin case of funky EOF behavior") (DECLARE (USEDFREE *BYTECOUNTER*)) (LET (CODE BYTE1 BYTE2 COUNT) @@ -264,14 +347,37 @@ CODE ELSE (ERROR "ODD NUMBER OF BYTES IN UTF16 FILE" STREAM]) -(UTF16BE.PEEKCCODEFN [LAMBDA (STREAM NOERROR RAW) (* ; "Edited 14-Jun-2021 22:58 by rmk:") (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.") (* ;; "Do not do UNICODE to XCCS translation if RAW") (LET (BYTE1 BYTE2 CODE) (SETQ BYTE1 (\PEEKBIN STREAM NOERROR)) (IF BYTE1 THEN (\BIN STREAM) (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (IF BYTE2 THEN (SETQ CODE (LOGOR (LLSH BYTE1 8) BYTE2)) (CL:IF RAW CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*)) ELSEIF NOERROR THEN NIL) ELSEIF NOERROR THEN NIL ELSE (ERROR "INVALID UTF16 CHARACTER" (LIST BYTE1 BYTE2]) +(UTF16BE.PEEKCCODEFN + [LAMBDA (STREAM NOERROR RAW) (* ; "Edited 14-Jun-2021 22:58 by rmk:") + + (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.") + + (* ;; "Do not do UNICODE to XCCS translation if RAW") + + (LET (BYTE1 BYTE2 CODE) + (SETQ BYTE1 (\PEEKBIN STREAM NOERROR)) + (IF BYTE1 + THEN (\BIN STREAM) + (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) + (\BACKFILEPTR STREAM) + (IF BYTE2 + THEN (SETQ CODE (LOGOR (LLSH BYTE1 8) + BYTE2)) + (CL:IF RAW + CODE + (UNICODE.TRANSLATE CODE *UNICODETOXCCS*)) + ELSEIF NOERROR + THEN NIL) + ELSEIF NOERROR + THEN NIL + ELSE (ERROR "INVALID UTF16 CHARACTER" (LIST BYTE1 BYTE2]) (\UTF16.BACKCCODEFN - [LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:07 by rmk:") + [LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:07 by rmk:") - (* ;; "\BACKFILEPTR is NIL at beginning of FILE, do nothing.") + (* ;; "\BACKFILEPTR is NIL at beginning of FILE, do nothing.") - (* ;; "Common for big-ending and little-ending") + (* ;; "Common for big-ending and little-ending") (DECLARE (USEDFREE *BYTECOUNTER*)) (CL:WHEN (\BACKFILEPTR STREAM) @@ -285,11 +391,11 @@ (DEFINEQ (MAKE-UNICODE-FORMATS - [LAMBDA (EXTERNALEOL) (* ; "Edited 6-Aug-2021 16:08 by rmk:") + [LAMBDA (EXTERNALEOL) (* ; "Edited 6-Aug-2021 16:08 by rmk:") - (* ;; "RAW formats do not do XCCS/Unicode translation, just deal with the byte encoding.") + (* ;; "RAW formats do not do XCCS/Unicode translation, just deal with the byte encoding.") - (* ;; "The EXTERNALEOL specifies the EOLCONVENTION of the stream, particularly to produce output files with the desired convention. On input the macro \CHECKEOLC (LLREAD) coerces only that coding to the internal EOL, which is a mistake.") + (* ;; "The EXTERNALEOL specifies the EOLCONVENTION of the stream, particularly to produce output files with the desired convention. On input the macro \CHECKEOLC (LLREAD) coerces only that coding to the internal EOL, which is a mistake.") (MAKE-EXTERNALFORMAT :UTF-8 (FUNCTION UTF8.INCCODEFN) (FUNCTION UTF8.PEEKCCODEFN) @@ -325,11 +431,11 @@ (DEFINEQ (UNICODE.UNMAPPED - [LAMBDA (CODE TRANSLATION-TABLE) (* ; "Edited 11-Aug-2020 20:23 by rmk:") + [LAMBDA (CODE TRANSLATION-TABLE) (* ; "Edited 11-Aug-2020 20:23 by rmk:") - (* ;; "This is the slow fall-out when UNICODE.TRANSLATE determines that CODED has no fast mapping in TRANSLATION-TABLE.") + (* ;; "This is the slow fall-out when UNICODE.TRANSLATE determines that CODED has no fast mapping in TRANSLATION-TABLE.") - (* ;; "We return an existing entry in the hash array of the table. If CODE has not previously been seen, we allocate a new code in the forward unmapped hasharray and put the inverse in the backward array.") + (* ;; "We return an existing entry in the hash array of the table. If CODE has not previously been seen, we allocate a new code in the forward unmapped hasharray and put the inverse in the backward array.") (LET ((FORWARD (CL:SVREF TRANSLATION-TABLE N-TRANSLATION-SEGMENTS)) INVERSE NEXTCODE) @@ -349,9 +455,9 @@ (DEFINEQ (XCCS-UTF8-AFTER-OPEN - [LAMBDA (STREAM ACCESS PARAMETERS) (* ; "Edited 13-Aug-2020 11:54 by rmk:") + [LAMBDA (STREAM ACCESS PARAMETERS) (* ; "Edited 13-Aug-2020 11:54 by rmk:") - (* ;; "If added to STREAM-AFTER-OPEN-FNS, causes mapping files to be opened as UTF8.") + (* ;; "If added to STREAM-AFTER-OPEN-FNS, causes mapping files to be opened as UTF8.") (CL:WHEN (AND (STRPOS "XCCS-" (U-CASE (FULLNAME STREAM))) [EQ 'TXT (U-CASE (FILENAMEFIELD (FULLNAME STREAM) @@ -379,11 +485,11 @@ (DEFINEQ (XTOUCODE - [LAMBDA (XCCSCODE) (* ; "Edited 9-Aug-2020 09:04 by rmk:") + [LAMBDA (XCCSCODE) (* ; "Edited 9-Aug-2020 09:04 by rmk:") (UNICODE.TRANSLATE XCCSCODE *XCCSTOUNICODE*]) (UTOXCODE - [LAMBDA (UNICODE) (* ; "Edited 9-Aug-2020 09:04 by rmk:") + [LAMBDA (UNICODE) (* ; "Edited 9-Aug-2020 09:04 by rmk:") (UNICODE.TRANSLATE UNICODE *UNICODETOXCCS*]) ) @@ -394,9 +500,8 @@ (DEFINEQ (READ-UNICODE-MAPPING-FILENAMES - [LAMBDA (FILESPEC) (* ; "Edited 5-Aug-2020 15:59 by kaplan") - (* ; - "Edited 4-Aug-2020 17:31 by rmk:") + [LAMBDA (FILESPEC) (* ; "Edited 5-Aug-2020 15:59 by kaplan") + (* ; "Edited 4-Aug-2020 17:31 by rmk:") (FOR F X CSI INSIDE FILESPEC COLLECT (IF (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT) T UNICODEDIRECTORIES) @@ -412,24 +517,24 @@ ELSE F]) (READ-UNICODE-MAPPING - [LAMBDA (FILESPEC NOPRINT NOERROR) (* ; "Edited 3-Jul-2021 13:37 by rmk:") + [LAMBDA (FILESPEC NOPRINT NOERROR) (* ; "Edited 3-Jul-2021 13:37 by rmk:") - (* ;; "Combines the char-mapping tables from FILES coded in the Uncode-CDROM format. Comments prefixed by # and") + (* ;; "Combines the char-mapping tables from FILES coded in the Uncode-CDROM format. Comments prefixed by # and") - (* ;; " Column 1: Input hex code in the format 0xXXXX") + (* ;; " Column 1: Input hex code in the format 0xXXXX") - (* ;; " Column 2: Corresponding Unicode code-sequence in the format") + (* ;; " Column 2: Corresponding Unicode code-sequence in the format") - (* ;; " 0xXXXX ... 0xYYYY") + (* ;; " 0xXXXX ... 0xYYYY") - (* ;; - " Column 3: (after #) Character name in some mapping files, utf-8 character") + (* ;; + " Column 3: (after #) Character name in some mapping files, utf-8 character") - (* ;; " for XCCS mapping files") + (* ;; " for XCCS mapping files") - (* ;; "") + (* ;; "") - (* ;; "Result is a list of (fromcode tocode1 ... tocoden) integer lists (almost always with only a single tocode") + (* ;; "Result is a list of (fromcode tocode1 ... tocoden) integer lists (almost always with only a single tocode") (FOR FILE [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] IN (  READ-UNICODE-MAPPING-FILENAMES @@ -461,18 +566,18 @@ (NTHCHARCODE LINE START]) (WRITE-UNICODE-MAPPING - [LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK) (* ; "Edited 16-Aug-2020 16:56 by rmk:") + [LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK) (* ; "Edited 16-Aug-2020 16:56 by rmk:") - (* ;; "Writes a symbol unicode mapping file. Mapping is a list of (XCCS-code Unicode) pairs, which may contain codes in multiple character sets.") + (* ;; "Writes a symbol unicode mapping file. Mapping is a list of (XCCS-code Unicode) pairs, which may contain codes in multiple character sets.") - (* ;; "If FILE is NIL, it defaults to a name XCCS- followed by the octal character sets in the mapping, in the unicode/XEROX directory.") + (* ;; "If FILE is NIL, it defaults to a name XCCS- followed by the octal character sets in the mapping, in the unicode/XEROX directory.") - (* ;; "The output lines are of the form x0XXXx0UUUU# Unicode-char") + (* ;; "The output lines are of the form x0XXXx0UUUU# Unicode-char") - (* ;; - "If INCLUDECHARSETS=T then the mappings are split up into separate per-character set files.") + (* ;; + "If INCLUDECHARSETS=T then the mappings are split up into separate per-character set files.") - (* ;; "Otherwise, all and only mappings included in thos charsets are included in a single output file--an implicit subset.") + (* ;; "Otherwise, all and only mappings included in thos charsets are included in a single output file--an implicit subset.") (IF (AND (EQ INCLUDECHARSETS T) (NULL FILE)) @@ -513,15 +618,15 @@ " # " (SELECTC FIRSTRIGHTC (UNDEFINEDCODE - (* ;; "FFFF") + (* ;; "FFFF") "UNDEFINED") (MISSINGCODE - (* ;; "FFFE") + (* ;; "FFFE") "MISSING") (IF (ILESSP FIRSTRIGHTC 32) - THEN (* ; "Control chars") + THEN (* ; "Control chars") [CONCAT "^" (CHARACTER (IPLUS FIRSTRIGHTC (CHARCODE @] ELSE (CHARACTER FIRSTRIGHTC))) @@ -535,13 +640,13 @@ NIL]) (WRITE-UNICODE-INCLUDED - [LAMBDA (MAPPING INCLUDECHARSETS) (* ; "Edited 4-Aug-2020 17:47 by rmk:") + [LAMBDA (MAPPING INCLUDECHARSETS) (* ; "Edited 4-Aug-2020 17:47 by rmk:") - (* ;; "CSETINFO is a list of (num string name) for each included character set.") + (* ;; "CSETINFO is a list of (num string name) for each included character set.") (LET (CHARSETS CSETINFO RANGES ICSETS IMAPPING) - (* ;; "Normalize the INCLUDECHARSETS, then reduce MAPPING to the included mappings") + (* ;; "Normalize the INCLUDECHARSETS, then reduce MAPPING to the included mappings") [SETQ ICSETS (FOR C POS KNOWN INSIDE (OR INCLUDECHARSETS (FOR CSI IN XCCS-SET-NAMES @@ -569,13 +674,13 @@ ICSETS)) COLLECT - (* ;; "The attested subset of INCLUDED") + (* ;; "The attested subset of INCLUDED") (CL:UNLESS (MEMB CSI CSETINFO) (PUSH CSETINFO CSI)) M)) - (* ;; "Sort as numbers, not octal strings, then group into consecutive ranges") + (* ;; "Sort as numbers, not octal strings, then group into consecutive ranges") (SETQ CSETINFO (SORT CSETINFO T)) [SETQ RANGES (FOR CTAIL C START END ON (FOR CSI IN CSETINFO @@ -587,7 +692,7 @@ COLLECT (SETQ CTAIL (CDR CTAIL)) (SETQ END (CAR CTAIL] - (* ;; "Split out groups of less than 3. But if a range exhaustively covers a known subset (like JIS), replace by the name") + (* ;; "Split out groups of less than 3. But if a range exhaustively covers a known subset (like JIS), replace by the name") [SETQ RANGES (FOR R STR KNOWN LAST IN RANGES JOIN (SETQ LAST (CAR (LAST R))) @@ -607,9 +712,9 @@ (CL:VALUES IMAPPING CSETINFO RANGES]) (WRITE-UNICODE-MAPPING-HEADER - [LAMBDA (STREAM CSETINFO RANGES) (* ; "Edited 4-Aug-2020 17:38 by rmk:") + [LAMBDA (STREAM CSETINFO RANGES) (* ; "Edited 4-Aug-2020 17:38 by rmk:") - (* ;; "Writes the standard per-file header information") + (* ;; "Writes the standard per-file header information") (FOR LINE IN UNICODE-MAPPING-HEADER DO (PRINTOUT STREAM "#" 2) @@ -620,7 +725,7 @@ THEN (PRINTOUT STREAM "s:" -4) (FOR R IN RANGES DO (PRINTOUT STREAM R " ")) (TERPRI STREAM) - ELSE (* ; "Singleton") + ELSE (* ; "Singleton") (PRINTOUT STREAM ": " -4 (CADAR CSETINFO) " " (CADDAR CSETINFO))) @@ -632,7 +737,7 @@ (TERPRI STREAM]) (WRITE-UNICODE-MAPPING-FILENAME - [LAMBDA (FILE CSETINFO RANGES) (* ; "Edited 4-Aug-2020 19:34 by rmk:") + [LAMBDA (FILE CSETINFO RANGES) (* ; "Edited 4-Aug-2020 19:34 by rmk:") (PACKFILENAME 'BODY [OR FILE (CONCATLIST (CONS 'XCCS- (IF (CDR CSETINFO) THEN (FOR RTAIL R ON RANGES @@ -736,53 +841,53 @@ (DEFINEQ (MAKE-UNICODE-TRANSLATION-TABLES - [LAMBDA (MAPPING LTORVAR RTOLVAR) (* ; "Edited 21-Aug-2021 13:12 by rmk:") - (* ; "Edited 17-Aug-2020 08:46 by rmk:") + [LAMBDA (MAPPING LTORVAR RTOLVAR) (* ; "Edited 21-Aug-2021 13:12 by rmk:") + (* ; "Edited 17-Aug-2020 08:46 by rmk:") - (* ;; "MAPPING is the list of numeric code correspondence pairs constructed by applying READ-UNICODE-MAPPING to a Unicode mapping file.") + (* ;; "MAPPING is the list of numeric code correspondence pairs constructed by applying READ-UNICODE-MAPPING to a Unicode mapping file.") - (* ;; "This produces two recoding arrays, one maps left-side codes into right-side codes (e.g. XCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. XCCS).") + (* ;; "This produces two recoding arrays, one maps left-side codes into right-side codes (e.g. XCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. XCCS).") - (* ;; "") + (* ;; "") - (* ;; "We assume that the left-to-right mapping into Unicode is functional, so that each left code maps to a unique right (Unicode) code, because Unicode is presumably the most refined coding scheme. But several Unicode codes may map to the same left code, for logically different codes that happen to have the same glyphs. In that case the heuristic is to map each %"from%" code to the lowest of the possible %"to%" codes. This means that round-trip reading/writing or writing/reading from one or both starting points may not always be lossless.") + (* ;; "We assume that the left-to-right mapping into Unicode is functional, so that each left code maps to a unique right (Unicode) code, because Unicode is presumably the most refined coding scheme. But several Unicode codes may map to the same left code, for logically different codes that happen to have the same glyphs. In that case the heuristic is to map each %"from%" code to the lowest of the possible %"to%" codes. This means that round-trip reading/writing or writing/reading from one or both starting points may not always be lossless.") - (* ;; " ") + (* ;; " ") - (* ;; " Each recoding array has 256 elements, one for each possible high-order byte of a character code. An array entry is either NIL, a 256-array of codes indexed by low-order bytes, or an alist of (lower-order-bytes . codes). The latter is used to save space for sparsely populated character sets.") + (* ;; " Each recoding array has 256 elements, one for each possible high-order byte of a character code. An array entry is either NIL, a 256-array of codes indexed by low-order bytes, or an alist of (lower-order-bytes . codes). The latter is used to save space for sparsely populated character sets.") - (* ;; "") + (* ;; "") - (* ;; "The element 256 of each array contains a hash table for characters that might be encountered in XCCS memory or Unicode files for which there is no mapping. Element 257 contains the corresponding inverse unmapped hash-array, so that UNICODE.TRANSLATE can update them consistently.") + (* ;; "The element 256 of each array contains a hash table for characters that might be encountered in XCCS memory or Unicode files for which there is no mapping. Element 257 contains the corresponding inverse unmapped hash-array, so that UNICODE.TRANSLATE can update them consistently.") - (* ;; "") + (* ;; "") - (* ;; "UNICODE.TRANSLATE assigns an unmapped Unicode character to a %"not used%" XCCS code position (from 5,0 to 40,FF, leaving other low not-used sets for other internal uses (TEDIT?).") + (* ;; "UNICODE.TRANSLATE assigns an unmapped Unicode character to a %"not used%" XCCS code position (from 5,0 to 40,FF, leaving other low not-used sets for other internal uses (TEDIT?).") - (* ;; "") + (* ;; "") - (* ;; - "An unmapped XCCS character is assigned a code in the %"private use%" code blocks 0xE000-F8FF") + (* ;; + "An unmapped XCCS character is assigned a code in the %"private use%" code blocks 0xE000-F8FF") - (* ;; "") + (* ;; "") - (* ;; "For the convenience of not having to deal with the multiple values, if LTORVAR or RTOLVAR are given, they are set to the constructed arrays before return.") + (* ;; "For the convenience of not having to deal with the multiple values, if LTORVAR or RTOLVAR are given, they are set to the constructed arrays before return.") - (* ;; "") + (* ;; "") (LET ((LTORARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS) :INITIAL-ELEMENT NIL)) (RTOLARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS) :INITIAL-ELEMENT NIL))) - (* ;; "The left-to-right direction (into Unicode). We start by distributing the mappings into alists in arrays indexed by the higher-order (charaset set byte). The second loop converts long alists into arrays.") + (* ;; "The left-to-right direction (into Unicode). We start by distributing the mappings into alists in arrays indexed by the higher-order (charaset set byte). The second loop converts long alists into arrays.") [FOR M LEFTC RBASE RCODES IN MAPPING EACHTIME (SETQ RCODES (CDR M)) (SETQ RBASE (CAR RCODES)) UNLESS (IGEQ RBASE MISSINGCODE) DO (SETQ LEFTC (CAR M)) - (* ;; - "(CDR RCODES) contains combiners on the base") + (* ;; + "(CDR RCODES) contains combiners on the base") (CL:PUSH (CONS (LOGAND LEFTC TRANSLATION-MASK) (CL:IF (CDR RCODES) @@ -796,7 +901,7 @@ MAX-ALIST-LENGTH) DO - (* ;; "Leave it alone if the alist is short") + (* ;; "Leave it alone if the alist is short") (SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL)) (FOR P IN (CL:SVREF LTORARRAY I) @@ -806,17 +911,17 @@ (CL:SETF (CL:SVREF LTORARRAY I) CSA)) - (* ;; "") + (* ;; "") - (* ;; "Now the right-to-left direction (from Unicode). Here we have to detect and compensate for ambiguity.") + (* ;; "Now the right-to-left direction (from Unicode). Here we have to detect and compensate for ambiguity.") (FOR M LEFTC RBASE RCOMBINERS PREV IN MAPPING EACHTIME (SETQ RBASE (CADR M)) (SETQ RCOMBINERS (CDDR M)) UNLESS (OR (IGEQ RBASE MISSINGCODE) RCOMBINERS) DO - (* ;; - "Have we already seen an explicit mapping from right to left?") + (* ;; + "Have we already seen an explicit mapping from right to left?") (SETQ LEFTC (CAR M)) [SETQ PREV (ASSOC (LOGAND RBASE TRANSLATION-MASK) @@ -838,7 +943,7 @@ MAX-ALIST-LENGTH) DO - (* ;; "Long list, make an array") + (* ;; "Long list, make an array") (SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL)) (FOR P IN (CL:SVREF RTOLARRAY I) @@ -848,9 +953,9 @@ (CL:SETF (CL:SVREF RTOLARRAY I) CSA)) - (* ;; "") + (* ;; "") - (* ;; "Allocate the hash arrays for future out-of-map codes. We we have to keep track of the next available and last possible codes, as well as the first available, for error checking.") + (* ;; "Allocate the hash arrays for future out-of-map codes. We we have to keep track of the next available and last possible codes, as well as the first available, for error checking.") (CL:SETF (CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS) (LIST (HASHARRAY 10) @@ -863,14 +968,14 @@ (CHARCODE.DECODE "U+F8FF") (CHARCODE.DECODE "U+E000"))) - (* ;; "Now put in the inverse unmapped hash arrays") + (* ;; "Now put in the inverse unmapped hash arrays") (CL:SETF (CL:SVREF LTORARRAY (ADD1 N-TRANSLATION-SEGMENTS)) (CL:SVREF RTOLARRAY N-TRANSLATION-SEGMENTS)) (CL:SETF (CL:SVREF RTOLARRAY (ADD1 N-TRANSLATION-SEGMENTS)) (CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS)) - (* ;; "") + (* ;; "") (CL:WHEN LTORVAR (SETATOMVAL LTORVAR LTORARRAY)) (CL:WHEN RTOLVAR (SETATOMVAL RTOLVAR RTOLARRAY)) @@ -892,11 +997,11 @@ (DEFINEQ (HEXSTRING - [LAMBDA (N WIDTH) (* ; "Edited 23-Jul-2020 08:28 by rmk:") - (* ; "Edited 20-Dec-93 17:51 by rmk:") + [LAMBDA (N WIDTH) (* ; "Edited 23-Jul-2020 08:28 by rmk:") + (* ; "Edited 20-Dec-93 17:51 by rmk:") - (* ;; - "Converts positive numbers to Hex strings, padding on the right with 0 up to WIDTH if given.") + (* ;; + "Converts positive numbers to Hex strings, padding on the right with 0 up to WIDTH if given.") (CL:UNLESS (FIXP N) (SETQ N (CHARCODE.DECODE N))) @@ -915,21 +1020,21 @@ STR]) (UTF8HEXSTRING - [LAMBDA (CHARCODE) (* ; "Edited 10-Aug-2020 08:33 by rmk:") + [LAMBDA (CHARCODE) (* ; "Edited 10-Aug-2020 08:33 by rmk:") - (* ;; "Utility to produces the UTF8 hexstring representing CODE") + (* ;; "Utility to produces the UTF8 hexstring representing CODE") (HEXSTRING (IF (ILESSP CHARCODE 128) THEN CHARCODE ELSEIF (ILESSP CHARCODE 2048) - THEN (* ; "x800") + THEN (* ; "x800") (LOGOR (LLSH (LOGOR (LLSH 3 6) (LRSH CHARCODE 6)) 8) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) - THEN (* ; "x10000") + THEN (* ; "x10000") (LOGOR (LLSH (LOGOR (LLSH 7 5) (LRSH CHARCODE 12)) 16) @@ -939,7 +1044,7 @@ (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) - THEN (* ; "x200000") + THEN (* ; "x200000") (LOGOR (LLSH (LOGOR (LLSH 15 4) (LRSH CHARCODE 18)) 24) @@ -954,27 +1059,27 @@ ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (NUTF8CODEBYTES - [LAMBDA (N) (* ; "Edited 10-Aug-2020 12:35 by rmk:") + [LAMBDA (N) (* ; "Edited 10-Aug-2020 12:35 by rmk:") - (* ;; "Returns the number of bytes needed to encode N in UTF8, ") + (* ;; "Returns the number of bytes needed to encode N in UTF8, ") (IF (ILESSP N 128) THEN 1 ELSEIF (ILESSP N 2048) - THEN (* ; "x800") + THEN (* ; "x800") 4 ELSEIF (ILESSP N 65536) - THEN (* ; "x10000") + THEN (* ; "x10000") 3 ELSEIF (ILESSP N 2097152) - THEN (* ; "x200000") + THEN (* ; "x200000") 2 ELSE (SHOULDNT]) (NUTF8STRINGBYTES - [LAMBDA (STRING RAWFLG) (* ; "Edited 10-Aug-2020 09:06 by rmk:") + [LAMBDA (STRING RAWFLG) (* ; "Edited 10-Aug-2020 09:06 by rmk:") - (* ;; "Returns the number of bytes it would take to represent STRING in UTF8, assuming it is an XCCS string unless RAWFLG. ") + (* ;; "Returns the number of bytes it would take to represent STRING in UTF8, assuming it is an XCCS string unless RAWFLG. ") (FOR I C FROM 1 WHILE (SETQ C (NTHCHARCODE STRING I)) SUM (NUTF8CODEBYTES (CL:IF RAWFLG @@ -982,11 +1087,11 @@ (XTOUCODE C))]) (XTOUSTRING - [LAMBDA (XCCSSTRING RAWFLG) (* ; "Edited 10-Aug-2020 21:42 by rmk:") + [LAMBDA (XCCSSTRING RAWFLG) (* ; "Edited 10-Aug-2020 21:42 by rmk:") - (* ;; "Produces a string that contains the UTF8 bytes that represent the characters in XCCSSTRING. Applies the XCCSTOUNICODE translation unless RAWFLG. ") + (* ;; "Produces a string that contains the UTF8 bytes that represent the characters in XCCSSTRING. Applies the XCCSTOUNICODE translation unless RAWFLG. ") - (* ;; "The resulting string will not be readable inside Medley.") + (* ;; "The resulting string will not be readable inside Medley.") (LET [(USTR (ALLOCSTRING (NUTF8STRINGBYTES XCCSSTRING RAWFLG] (FOR I CHARCODE (SINDEX _ 0) FROM 1 WHILE (SETQ CHARCODE (NTHCHARCODE XCCSSTRING @@ -997,7 +1102,7 @@ THEN (RPLCHARCODE USTR (ADD SINDEX 1) CHARCODE) ELSEIF (ILESSP CHARCODE 2048) - THEN (* ; "x800") + THEN (* ; "x800") (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) @@ -1005,7 +1110,7 @@ (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) - THEN (* ; "x10000") + THEN (* ; "x10000") (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) @@ -1016,7 +1121,7 @@ (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) - THEN (* ; "x200000") + THEN (* ; "x200000") (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) @@ -1033,9 +1138,9 @@ USTR]) (XCCSSTRING - [LAMBDA (CODE) (* ; "Edited 13-Aug-2020 12:16 by rmk:") + [LAMBDA (CODE) (* ; "Edited 13-Aug-2020 12:16 by rmk:") - (* ;; "Returns XCCS character representation of string %"cset,char%"") + (* ;; "Returns XCCS character representation of string %"cset,char%"") (CL:UNLESS (FIXP CODE) (SETQ CODE (CHCON1 CODE))) @@ -1046,14 +1151,14 @@ (DEFINEQ (SHOWCHARS - [LAMBDA (FROMCHAR TOCHAR FONT) (* ; "Edited 1-Aug-2020 09:27 by rmk:") + [LAMBDA (FROMCHAR TOCHAR FONT) (* ; "Edited 1-Aug-2020 09:27 by rmk:") (RESETFORM (DSPFONT (OR FONT '(CLASSIC 12)) T) (CL:WHEN (AND (SMALLP FROMCHAR) (NOT TOCHAR)) - (* ;; - "If a small number, assume it's an octal (in decimal) character set, no need for string quotes") + (* ;; + "If a small number, assume it's an octal (in decimal) character set, no need for string quotes") (SETQ TOCHAR (CONCAT FROMCHAR "," 376)) (SETQ FROMCHAR (CONCAT FROMCHAR "," 41))) @@ -1100,15 +1205,15 @@ ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4105 17785 (UTF8.OUTCHARFN 4115 . 6946) (UTF8.INCCODEFN 6948 . 12438) (UTF8.PEEKCCODEFN - 12440 . 17214) (\UTF8.BACKCCODEFN 17216 . 17783)) (17786 21112 (UTF16BE.OUTCHARFN 17796 . 18620) ( -UTF16BE.INCCODEFN 18622 . 19521) (UTF16BE.PEEKCCODEFN 19523 . 20594) (\UTF16.BACKCCODEFN 20596 . 21110 -)) (21142 22950 (MAKE-UNICODE-FORMATS 21152 . 22948)) (23047 24353 (UNICODE.UNMAPPED 23057 . 24351)) ( -24354 24890 (XCCS-UTF8-AFTER-OPEN 24364 . 24888)) (25960 26309 (XTOUCODE 25970 . 26138) (UTOXCODE -26140 . 26307)) (26349 42532 (READ-UNICODE-MAPPING-FILENAMES 26359 . 27521) (READ-UNICODE-MAPPING -27523 . 30821) (WRITE-UNICODE-MAPPING 30823 . 35040) (WRITE-UNICODE-INCLUDED 35042 . 39764) ( -WRITE-UNICODE-MAPPING-HEADER 39766 . 40998) (WRITE-UNICODE-MAPPING-FILENAME 41000 . 42530)) (45869 -54348 (MAKE-UNICODE-TRANSLATION-TABLES 45879 . 54346)) (54769 62673 (HEXSTRING 54779 . 55940) ( -UTF8HEXSTRING 55942 . 58147) (NUTF8CODEBYTES 58149 . 58812) (NUTF8STRINGBYTES 58814 . 59295) ( -XTOUSTRING 59297 . 62308) (XCCSSTRING 62310 . 62671)) (62674 64143 (SHOWCHARS 62684 . 64141))))) + (FILEMAP (NIL (4046 17726 (UTF8.OUTCHARFN 4056 . 6887) (UTF8.INCCODEFN 6889 . 12379) (UTF8.PEEKCCODEFN + 12381 . 17155) (\UTF8.BACKCCODEFN 17157 . 17724)) (17727 21053 (UTF16BE.OUTCHARFN 17737 . 18561) ( +UTF16BE.INCCODEFN 18563 . 19462) (UTF16BE.PEEKCCODEFN 19464 . 20535) (\UTF16.BACKCCODEFN 20537 . 21051 +)) (21083 22891 (MAKE-UNICODE-FORMATS 21093 . 22889)) (22988 24294 (UNICODE.UNMAPPED 22998 . 24292)) ( +24295 24831 (XCCS-UTF8-AFTER-OPEN 24305 . 24829)) (25901 26250 (XTOUCODE 25911 . 26079) (UTOXCODE +26081 . 26248)) (26290 42412 (READ-UNICODE-MAPPING-FILENAMES 26300 . 27401) (READ-UNICODE-MAPPING +27403 . 30701) (WRITE-UNICODE-MAPPING 30703 . 34920) (WRITE-UNICODE-INCLUDED 34922 . 39644) ( +WRITE-UNICODE-MAPPING-HEADER 39646 . 40878) (WRITE-UNICODE-MAPPING-FILENAME 40880 . 42410)) (45749 +54228 (MAKE-UNICODE-TRANSLATION-TABLES 45759 . 54226)) (54649 62553 (HEXSTRING 54659 . 55820) ( +UTF8HEXSTRING 55822 . 58027) (NUTF8CODEBYTES 58029 . 58692) (NUTF8STRINGBYTES 58694 . 59175) ( +XTOUSTRING 59177 . 62188) (XCCSSTRING 62190 . 62551)) (62554 64023 (SHOWCHARS 62564 . 64021))))) STOP diff --git a/library/UNICODE.LCOM b/library/UNICODE.LCOM index 4f7ba73a53b26e7f54ec06fe870b041e5fb61315..1204a0dd15a7f20592320a82492d9ce4ef4b25b7 100644 GIT binary patch delta 243 zcmdnAmhtHt#tC5}#s<2=IP_=9OUX4;_9NHWNaXUuo>biLklH^$pTD{dL~>7W+vtq#tH>Rsb!h@ mrNv;Aflg2|GSqb}O^15L*vin@%D`kYFOv(S@#Y|=gb)C30zVJ{ delta 264 zcmaF5hH=wc#tC5}MuxhMrRlmx21bSohQ?MvWMDEeE5y)PQ$fkl5=qX;%D~*p$V5pY zsVFr$Ker$=CpCpjAvq&4FFmzb)kLPajw3AXmo_R~MinEN+_Y&*&^|%%xyvVrgIuvsR%bA850N wn_n=