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

(filecreated " 5-Dec-86 05:44:27" {eris}<lispcore>internal>library>give-and-take.\;8
 16094  

      |changes| |to:|  (variables *give-and-take-directories*)
                       (functions give-file take-file)

      |previous| |date:| "21-Nov-86 17:41:52" {eris}<lispcore>internal>library>give-and-take.\;7)


; Copyright (c) 1986 by Xerox Corporation.  All rights reserved.

(prettycomprint give-and-takecoms)

(rpaqq give-and-takecoms
 ((commands "give?" "taken?" "give" "take" "steal")
                          (functions give-or-take-find add-default-registry send-steal-message 
                                 give-file take-file taken?)
                          (variables *give-and-take-directories*)
                          (prop filetype give-and-take)))

(defcommand "give?"
 nil (taken? :give? t))


(defcommand "taken?"
 (&rest args) (cl:apply #'taken? args))


(defcommand "give"
 (&rest files) (for
 file in
 files always
 (give-file file)))


(defcommand "take"
 (&rest files) (for
 file in
 files always
 (take-file file)))


(defcommand "steal"
 (&rest files) (for
 file in
 files always
 (take-file file t)))


(cl:defun give-or-take-find
 (filename) (let ((name (findfile filename t *give-and-take-directories*))
                                             )
                                            (cond
                                               (name name)
                                               (t (cl:format t 
                                               "~A does not exist and so cannot be taken or given.~%" 
                                                         filename)
                                                  nil))))


(cl:defun add-default-registry
 (name) 

(* |;;;| "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 send-steal-message
 (thief author file) (lafite.sendmessage (mkstring (cl:format nil 
               "Subject: File stolen
To: ~A

~A just stole the file ~A from you.

	The STEAL command" author thief file))))


(cl:defun give-file
 (filename) "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)))))))
            (cl: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))
            (cl:format t "~A is now unlocked.~%" name)
            t)
           (t                                                (* \; "We're a loser")

              (cl: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) 
          
          (* |;;| "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))
                                                               (cl: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)))
                           (cl:format (status-stream)
                                  "~S ~S~%" uname d)
                           (closef (status-stream))
                           (cl: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))))))
                               (cl: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)))
                            (cl: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 
          
          (* |;;| "If we're going to steal it, we should send the former locker a notice.")


                                  (cl:format t "Stealing ~A (and sending ~A a message about it).~%" 
                                         name (getfileinfo (status-stream)
                                                     'author))
                                  (add.process `(send-steal-message ',(username nil nil t)
                                                       ',(getfileinfo (status-stream)
                                                                'author)
                                                       ',name))
                                  (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))))
                                                     (cl:if (string-equal taken-by (
                                                                                 add-default-registry
                                                                                    (username)))
                                                            (cl:format t 
                                                             "You've already had ~A taken, since ~A." 
                                                                   name taken-on)
                                                            (cl:format t 
                                                     "Sorry, but ~A was already taken by ~A on ~A.~%" 
                                                                   name taken-by taken-on)))))
                                   (closef (status-stream)))
                            (cl: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)))))))))


(defglobalvar *give-and-take-directories*
 '("{ERIS}<LISPCORE>SOURCES>" "{ERIS}<LISPCORE>LIBRARY>" 
                                                  "{ERIS}<LISPCORE>INTERNAL>LIBRARY>" 
                                                  "{ERIS}<LISPUSERS>LISPCORE>" 
                                                  "{ERIS}<LISPCORE>CML>TEST>") )


(putprops give-and-take filetype
 cl:compile-file)
(putprops give-and-take copyright ("Xerox Corporation" 1986))
(declare\: dontcopy
  (filemap (nil)))
stop