(FILECREATED " 8-Sep-86 16:41:16" {ERIS}<LISPCORE>LIBRARY>GIVE-AND-TAKE.;10 17320
changes to: (FUNCTIONS TAKE-FILE)
previous date: " 8-Sep-86 16:11:51" {ERIS}<LISPCORE>LIBRARY>GIVE-AND-TAKE.;9)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT GIVE-AND-TAKECOMS)
(RPAQQ GIVE-AND-TAKECOMS ((FNS GIVE TAKE STEAL GIVE-OR-TAKE-FIND ADD-DEFAULT-REGISTRY)
(FUNCTIONS GIVE-FILE TAKE-FILE TAKEN?)
(INITVARS (*GIVE-AND-TAKE-DIRECTORIES* (QUOTE ({ERIS}<LISPCORE>SOURCES>
{ERIS}<LISPCORE>LIBRARY>))))
(GLOBALVARS *GIVE-AND-TAKE-DIRECTORIES*)
(LISPXMACROS GIVE? TAKEN?)
(PROP FILETYPE GIVE-AND-TAKE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA STEAL TAKE GIVE)
(NLAML)
(LAMA)))))
(DEFINEQ
(GIVE
(NLAMBDA FILES (* bvm: "11-Jun-86 16:40")
(LET ((SCORE T))
(for FILE inside (NLAMBDA.ARGS FILES)
unless
(GIVE-FILE FILE)
do
(SETQ SCORE NIL))
SCORE)))
(TAKE
(NLAMBDA FILES (* bvm: "11-Jun-86 16:41")
(LET ((SCORE T))
(for FILE inside (NLAMBDA.ARGS FILES)
unless
(TAKE-FILE FILE)
do
(SETQ SCORE NIL))
SCORE)))
(STEAL
(NLAMBDA FILES (* amd " 5-Aug-86 11:47")
(LET ((SCORE T))
(for FILE inside (NLAMBDA.ARGS FILES)
unless
(TAKE-FILE FILE T)
do
(SETQ SCORE NIL))
SCORE)))
(GIVE-OR-TAKE-FIND
(LAMBDA (FILENAME) (* bvm: "11-Jun-86 17:49")
(LET ((NAME (FINDFILE FILENAME T *GIVE-AND-TAKE-DIRECTORIES*)))
(COND
(NAME)
(T (FORMAT T "~A does not exist and so cannot be taken or given.~%%" FILENAME)
NIL)))))
(ADD-DEFAULT-REGISTRY
(LAMBDA (NAME) (* bvm: "11-Jun-86 16:20")
(* * "Adds default registry to NAME if there isn't one there already")
(COND
((OR (STRPOS "." NAME)
(NULL DEFAULTREGISTRY))
NAME)
(T (CONCAT NAME "." DEFAULTREGISTRY)))))
)
(DEFUN GIVE-FILE (FILENAME) (* "Pavel" "11-May-86 00:11")
"Find the file named and look for a STATUS file associated with it. If found and this user wrote it, then remove it, thus unlocking the file."
(LET ((NAME (GIVE-OR-TAKE-FIND FILENAME))
STATUS-STREAM TAKEN-BY)
(COND
((NULL NAME)
NIL)
((NOT (STREAMP (SETQ STATUS-STREAM (CAR (NLSETQ (OPENSTREAM (PACKFILENAME.STRING
(QUOTE EXTENSION)
(QUOTE STATUS)
(QUOTE VERSION)
1
(QUOTE BODY)
NAME)
(QUOTE INPUT)
NIL
(QUOTE (DON'TCACHE))))))))
(FORMAT T "Sorry, but you can't give what you haven't taken.~%%~A has not been taken by anyone, including you.~%%"
NAME)
NIL)
((STRING-EQUAL (SETQ TAKEN-BY (ADD-DEFAULT-REGISTRY (CL:READ STATUS-STREAM)))
(ADD-DEFAULT-REGISTRY (USERNAME))) (* "We're a winner")
(DELFILE (CLOSEF STATUS-STREAM))
(FORMAT T "~A is now unlocked.~%%" NAME)
T)
(T (* "We're a loser")
(FORMAT T
"Sorry, but you can't give what you haven't taken.~%%~A was taken by ~A on ~A.~%%"
NAME TAKEN-BY (CL:READ STATUS-STREAM))
(CLOSEF STATUS-STREAM)
NIL))))
(DEFUN TAKE-FILE (FILENAME &OPTIONAL STEAL) (* "Pavel" "12-May-86 14:44")
"Find the given file and open a status file to be associated with it. If the file we open turns out to be version 1, then we've got the lock and we write our name and the date into the file. Otherwise, somebody (possibly us!) has already got it and the lock cannot be obtained."
(RESETLST (PROG ((GROSS-LIST-HACK (LIST NIL NIL T))
NAME STATUS-NAME STATUS-NAME-PARTS STATUS-VERSION SUCCESS)
(COND
((NOT (SETF NAME (GIVE-OR-TAKE-FIND FILENAME)))
(RETURN NIL)))
(SETF STATUS-NAME (PACKFILENAME.STRING (QUOTE EXTENSION)
(QUOTE STATUS)
(QUOTE VERSION)
NIL
(QUOTE BODY)
NAME))
(MACROLET ((STATUS-STREAM NIL (QUOTE (CL:FIRST GROSS-LIST-HACK)))
(STATUS-FULL-NAME NIL (QUOTE (SECOND GROSS-LIST-HACK)))
(FINISHED-NORMALLY-P NIL (QUOTE (THIRD GROSS-LIST-HACK))))
(RESETSAVE NIL (LIST (FUNCTION (CL:LAMBDA
(NAME GROSS-LIST-HACK)
(* "We have been interrupted during processing. Close any open streams and delete the status file we were making.")
(CL:WHEN (NOT (FINISHED-NORMALLY-P))
(FORMAT T
"Interrupted during processing of ~A. Take aborted.~%%"
NAME)
(CL:WHEN (AND (NULL (
STATUS-FULL-NAME
))
(STREAMP (
STATUS-STREAM
)))
(*
"If STATUS-FULL-NAME was never set, then STATUS-STREAM, if open, must refer to the new status file.")
(SETF (STATUS-FULL-NAME)
(FULLNAME (
STATUS-STREAM
))))
(CL:IF (STREAMP (STATUS-STREAM))
(CLOSEF? (STATUS-STREAM)))
(CL:IF (NOT (NULL (STATUS-FULL-NAME)
))
(DELFILE (STATUS-FULL-NAME)))
)))
NAME GROSS-LIST-HACK))
(SETF (STATUS-STREAM)
(OPENSTREAM STATUS-NAME (QUOTE OUTPUT)
NIL
(QUOTE (DON'TCACHE))))
(SETF (STATUS-FULL-NAME)
(FULLNAME (STATUS-STREAM)))
(COND
((= (FILENAMEFIELD (STATUS-FULL-NAME)
(QUOTE VERSION))
1) (* "We're a winner")
(LET ((UNAME (ADD-DEFAULT-REGISTRY (USERNAME)))
(D (DATE)))
(FORMAT (STATUS-STREAM)
"~S ~S~%%" UNAME D)
(CLOSEF (STATUS-STREAM))
(FORMAT T "~A is now locked by ~A at ~A.~%%" NAME UNAME D))
(LET ((INSTALLEDVERSION (CDAR (GET (ROOTFILENAME NAME)
(QUOTE FILEDATES)))))
(CL:UNLESS (STRING-EQUAL NAME INSTALLEDVERSION)
(FORMAT T
"Warning: File ~A is different from loaded file ~A~%%"
NAME INSTALLEDVERSION)))
(SETF SUCCESS T))
(T (* "We're a loser")
(CLOSEF (STATUS-STREAM))
(DELFILE (STATUS-FULL-NAME))
(SETF (STATUS-STREAM)
(CAR (NLSETQ (OPENSTREAM (PACKFILENAME.STRING (QUOTE VERSION)
1
(QUOTE BODY)
(STATUS-FULL-NAME))
(QUOTE INPUT)
NIL
(QUOTE (DON'TCACHE))))))
(COND
((NOT (STREAMP (STATUS-STREAM)))
(FORMAT T "Bad situation: Illegal versions of the status file exist.~&Try again in a moment or try to fix the problem.~%%"
)
(SETF SUCCESS NIL))
(STEAL (FORMAT T "Stealing ~A from ~A.~%%" NAME
(GETFILEINFO (STATUS-STREAM)
(QUOTE AUTHOR)))
(CLOSEF (STATUS-STREAM))
(DELFILE (FULLNAME (STATUS-STREAM)))
(SETF SUCCESS (TAKE-FILE FILENAME NIL)))
((PROG1 (NOT (NLSETQ (LET ((TAKEN-BY (CL:READ (STATUS-STREAM)))
(TAKEN-ON (CL:READ (STATUS-STREAM))))
(FORMAT T
"Sorry, but ~A was already taken by ~A on ~A.~%%"
NAME TAKEN-BY TAKEN-ON))))
(CLOSEF (STATUS-STREAM)))
(FORMAT T "Bad situation: Only an illegal status file exists.~%%Try again in a moment or try to fix the problem.~%%"
)
(SETF SUCCESS NIL))
(T (SETF SUCCESS NIL)))))
(SETF (FINISHED-NORMALLY-P)
T))
(RETURN SUCCESS))))
(DEFUN TAKEN? (&KEY ((:BY AUTHOR))
GIVE?) (COND
((NULL AUTHOR)
(SETQ AUTHOR (USERNAME))
(COND
((STRPOS "." AUTHOR)
(SETQ AUTHOR (SUBSTRING AUTHOR 1 (SUB1 (STRPOS "." AUTHOR)))))))
((OR (STRING-EQUAL AUTHOR "ANY")
(STRING-EQUAL AUTHOR "ALL")
(STRING-EQUAL AUTHOR "*"))
(SETQ AUTHOR NIL)))
(printout T "Looking for files taken by " (OR AUTHOR "any")
T)
(for DIR in *GIVE-AND-TAKE-DIRECTORIES* do
(RESETLST (LET ((GEN (\GENERATEFILES (PACKFILENAME.STRING
(QUOTE DIRECTORY)
DIR
(QUOTE NAME)
"*"
(QUOTE EXTENSION)
"STATUS")
(QUOTE (AUTHOR CREATIONDATE))
(QUOTE (RESETLST))))
NEXT THISAUTHOR DIRPRINTED)
(while (SETQ NEXT (\GENERATENEXTFILE GEN))
when
(PROGN (SETQ THISAUTHOR (\GENERATEFILEINFO
GEN
(QUOTE AUTHOR)))
(OR (NULL AUTHOR)
(STRPOS AUTHOR THISAUTHOR 1 NIL T
NIL UPPERCASEARRAY)))
do
(COND
((NOT DIRPRINTED)
(printout T T " " DIR T)
(SETQ DIRPRINTED T)))
(printout T (FILENAMEFIELD NEXT (QUOTE NAME))
16
(\GENERATEFILEINFO GEN (QUOTE
CREATIONDATE
))
40 THISAUTHOR)
(COND
((NOT GIVE?)
(TERPRI T))
((EQ (ASKUSER NIL NIL " Give? " NIL T)
(QUOTE Y))
(GIVE-FILE (PACKFILENAME.STRING
(QUOTE EXTENSION)
NIL
(QUOTE VERSION)
NIL
(QUOTE BODY)
NEXT)))))))))
(RPAQ? *GIVE-AND-TAKE-DIRECTORIES* (QUOTE ({ERIS}<LISPCORE>SOURCES> {ERIS}<LISPCORE>LIBRARY>)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *GIVE-AND-TAKE-DIRECTORIES*)
)
(ADDTOVAR LISPXMACROS (GIVE? (TAKEN? :GIVE? T))
(TAKEN? (APPLY (FUNCTION TAKEN?)
LISPXLINE)))
(PUTPROPS GIVE-AND-TAKE FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA STEAL TAKE GIVE)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS GIVE-AND-TAKE COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1106 2695 (GIVE 1116 . 1408) (TAKE 1410 . 1702) (STEAL 1704 . 1998) (GIVE-OR-TAKE-FIND
2000 . 2335) (ADD-DEFAULT-REGISTRY 2337 . 2693)))))
STOP