(FILECREATED " 4-Mar-87 17:04:08" {PHYLUM}<LISPUSERS>KOTO>ARCHIVEBROWSER.;3 28150
changes to: (VARS ARCHIVEBROWSERCOMS) (FNS AB.Delete.Command AB.Retrieve.Command
AB.Retrieve.Directory.Command AB.Retrieve.Renamed.Aux AB.Undelete.Command AB ARCHIVEBROWSER
AB.Make.Cedar.Filename AB.Retrieve.Renamed.Command)
previous date: "22-Sep-86 13:12:01" {QV}<BRIGGS>LISP>ARCHIVEBROWSER.;4)
(* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ARCHIVEBROWSERCOMS)
(RPAQQ ARCHIVEBROWSERCOMS ((* * the user's interface to the archive browser) (FNS ARCHIVEBROWSER AB)
(* * command processing functions) (FNS AB.When.Selected.Fn AB.Command.Fn AB.Delete.Command
AB.Expunge.Command AB.Filter.Command AB.Recompute.Command AB.Retrieve.Command
AB.Retrieve.Directory.Command AB.Retrieve.Renamed.Command AB.Retrieve.Renamed.Aux AB.Sort.Command
AB.Undelete.Command) (* * miscellaneous functions) (FNS AB.Set.Browser.Title AB.Iconfn AB.Closefn
AB.Printfn AB.Prompt.For.Input AB.Read.Directory AB.Subitemp AB.Make.Cedar.Filename) (* * the user
that gets retrieval requests) (INITVARS (AB.archivist "Archivist")) (* * the structure for an archive
entry) (RECORDS AB.item) (* * the icon) (BITMAPS AB.icon AB.icon.mask) (INITVARS (AB.titled.icon (
create TITLEDICON ICON ← AB.icon MASK ← AB.icon.mask TITLEREG ← (CREATEREGION 7 8 60 24)))) (* * the
font for the browser, which must be a fixed pitch font for now) (VARS (AB.browser.font (FONTCREATE (
QUOTE TERMINAL) 10))) (* * based on the TableBrowser package) (FILES TABLEBROWSER) (DECLARE:
EVAL@COMPILE DONTCOPY (FILES TABLEBROWSERDECLS)) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
COMPILERVARS (ADDVARS (NLAMA AB) (NLAML) (LAMA)))))
(* * the user's interface to the archive browser)
(DEFINEQ
(ARCHIVEBROWSER
(LAMBDA (archivefilespec filter) (* N.H.Briggs " 2-Mar-87 16:56") (LET* ((menu (create MENU ITEMS ← (
QUOTE ((Retrieve AB.Retrieve.Command "Retrieve selected files" (SUBITEMS ("Retrieve selected files"
AB.Retrieve.Command "Retrieve selected files") ("Retrieve to directory" AB.Retrieve.Directory.Command
"Retrieve selected files to a different directory") ("Retrieve renamed" AB.Retrieve.Renamed.Command
"Retrieve selected files specifying new name for each file"))) (Filter AB.Filter.Command
"Set filter for displayed file names") (Sort AB.Sort.Command "Sort entries by file name" (SUBITEMS (
"Sort by file name" AB.Sort.Command "Sort entries by file name") ("Sort by creation date" (
AB.Sort.Command CreationDate) "Sort entries by creation date of the file") ("Sort by archive date" (
AB.Sort.Command Archive) "Sort entries by date that the file was archived") (Reverse (AB.Sort.Command
Reverse) "Reverse the order of the entries"))) (Recompute AB.Recompute.Command
"Redisplay browser items after re-reading archive directory" (SUBITEMS ("Same directory"
AB.Recompute.Command "Redisplay browser items after re-reading archive directory") ("New directory" (
AB.Recompute.Command T) "Browse a different archive directory"))) ("" NIL "do nothing - a separator")
(Delete AB.Delete.Command "Delete selected items") (Undelete AB.Undelete.Command
"Undelete selected items" (SUBITEMS ("Undelete selected items" AB.Undelete.Command
"Undelete selected items") ("Undelete ALL items" (AB.Undelete.Command T) "Undelete all deleted items")
)) ("" NIL "do nothing - a separator so you don't accidentally Expunge") (Expunge AB.Expunge.Command
"Expunge deleted items and rewrite the archive directory"))) CENTERFLG ← T TITLE ← " Commands "
WHENSELECTEDFN ← (QUOTE AB.When.Selected.Fn))) (promptfont (FONTCREATE (QUOTE HELVETICA) 10)) (
promptheight (HEIGHTIFWINDOW (TIMES 2 (FONTPROP promptfont (QUOTE HEIGHT))) T)) (promptwindow) (
windowregion (GETREGION (PLUS (fetch IMAGEWIDTH of menu) 144) (PLUS (fetch IMAGEHEIGHT of menu)
promptheight))) (window (CREATEW (CREATEREGION (fetch LEFT of windowregion) (fetch BOTTOM of
windowregion) (DIFFERENCE (fetch WIDTH of windowregion) (fetch IMAGEWIDTH of menu)) (DIFFERENCE (fetch
HEIGHT of windowregion) promptheight)) "")) (browser (TB.MAKE.BROWSER NIL window (BQUOTE (PRINTFN
AB.Printfn FONT (\, AB.browser.font)))))) (ATTACHMENU menu window (QUOTE RIGHT) (QUOTE TOP)) (
TB.USERDATA browser (LIST (QUOTE ARCHIVE) (PACKFILENAME.STRING (QUOTE HOST) (OR (FILENAMEFIELD
archivefilespec (QUOTE HOST)) (FILENAMEFIELD (DIRECTORYNAME) (QUOTE HOST))) (QUOTE DIRECTORY) (OR (
FILENAMEFIELD archivefilespec (QUOTE DIRECTORY)) (CAR (FULLUSERNAME T))) (QUOTE NAME) (OR (
FILENAMEFIELD archivefilespec (QUOTE NAME)) (QUOTE Archive)) (QUOTE EXTENSION) (OR (FILENAMEFIELD
archivefilespec (QUOTE EXTENSION)) (QUOTE directory)) (QUOTE BODY) archivefilespec) (QUOTE FILTER) (OR
filter "*.*"))) (* (use something like this if the "attic" is used) L-CASE (OR filter (CONCAT (CAR (
FULLUSERNAME T)) ">*.*"))) (SETQ promptwindow (GETPROMPTWINDOW window 2 (FONTCREATE (QUOTE HELVETICA)
10))) (AB.Set.Browser.Title browser) (WINDOWPROP promptwindow (QUOTE MINSIZE) (CONS 0 (fetch (REGION
HEIGHT) of (WINDOWPROP promptwindow (QUOTE REGION))))) (WINDOWPROP promptwindow (QUOTE MAXSIZE) (CONS
64000 (fetch (REGION HEIGHT) of (WINDOWPROP promptwindow (QUOTE REGION))))) (LINELENGTH MAX.SMALLP
promptwindow) (WINDOWPROP window (QUOTE ICONFN) (FUNCTION AB.Iconfn)) (WINDOWADDPROP window (QUOTE
CLOSEFN) (FUNCTION AB.Closefn) T) (AB.Command.Fn (SASSOC (QUOTE Recompute) (fetch (MENU ITEMS) of menu
)) menu (QUOTE LEFT)))))
(AB
(NLAMBDA filespec% filter (* N.H.Briggs " 4-Mar-87 12:11") (LET ((patternandfilter (NLAMBDA.ARGS
filespec% filter))) (ARCHIVEBROWSER (CAR patternandfilter) (CADR patternandfilter)) NIL)))
)
(* * command processing functions)
(DEFINEQ
(AB.When.Selected.Fn
(LAMBDA (Item Menu Key) (* N.H.Briggs "25-Jun-86 11:48") (if (AND (LISTP Item) (CADR Item)) then (
TB.PROCESS (LIST (FUNCTION AB.Command.Fn) (KWOTE Item) (KWOTE Menu) (KWOTE Key)) (PACK* (QUOTE AB-) (
CAR Item))))))
(AB.Command.Fn
(LAMBDA (item menu key) (* N.H.Briggs "18-Jun-86 13:09") (RESETLST (LET* ((realitem item) (window (
WINDOWPROP (WFROMMENU menu) (QUOTE MAINWINDOW))) (browser (WINDOWPROP window (QUOTE TABLEBROWSER)))) (
if (NOT (MEMBER item (fetch (MENU ITEMS) of menu))) then (* A subitem -- fetch main item) (SETQ item (
for I in (fetch (MENU ITEMS) of menu) thereis (AB.Subitemp item I)))) (if (OBTAIN.MONITORLOCK (fetch (
TABLEBROWSER TBLOCK) of browser) T T) then (RESETSAVE (SHADEITEM item menu MENUSELECTSHADE) (LIST (
FUNCTION SHADEITEM) item menu WHITESHADE)) (LET ((function (CADR realitem)) (promptwindow (
GETPROMPTWINDOW window)) extra) (if (OPENWP promptwindow) then (CLEARW promptwindow)) (if (LISTP
function) then (SETQ extra (CADR function)) (SETQ function (CAR function))) (APPLY* function browser
extra)) else (TB.BROWSER.BUSY browser))))))
(AB.Delete.Command
(LAMBDA (browser) (* N.H.Briggs " 4-Mar-87 17:01") (LET ((count 0) (browserpromptwindow (
GETPROMPTWINDOW (TB.WINDOW browser)))) (DECLARE (SPECVARS count)) (TB.MAP.SELECTED.ITEMS browser (
FUNCTION (LAMBDA (browser item) (DECLARE (SPECVARS count)) (TB.DELETE.ITEM browser item) (add count 1)
))) (if (EQ count 0) then (printout browserpromptwindow "No items marked for deletion.") else (
printout browserpromptwindow count " item" (if (IGREATERP count 1) then "s" else "")
" marked for deletion.")))))
(AB.Expunge.Command
(LAMBDA (browser) (* N.H.Briggs "18-Jun-86 12:23") (if (EQ (fetch (TABLEBROWSER TB#DELETED) of browser
) 0) then (printout (GETPROMPTWINDOW (TB.WINDOW browser)) "Nothing to expunge!") else (LET ((
directorystream (OPENSTREAM (PACKFILENAME (QUOTE VERSION) NIL (QUOTE BODY) (LISTGET (TB.USERDATA
browser) (QUOTE ARCHIVE))) (QUOTE OUTPUT)))) (if (NOT directorystream) then (printout (GETPROMPTWINDOW
(TB.WINDOW browser)) "Error opening (new version of) archive directory " (LISTGET (TB.USERDATA
browser) (QUOTE ARCHIVE)) " ...aborted.") else (LINELENGTH MAX.SMALLP directorystream) (* ensure
nothing wraps around) (LISTPUT (TB.USERDATA browser) (QUOTE ALLITEMS) (for item in (LISTGET (
TB.USERDATA browser) (QUOTE ALLITEMS)) when (NOT (TB.ITEM.DELETED? browser item)) collect (printout
directorystream (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of item)) , (fetch (AB.item
AB.Creation.Date) of (fetch (TABLEITEM TIDATA) of item))) (for media on (fetch (AB.item AB.Media) of (
fetch (TABLEITEM TIDATA) of item)) by (CDDR media) do (printout directorystream ,, (CAR media)) (
printout directorystream , (CADR media)) finally (printout directorystream T)) item)) (LISTPUT (
TB.USERDATA browser) (QUOTE ARCHIVE) (L-CASE (FULLNAME directorystream))) (CLOSEF directorystream) (
AB.Set.Browser.Title browser) (TB.MAP.DELETED.ITEMS browser (FUNCTION TB.REMOVE.ITEM)))))))
(AB.Filter.Command
(LAMBDA (browser) (* N.H.Briggs "18-Jun-86 12:28") (LET ((pattern (AB.Prompt.For.Input
"Files matching what? " (LISTGET (TB.USERDATA browser) (QUOTE FILTER)) browser T))) (if pattern then (
LISTPUT (TB.USERDATA browser) (QUOTE FILTER) (L-CASE pattern)) (AB.Set.Browser.Title browser) (
AB.Recompute.Command browser)))))
(AB.Recompute.Command
(LAMBDA (browser newdirectory?) (* N.H.Briggs "19-Sep-86 12:34") (LET* ((window (TB.WINDOW browser)) (
windowregion (WINDOWPROP window (QUOTE REGION))) (region (CREATEREGION 0 0 (fetch (REGION WIDTH) of
windowregion) (fetch (REGION HEIGHT) of windowregion))) (namewidth 0) (userdata (TB.USERDATA browser))
(filter (DIRECTORY.MATCH.SETUP (PACKFILENAME (QUOTE BODY) (LISTGET userdata (QUOTE FILTER))))) result
) (if (NOT (ZEROP (fetch (TABLEBROWSER TB#DELETED) of browser))) then (if (MENU (create MENU ITEMS ← (
QUOTE (("Expunge" (QUOTE Expunge) "Expunge items marked for deletion") ("Don't Expunge" NIL
"Don't expunge items marked for deletion"))) TITLE ← "Expunge deleted items?" CENTERFLG ← T)) then (
AB.Expunge.Command browser))) (if (AND newdirectory? (SETQ result (AB.Prompt.For.Input
"New archive directory? " NIL browser T))) then (LISTPUT userdata (QUOTE ARCHIVE) (PACKFILENAME.STRING
(QUOTE NAME) (OR (FILENAMEFIELD result (QUOTE NAME)) (QUOTE Archive)) (QUOTE EXTENSION) (OR (
FILENAMEFIELD result (QUOTE EXTENSION)) (QUOTE directory)) (QUOTE BODY) result))) (if (OR (NOT
newdirectory?) (AND newdirectory? result)) then (TB.REPLACE.ITEMS browser) (LISTPUT userdata (QUOTE
ALLITEMS) (for item in (AB.Read.Directory browser) bind tableitem eachtime (SETQ tableitem (create
TABLEITEM TIDATA ← item)) collect (if (DIRECTORY.MATCH filter (PACKFILENAME (QUOTE BODY) (fetch (
AB.item AB.Filename) of item))) then (SETQ namewidth (MAX namewidth (STRINGWIDTH (fetch (AB.item
AB.Filename) of item) AB.browser.font))) (TB.INSERT.ITEM browser tableitem)) tableitem)) (LISTPUT
userdata (QUOTE NAMEWIDTH) namewidth) (TB.DISPLAY.LINES browser (TB.FIRST.VISIBLE.ITEM# browser region
) (TB.LAST.VISIBLE.ITEM# browser region))))))
(AB.Retrieve.Command
(LAMBDA (browser) (* N.H.Briggs " 4-Mar-87 16:54") (DECLARE (GLOBALVARS AB.archivist)) (PROG ((count 0
) registry corestream) (DECLARE (SPECVARS corestream count)) (SETQ registry (SELECTQ (OR (LAFITEMODE)
(\LAFITE.INFER.MODE)) (GV ".pa") (NS ":PA") (RETURN (printout (GETPROMPTWINDOW (TB.WINDOW browser))
"Can't retrieve -- Lafite mode must be set to GV or NS")))) (SETQ corestream (OPENSTREAM (QUOTE
{NODIRCORE}) (QUOTE BOTH))) (LINELENGTH MAX.SMALLP corestream) (printout corestream
"Subject: Retrieve request" T "To: " AB.archivist registry T "cc: " (FULLUSERNAME) T T) (
TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item) (DECLARE (SPECVARS corestream count)) (
printout corestream "Retrieve: " (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of item))
" of " (fetch (AB.item AB.Creation.Date) of (fetch (TABLEITEM TIDATA) of item)) " from " (CAR (fetch (
AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item))) " or " (CADR (fetch (AB.item AB.Media) of (
fetch (TABLEITEM TIDATA) of item))) T) (add count 1)))) (if (EQ count 0) then (printout (
GETPROMPTWINDOW (TB.WINDOW browser)) "Nothing to retrieve.") (CLOSEF corestream) (RETURN)) (SETQ
corestream (OPENTEXTSTREAM corestream)) (printout (GETPROMPTWINDOW (TB.WINDOW browser))
"Sending mail to " AB.archivist registry " requesting " count " file" (if (NEQ count 1) then "s: "
else ": ")) (if (CAR (ERSETQ (LAFITE.SENDMESSAGE corestream))) then (printout (GETPROMPTWINDOW (
TB.WINDOW browser)) " done.") else (printout (GETPROMPTWINDOW (TB.WINDOW browser)) " failed.")))))
(AB.Retrieve.Directory.Command
(LAMBDA (browser) (* N.H.Briggs " 4-Mar-87 16:53") (DECLARE (GLOBALVARS AB.archivist)) (PROG ((count 0
) registry corestream newdirectory) (DECLARE (SPECVARS corestream count newdirectory)) (SETQ registry
(SELECTQ (OR (LAFITEMODE) (\LAFITE.INFER.MODE)) (GV ".pa") (NS ":PA") (RETURN (printout (
GETPROMPTWINDOW (TB.WINDOW browser)) "Can't retrieve -- Lafite mode must be set to GV or NS")))) (if (
NOT (SETQ newdirectory (AB.Prompt.For.Input "Directory to retrieve into? " NIL browser T))) then (
RETURN)) (SETQ corestream (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (LINELENGTH MAX.SMALLP
corestream) (printout corestream "Subject: Retrieve request" T "To: " AB.archivist registry T "cc: " (
FULLUSERNAME) T T) (TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item) (DECLARE (SPECVARS
corestream count newdirectory)) (printout corestream "Retrieve: " (fetch (AB.item AB.Filename) of (
fetch (TABLEITEM TIDATA) of item)) " of " (fetch (AB.item AB.Creation.Date) of (fetch (TABLEITEM
TIDATA) of item)) " from " (CAR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item)))
" or " (CADR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item))) " as " (
AB.Make.Cedar.Filename (PACKFILENAME.STRING (QUOTE DIRECTORY) newdirectory (QUOTE VERSION) NIL (QUOTE
BODY) (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of item)))) T) (add count 1)))) (if (
EQ count 0) then (printout (GETPROMPTWINDOW (TB.WINDOW browser)) "Nothing to retrieve.") (CLOSEF
corestream) (RETURN)) (SETQ corestream (OPENTEXTSTREAM corestream)) (printout (GETPROMPTWINDOW (
TB.WINDOW browser)) "Sending mail to " AB.archivist registry " requesting " count " file" (if (NEQ
count 1) then "s: " else ": ")) (if (CAR (ERSETQ (LAFITE.SENDMESSAGE corestream))) then (printout (
GETPROMPTWINDOW (TB.WINDOW browser)) " done.") else (printout (GETPROMPTWINDOW (TB.WINDOW browser))
" failed.")))))
(AB.Retrieve.Renamed.Command
(LAMBDA (browser) (* N.H.Briggs " 3-Mar-87 12:34") (DECLARE (GLOBALVARS AB.archivist)) (PROG ((count 0
) registry corestream) (DECLARE (SPECVARS corestream count)) (SETQ registry (SELECTQ (OR (LAFITEMODE)
(\LAFITE.INFER.MODE)) (GV ".pa") (NS ":PA") (RETURN (printout (GETPROMPTWINDOW (TB.WINDOW browser))
"Can't retrieve -- Lafite mode must be set to GV or NS")))) (SETQ corestream (OPENSTREAM (QUOTE
{NODIRCORE}) (QUOTE BOTH))) (LINELENGTH MAX.SMALLP corestream) (printout corestream
"Subject: Retrieve request" T "To: " AB.archivist registry T "cc: " (FULLUSERNAME) T T) (
TB.MAP.SELECTED.ITEMS browser (FUNCTION AB.Retrieve.Renamed.Aux)) (if (EQ count 0) then (printout (
GETPROMPTWINDOW (TB.WINDOW browser)) "Nothing to retrieve.") (CLOSEF corestream) (RETURN)) (SETQ
corestream (OPENTEXTSTREAM corestream)) (printout (GETPROMPTWINDOW (TB.WINDOW browser))
"Sending mail to " AB.archivist registry " requesting " count " file" (if (NEQ count 1) then "s: "
else ": ")) (if (CAR (ERSETQ (LAFITE.SENDMESSAGE corestream))) then (printout (GETPROMPTWINDOW (
TB.WINDOW browser)) " done.") else (printout (GETPROMPTWINDOW (TB.WINDOW browser)) " failed.")))))
(AB.Retrieve.Renamed.Aux
(LAMBDA (browser item) (* N.H.Briggs " 4-Mar-87 16:52") (DECLARE (SPECVARS corestream count)) (LET ((
newname (AB.Prompt.For.Input (CONCAT "Retrieve " (fetch (AB.item AB.Filename) of (fetch (TABLEITEM
TIDATA) of item)) " as ?") (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of item)) browser
"... skipped"))) (if newname then (printout corestream "Retrieve: " (fetch (AB.item AB.Filename) of (
fetch (TABLEITEM TIDATA) of item)) " of " (fetch (AB.item AB.Creation.Date) of (fetch (TABLEITEM
TIDATA) of item)) " from " (CAR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item)))
" or " (CADR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item))) " as " (
AB.Make.Cedar.Filename (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) newname)) T) (add count 1
)))))
(AB.Sort.Command
(LAMBDA (browser sorttype) (* N.H.Briggs "17-Jun-86 12:47") (LET ((items (fetch (TABLEBROWSER TBITEMS)
of browser))) (if (EQ sorttype (QUOTE Reverse)) then (SETQ items (DREVERSE items)) else (SORT items (
SELECTQ sorttype (CreationDate (FUNCTION (LAMBDA (x y) (IGREATERP (IDATE (fetch (AB.item
AB.Creation.Date) of (fetch (TABLEITEM TIDATA) of x))) (IDATE (fetch (AB.item AB.Creation.Date) of (
fetch (TABLEITEM TIDATA) of y))))))) (Archive (FUNCTION (LAMBDA (x y) (ILESSP (fetch (AB.item
AB.Sequence.Number) of (fetch (TABLEITEM TIDATA) of x)) (fetch (AB.item AB.Sequence.Number) of (fetch
(TABLEITEM TIDATA) of y)))))) (FUNCTION (LAMBDA (x y) (ALPHORDER (fetch (AB.item AB.Filename) of (
fetch (TABLEITEM TIDATA) of x)) (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of y)) (
UPPERCASEARRAY))))))) (for item in items as i from 1 do (replace TI# of item with i)) (
TB.REPLACE.ITEMS browser items) (TB.REDISPLAY.ITEMS browser))))
(AB.Undelete.Command
(LAMBDA (browser all?) (* N.H.Briggs " 4-Mar-87 17:00") (LET ((count 0) (browserpromptwindow (
GETPROMPTWINDOW (TB.WINDOW browser)))) (DECLARE (SPECVARS count)) (if all? then (TB.MAP.DELETED.ITEMS
browser (FUNCTION (LAMBDA (browser item) (DECLARE (SPECVARS count)) (TB.UNDELETE.ITEM browser item) (
add count 1)))) else (TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item) (DECLARE (
SPECVARS count)) (TB.UNDELETE.ITEM browser item) (add count 1))))) (if (EQ count 0) then (printout
browserpromptwindow "No items were undeleted.") else (printout browserpromptwindow count " item" (if (
NEQ count 1) then "s" else "") " undeleted.")))))
)
(* * miscellaneous functions)
(DEFINEQ
(AB.Set.Browser.Title
(LAMBDA (browser) (* N.H.Briggs "17-Jun-86 15:45") (LET ((archive (LISTGET (TB.USERDATA browser) (
QUOTE ARCHIVE))) (filter (LISTGET (TB.USERDATA browser) (QUOTE FILTER)))) (WINDOWPROP (GETPROMPTWINDOW
(TB.WINDOW browser)) (QUOTE TITLE) (CONCAT "Archive Browser" (OR (AND archive (CONCAT " " archive))
"") (OR (AND filter (CONCAT " - files " filter)) ""))))))
(AB.Iconfn
(LAMBDA (window icon) (* N.H.Briggs "19-Sep-86 18:58") (DECLARE (GLOBALVARS AB.titled.icon)) (LET* ((
browser (WINDOWPROP window (QUOTE TABLEBROWSER))) (archive (LISTGET (TB.USERDATA browser) (QUOTE
ARCHIVE))) (directory (UNPACKFILENAME.STRING archive (QUOTE DIRECTORY))) (host (UNPACKFILENAME.STRING
archive (QUOTE HOST))) (title (PACKFILENAME.STRING (QUOTE HOST) host (QUOTE DIRECTORY) (SUBSTRING
directory 1 (STRPOS directory ">"))))) (if icon then (ICONW.TITLE icon title) icon else (TITLEDICONW
AB.titled.icon title (FONTCREATE (QUOTE MODERN) 8) NIL NIL NIL (CHARCODE (})))))))
(AB.Closefn
(LAMBDA (window) (* edited: "20-Jun-86 12:42") (LET ((browser (WINDOWPROP window (QUOTE TABLEBROWSER))
)) (if (NOT (ZEROP (fetch (TABLEBROWSER TB#DELETED) of browser))) then (if (MENU (create MENU ITEMS ←
(QUOTE (("Expunge" (QUOTE Expunge) "Expunge items marked for deletion") ("Don't Expunge" NIL
"Don't expunge items marked for deletion"))) TITLE ← "Expunge deleted items?" CENTERFLG ← T)) then (
AB.Expunge.Command browser))) NIL)))
(AB.Printfn
(LAMBDA (browser item window) (* N.H.Briggs "22-Sep-86 13:09") (LET* ((entry (fetch TIDATA of item)) (
namewidth (OR (LISTGET (TB.USERDATA browser) (QUOTE NAMEWIDTH)) 0)) (offset (DSPXPOSITION NIL window))
(datestart (IPLUS offset namewidth 10))) (* if this is to work for variable spaced fonts it has to be
smart about the widths of date and media fields too) (PRIN1 (fetch (AB.item AB.Filename) of entry)
window) (if (ZEROP namewidth) then (PRIN1 " " window) else (BLTSHADE WHITESHADE window (DSPXPOSITION
NIL window) (IDIFFERENCE (DSPYPOSITION NIL window) (FONTPROP AB.browser.font (QUOTE DESCENT))) (
IDIFFERENCE datestart (DSPXPOSITION NIL window)) (FONTPROP AB.browser.font (QUOTE HEIGHT))) (
DSPXPOSITION datestart window)) (PRIN1 (fetch (AB.item AB.Creation.Date) of entry) window) (PRIN1
" " window) (for media in (fetch (AB.item AB.Media) of entry) do (PRIN1 media window) (PRIN1 " "
window)))))
(AB.Prompt.For.Input
(LAMBDA (prompt default browser abortflag) (* N.H.Briggs "22-Apr-86 17:32") (* * Prompt for input for
browser browser with question prompt offering default answer DEFAULT. If abortflag is true and
response is NIL, prints "... aborted" or abortflag (should be a text string)) (LET* ((promptwindow (
GETPROMPTWINDOW (TB.WINDOW browser))) (promptwidth (STRINGWIDTH prompt promptwindow)) (windowwidth (
WINDOWPROP promptwindow (QUOTE WIDTH))) result) (CLEARW promptwindow) (if (IGREATERP (IPLUS
promptwidth (STRINGWIDTH (OR default "XXX") promptwindow)) windowwidth) then (* Prompt plus default
response will overflow the width of the window, so be a nice guy and break it up) (for i from (
IDIFFERENCE (NCHARS prompt) 4) to 10 by -1 bind (excesswidth ← (IDIFFERENCE promptwidth windowwidth))
when (AND (EQ (NTHCHARCODE prompt i) (CHARCODE SPACE)) (IGREATERP (STRINGWIDTH (SUBSTRING prompt i)
promptwindow) excesswidth)) do (RETURN (SETQ prompt (CONCAT (SUBSTRING prompt 1 (IPLUS i -1)) "
" (SUBSTRING prompt (IPLUS i 1))))))) (SETQ result (CAR (NLSETQ (PROMPTFORWORD prompt default NIL
promptwindow NIL (QUOTE TTY) (CHARCODE (CR ESC)))))) (if (AND (EQ result NIL) abortflag) then (
PRINTOUT promptwindow (if (EQ abortflag T) then "... aborted" else abortflag))) (TERPRI promptwindow)
result)))
(AB.Read.Directory
(LAMBDA (browser) (* N.H.Briggs "22-Sep-86 12:53") (LET ((directorystream (AND (LISTGET (TB.USERDATA
browser) (QUOTE ARCHIVE)) (CAR (NLSETQ (OPENSTREAM (LISTGET (TB.USERDATA browser) (QUOTE ARCHIVE)) (
QUOTE INPUT)))))) (linerdtable (COPYREADTABLE (QUOTE ORIG))) (promptwindow (GETPROMPTWINDOW (TB.WINDOW
browser))) items) (if (NOT directorystream) then (printout promptwindow
"Can't find archive directory " (LISTGET (TB.USERDATA browser) (QUOTE ARCHIVE))) (LISTPUT (TB.USERDATA
browser) (QUOTE ARCHIVE) NIL) (AB.Set.Browser.Title browser) NIL else (LISTPUT (TB.USERDATA browser)
(QUOTE ARCHIVE) (L-CASE (FULLNAME directorystream))) (AB.Set.Browser.Title browser) (SETSEPR (LIST (
CONSTANT (CHARCODE EOL))) NIL linerdtable) (SETBRK NIL NIL linerdtable) (bind start end inputline
repeatuntil (EOFP directorystream) eachtime (SETQ inputline (RSTRING directorystream linerdtable)) (
READC directorystream) as i from 1 collect (create AB.item AB.Filename ← (L-CASE (SUBSTRING inputline
1 (SUB1 (SETQ end (STRPOS " " inputline))))) AB.Creation.Date ← (SUBSTRING inputline (ADD1 end) (SUB1
(SETQ end (STRPOS " " inputline (ADD1 end))))) AB.Media ← (first (SETQ end (ADD1 end)) repeatwhile
end eachtime (SETQ start (ADD1 end)) (while (EQUAL (SUBSTRING inputline start start) " ") do (SETQ
start (ADD1 start))) (SETQ end (STRPOS " " inputline start)) collect (SUBSTRING inputline start (AND
end (SUB1 end)))) AB.Sequence.Number ← i) finally (CLOSEF directorystream))))))
(AB.Subitemp
(LAMBDA (subitem item) (* N.H.Briggs "16-Apr-86 18:32") (* * True if subitem appears among the
subitems of item or descendents) (LET ((sub (CADDDR item))) (AND sub (EQ (CAR (LISTP sub)) (QUOTE
SUBITEMS)) (OR (MEMBER subitem sub) (for i in (CDR sub) thereis (AB.Subitemp subitem i)))))))
(AB.Make.Cedar.Filename
(LAMBDA (filename) (* N.H.Briggs " 3-Mar-87 12:08") (LET ((unpackedfilename (UNPACK filename))) (PACK
(SUBLIS (QUOTE (({ . %[) (} . %]) (; . !))) unpackedfilename)))))
)
(* * the user that gets retrieval requests)
(RPAQ? AB.archivist "Archivist")
(* * the structure for an archive entry)
[DECLARE: EVAL@COMPILE
(RECORD AB.item (AB.Filename AB.Creation.Date AB.Media AB.Sequence.Number))
]
(* * the icon)
(RPAQ AB.icon (READBITMAP))
(73 73
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"O@@@@@@AN@@@@@@@@AH@"
"ML@@@@@CK@@@@@@@@AH@"
"LOOOOOOOOOOOOOOOOIH@"
"LJ@@@@@DHG@@@@@@AIH@"
"LK@@@@AHHAL@@@@@FIH@"
"LIH@@@A@H@GH@@@@LIH@"
"LHF@@@G@H@@OL@@GHIH@"
"LHC@@COOOOOOGOOO@IH@"
"LHAH@C@CN@@A@@@F@IH@"
"LH@LON@FK@@A@@AL@IH@"
"LH@FNBAOOOOA@@CL@IH@"
"LH@CLBCHHL@A@@FH@IH@"
"LH@AKOOOOOOI@@MH@IH@"
"LH@ADB@@L@LA@AI@@IH@"
"LH@ANB@@L@CA@FA@@IH@"
"LH@@KCOOOOOOMOC@@IH@"
"LH@@IH@CL@@@CJB@@IH@"
"LH@@HH@FF@@@GBB@@IH@"
"LH@@HDALG@@@LFC@@IH@"
"LH@@HCOOOOOOHDA@@IH@"
"LH@@HCL@F@@G@DA@@IH@"
"LH@@HAOOOOOO@DAH@IH@"
"OH@AHAOOOOOO@D@H@IH@"
"LO@C@AOOOOOO@D@L@IH@"
"LION@CAHC@FA@D@GHIH@"
"LH@N@F@HA@LA@D@AOIH@"
"LH@GNL@DAAHAHBAO@IH@"
"LH@BGO@CAB@@LCOB@IH@"
"LH@B@MNAIFAOOO@F@IH@"
"LH@B@DCLOMNCHB@D@IH@"
"LH@B@D@COO@F@B@D@IH@"
"LH@B@D@@FGLB@B@D@IH@"
"LH@B@L@GL@CO@C@F@IH@"
"LH@B@HCL@@@GNAHC@IH@"
"LH@FAKL@@@@@AOLAHIH@"
"LH@DAL@@@@@@@AN@LIH@"
"LH@OO@@@@@@@@@CNFIH@"
"LHCL@@@@@@@@@@@CNIH@"
"OOO@@@@@@@@@@@@@AIH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LH@@@@@@@@@@@@@@@IH@"
"LOOOOOOOOOOOOOOOOIH@"
"L@@@@@@@@@@@@@@@@AH@"
"L@@@@@@@@@@@@@@@@AH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@")
(RPAQ AB.icon.mask (READBITMAP))
(73 73
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@"
"OOOOOOOOOOOOOOOOOOH@")
(RPAQ? AB.titled.icon (create TITLEDICON ICON ← AB.icon MASK ← AB.icon.mask TITLEREG ← (CREATEREGION
7 8 60 24)))
(* * the font for the browser, which must be a fixed pitch font for now)
(RPAQ AB.browser.font (FONTCREATE (QUOTE TERMINAL) 10))
(* * based on the TableBrowser package)
(FILESLOAD TABLEBROWSER)
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD TABLEBROWSERDECLS)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA AB)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS ARCHIVEBROWSER COPYRIGHT ("Xerox Corporation" 1986 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1797 5673 (ARCHIVEBROWSER 1807 . 5473) (AB 5475 . 5671)) (5715 18075 (
AB.When.Selected.Fn 5725 . 5965) (AB.Command.Fn 5967 . 6830) (AB.Delete.Command 6832 . 7357) (
AB.Expunge.Command 7359 . 8764) (AB.Filter.Command 8766 . 9109) (AB.Recompute.Command 9111 . 10870) (
AB.Retrieve.Command 10872 . 12460) (AB.Retrieve.Directory.Command 12462 . 14401) (
AB.Retrieve.Renamed.Command 14403 . 15599) (AB.Retrieve.Renamed.Aux 15601 . 16431) (AB.Sort.Command
16433 . 17398) (AB.Undelete.Command 17400 . 18073)) (18112 23830 (AB.Set.Browser.Title 18122 . 18509)
(AB.Iconfn 18511 . 19112) (AB.Closefn 19114 . 19567) (AB.Printfn 19569 . 20498) (AB.Prompt.For.Input
20500 . 21823) (AB.Read.Directory 21825 . 23323) (AB.Subitemp 23325 . 23630) (AB.Make.Cedar.Filename
23632 . 23828)))))
STOP