(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")

(FILECREATED "28-Oct-86 23:23:08" {ERIS}<LISPCORE>LIBRARY>GIVE-AND-TAKE.;12
 15825  

      previous date%: "17-Sep-86 16:12:46" {ERIS}<LISPCORE>LIBRARY>GIVE-AND-TAKE.;11)


(* "
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* '({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)))))
)
(CL: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
                                                                        'EXTENSION
                                                                        'STATUS
                                                                        'VERSION 1 'BODY NAME)
                                                                  'INPUT NIL '(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))))

(CL: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 (CL:SETF NAME (GIVE-OR-TAKE-FIND FILENAME)))
                       (RETURN NIL)))
                   (CL:SETF STATUS-NAME (PACKFILENAME.STRING 'EXTENSION 'STATUS 'VERSION NIL
                                               'BODY NAME))
                   (CL:MACROLET ((STATUS-STREAM NIL '(CL:FIRST GROSS-LIST-HACK))
                                 (STATUS-FULL-NAME NIL '(CL:SECOND GROSS-LIST-HACK))
                                 (FINISHED-NORMALLY-P NIL '(CL: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.")

                                                                        (CL: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))
                          (CL:SETF (STATUS-STREAM)
                                 (OPENSTREAM STATUS-NAME 'OUTPUT NIL '(DON'TCACHE)))
                          (CL:SETF (STATUS-FULL-NAME)
                                 (FULLNAME (STATUS-STREAM)))
                          (COND
                             ((= (FILENAMEFIELD (STATUS-FULL-NAME)
                                        '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 ((ROOTNAME (ROOTFILENAME NAME))
                                    INSTALLEDVERSION)
                                   (COND
                                      ((AND (GET ROOTNAME 'FILE)
                                            (NOT (STRING-EQUAL NAME (SETQ INSTALLEDVERSION
                                                                     (CDAR (GET ROOTNAME 'FILEDATES))
                                                                     ))))
                                       (FORMAT T 
                                              "Warning: File ~A is different from loaded file ~A~%%" 
                                              NAME INSTALLEDVERSION))))
                              (CL:SETF SUCCESS T))
                             (T 
                             (* ; "We're a loser")

                                (CLOSEF (STATUS-STREAM))
                                (DELFILE (STATUS-FULL-NAME))
                                (CL:SETF (STATUS-STREAM)
                                       (CAR (NLSETQ (OPENSTREAM (PACKFILENAME.STRING 'VERSION 1
                                                                       'BODY
                                                                       (STATUS-FULL-NAME))
                                                           'INPUT NIL '(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.~%%"
                                           )
                                    (CL:SETF SUCCESS NIL))
                                   (STEAL (FORMAT T "Stealing ~A from ~A.~%%" NAME
                                                 (GETFILEINFO (STATUS-STREAM)
                                                        'AUTHOR))
                                          (CLOSEF (STATUS-STREAM))
                                          (DELFILE (FULLNAME (STATUS-STREAM)))
                                          (CL: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.~%%"
                                           )
                                    (CL:SETF SUCCESS NIL))
                                   (T (CL:SETF SUCCESS NIL)))))
                          (CL:SETF (FINISHED-NORMALLY-P)
                                 T))
                   (RETURN SUCCESS))))

(CL: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
                                                                          'DIRECTORY DIR 'NAME "*"
                                                                          'EXTENSION "STATUS")
                                                                '(AUTHOR CREATIONDATE)
                                                                '(RESETLST)))
                                                    NEXT THISAUTHOR DIRPRINTED)
                                                   (while
 (SETQ NEXT (\GENERATENEXTFILE GEN))
                                                      when
 (PROGN (SETQ THISAUTHOR
                                                                   (\GENERATEFILEINFO GEN
                                                                          '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 'NAME)
                                                                16
                                                                (\GENERATEFILEINFO GEN 'CREATIONDATE)
                                                                40 THISAUTHOR)
                                                         (COND
                                                            ((NOT GIVE?)
                                                             (TERPRI T))
                                                            ((EQ (ASKUSER NIL NIL "  Give? " NIL T)
                                                                 'Y)
                                                             (GIVE-FILE (PACKFILENAME.STRING
                                                                         'EXTENSION NIL 'VERSION NIL
                                                                         'BODY NEXT)))))))))


(RPAQ? *GIVE-AND-TAKE-DIRECTORIES*
 '({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
 CL: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 (1129 2602 (GIVE 1139 . 1392) (TAKE 1394 . 1647) (STEAL 1649 . 1903) (GIVE-OR-TAKE-FIND 
1905 . 2241) (ADD-DEFAULT-REGISTRY 2243 . 2600)))))
STOP