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


(FILECREATED "23-Feb-2024 22:24:01" {WMEDLEY}<library>lafite>LAFITE-FOLDERS.;2
 44255  

      :EDIT-BY rmk

      :CHANGES-TO (VARS LAFITE-FOLDERSCOMS)

      :PREVIOUS-DATE "23-Feb-2024 22:01:00" {WMEDLEY}<library>lafite>LAFITE-FOLDERS.;1)


(PRETTYCOMPRINT LAFITE-FOLDERSCOMS)

(RPAQQ LAFITE-FOLDERSCOMS

       [
        (* ;; "Maintenance of Lafite's folder structures, menus etc.")


        [COMS                                                (* ; "The profile")

              (FNS \LAFITE.READ.PROFILE \LAFITE.PROCESS.PROFILE \LAFITE.WRITE.PROFILE 
                   \LAFITE.MERGE.NAMELISTS \LAFITE.READ.OLD.PROFILE \LAFITE.MERGE.FOLDERS 
                   \LAFITE.MERGE.STRUCTURES \LAFITE.REPACK.FOLDERS)
              (INITVARS (\LAFITEPROFILECHANGED)
                     (LAFITEMAILFOLDERS)
                     (\LAFITEPROFILEDATE))
              (ADDVARS (LAFITE.PROFILE.VARS (*LA.ABBREVS.IN.PROFILE*)
                              (LAFITEMAILFOLDERS \LAFITE.MERGE.FOLDERS)
                              (LAFITEFORMFILES \LAFITE.MERGE.NAMELISTS)
                              (LAFITE.FOLDER.STRUCTURE \LAFITE.MERGE.STRUCTURES]
        (COMS                                                (* ; "Prompting for folders")

              (FNS \LAFITE.PROMPTFORFOLDER PROMPTFORFILENAME MAKELAFITEMAILFOLDERSMENU 
                   MAKELAFITEFOLDERSMENUITEMS LAFITE.GROUP.ITEM \LAFITE.ARRANGE.MENU 
                   \LAFITE.MAKE.FOLDER.MENU LAFITE.SELECT.FOLDERS LAFITE.SELECT.MULTIPLE 
                   \LAFITE.HANDLE.MULTIPLE.SELECTION COLLECT.SHADED.ITEMS)
              (INITVARS (LAFITE.2COLUMN.MENU.MIN.ITEMS 10)
                     (LAFITEFOLDERSMENU)
                     (LAFITEMULTIPLEFOLDERSMENU))
              (ADDVARS (LAFITEMENUVARS LAFITEFOLDERSMENU LAFITEMULTIPLEFOLDERSMENU)))
        (COMS                                                (* ; "Name hacking")

              (FNS LA.LONGFILENAME LA.SHORTFILENAME FORGETMAILFILE \LAFITE.FOLDER.NAME.CHANGED 
                   \LAFITE.CHANGE.NAME.IN.LIST \LAFITE.RECOMPUTE.FOLDER.NAMES \LAFITE.NEW.SHORT.NAME
                   \LAFITE.NOTICE.FILE \LAFITE.UNCACHE.FOLDER)
              (INITVARS LAFITE.HOST.ABBREVS \LAFITE.PSEUDO.DEVICES))
        (COMS                                                (* ; "Hacking the hierarchy")

              (FNS \LAFITE.NOTICE.FOLDERS \LAFITE.GC.FOLDERS \LAFITE.GC.FOLDERS.CONFIRM 
                   \LAFITE.MAKE.RANDOM.DISPLAY \LAFITE.CHANGE.FOLDER.LIST \LAFITE.RENAME.FOLDER 
                   \LAFITE.ADD.NEW.GROUP \LAFITE.CHECK.GROUP.NAME \LAFITE.CHANGE.GROUP.MEMBERS 
                   \LAFITE.SELECT.GROUP.FOLDERS \LAFITE.CHANGE.SUBGROUPS \LAFITE.CHANGE.TOP.GROUPS 
                   \LAFITE.DELETE.GROUP LAFITE.RENAME.GROUP \LAFITE.EDIT.HIERARCHY LAFITE.FIND.GROUP
                   UALPHORDERCAR)
              (VARS LAFITE.SPACER.MENU.ITEM LAFITE.GROUP.COMMANDS (LAFITE.GROUP.COMMANDS.MENU)))
        (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE)
                                                LAFITE-DECLS)
               (LOCALVARS . T)
               (GLOBALVARS MENUFONT LAFITE.GROUP.COMMANDS.MENU LAFITE.GROUP.COMMANDS)
               (P (CL:PROCLAIM '(CL:SPECIAL *LA.ABBREVS.IN.PROFILE*])



(* ;; "Maintenance of Lafite's folder structures, menus etc.")





(* ; "The profile")


(DEFINEQ

(\LAFITE.READ.PROFILE

(LAMBDA (ONLYIFCHANGED) (* ; "Edited  8-May-89 16:20 by bvm") (WITH.MONITOR \LAFITE.PROFILELOCK (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (*LA.ABBREVS.IN.PROFILE* NIL) FILENAME NEWDATE) (SETQ \LAFITEPROFILECHANGED) (if (SETQ FILENAME (INFILEP (LA.LONGFILENAME LAFITEINFO.NAME))) then (COND ((OR (NOT ONLYIFCHANGED) (NULL \LAFITEPROFILEDATE) (NULL (SETQ NEWDATE (GETFILEINFO FILENAME (QUOTE ICREATIONDATE)))) (> NEWDATE \LAFITEPROFILEDATE)) (* ; "read in the profile file") (LET ((STREAM (\LAFITE.OPENSTREAM FILENAME (QUOTE INPUT)))) (CL:UNWIND-PROTECT (PROGN (SETQ \LAFITEPROFILEDATE (GETFILEINFO STREAM (QUOTE ICREATIONDATE))) (\LAFITE.PROCESS.PROFILE STREAM)) (CLOSEF STREAM))))) elseif (AND (NOT ONLYIFCHANGED) (SETQ FILENAME (INFILEP (LA.LONGFILENAME "Lafite.profile")))) then (* ; "Read old-style profile") (\LAFITE.READ.OLD.PROFILE FILENAME)) (if (NULL LAFITEMAILFOLDERS) then (SETQ LAFITEMAILFOLDERS (LIST (fetch PACKEDHOST&DIR of \LAFITEDEFAULTHOST&DIR))) (SETQ LAFITEFORMFILES (SETQ LAFITE.FOLDER.STRUCTURE NIL)) else (if (AND LAFITE.FOLDER.STRUCTURE (LET ((TMP (CADR (CAR LAFITE.FOLDER.STRUCTURE)))) (OR (NLISTP TMP) (NOT (FMEMB (CAR TMP) (QUOTE (T NIL))))))) then (* ; "Old style without the %"top-level%" flag.  Fix up.  Make top-level everything that's without a parent.") (LET (SUBGROUPS) (for GROUP in LAFITE.FOLDER.STRUCTURE do (SETQ SUBGROUPS (APPEND (CADR GROUP) SUBGROUPS)) (RPLACA (CDR GROUP) (CONS NIL (CADR GROUP)))) (for GROUP in LAFITE.FOLDER.STRUCTURE unless (CL:MEMBER (CAR GROUP) SUBGROUPS :TEST (QUOTE STRING-EQUAL)) do (replace FGTOPLEVEL of GROUP with T)))) (if (NOT (AND (STRING-EQUAL (CAR LAFITEMAILFOLDERS) (fetch PACKEDHOST&DIR of \LAFITEDEFAULTHOST&DIR)) (EQUAL *LA.ABBREVS.IN.PROFILE* (CDR \LAFITE.PSEUDO.DEVICES)))) then (* ; "Profile moved?  ") (\LAFITE.RECOMPUTE.FOLDER.NAMES *LA.ABBREVS.IN.PROFILE*)) (if LAFITEFORMFILES then (* ; "Canonicalize them.  Old profiles may have stored long names.  Yuck.") (SETQ LAFITEFORMFILES (CL:REMOVE-DUPLICATES (for NAME in LAFITEFORMFILES collect (LA.SHORTFILENAME NAME LAFITEFORM.EXT)) :TEST (QUOTE STRING-EQUAL))))) (SETQ LAFITEMULTIPLEFOLDERSMENU (SETQ LAFITEFOLDERSMENU (SETQ LAFITEFORMSMENU NIL))))))
)

(\LAFITE.PROCESS.PROFILE

(LAMBDA (STREAM MERGE) (* ; "Edited  9-Sep-87 15:09 by bvm:") (* ;; "Process the profile living on STREAM.  We are positioned at the start and will read to the end.  If MERGE is true, then we are attempting to merge an old profile with the current state; otherwise, we are reading it from scratch.") (LET ((*READTABLE* LAFITEPROFILERDTBL) FORM VARDESC FN) (* ;; "Format is a series of lists (var value).") (while (SETQ FORM (CL:READ STREAM NIL)) do (SETQ VARDESC (ASSOC (CAR FORM) LAFITE.PROFILE.VARS)) (if (NULL VARDESC) then (* ; "Make sure everything we read is on LAFITE.PROFILE.VARS so that it will get dumped back out, too, even if it's a user variable we know nothing about.") (CL:PUSH (SETQ VARDESC (LIST (CAR FORM))) LAFITE.PROFILE.VARS)) (SET (CAR FORM) (if (AND MERGE (SETQ FN (fetch PFRECONCILIATIONFN of VARDESC))) then (* ; "Var says how to reconcile old value with current.  Args are (oldvalue currentvalue varname)") (CL:FUNCALL FN (CADR FORM) (EVALV (CAR FORM)) (CAR FORM)) else (CADR FORM))) (if (SETQ FN (fetch PFLOADFN of VARDESC)) then (* ; "Take arbitrary user action upon loading of this var") (CL:FUNCALL FN (CADR FORM) (CAR FORM))))))
)

(\LAFITE.WRITE.PROFILE

(LAMBDA NIL (* ; "Edited 12-Sep-88 16:04 by bvm") (* ;;; "If 'Profile' has changed, write out a new one.  Profile is set of mail files and form files known to this Lafite, and anything else that has been entered on LAFITE.PROFILE.VARS") (WITH.MONITOR \LAFITE.PROFILELOCK (NLSETQ (COND (\LAFITEPROFILECHANGED (LET ((*UPPER-CASE-FILE-NAMES* NIL) (*LA.ABBREVS.IN.PROFILE* (CDR \LAFITE.PSEUDO.DEVICES)) (NAME (LA.LONGFILENAME LAFITEINFO.NAME)) OLDNAME OLDDATE PFSTREAM OVERWRITING) (* ;; "Before dumping a new profile, check that a newer one hasn't been written behind our back.  This handles two cases -- same user using Lafite from two machines, and file server having been down when we first tried to read profile") (COND ((AND (SETQ OLDNAME (INFILEP NAME)) (SETQ OLDDATE (GETFILEINFO OLDNAME (QUOTE ICREATIONDATE))) (OR (NULL \LAFITEPROFILEDATE) (NOT (= \LAFITEPROFILEDATE OLDDATE)))) (printout PROMPTWINDOW T OLDNAME " has changed since you started this Lafite, rereading it.") (SETQ OVERWRITING (SETQ PFSTREAM (OPENSTREAM OLDNAME (QUOTE BOTH) (QUOTE OLD)))) (\LAFITE.PROCESS.PROFILE PFSTREAM T) (SETFILEPTR PFSTREAM 0)) (T (SETQ PFSTREAM (OPENSTREAM (OR OLDNAME NAME) (QUOTE OUTPUT) (QUOTE OLD/NEW))))) (LINELENGTH MAX.SMALLP PFSTREAM) (for V in LAFITE.PROFILE.VARS do (PRIN2 (LIST (fetch PFVARNAME of V) (CL:FUNCALL (OR (fetch PFDUMPFN of V) (FUNCTION CL:IDENTITY)) (EVALV (fetch PFVARNAME of V)) (fetch PFVARNAME of V))) PFSTREAM LAFITEPROFILERDTBL)) (COND (OVERWRITING (* ; "Truncate old file to current length") (SETFILEINFO PFSTREAM (QUOTE LENGTH) (GETFILEPTR PFSTREAM)))) (FORCEOUTPUT PFSTREAM) (* ; "Do this first to ensure that any change of creation date has happened.") (SETQ \LAFITEPROFILEDATE (GETFILEINFO PFSTREAM (QUOTE ICREATIONDATE))) (CLOSEF PFSTREAM) (SETQ \LAFITEPROFILECHANGED)))))))
)

(\LAFITE.MERGE.NAMELISTS

(LAMBDA (OLDNAMES NEWNAMES) (* ; "Edited 12-Sep-88 16:04 by bvm") (* ;;; "Remove duplicates from the two lists NAMES1 and NAMES2 and merge them") (LET ((DIFFNAMES (CL:SET-DIFFERENCE OLDNAMES NEWNAMES :TEST (FUNCTION STRING-EQUAL)))) (COND ((AND DIFFNAMES (OR (EQUAL *LA.ABBREVS.IN.PROFILE* (CDR \LAFITE.PSEUDO.DEVICES)) (SETQ DIFFNAMES (CL:SET-DIFFERENCE OLDNAMES (for NAME in NEWNAMES collect (* ; "Grumble--abbrevs changed, so have to recompute old list as if with new abbrevs") (LA.SHORTFILENAME (LA.LONGFILENAME NAME NIL NIL *LA.ABBREVS.IN.PROFILE* T))) :TEST (FUNCTION STRING-EQUAL))))) (* ; "Yes, there are some new names") (SORT (APPEND DIFFNAMES NEWNAMES) (FUNCTION UALPHORDER))) (T NEWNAMES))))
)

(\LAFITE.READ.OLD.PROFILE

(LAMBDA (FILE) (* ; "Edited 21-Sep-87 15:16 by bvm:") (* ;; "Read old-style profile, which consisted of the list of folders, then the list of forms.") (LET ((STREAM (\LAFITE.OPENSTREAM FILE (QUOTE INPUT) (QUOTE OLD)))) (CL:UNWIND-PROTECT (PROGN (SETQ LAFITEMAILFOLDERS (MAPCAR (READ STREAM LAFITEPROFILERDTBL) (FUNCTION MKSTRING))) (RPLACD LAFITEMAILFOLDERS (CL:SORT (CDR LAFITEMAILFOLDERS) (FUNCTION UALPHORDER))) (* ; "just in case it wasn't already sorted") (SETQ LAFITEFORMFILES (READ STREAM LAFITEPROFILERDTBL)) (SETQ \LAFITEPROFILECHANGED T)) (CLOSEF STREAM))))
)

(\LAFITE.MERGE.FOLDERS

(LAMBDA (OLDFOLDERS CURRENTFOLDERS) (* ; "Edited  9-Sep-87 16:16 by bvm:") (COND ((STRING-EQUAL (CAR OLDFOLDERS) (CAR CURRENTFOLDERS)) (* ; "same host&dir, ok to merge") (CONS (CAR CURRENTFOLDERS) (\LAFITE.MERGE.NAMELISTS (CDR OLDFOLDERS) (CDR CURRENTFOLDERS)))) (T CURRENTFOLDERS)))
)

(\LAFITE.MERGE.STRUCTURES

(LAMBDA (NEWSTRUCTURE) (* ; "Edited 12-Apr-89 16:57 by bvm") (for GROUP in NEWSTRUCTURE do (RPLACD (CDR GROUP) (CL:INTERSECTION (CDDR GROUP) (CDR LAFITEMAILFOLDERS)))))
)

(\LAFITE.REPACK.FOLDERS

(LAMBDA (NAMES OLDDIR OLDABBREVS) (* ; "Edited 12-Sep-88 15:57 by bvm") (* ;; "Action taken when you load a profile whose internal host&dir is different from the directory where it lives.  Fix up any partially specified names, returning a new list of %"short%" names.  We assume that completely unqualified folder names have been moved along with the profile, but that other names haven't.") (for FILE in NAMES bind FIELDS FIRSTFIELD (OLDFIELDS _ (AND OLDDIR (UNPACKFILENAME.STRING OLDDIR))) collect (SETQ FIELDS (UNPACKFILENAME.STRING FILE)) (if (EQ (SETQ FIRSTFIELD (CAR FIELDS)) (QUOTE NAME)) then (* ; "No host & dir at all, so nothing to change.") FILE else (LA.SHORTFILENAME (LA.LONGFILENAME FIELDS NIL OLDFIELDS OLDABBREVS T)))))
)
)

(RPAQ? \LAFITEPROFILECHANGED
 )

(RPAQ? LAFITEMAILFOLDERS
 )

(RPAQ? \LAFITEPROFILEDATE
 )

(ADDTOVAR LAFITE.PROFILE.VARS
 (*LA.ABBREVS.IN.PROFILE*)
                              (LAFITEMAILFOLDERS \LAFITE.MERGE.FOLDERS)
                              (LAFITEFORMFILES \LAFITE.MERGE.NAMELISTS)
                              (LAFITE.FOLDER.STRUCTURE \LAFITE.MERGE.STRUCTURES))



(* ; "Prompting for folders")


(DEFINEQ

(\LAFITE.PROMPTFORFOLDER

(LAMBDA (WINDOW) (* ; "Edited 20-Jun-88 17:03 by bvm") (* ;; "Prompts for a folder name from the folders menu and returns it.  WINDOW is used if %"Other%" was selected; if NIL, a pop-up window is used.  If a filename was typed manually, second value returned is T.") (LET ((FILE (MENU (OR LAFITEFOLDERSMENU (MAKELAFITEMAILFOLDERSMENU))))) (SELECTQ FILE (NIL NIL) (%##ANOTHERFILE## (if (SETQ FILE (PROMPTFORFILENAME WINDOW \LAFITE.LAST.FOLDER.NAME)) then (SETQ \LAFITE.LAST.FOLDER.NAME FILE) (CL:VALUES FILE T))) FILE)))
)

(PROMPTFORFILENAME

(LAMBDA (WINDOW DEFAULT PROMPT) (* ; "Edited  2-Nov-89 17:56 by bvm") (OR PROMPT (SETQ PROMPT (if DEFAULT then "File name (null name aborts command): " else "File name (CR to abort): "))) (RESETLST (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (RESETSAVE NIL (LIST (COND (WINDOW (FUNCTION CLEARW)) (T (SETQ WINDOW (LET* ((FONT (DEFAULTFONT (QUOTE DISPLAY))) (WIDTH (WIDTHIFWINDOW (+ (STRINGWIDTH PROMPT FONT) (TIMES 50 (CHARWIDTH (CHARCODE A) FONT))))) (HEIGHT (HEIGHTIFWINDOW (FONTPROP FONT (QUOTE HEIGHT))))) (CREATEW (create REGION LEFT _ (MIN LASTMOUSEX (- SCREENWIDTH WIDTH)) BOTTOM _ (MIN LASTMOUSEY (- SCREENHEIGHT HEIGHT)) WIDTH _ WIDTH HEIGHT _ HEIGHT)))) (WINDOWPROP WINDOW (QUOTE PAGEFULLFN) (FUNCTION NILL)) (FUNCTION CLOSEW))) WINDOW)) (TTYINPROMPTFORWORD PROMPT DEFAULT NIL WINDOW NIL NIL (CHARCODE (CR)))))
)

(MAKELAFITEMAILFOLDERSMENU

(LAMBDA NIL (* ; "Edited 12-Apr-89 15:31 by bvm") (SETQ LAFITEFOLDERSMENU (\LAFITE.MAKE.FOLDER.MENU (MAKELAFITEFOLDERSMENUITEMS))))
)

(MAKELAFITEFOLDERSMENUITEMS

(LAMBDA NIL (* ; "Edited 29-Jun-89 10:33 by bvm") (if LAFITE.FOLDER.STRUCTURE then (LET (UNGROUPED.FOLDERS GROUPED.FOLDERS SUBGROUPS GROUP) (for GROUP in LAFITE.FOLDER.STRUCTURE do (SETQ GROUPED.FOLDERS (APPEND (fetch FGFOLDERS of GROUP) GROUPED.FOLDERS)) (SETQ SUBGROUPS (APPEND (fetch FGSUBGROUPS of GROUP) SUBGROUPS))) (SETQ UNGROUPED.FOLDERS (for FOLDER in (CDR LAFITEMAILFOLDERS) collect FOLDER unless (CL:MEMBER FOLDER GROUPED.FOLDERS :TEST (QUOTE STRING-EQUAL)))) (* ; "This is just SET-DIFFERENCE, but writing it this way forces the order to be preserved, so I don't have to SORT again.") (NCONC (for GROUP in LAFITE.FOLDER.STRUCTURE when (OR (fetch FGTOPLEVEL of GROUP) (NOT (CL:MEMBER (fetch FGNAME of GROUP) SUBGROUPS :TEST (QUOTE STRING-EQUAL)))) collect (* ; "Groups that are explicitly top-level or aren't already subgroups of another") (LAFITE.GROUP.ITEM GROUP (LIST (fetch FGNAME of GROUP)))) (LIST LAFITE.SPACER.MENU.ITEM) UNGROUPED.FOLDERS (LIST ANOTHERFOLDERMENUITEM))) else (APPEND (CDR LAFITEMAILFOLDERS) (LIST LAFITE.SPACER.MENU.ITEM ANOTHERFOLDERMENUITEM))))
)

(LAFITE.GROUP.ITEM

(LAMBDA (GROUP SUPERS) (* ; "Edited  8-May-89 15:51 by bvm") (LET ((FOLDERS (fetch FGFOLDERS of GROUP)) (SUBGROUPITEMS (for SUBGROUP in (fetch FGSUBGROUPS of GROUP) unless (CL:MEMBER SUBGROUP SUPERS :TEST (QUOTE STRING-EQUAL)) collect (LAFITE.GROUP.ITEM (LAFITE.FIND.GROUP SUBGROUP) (CONS SUBGROUP SUPERS))))) (BQUOTE ((\, (CAR GROUP)) NIL "Slide out the submenu to choose a folder from this group" (SUBITEMS (\,@ FOLDERS) (\,@ (AND SUBGROUPITEMS FOLDERS (LIST LAFITE.SPACER.MENU.ITEM))) (\,@ SUBGROUPITEMS))))))
)

(\LAFITE.ARRANGE.MENU

(LAMBDA (ITEMS FONT MAXHEIGHT TITLE) (* ; "Edited 21-Jun-89 11:58 by bvm") (* ;; "Returns 2 values: the number of columns it takes to make a menu no taller than MAXHEIGHT containing ITEMS printed in FONT, and a rearrangement of ITEMS to make the menu appear vertical.  We do this manually to get around bugs in the MENU code (viz. that the column width is at least as wide as the menu title).  We also make 2 columns when the title is much wider than the columns would need to be") (OR FONT (SETQ FONT MENUFONT)) (LET* ((ITEMHEIGHT (FONTPROP FONT (QUOTE HEIGHT))) (NITEMS (LENGTH ITEMS)) (TOTALHEIGHT (TIMES NITEMS ITEMHEIGHT))) (if (OR (> TOTALHEIGHT MAXHEIGHT) (AND (> NITEMS LAFITE.2COLUMN.MENU.MIN.ITEMS) (> (TIMES 2 (STRINGWIDTH TITLE WINDOWTITLEFONT)) (TIMES 3 (for I in ITEMS bind (MAXWIDTH _ 0) when (AND (STRINGP (if (LISTP I) then (SETQ I (CAR I)) else I)) (> (SETQ I (STRINGWIDTH I FONT)) MAXWIDTH)) do (SETQ MAXWIDTH I) finally (RETURN MAXWIDTH)))))) then (* ; "1 column would be taller than MAXHEIGHT, or the title is more than 50%% wider than the widest item") (LET ((NCOLUMNS (MAX 2 (CL:CEILING TOTALHEIGHT MAXHEIGHT)))) (CL:VALUES NCOLUMNS (\MAKE.ITEMS.VERT.ORDER ITEMS (CL:CEILING NITEMS NCOLUMNS) NCOLUMNS))) else (CL:VALUES 1 ITEMS))))
)

(\LAFITE.MAKE.FOLDER.MENU

(LAMBDA (ITEMS TITLE) (* ; "Edited 13-Apr-89 15:02 by bvm") (* ;; "Make a folders menu out of ITEMS.") (OR TITLE (SETQ TITLE (CONCAT "Folders on " (L-CASE (fetch PACKEDHOST&DIR \LAFITEDEFAULTHOST&DIR))))) (CL:MULTIPLE-VALUE-BIND (NCOLUMNS ITEMS) (\LAFITE.ARRANGE.MENU ITEMS LAFITE.FOLDER.MENU.FONT (- SCREENHEIGHT (FONTPROP WINDOWTITLEFONT (QUOTE HEIGHT))) TITLE) (create MENU ITEMS _ ITEMS MENUCOLUMNS _ NCOLUMNS TITLE _ TITLE CENTERFLG _ T MENUFONT _ (OR LAFITE.FOLDER.MENU.FONT MENUFONT))))
)

(LAFITE.SELECT.FOLDERS

(LAMBDA (PRESELECTED NILOK) (* ; "Edited  8-May-89 16:43 by bvm") (* ;; "Offer menu of folders, return all folders selected.  If NILOK is true, then return :ABORT if aborted, else just NIL.") (LET ((RESULT (LAFITE.SELECT.MULTIPLE (CDR LAFITEMAILFOLDERS) PRESELECTED NIL NIL (QUOTE LAFITEMULTIPLEFOLDERSMENU)))) (AND (OR NILOK (NEQ RESULT :ABORT)) RESULT)))
)

(LAFITE.SELECT.MULTIPLE

(LAMBDA (ITEMS PRESELECTED TITLE PROMPT MENUVAR) (* ; "Edited  8-May-89 16:41 by bvm") (* ;; "Put up a menu containing ITEMS, with PRESELECTED among them already shaded.  Let user select multiply from the menu, and return a list of the selected items.  MENUVAR optionally caches the menu from last time--you must clear it whenever ITEMS changes.") (LET ((MENUW (AND MENUVAR (EVALV MENUVAR))) MENU OLDSHADED) (if (NULL MENUW) then (SETQ MENU (\LAFITE.MAKE.FOLDER.MENU (APPEND ITEMS (CONS LAFITE.SPACER.MENU.ITEM (QUOTE (("--OK--" :DONE "Click here when selection is satisfactory") ("--Abort--" :ABORT "Click here to abort selection."))))) TITLE)) (replace (MENU MENUTITLEFONT) of MENU with WINDOWTITLEFONT) (replace (MENU WHENSELECTEDFN) of MENU with (FUNCTION \LAFITE.HANDLE.MULTIPLE.SELECTION)) (SETQ MENUW (MENUWINDOW MENU)) (if MENUVAR then (SET MENUVAR MENUW)) else (SETQ OLDSHADED (COLLECT.SHADED.ITEMS (SETQ MENU (CAR (WINDOWPROP MENUW (QUOTE MENU)))))) (if (LISTGET (fetch (MENU MENUUSERDATA) of MENU) (QUOTE RESULT)) then (* ; "Erase any old result") (LISTPUT (fetch (MENU MENUUSERDATA) of MENU) (QUOTE RESULT) NIL))) (if PRESELECTED then (SETQ PRESELECTED (for ITEM in (fetch (MENU ITEMS) of MENU) collect ITEM when (AND (NLISTP ITEM) (CL:MEMBER ITEM PRESELECTED :TEST (QUOTE STRING-EQUAL))))) (for ITEM in PRESELECTED do (SHADEITEM ITEM MENU LAFITEHARDCOPYBATCHSHADE)) (if OLDSHADED then (SETQ OLDSHADED (CL:SET-DIFFERENCE OLDSHADED PRESELECTED :TEST (QUOTE EQ))))) (for ITEM in OLDSHADED do (SHADEITEM ITEM MENU 0)) (CL:UNWIND-PROTECT (LET (RESULT) (ALLOW.BUTTON.EVENTS) (TTY.PROCESS (THIS.PROCESS)) (* ; "To avoid caret fights") (MOVEW MENUW (MIN LASTMOUSEX (- SCREENWIDTH (fetch (MENU IMAGEWIDTH) of MENU))) (MIN LASTMOUSEY (- SCREENHEIGHT (fetch (MENU IMAGEHEIGHT) of MENU)))) (* ; "Move window to cursor position") (OPENW MENUW) (if PROMPT then (CLRPROMPT) (PRINTOUT PROMPTWINDOW PROMPT T "Click OK when finished.")) (if (OR OLDSHADED PRESELECTED) then (* ; "Have to get the shading to take effect") (REDISPLAYW MENUW)) (until (SETQ RESULT (LISTGET (fetch (MENU MENUUSERDATA) of MENU) (QUOTE RESULT))) do (BLOCK) (TOTOPW MENUW)) (if (EQ RESULT :DONE) then (COLLECT.SHADED.ITEMS MENU) else (* ; "Return keyword, such as :ABORT") RESULT)) (CLOSEW MENUW) (TTY.PROCESS T) (if PROMPT then (CLRPROMPT)))))
)

(\LAFITE.HANDLE.MULTIPLE.SELECTION

(LAMBDA (ITEM MENU KEY) (* ; "Edited 12-Apr-89 17:58 by bvm") (if (AND (LISTP ITEM) (CL:KEYWORDP (CADR ITEM))) then (* ; "done") (push (fetch (MENU MENUUSERDATA) of MENU) (QUOTE RESULT) (CADR ITEM)) else (* ; "Select or unselect an item") (SHADEITEM ITEM MENU (SELECTQ (CDR (ASSOC (\ItemNumber ITEM (fetch (MENU ITEMS) of MENU)) (fetch (MENU SHADEDITEMS) of MENU))) ((NIL 0) (* ; "Not yet selected") LAFITEHARDCOPYBATCHSHADE) 0))))
)

(COLLECT.SHADED.ITEMS

(LAMBDA (MENU) (* ; "Edited 29-Aug-88 12:38 by bvm") (* ;; "Return a list of the items currently shaded in MENU") (for PAIR in (fetch (MENU SHADEDITEMS) of MENU) bind (ITEMS _ (fetch (MENU ITEMS) of MENU)) unless (EQ (CDR PAIR) 0) collect (CAR (NTH ITEMS (CAR PAIR)))))
)
)

(RPAQ? LAFITE.2COLUMN.MENU.MIN.ITEMS
 10)

(RPAQ? LAFITEFOLDERSMENU
 )

(RPAQ? LAFITEMULTIPLEFOLDERSMENU
 )

(ADDTOVAR LAFITEMENUVARS
 LAFITEFOLDERSMENU LAFITEMULTIPLEFOLDERSMENU)



(* ; "Name hacking")


(DEFINEQ

(LA.LONGFILENAME

(LAMBDA (FILENAME EXT UNPACKEDHOST&DIR HOST.ABBREVS UNPACKEDFLG) (* ; "Edited 18-Apr-89 15:44 by bvm") (* ;;; "Composes a (nearly) full-specified filename, filling in defaults from \LAFITEDEFAULTHOST&DIR") (LET* ((FILEFIELDS (OR (LISTP FILENAME) (UNPACKFILENAME.STRING FILENAME))) (FIRSTFIELD (CAR FILEFIELDS)) QUALTAIL SYNONYM SYNFIELDS) (if (AND (EQ FIRSTFIELD (QUOTE DEVICE)) (SETQ SYNONYM (for PAIR in (OR HOST.ABBREVS (CDR \LAFITE.PSEUDO.DEVICES)) bind (DEV _ (CADR FILEFIELDS)) thereis (CL:MEMBER DEV (CAR PAIR) :TEST (QUOTE STRING-EQUAL))))) then (* ; "User gave a synonym for host/dir") (SETQ SYNFIELDS (APPEND (CDR SYNONYM))) (SETQ FILEFIELDS (CDDR FILEFIELDS)) (if (AND (EQ (CAR FILEFIELDS) (QUOTE DIRECTORY)) (LISTGET SYNFIELDS (QUOTE DIRECTORY))) then (* ; "But user also specified a dir.  We don't support this really, but let's not lose") (LISTPUT SYNFIELDS (QUOTE DIRECTORY) (CONCAT (LISTGET SYNFIELDS (QUOTE DIRECTORY)) ">" (CADR FILEFIELDS))) (SETQ FILEFIELDS (CDDR FILEFIELDS))) (SETQ FILEFIELDS (NCONC SYNFIELDS FILEFIELDS)) (SETQ FIRSTFIELD (CAR FILEFIELDS))) (OR UNPACKEDHOST&DIR (SETQ UNPACKEDHOST&DIR (fetch UNPACKEDHOST&DIR of \LAFITEDEFAULTHOST&DIR))) (if (NEQ UNPACKEDHOST&DIR (SETQ QUALTAIL (find TAIL on UNPACKEDHOST&DIR by (CDDR TAIL) suchthat (EQ (CAR TAIL) FIRSTFIELD)))) then (* ; "Want default fields that do not occur in FILENAME, but only until FILENAME shows up with any such field (so if FILENAME has HOST, never default the directory).") (* ; "I was going to write a single loop with xcl:collect, but dwim got in the way...") (SETQ FILEFIELDS (NCONC (for TAIL on UNPACKEDHOST&DIR until (EQ TAIL QUALTAIL) collect (CAR TAIL)) FILEFIELDS))) (if EXT then (SETQ FILEFIELDS (NCONC FILEFIELDS (LIST (QUOTE EXTENSION) EXT)))) (if UNPACKEDFLG then (* ; "Leave unpacked") FILEFIELDS else (PACKFILENAME.STRING FILEFIELDS))))
)

(LA.SHORTFILENAME

(LAMBDA (FILE EXT KEEPVERSIONFLG) (* ; "Edited 12-Sep-88 16:42 by bvm") (* ;;; "returns that shortest file name that is compatible with \LAFITEDEFAULTHOST&DIR and EXT and no version number -- the result is used in menu creation") (COND (FILE (LET ((FILEFIELDS (COND ((LISTP FILE) (* ; "Already unpacked") (APPEND FILE)) (T (UNPACKFILENAME.STRING FILE)))) REST) (* ;; "Scan FILEFIELDS to see if it has a prefix matching either the default host&dir or one of our funny synonyms.") (for SYNONYM in \LAFITE.PSEUDO.DEVICES when (for (FILETAIL _ FILEFIELDS) (SYNTAIL _ (CDR SYNONYM)) do (if (NULL SYNTAIL) then (* ; "Matched completely") (RETURN (SETQ FILEFIELDS (SETQ REST FILETAIL))) elseif (AND (EQ (CAR FILETAIL) (CAR SYNTAIL)) (STRING-EQUAL (CAR (SETQ FILETAIL (CDR FILETAIL))) (CAR (SETQ SYNTAIL (CDR SYNTAIL))))) then (* ; "Matched that field, keep going") (SETQ FILETAIL (CDR FILETAIL)) (SETQ SYNTAIL (CDR SYNTAIL)) else (RETURN NIL))) do (if (CAR SYNONYM) then (* ; "NIL is for default host & dir") (push FILEFIELDS (QUOTE DEVICE) (CAAR SYNONYM))) (RETURN) finally (* ; "Maybe it matches part of default host&dir") (for (DEFAULTTAIL _ (fetch UNPACKEDHOST&DIR of \LAFITEDEFAULTHOST&DIR)) while (AND DEFAULTTAIL (EQ (CAR FILEFIELDS) (CAR DEFAULTTAIL)) (STRING-EQUAL (CADR FILEFIELDS) (CAR (SETQ DEFAULTTAIL (CDR DEFAULTTAIL))))) do (* ; "Pop off the matching fields") (SETQ FILEFIELDS (CDDR FILEFIELDS)) (SETQ DEFAULTTAIL (CDR DEFAULTTAIL))) (SETQ REST FILEFIELDS)) (while REST do (* ; "Scan the rest of the name to worry about extension and version defaulting") (if (SELECTQ (pop REST) (EXTENSION (AND EXT (STRING-EQUAL (CAR REST) EXT))) (VERSION (NOT KEEPVERSIONFLG)) NIL) then (* ; "Remove a field from the result") (RPLACA REST NIL)) (SETQ REST (CDR REST))) (PACKFILENAME.STRING FILEFIELDS)))))
)

(FORGETMAILFILE

(LAMBDA (FILENAME) (* ; "Edited  7-Sep-88 18:14 by bvm") (* ;;; "removes FILENAME from the list of known mail files and invalidates the menu cache") (LET ((KNOWNFILE (OR (find F in (CDR LAFITEMAILFOLDERS) suchthat (STRING-EQUAL F FILENAME)) (find F in (CDR LAFITEMAILFOLDERS) bind (SHORTNAME _ (LA.SHORTFILENAME FILENAME LAFITEMAIL.EXT)) suchthat (STRING-EQUAL F SHORTNAME))))) (COND (KNOWNFILE (\LAFITE.FOLDER.NAME.CHANGED KNOWNFILE)))))
)

(\LAFITE.FOLDER.NAME.CHANGED

(LAMBDA (OLDNAME NEWNAME) (* ; "Edited  8-May-89 15:44 by bvm") (* ;; "Called when a folder named OLDNAME has been renamed to NEWNAME, or deleted in the case where NEWNAME is NIL, or introduced in the case where OLDNAME is NIL.") (if OLDNAME then (* ; "Fix auto-move menus containing this one") (for FOLDER in \ACTIVELAFITEFOLDERS bind ITEMS FOUND WINDOW when (AND (SETQ WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (SETQ ITEMS (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES))) (SETQ FOUND (CL:MEMBER OLDNAME ITEMS :TEST (QUOTE STRING-EQUAL)))) do (* ; "Remove from the auto-move menu") (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES) (if NEWNAME then (DSUBST NEWNAME (CAR FOUND) ITEMS) else (DREMOVE (CAR FOUND) ITEMS))) (\LAFITE.UPDATE.MOVE.MENU FOLDER))) (RPLACD LAFITEMAILFOLDERS (\LAFITE.CHANGE.NAME.IN.LIST (CDR LAFITEMAILFOLDERS) OLDNAME NEWNAME)) (for GROUP in LAFITE.FOLDER.STRUCTURE when (CL:MEMBER OLDNAME (fetch FGFOLDERS of GROUP) :TEST (QUOTE STRING-EQUAL)) do (replace FGFOLDERS of GROUP with (\LAFITE.CHANGE.NAME.IN.LIST (fetch FGFOLDERS of GROUP) OLDNAME NEWNAME))) (SETQ LAFITEFOLDERSMENU (SETQ LAFITEMULTIPLEFOLDERSMENU NIL)) (SETQ \LAFITEPROFILECHANGED T))
)

(\LAFITE.CHANGE.NAME.IN.LIST

(LAMBDA (FOLDERS OLDNAME NEWNAME) (* ; "Edited 29-Aug-89 11:10 by bvm") (* ;; "Return FOLDERS with OLDNAME replace with NEWNAME (or deleted if new = nil)") (if OLDNAME then (SETQ FOLDERS (CL:DELETE OLDNAME FOLDERS :TEST (QUOTE STRING-EQUAL)))) (if NEWNAME then (CL:MERGE (QUOTE LIST) (LIST NEWNAME) FOLDERS (FUNCTION UALPHORDER)) else FOLDERS))
)

(\LAFITE.RECOMPUTE.FOLDER.NAMES

(LAMBDA (OLDABBREVS) (* ; "Edited  8-May-89 15:45 by bvm") (* ;; "Called when either the host&dir in LAFITEMAILFOLDERS disagrees with \lafitedefaulthost&dir or the abbreviation list changed.") (LET ((OLDHOST&DIR (CAR LAFITEMAILFOLDERS))) (SETQ LAFITEFORMFILES (\LAFITE.REPACK.FOLDERS LAFITEFORMFILES OLDHOST&DIR OLDABBREVS)) (SETQ LAFITEMAILFOLDERS (CONS (fetch PACKEDHOST&DIR of \LAFITEDEFAULTHOST&DIR) (CL:SORT (\LAFITE.REPACK.FOLDERS (CDR LAFITEMAILFOLDERS) OLDHOST&DIR OLDABBREVS) (FUNCTION UALPHORDER)))) (for GROUP in LAFITE.FOLDER.STRUCTURE do (replace FGFOLDERS of GROUP with (CL:SORT (\LAFITE.REPACK.FOLDERS (fetch FGFOLDERS of GROUP) OLDHOST&DIR OLDABBREVS) (FUNCTION UALPHORDER))))) (for FOLDER in \ACTIVELAFITEFOLDERS bind WINDOW ITEMS NEWNAME do (* ; "Update short names") (if (NOT (STREQUAL (fetch (MAILFOLDER SHORTFOLDERNAME) of FOLDER) (SETQ NEWNAME (LA.SHORTFILENAME (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER) LAFITEMAIL.EXT)))) then (\LAFITE.NEW.SHORT.NAME FOLDER NEWNAME)) (if (AND (SETQ WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (SETQ ITEMS (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES))) (NOT (EQUAL ITEMS (SETQ ITEMS (for NAME in ITEMS collect (LA.SHORTFILENAME (LA.LONGFILENAME NAME NIL NIL OLDABBREVS T))))))) then (* ; "Recanonicalize the names") (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES) ITEMS) (\LAFITE.UPDATE.MOVE.MENU FOLDER))))
)

(\LAFITE.NEW.SHORT.NAME

(LAMBDA (FOLDER NEWSHORTNAME) (* ; "Edited 12-Sep-88 16:35 by bvm") (* ;; "Called when FOLDER acquires a new short name, e.g. because abbreviations changed.  Updates things in the folder that care about that.") (replace (MAILFOLDER SHORTFOLDERNAME) of FOLDER with NEWSHORTNAME) (LET ((W (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) IW) (if W then (* ; "Fix browser title") (SETQ IW (WINDOWPROP W (QUOTE ICONWINDOW))) (if IW then (* ; "Fix icon title") (ICONW.TITLE IW NEWSHORTNAME)) (if (AND (PROG1 (NOT (OPENWP W)) (WINDOWPROP W (QUOTE TITLE) (LAB.TITLE.STRING FOLDER))) (OPENWP W)) then (* ; "Reshrink it after we change the title") (SHRINKW W)))))
)

(\LAFITE.NOTICE.FILE

(LAMBDA (SHORTNAME) (* ; "Edited  7-Sep-88 18:14 by bvm") (* ;; "Adds SHORTNAME to Lafite's menu of folders") (\LAFITE.FOLDER.NAME.CHANGED NIL SHORTNAME))
)

(\LAFITE.UNCACHE.FOLDER

(LAMBDA (ITEM MENU) (* ; "Edited 29-Aug-88 17:23 by bvm") (* ;;; "Remove one or more names from the folder menu.") (PROMPTPRINT "Select the folders to be removed, then select OK.") (LET ((NAMES (LAFITE.SELECT.FOLDERS))) (CLRPROMPT) (if NAMES then (for NAME in NAMES do (FORGETMAILFILE NAME)) (PRINTOUT PROMPTWINDOW T (if (CDR NAMES) then (CONCAT (LENGTH NAMES) " folders") else (CAR NAMES)) " forgotten."))))
)
)

(RPAQ? LAFITE.HOST.ABBREVS
 NIL)

(RPAQ? \LAFITE.PSEUDO.DEVICES
 NIL)



(* ; "Hacking the hierarchy")


(DEFINEQ

(\LAFITE.NOTICE.FOLDERS

(LAMBDA NIL (* ; "Edited 12-Apr-89 16:35 by bvm") (RESETLST (LET ((*UPPER-CASE-FILE-NAMES* NIL) (PATTERN (PROMPTFORFILENAME NIL (CAR \LAFITEDEFAULTHOST&DIR) "Notice mail folders on directory: ")) WINDOW GEN FILE NEWFILES NEWCASEFILES OLDCASEFILES FOUND) (COND (PATTERN (SETQ PATTERN (PACKFILENAME.STRING (APPEND (LA.LONGFILENAME (PACKFILENAME.STRING (QUOTE BODY) PATTERN (QUOTE NAME) (QUOTE *)) LAFITEMAIL.EXT NIL NIL T) (QUOTE (VERSION ""))))) (* ; "Default to *.MAIL;") (SETQ WINDOW (\LAFITE.MAKE.RANDOM.DISPLAY "Noticed Mail Folders" PATTERN (CONCAT "Enumerating " PATTERN "...
"))) (SETQ GEN (\GENERATEFILES PATTERN NIL (QUOTE (RESETLST)))) (COND ((NULL (SETQ FILE (\GENERATENEXTFILE GEN))) (printout WINDOW T "No matching files found.")) (T (do (if (NOT (SETQ FOUND (CL:MEMBER (SETQ FILE (LA.SHORTFILENAME FILE LAFITEMAIL.EXT)) (CDR LAFITEMAILFOLDERS) :TEST (QUOTE STRING-EQUAL)))) then (* ; "New file") (push NEWFILES FILE) (printout WINDOW FILE ", ") elseif (NOT (STREQUAL (CAR FOUND) FILE)) then (* ; "New case or canonicalization") (push NEWCASEFILES (CONS (CAR FOUND) FILE))) repeatwhile (SETQ FILE (\GENERATENEXTFILE GEN))) (if (NULL (OR NEWFILES NEWCASEFILES)) then (printout WINDOW T "No new files found.") elseif (\LAFITE.GC.FOLDERS.CONFIRM WINDOW (CONCAT (if NEWCASEFILES then (CL:FORMAT NIL "~:[No new files, but~;~%%Also~] found new canonical names for ~D existing folders.~%%" NEWFILES (LENGTH NEWCASEFILES)) else "") "Click Confirm to add these folders to set of known folders.")) then (\LAFITE.CHANGE.FOLDER.LIST NEWFILES NEWCASEFILES NIL WINDOW) else (printout WINDOW T "Aborted.")))))))))
)

(\LAFITE.GC.FOLDERS

(LAMBDA NIL (* ; "Edited 12-Apr-89 16:35 by bvm") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (WINDOW (\LAFITE.MAKE.RANDOM.DISPLAY "Folders no longer found" (CAR \LAFITEDEFAULTHOST&DIR))) (OLDFILES (CDR LAFITEMAILFOLDERS)) FOUND NOTFOUND NEWCASEFILES) (printout WINDOW "Scanning...") (for F in OLDFILES do (printout WINDOW ".") (if (NULL (SETQ FOUND (INFILEP (LA.LONGFILENAME F LAFITEMAIL.EXT)))) then (printout WINDOW T F " not found.") (push NOTFOUND F) elseif (NOT (STREQUAL (SETQ FOUND (LA.SHORTFILENAME FOUND LAFITEMAIL.EXT)) F)) then (* ; "Different case") (push NEWCASEFILES (CONS F FOUND)))) (COND ((NULL (OR NOTFOUND NEWCASEFILES)) (printout WINDOW T "All known folders still exist.")) ((\LAFITE.GC.FOLDERS.CONFIRM WINDOW (CONCAT (if NEWCASEFILES then (CL:FORMAT NIL "~:[All folders exist, but~;~%%Also~] found new canonical names for ~D folders.~%%" NOTFOUND (LENGTH NEWCASEFILES)) else "") "Click Confirm to make these changes to the set of known folders.")) (\LAFITE.CHANGE.FOLDER.LIST NIL NEWCASEFILES NOTFOUND WINDOW)) (T (printout WINDOW T "Aborted")))))
)

(\LAFITE.GC.FOLDERS.CONFIRM

(LAMBDA (TEXTSTREAM PROMPT) (* ; "Edited 20-Apr-89 19:36 by bvm") (* ;;; "Wait for confirming response from Proceed/Abort menu before changing folders menu.  PROMPT is instructions to issue in TEXTSTREAM") (TEDIT.SETSEL TEXTSTREAM (GETEOFPTR TEXTSTREAM) 0 (QUOTE RIGHT)) (TEDIT.NORMALIZECARET TEXTSTREAM) (* ; "This makes the last line visible, I hope") (printout TEXTSTREAM T T PROMPT) (PROG1 (MENU (create MENU ITEMS _ (QUOTE (("Confirm" T "Yes, change the folder menu as indicated.") ("Abort" NIL "No, take no action"))) MENUROWS _ 1 CENTERFLG _ T MENUFONT _ LAFITEMENUFONT MENUBORDERSIZE _ 2) (LA.POSITION.FROM.REGION (WINDOWPROP (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM) (QUOTE REGION)) NIL (- (+ 2 (FONTPROP LAFITEMENUFONT (QUOTE HEIGHT))))) T) (SETFILEPTR TEXTSTREAM -1)))
)

(\LAFITE.MAKE.RANDOM.DISPLAY

  [LAMBDA (TITLE SAMPLESTRING INITIALCONTENT)
                (* ; "Edited  7-Feb-2022 11:59 by rmk")


                                                             (* ; "Edited 23-Aug-88 14:54 by bvm")

    (LET ((REG (WINDOWREGION LAFITESTATUSWINDOW))
          (HEIGHT (HEIGHTIFWINDOW (TIMES 6 (FONTPROP NIL 'HEIGHT))
                         T))
          BOTTOM WINDOW)
         [SETQ WINDOW (OPENTEXTSTREAM (OPENSTRINGSTREAM INITIALCONTENT)
                             (CREATEW (MAKEWITHINREGION
                                       (create
 REGION
                                              LEFT _ (fetch
 (REGION LEFT) of
 REG)
                                              BOTTOM _ (COND
                                                          ((< (SETQ BOTTOM (- (fetch
 (REGION BOTTOM)
                                                                                 of
 REG)
                                                                              HEIGHT))
                                                              0)
                                                             (* ; 

                                        "tried placing it below status window, but that's off screen")

                                                           (fetch
 (REGION TOP) of
 REG))
                                                          (T BOTTOM))
                                              WIDTH _ [IMAX (FIXR (TIMES 1.5 (STRINGWIDTH 
                                                                                    SAMPLESTRING)))
                                                            (TIMES 64 (CHARWIDTH (CHARCODE M]
                                              HEIGHT _ HEIGHT))
                                    TITLE)
                             NIL NIL '(PROMPTWINDOW DON'T]
         (SETFILEPTR WINDOW -1)
         (LINELENGTH MAX.SMALLP WINDOW)
         WINDOW])

(\LAFITE.CHANGE.FOLDER.LIST

(LAMBDA (NEWFILES NEWCASEFILES NOTFOUND TEXTSTREAM) (* ; "Edited 12-Apr-89 16:34 by bvm") (* ;; "Change Lafite's set of folders by adding NEWFILES, removing NOTFOUND and renaming each (oldname . newname) in NEWCASEFILES.  Outputs %"Done%" to optional TEXTSTREAM") (for FILE in NEWFILES do (* ; "add these") (\LAFITE.FOLDER.NAME.CHANGED NIL FILE)) (for FILE in NOTFOUND do (* ; "forget these") (\LAFITE.FOLDER.NAME.CHANGED FILE NIL)) (for FILE in NEWCASEFILES do (* ; "Fix case on these") (\LAFITE.FOLDER.NAME.CHANGED (CAR FILE) (CDR FILE))) (if TEXTSTREAM then (* ; "Use TEDIT.INSERT here instead of printout to insure that scrolling occurs if needed.") (TEDIT.INSERT TEXTSTREAM "
Done." (ADD1 (GETEOFPTR TEXTSTREAM))))))

(\LAFITE.RENAME.FOLDER

(LAMBDA NIL (* ; "Edited  2-Nov-89 17:59 by bvm") (RESETLST (LET ((*UPPER-CASE-FILE-NAMES* NIL) (FOLDERNAME (\LAFITE.PROMPTFORFOLDER)) FULLNAME NEWNAME FOLDER TOC NEWFULLNAME NEWSHORTNAME) (if (OR (NULL FOLDERNAME) (NULL (SETQ NEWNAME (PROMPTFORFILENAME NIL FOLDERNAME (CONCAT "Rename " (UNPACKFILENAME.STRING FOLDERNAME (QUOTE NAME)) " to be: ")))) (STREQUAL NEWNAME FOLDERNAME)) then (PRINTOUT PROMPTWINDOW T FOLDERNAME " not renamed.") elseif (NULL (SETQ FULLNAME (INFILEP (LA.LONGFILENAME FOLDERNAME LAFITEMAIL.EXT)))) then (PRINTOUT PROMPTWINDOW T "Can't find " FOLDERNAME) else (PRINTOUT PROMPTWINDOW T "Renaming " FULLNAME "...") (SETQ NEWNAME (LA.LONGFILENAME NEWNAME LAFITEMAIL.EXT)) (if (SETQ FOLDER (LAFITE.OBTAIN.FOLDER FULLNAME)) then (OBTAIN.MONITORLOCK (fetch FOLDERLOCK of FOLDER) NIL T) (\LAFITE.CLOSE.FOLDER FOLDER T)) (if (NULL (SETQ NEWFULLNAME (RENAMEFILE FULLNAME NEWNAME))) then (PRINTOUT PROMPTWINDOW " failed.") else (PRINTOUT PROMPTWINDOW T " to " NEWFULLNAME) (if (SETQ TOC (INFILEP (TOCFILENAME FULLNAME))) then (PRINTOUT PROMPTWINDOW T "Renaming toc file...") (if (NOT (RENAMEFILE TOC (TOCFILENAME NEWFULLNAME))) then (PRINTOUT PROMPTWINDOW T "Could not rename toc file " TOC " - you may want to delete or rename it yourself."))) (SETQ NEWSHORTNAME (LA.SHORTFILENAME NEWFULLNAME LAFITEMAIL.EXT)) (if FOLDER then (* ; "Fix up this guy's name") (replace (MAILFOLDER FULLFOLDERNAME) of FOLDER with NEWFULLNAME) (replace (MAILFOLDER VERSIONLESSFOLDERNAME) of FOLDER with (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) NEWFULLNAME)) (\LAFITE.NEW.SHORT.NAME FOLDER NEWSHORTNAME)) (\LAFITE.FOLDER.NAME.CHANGED FOLDERNAME NEWSHORTNAME) (PRINTOUT PROMPTWINDOW " done."))))))
)

(\LAFITE.ADD.NEW.GROUP

(LAMBDA (SUPERGROUP) (* ; "Edited  8-May-89 16:51 by bvm") (LET ((GROUP (PROMPTFORFILENAME NIL NIL "Name of new group (CR to abort): ")) MEMBERS) (if (AND GROUP (\LAFITE.CHECK.GROUP.NAME GROUP) (NEQ (SETQ MEMBERS (\LAFITE.SELECT.GROUP.FOLDERS GROUP)) :ABORT)) then (if SUPERGROUP then (SETQ SUPERGROUP (LAFITE.FIND.GROUP SUPERGROUP)) (replace FGSUBGROUPS of SUPERGROUP with (MERGE (fetch FGSUBGROUPS of SUPERGROUP) (LIST GROUP) (FUNCTION UALPHORDER)))) (SETQ LAFITE.FOLDER.STRUCTURE (MERGE LAFITE.FOLDER.STRUCTURE (LIST (create FOLDERGROUP FGNAME _ GROUP FGTOPLEVEL _ (NOT SUPERGROUP) FGFOLDERS _ MEMBERS)) (FUNCTION UALPHORDERCAR))) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFOLDERSMENU))) NIL)
)

(\LAFITE.CHECK.GROUP.NAME

(LAMBDA (NAME) (* ; "Edited  8-May-89 15:53 by bvm") (* ;; "Verify that NAME is not yet the name of a group.  Return NAME if unique, NIL if it already exists.") (LET ((FOUND (LAFITE.FIND.GROUP NAME))) (if FOUND then (printout PROMPTWINDOW T "There's already a group named " (fetch FGNAME of FOUND) ".") NIL else NAME)))
)

(\LAFITE.CHANGE.GROUP.MEMBERS

(LAMBDA (NAME) (* ; "Edited  8-May-89 15:53 by bvm") (LET* ((GROUP (LAFITE.FIND.GROUP NAME)) (NEWMEMBERS (\LAFITE.SELECT.GROUP.FOLDERS NAME (fetch FGFOLDERS of GROUP)))) (if (NEQ NEWMEMBERS :ABORT) then (replace FGFOLDERS of GROUP with (SORT NEWMEMBERS (FUNCTION UALPHORDER))) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFOLDERSMENU))) NIL)
)

(\LAFITE.SELECT.GROUP.FOLDERS

(LAMBDA (GROUPNAME PRESELECTED) (* ; "Edited  8-May-89 16:42 by bvm") (* ;; "Like LAFITE.SELECT.FOLDERS, but called to select a subset of folders to put in group GROUPNAME.") (LAFITE.SELECT.MULTIPLE (LET* ((ALLFOLDERS (CDR LAFITEMAILFOLDERS)) (GROUPED (CL:REMOVE-DUPLICATES (for GROUP in LAFITE.FOLDER.STRUCTURE join (APPEND (fetch FGFOLDERS of GROUP))) :TEST (QUOTE STRING-EQUAL))) (UNGROUPED (AND (> (LENGTH ALLFOLDERS) (LENGTH GROUPED)) (CL:SET-DIFFERENCE ALLFOLDERS GROUPED :TEST (QUOTE STRING-EQUAL))))) (* ; "The LENGTH check is an optimization to skip the SET-DIFFERENCE call when everybody is in a group.") (if UNGROUPED then (* ; "Show the ungrouped ones in a clump to make it easier to see which folders still need to be classified") (NCONC UNGROUPED (LIST LAFITE.SPACER.MENU.ITEM) (SORT GROUPED (FUNCTION UALPHORDER))) else ALLFOLDERS)) PRESELECTED (CONCAT "Folders in group " GROUPNAME) (CL:FORMAT NIL "Select which folders should belong to ~A." GROUPNAME)))
)

(\LAFITE.CHANGE.SUBGROUPS

(LAMBDA (NAME) (* ; "Edited  8-May-89 16:41 by bvm") (LET* ((GROUP (LAFITE.FIND.GROUP NAME)) (CANDIDATES (MAPCAR (CL:REMOVE GROUP LAFITE.FOLDER.STRUCTURE) (FUNCTION CAR)))) (if CANDIDATES then (LET ((NEWMEMBERS (LAFITE.SELECT.MULTIPLE CANDIDATES (fetch FGSUBGROUPS of GROUP) (CONCAT "Subgroups of " NAME) (CL:FORMAT NIL "Select which groups should lie below ~A in the folder hierarchy." NAME)))) (if (NEQ NEWMEMBERS :ABORT) then (replace FGSUBGROUPS of GROUP with (SORT NEWMEMBERS (FUNCTION UALPHORDER))) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFOLDERSMENU))) else (PROMPTPRINT "No other groups are yet defined."))))
)

(\LAFITE.CHANGE.TOP.GROUPS

(LAMBDA NIL (* ; "Edited  8-May-89 16:43 by bvm") (if LAFITE.FOLDER.STRUCTURE then (LET ((NEWTOP (LAFITE.SELECT.MULTIPLE (for GROUP in LAFITE.FOLDER.STRUCTURE collect (fetch FGNAME of GROUP)) (for GROUP in LAFITE.FOLDER.STRUCTURE when (fetch FGTOPLEVEL of GROUP) collect (fetch FGNAME of GROUP)) "Top level groups" "Select which groups should appear in the top-level folder menu."))) (if (NEQ NEWTOP :ABORT) then (for GROUP in LAFITE.FOLDER.STRUCTURE do (replace FGTOPLEVEL of GROUP with (AND (CL:MEMBER (fetch FGNAME of GROUP) NEWTOP :TEST (QUOTE STRING-EQUAL)) T))) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFOLDERSMENU))) else (PROMPTPRINT "No groups are yet defined.")))
)

(\LAFITE.DELETE.GROUP

(LAMBDA (NAME) (* ; "Edited  8-May-89 15:54 by bvm") (LET ((GROUP (LAFITE.FIND.GROUP NAME))) (if (AND GROUP (MOUSECONFIRM (CONCAT "Click LEFT to confirm deleting group " NAME) "")) then (for OTHER in (SETQ LAFITE.FOLDER.STRUCTURE (DREMOVE GROUP LAFITE.FOLDER.STRUCTURE)) bind FOUND when (SETQ FOUND (CL:MEMBER NAME (fetch FGSUBGROUPS of OTHER) :TEST (QUOTE STRING-EQUAL))) do (* ; "Remove this as subgroup") (replace FGSUBGROUPS of OTHER with (DREMOVE (CAR FOUND) (fetch FGSUBGROUPS of OTHER)))) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFOLDERSMENU))))
)

(LAFITE.RENAME.GROUP

(LAMBDA (OLDNAME NEWNAME) (* ; "Edited  8-May-89 15:54 by bvm") (if (AND (OR NEWNAME (SETQ NEWNAME (PROMPTFORFILENAME NIL OLDNAME (CONCAT "New name for group " OLDNAME " (CR to abort): ")))) (OR (STRING-EQUAL NEWNAME OLDNAME) (\LAFITE.CHECK.GROUP.NAME NEWNAME))) then (LET ((OLDGROUP (LAFITE.FIND.GROUP OLDNAME)) FOUND) (if (NULL OLDGROUP) then (PRINTOUT PROMPTWINDOW T "Group " OLDNAME " not found.") else (replace FGNAME of OLDGROUP with NEWNAME) (for GROUP in (SORT LAFITE.FOLDER.STRUCTURE (FUNCTION UALPHORDERCAR)) when (SETQ FOUND (CL:MEMBER OLDNAME (fetch FGSUBGROUPS of GROUP) :TEST (QUOTE STRING-EQUAL))) do (SORT (DSUBST NEWNAME (CAR FOUND) (fetch FGSUBGROUPS of GROUP)) (FUNCTION UALPHORDER))) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFOLDERSMENU) (PRINTOUT PROMPTWINDOW T "Group " OLDNAME " renamed to " NEWNAME)))))
)

(\LAFITE.EDIT.HIERARCHY

(LAMBDA NIL (* ; "Edited 13-Apr-89 14:43 by bvm") (if (NULL LAFITE.FOLDER.STRUCTURE) then (\LAFITE.ADD.NEW.GROUP) else (LET ((GROUP (MENU (create MENU ITEMS _ (NCONC1 (MAPCAR LAFITE.FOLDER.STRUCTURE (FUNCTION CAR)) (QUOTE ("**New Group**" :NEW "Define a new folder group"))) CENTERFLG _ T TITLE _ "Edit which group?")))) (if (EQ GROUP :NEW) then (\LAFITE.ADD.NEW.GROUP) elseif GROUP then (LET ((CMD (MENU (.LAFITEMENU. LAFITE.GROUP.COMMANDS.MENU LAFITE.GROUP.COMMANDS "Change group how?")))) (AND CMD (CL:FUNCALL CMD GROUP)))))))
)

(LAFITE.FIND.GROUP

(LAMBDA (NAME) (* ; "Edited  8-May-89 15:51 by bvm") (* ;; "Return the FOLDERGROUP object named NAME.") (CL:ASSOC NAME LAFITE.FOLDER.STRUCTURE :TEST (QUOTE STRING-EQUAL)))
)

(UALPHORDERCAR

(LAMBDA (X Y) (* ; "Edited 13-Apr-89 14:38 by bvm") (ALPHORDER (CAR X) (CAR Y) UPPERCASEARRAY)))
)

(RPAQQ LAFITE.SPACER.MENU.ITEM
 (#*(32 1)OOOOOOOO NIL "(this is not a choice)"))

(RPAQQ LAFITE.GROUP.COMMANDS

       (("Delete Group" '\LAFITE.DELETE.GROUP "Remove this group from the hierarchy")
        ("Rename Group" 'LAFITE.RENAME.GROUP "Change the name of this group")
        ("Change Members" '\LAFITE.CHANGE.GROUP.MEMBERS "Change the membership of this group")
        ("Change Subgroups" '\LAFITE.CHANGE.SUBGROUPS "Change the subgroups of this group")
        ("Create Subgroup" '\LAFITE.ADD.NEW.GROUP 
               "Create a new group and make it a subgroup of this group")))

(RPAQQ LAFITE.GROUP.COMMANDS.MENU
 NIL)
(DECLARE%: EVAL@COMPILE DONTCOPY 

(FILESLOAD (SOURCE)
       LAFITE-DECLS)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS MENUFONT LAFITE.GROUP.COMMANDS.MENU LAFITE.GROUP.COMMANDS)
)


(CL:PROCLAIM '(CL:SPECIAL *LA.ABBREVS.IN.PROFILE*))
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (3431 11296 (\LAFITE.READ.PROFILE 3441 . 5645) (\LAFITE.PROCESS.PROFILE 5647 . 6837) (
\LAFITE.WRITE.PROFILE 6839 . 8673) (\LAFITE.MERGE.NAMELISTS 8675 . 9409) (\LAFITE.READ.OLD.PROFILE 
9411 . 10010) (\LAFITE.MERGE.FOLDERS 10012 . 10324) (\LAFITE.MERGE.STRUCTURES 10326 . 10526) (
\LAFITE.REPACK.FOLDERS 10528 . 11294)) (11723 20267 (\LAFITE.PROMPTFORFOLDER 11733 . 12283) (
PROMPTFORFILENAME 12285 . 13126) (MAKELAFITEMAILFOLDERSMENU 13128 . 13292) (MAKELAFITEFOLDERSMENUITEMS
 13294 . 14409) (LAFITE.GROUP.ITEM 14411 . 14948) (\LAFITE.ARRANGE.MENU 14950 . 16232) (
\LAFITE.MAKE.FOLDER.MENU 16234 . 16759) (LAFITE.SELECT.FOLDERS 16761 . 17146) (LAFITE.SELECT.MULTIPLE 
17148 . 19492) (\LAFITE.HANDLE.MULTIPLE.SELECTION 19494 . 19966) (COLLECT.SHADED.ITEMS 19968 . 20265))
 (20490 28999 (LA.LONGFILENAME 20500 . 22375) (LA.SHORTFILENAME 22377 . 24200) (FORGETMAILFILE 24202
 . 24662) (\LAFITE.FOLDER.NAME.CHANGED 24664 . 25887) (\LAFITE.CHANGE.NAME.IN.LIST 25889 . 26268) (
\LAFITE.RECOMPUTE.FOLDER.NAMES 26270 . 27691) (\LAFITE.NEW.SHORT.NAME 27693 . 28374) (
\LAFITE.NOTICE.FILE 28376 . 28557) (\LAFITE.UNCACHE.FOLDER 28559 . 28997)) (29115 43294 (
\LAFITE.NOTICE.FOLDERS 29125 . 30765) (\LAFITE.GC.FOLDERS 30767 . 31854) (\LAFITE.GC.FOLDERS.CONFIRM 
31856 . 32666) (\LAFITE.MAKE.RANDOM.DISPLAY 32668 . 34659) (\LAFITE.CHANGE.FOLDER.LIST 34661 . 35414) 
(\LAFITE.RENAME.FOLDER 35416 . 37146) (\LAFITE.ADD.NEW.GROUP 37148 . 37873) (\LAFITE.CHECK.GROUP.NAME 
37875 . 38226) (\LAFITE.CHANGE.GROUP.MEMBERS 38228 . 38603) (\LAFITE.SELECT.GROUP.FOLDERS 38605 . 
39611) (\LAFITE.CHANGE.SUBGROUPS 39613 . 40264) (\LAFITE.CHANGE.TOP.GROUPS 40266 . 40974) (
\LAFITE.DELETE.GROUP 40976 . 41558) (LAFITE.RENAME.GROUP 41560 . 42416) (\LAFITE.EDIT.HIERARCHY 42418
 . 42977) (LAFITE.FIND.GROUP 42979 . 43175) (UALPHORDERCAR 43177 . 43292)))))
STOP