(FILECREATED " 3-Feb-86 11:16:19" {ERIS}<LISPUSERS>KOTO>NEW>ARCHIVETOOL.;1 7754
changes to: (FNS FB.ArchiveCommand)
previous date: "19-Sep-85 14:52:12" {ERIS}<LISPUSERS>KOTO>ARCHIVETOOL.;1)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ARCHIVETOOLCOMS)
(RPAQQ ARCHIVETOOLCOMS ((COMS (* LOAD the FILEBROWSER first)
(FILES FILEBROWSER))
(COMS (* Archive Tool Stuff)
(FNS Arch.ConvertToCedarFileName Arch.ParseReturnMsg
Arch.BackgroundMenuFn)
(DECLARE: DONTEVAL@LOAD DOCOPY (ADDVARS
(BackgroundMenuCommands (ArchiveTool (QUOTE (
Arch.BackgroundMenuFn))
"Delete files specified in an archive response message")))
(P (SETQ BackgroundMenu))))
(COMS (* FILEBROWSER change)
(FNS FB.ArchiveCommand FB.AddArchiveCommandToMenu)
(GLOBALVARS Arch.CcToSelfFlg)
(INITVARS (Arch.CcToSelfFlg T))
(DECLARE: DONTEVAL@LOAD DOCOPY (P (FB.AddArchiveCommandToMenu))))))
(* LOAD the FILEBROWSER first)
(FILESLOAD FILEBROWSER)
(* Archive Tool Stuff)
(DEFINEQ
(Arch.ConvertToCedarFileName
(LAMBDA (LispFileName) (* fgh: " 5-Feb-85 15:56")
(* * Convert a Lisp file name to a Cedar filename with the / directory naming convention and the ! version
numbering)
(PROG (Extension (UnpackedName (UNPACKFILENAME LispFileName)))
(RETURN (L-CASE (CONCAT "/" (LISTGET UnpackedName (QUOTE HOST))
"/"
(PACK (DSUBLIS (QUOTE ((> . /)))
(UNPACK (LISTGET UnpackedName (QUOTE DIRECTORY)))))
"/"
(LISTGET UnpackedName (QUOTE NAME))
(COND
((SETQ Extension (LISTGET UnpackedName (QUOTE EXTENSION)))
(CONCAT "." Extension))
(T ""))
"!"
(LISTGET UnpackedName (QUOTE VERSION))))))))
(Arch.ParseReturnMsg
[LAMBDA (Window) (* bvm: "19-Sep-85 12:32")
(* * Parse an archive response msg contained in Window. Returns a list of the files archived.)
(PROG (TextObj TextStream CHAR#)
(RETURN (COND
((WINDOWP Window)
(SETQ TextObj (WINDOWPROP Window (QUOTE TEXTOBJ)))
(SETQ TextStream (WINDOWPROP Window (QUOTE TEXTSTREAM)))
(SETQ CHAR# 0)
(while (SETQ CHAR# (TEDIT.FIND TextStream "Archived:" (ADD1 CHAR#)))
collect (PACKFILENAME
(QUOTE BODY)
(U-CASE (PACKC (DSUBLIS (CHARCODE (("[" . "{")
("]" . "}")))
(PROGN (SETFILEPTR TextStream CHAR#)
(READ TextStream)
(until (NEQ (PEEKC TextStream)
(QUOTE % ))
do (BIN TextStream))
(until (EQ (PEEKC TextStream)
(QUOTE % ))
collect (BIN TextStream])
(Arch.BackgroundMenuFn
(LAMBDA NIL (* fgh: " 6-Feb-85 01:03")
(* * Archive tool called from background menu. Get from the user a window containing an archive system response
message, parse the messsage, and delete the archived files.)
(PROG (Window PromptWindow FileList)
(PROMPTPRINT "Click in the window containing the response from Archivist.pa")
(SETQ Window (WHICHW (GETPOSITION)))
(CLRPROMPT)
(COND
((AND (WINDOWP Window)
(TEXTSTREAMP (WINDOWPROP Window (QUOTE TEXTSTREAM))))
(SETQ FileList (Arch.ParseReturnMsg Window))
(COND
(FileList (SETQ PromptWindow (GETPROMPTWINDOW Window 5))
(COND
((MEMBER (PROMPTFORWORD "Okay to delete files? " "Yes" NIL PromptWindow)
(QUOTE ("Yes" "yes" "Y" "y")))
(CLEARW PromptWindow)
(bind Deleted? for File in FileList
do (SETQ Deleted? (DELFILE File))
(printout PromptWindow (CONCAT File (COND
(Deleted? " deleted.")
(T " not deleted.")))
T)
(DISMISS 500))
(printout PromptWindow "Deletions Completed" T)
(DISMISS 2000)
(REMOVEPROMPTWINDOW Window))))
(T (SETQ PromptWindow (GETPROMPTWINDOW Window 1))
(printout PromptWindow "No archived files found in message.")
(DISMISS 2000)
(REMOVEPROMPTWINDOW Window))))))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(ADDTOVAR BackgroundMenuCommands (ArchiveTool (QUOTE (Arch.BackgroundMenuFn))
"Delete files specified in an archive response message"))
(SETQ BackgroundMenu)
)
(* FILEBROWSER change)
(DEFINEQ
(FB.ArchiveCommand
(LAMBDA (BROWSER) (* fgh: " 3-Feb-86 11:15")
(* * Called from FileBrowser Archive command -- Archive all selected files)
(PROG ((FileEntriesList (FB.SELECTEDFILES BROWSER))
REGISTRY CoreStream)
(OR FileEntriesList (RETURN))
(SETQ REGISTRY (SELECTQ (OR (LAFITEMODE)
(\LAFITE.INFER.MODE))
(GV ".pa")
(NS ":PA")
(RETURN (FB.PROMPTWPRINT BROWSER T
"Can't -- Lafite mode must be set to GV or NS"))))
(FB.PROMPTWPRINT BROWSER "Archiving " (CONCAT (LENGTH FileEntriesList)
" file"
(COND
((CDR FileEntriesList)
"s")
(T "")))
"... ")
(SETQ CoreStream (OPENSTREAM (QUOTE {NODIRCORE})
(QUOTE BOTH)))
(LINELENGTH 1000 CoreStream) (* In case of long file names)
(* * Setup the header fields for the msg)
(printout CoreStream "Subject: Archive request" T "To: Archivist" REGISTRY T "Cc: ")
(COND
(Arch.CcToSelfFlg (printout CoreStream (FULLUSERNAME))))
(TERPRI CoreStream)
(TERPRI CoreStream)
(* * Convert the file names and enter them into the msg)
(for FileName in (for FileEntry in FileEntriesList collect (
Arch.ConvertToCedarFileName
(FB.FETCHFILENAME
FileEntry)))
do (printout CoreStream "Archive: " FileName T))
(* * Send the mail off thru the Grapevine)
(SETQ CoreStream (OPENTEXTSTREAM CoreStream))
(FB.PROMPTWPRINT BROWSER T "Sending mail to Archivist" REGISTRY " ...")
(COND
((CAR (ERSETQ (LAFITE.SENDMESSAGE CoreStream)))
(FB.PROMPTWPRINT BROWSER "Done" T))
(T (FB.PROMPTWPRINT BROWSER "Failed" T))))))
(FB.AddArchiveCommandToMenu
[LAMBDA NIL (* bvm: "19-Sep-85 13:52")
(DECLARE (GLOBALVARS FB.MENU.ITEMS))
(* * Append the Archive command to the FileBrowser menu)
(LET [(ITEM (QUOTE ("Archive" FB.ArchiveCommand
"Archives selected files by sending mail to Archivist.pa"]
(COND
((NOT (MEMBER ITEM FB.MENU.ITEMS)) (* Add it undoably)
(APPLY* (FUNCTION RPAQQ)
(QUOTE FB.MENU.ITEMS)
(APPEND FB.MENU.ITEMS (LIST ITEM])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS Arch.CcToSelfFlg)
)
(RPAQ? Arch.CcToSelfFlg T)
(DECLARE: DONTEVAL@LOAD DOCOPY
(FB.AddArchiveCommandToMenu)
)
(PUTPROPS ARCHIVETOOL COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1098 4661 (Arch.ConvertToCedarFileName 1108 . 1954) (Arch.ParseReturnMsg 1956 . 3051) (
Arch.BackgroundMenuFn 3053 . 4659)) (4905 7505 (FB.ArchiveCommand 4915 . 6906) (
FB.AddArchiveCommandToMenu 6908 . 7503)))))
STOP