;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:Zetalisp -*-

;;; MAKE-TAPE - for making customer source tapes

;;; Based on PICON's MAKE-AI-TAPE:
;;; 1/28/87 11:54:29 -george carrette

;;; Expanded - handle multiple product data; new rules; etc.
;;; Now suitable for making system release tapes.
;;; 11/17/87 -keith corbett

;;; (SET-RELEASE)
;;; (MAKE-PRODUCT-TAPE)
;;;
;;; Shows directories and files being copied to tape.
;;; Shows time taken writing to tape.
;;;  (4.0 options takes about 54 minutes to make on lambda)
;;;

(defvar *release-product* nil "Product we're working on")

(defvar *release-file-host* (send (fs:get-pathname-host "SYS") :host)
  "Host product's source files are on")

(defvar *release-source-directory* 
	(ecase si:*release-major-version*
	  (4 '("L")))
  "Root directory for source - all pathnames are relative to this")

(defvar *release-root-directory*
	(ecase si:*release-major-version*
	  (4 '("RELEASE-4")))
  "Root directory for output (e.g., to transform for tapes) - may vary with release")

(defvar *release-source-file-list* nil "Current list of source files")
(defvar *release-rules-no-files-list* "List of fired rules for which no files were found")
(defvar *release-tape-finished* nil "The current product tape was written")
(defvar *release-tape-verified* nil "The current product tape was verified")

(defvar *default-root-dir* '("RELEASE"))
(defvar *default-file-host* (send (fs:translated-pathname "sys:release;") :host)
  "The host where auxiliary files such as log files go")

(defvar *release-author* nil "Who made the release tape")
(defvar *release-creation-date* nil "When release tape was made")

(defvar *generate-author* nil
  "If non-NIL, set each output file's author to *release-author*")
(defvar *generate-creation-date* nil
  "If non-NIL, set each output file's creation date to *release-creation-date*")
(defvar *release-files-not-backed-up* nil
  "If non-NIL, files on release tape will be marked as needing to be backed up")

;;;Might implement tape registration scheme, a-la PICON
(defvar *tape-registration-id* nil)
(defvar *tape-registration-marker* nil)


;;; ;;;  Release definitions
;;;

;;; Define releases
;;
;; A release-files property is a list of items of the form:
;;  (version-of <filespec> <version>)
;;  (system-files <system-name>) !!!System must be loadable, 'tho not necesarily loaded
;;  (files-matching <directory> <name> <type> <version>)
;;
;; A product-settings property is a plist whose car is the product name, and properties
;;  :author <creation-author>
;;  :root-directory <root-directory>
;;  :source-directory <source-directory>
;;  :creation-date <creation-date>

(defsubst release-files() (get *release-product* 'release-files))

;;; Define tapes
;;

(defmacro deftape (tapename
		   &optional
		   release-files
		   (source-directory *release-source-directory*)
		   (root-directory *release-root-directory*))
  (declare(zwei:indentation (1 1)))
  (setq release-files
	(or release-files `((complete-system ,tapename))))
  `(progn 
     (defprop ,tapename (,tapename
			 :source-directory ,source-directory
			 :root-directory ,root-directory)
       product-settings)
     (defprop ,tapename ,release-files release-files)
     (eval-when (eval load)
       (record-source-file-name ',tapename 'deftape))
     ',tapename))

;;;Xample
 
(deftape tester
  ((files-matching ("CUSTOMER-SITE") :wild :wild)
   (files-matching ("EXAMPLES") :wild "LISP"))
  ("L")
  ("RELEASE-4"))
		  

;;;Handling multiple releases / products.

(defun directorize(foo)
  (mapcar #'STRING-UPCASE
	  (if (atom foo) (ncons foo) foo)))

(defun get-release-settings(&optional (product *release-product*) &aux product-settings)
  (setq product-settings (get product 'product-settings))
  (setq  *release-author* (or (get product-settings :author) fs:user-id))
  (setq  *release-creation-date* (or (get product-settings :creation-date)
				     (time:get-universal-time)))
  (setq  *release-file-host* (or (get product-settings :file-host)
				 *release-file-host*
				 (send si:local-host :name)))
  (setq  *release-root-directory* (or (get product-settings :root-directory)
				      *release-root-directory*))
  (setq  *release-source-directory* (or (get product-settings :source-directory)
					*release-source-directory*))
  (setq  *release-files-not-backed-up* (or (get product-settings :not-backed-up)
					   *release-files-not-backed-up*))
  *release-product*)

(defun save-release-settings(&optional (product *release-product*))
  (unless (and product
	       (symbolp product)
	       (get product 'product-settings))
    (ferror nil "Product ~:[is NIL~;~:*~s is not a defined product~]" product))
  (setf (get product 'product-settings)
	(list *release-product*
	      :author *release-author*
	      :creation-date *release-creation-date*
	      :file-host *release-file-host*
	      :root-directory *release-root-directory*
	      :source-directory *release-source-directory*
	      :not-backed-up *release-files-not-backed-up*)))

(defun describe-release-settings ()
  (format t "~&; *** Release product ~A
             ~%; *** Release file author is ~A, creation date is ~A
             ~%; *** Root file host is ~a, root directory is ~{~:A~^.~:}; source directory is ~{~:A~^.~:};   
             ~%; *** Mark files on tape as ~@[not ~]backed up.~%"
	  *release-product*
	  (or *release-author* "????????")
	  (or (and *release-creation-date*
		   (time:print-universal-time *release-creation-date* nil))
	      "????????")
	  *release-file-host*
	  (or *release-root-directory* "????????")
	  *release-source-directory*
	  *release-files-not-backed-up*))

(defun set-release (&aux now product-settings)
  (cond ((or (null *release-product*)
	     (y-or-n-p "~&Do you want to change the current product from ~a ?" *release-product*))
	 (do ((prod (prompt-and-read :read "~&Work with product:")
		    (prompt-and-read :read "~&Work with product:")))
	     ((setq product-settings (get prod 'product-settings))
	      (setq *release-product* prod))
	   (beep)
	   (format t "~%That's not a defined product.."))
	 (get-release-settings)))
  (cond ((y-or-n-p "~&Do you want to change the release author from ~a?" *release-author*)
	 (do ()
	     ((setq *release-author* (prompt-and-read :string-or-nil "~&Product release AUTHOR: "))))))
  (setq now (time:get-universal-time))
  (cond ((y-or-n-p "~&Do you want to set the release date other than ~a ?"
		   (time:print-universal-time now nil))
	 (setq *release-creation-date* (prompt-and-read :date "~&Product release creation date: ")))
	('else
	 (setq *release-creation-date* now)))
  (cond ((y-or-n-p "~&Do you want to change the source file host from ~a ?" *release-file-host*)
	 (setq *release-file-host* (prompt-and-read :string "~&New file host:"))))
  (cond ((y-or-n-p "~&Do you want to change the release root directory from ~a?" *release-root-directory*)
	 (setq *release-root-directory*
	       (directorize (pathname-directory
			  (prompt-and-read :pathname "~&Product release root directory:"))))))
  (cond ((y-or-n-p "~&Do you want to set the release source directory from ~a ?" *release-source-directory*)
	 (setq *release-source-directory*
	       (directorize (pathname-directory
			  (prompt-and-read :string "~&Product release output directory:"))))))
  (setq *release-files-not-backed-up* (y-or-n-p "~&Mark files on tape as NOT backed up?"))
  (save-release-settings)
  (describe-release-settings))


;;; Utility functions for playing with files

(defun dir-lessp(dir1 dir2)
  (cond
    ((null dir2) nil)
    ((null dir1) t)
    ((string-lessp (car dir1) (car dir2)) t)
    ((string-equal (car dir1) (car dir2))
     (dir-lessp (cdr dir1) (cdr dir2)))
    (t nil)))

(defun dir-equal(dir1 dir2)
  (cond
    ((not(eql (length dir1) (length dir2))) nil)
    ((null(and dir1 dir2)) t)
    ((string-equal (car dir1) (car dir2))
     (dir-equal (cdr dir1) (cdr dir2)))
    (t nil)))

(defun pathname-lessp(path1 path2)
  (setq path1 (pathname path1))
  (setq path2 (pathname path2))
  (let((dir1 (pathname-directory path1))
       (dir2 (pathname-directory path2)))
    (if (atom dir1) (setq dir1 (ncons dir1)))
    (if (atom dir2) (setq dir2 (ncons dir2)))
    (cond
      ((dir-lessp dir1 dir2) t)
      ((not(dir-equal dir1 dir2)) nil)
      ((string-lessp (pathname-name path1) (pathname-name path2)) t)
      ((string-greaterp (pathname-name path1) (pathname-name path2)) nil)
      ((string-lessp (pathname-type path1) (pathname-type path2)) t)
      ((string-greaterp (pathname-type path1) (pathname-type path2)) nil)
      ((string-lessp (pathname-version path1) (pathname-version path2))))))

(defun product-file-lessp(flist1 flist2 &aux dist1 dist2)
  (setq dist1 (get flist1 :distribution-file-p))
  (setq dist2 (get flist2 :distribution-file-p))
  (cond
    ((and dist1 (not dist2)) t)
    ((and dist2 (not dist1)) nil)
    (t (pathname-lessp (car flist1) (car flist2)))))

;;; ;;;
;;; Selecting out files -- rule primitives
;;;

;;; Declaring rules

(defun rule-p(sym)
  (get :is-rule-p sym))

(defun set-rule(sym val)
  (setf (get :is-rule-p sym) val))

(defsetf rule-p set-rule)

(defun is-rule-documentation (sym)
  (documentation sym 'make-tape-rule))

(defun is-rule(sym &optional doc-string)
  (setf (rule-p sym) t)
  (setf (documentation sym 'make-tape-rule) doc-string))

;;; Running rules

(defun run-rule(rule)
  (typecase rule
    (null nil)
    (atom rule)
    (list
     (let((fcn (car rule))
	  (args (cdr rule)))
       (if (rule-p fcn)
	   (progn
	     (format t "~%Firing rule ~A~@[ - ~A~]" fcn (is-rule-documentation fcn))
	     (apply (symbol-function fcn)
		    (mapcar #'run-rule args)))
	 rule)))))

;;;Rules begin here.

(defun files-matching(dirspec
		      &optional
		      (name :wild) (type :wild) (version :highest)
		      recursive
		      &aux path1)
  "Returns the pathname/plist specs for files matching the specifications.
 DIRSPEC - a directory in list format, relative to *release-source-directory*.
 NAME - :WILD (match all files) or a string, or wild-card specification.
 TYPE - :WILD, or a string, or wild-card specification.
 VERSION - :WILD, or :HIGHEST, or absolute version number.
 RECURSIVE - if non-NIL, all subdirectories are also searched for matches."
  (setq dirspec (directorize dirspec))
  (if (and (symbolp name) (not (keywordp name)))
      (setq name (string name)))
  (if (and (symbolp type) (not (keywordp type)))
      (setq type (string type)))
  (setq path1 (make-pathname
			:host *release-file-host*
			      :name name
			      :type type
			      :version version
			      :directory
			      (typecase *release-source-directory*
				(null dirspec)
				(atom (cons *release-source-directory* dirspec))
				(list (append *release-source-directory* dirspec)))))
  (append
    (loop for dlist in  (fs:directory-list path1)
	  as path = (first dlist)
	  when path
	  collect dlist)
    (and recursive
	 (setq path1 (make-pathname :defaults path1
				     :name :wild
				     :type "DIRECTORY"
				     :version :highest))
	 (loop for dlist in (fs:directory-list path1)
			     as path = (first dlist)
			     when (and path (get dlist :directory))
			     append (files-matching
				      (reverse (cons (pathname-name path) (reverse dirspec)))
				      name
				      type
				      version
				      recursive)))))

(is-rule 'files-matching "list files by wild-card pathname specification")

(defun files-excluding(specs excludes)
  "Given a list of pathname//plist SPECS (e.g. from FILES-MATCHING),
remove the files in EXCLUDES."
  (loop for spec in specs
	as path = (car spec)
	when (not (member spec excludes))
	collect spec))

(is-rule 'files-excluding "exclude files from list by wild-card pathname specification")

(defun names-excluding(names specs)
  "Given a list of pathname/plist SPECS (e.g. from FILES-MATCHING),
weed out the files whose names match (using STRING-EQUAL) a member of NAMES."
  (declare(zwei:indentation (1 2)))
  (loop for spec in specs
	as path = (car spec)
	when (not (mem #'string-equal (pathname-name path) names))
	collect spec))

(is-rule 'names-excluding "exclude files from list by matching filename (only)")

(defun types-only (specs &optional (types '(:lisp)))
  "Given a list of pathname/plist SPECS (e.g. from FILES-MATCHING),
keep specified (canonical) types only."
  (declare(zwei:indentation (1 2)))
  (loop for spec in specs
	as path = (car spec)
	as type = (send path :canonical-type)
	when
	(or (member type types)
	    (format t "~%TYPES-ONLY skipping ~A - ~S" path type))
	collect spec))

(is-rule 'types-only "include files from list by matching canonical type")

(defun combining-files(&rest lists)
  (apply #'append lists))

(is-rule 'combining-files "combine any number of files lists")

(defun display-files (herald &rest lists)
  (declare (zwei:indentation 1 3))
  (format t "~2%~A~%" herald)
  (prog (files)
	(setq files
	      (lisp:sort
		(remove-duplicates
		  (apply #'append (copy-tree lists))
		  :key #'car)
		#'product-file-lessp))
	(lprint files)
	(return files)))

(is-rule 'display-files "combine files lists, sort, remove duplicates, and display")


;;; Finding/excluding patch files

(defun string-tokens(str)
  (multiple-value-bind(token end)
      (read-from-string str :eof)
    (when (neq token :eof)
      (cons token
	    (string-tokens (subseq str end))))))

(defun patch-file-name-candidate-p(pathname &aux name)
  (and
    (setq name (pathname-name pathname))
    (string-search #\- pathname)		;system-dependent!!!
    (setq name 
	  (substitute #\space #\- (pathname-name pathname)
		      :test #'char-equal))
    (setq name (reverse (string-tokens name)))
    (numberp (first name))
    (numberp (second name))))

(defparameter *patch-file-name-rule* #'patch-file-name-candidate-p
  "If non-NIL, a function which inspects a pathname and determines whether
it obeys the ''rules'' for patch file naming conventions.
Otherwise, only file attributes will be checked.")
  
(defun patch-file-p(pathname &aux attributes)
  "Determine, as best as possible, whether a file is a patch file.
Value of *PATCH-FILENAME-RULE* must be NIL, or a function to determine
whether a pathname corresponds to standard patch file naming convention
format."
  (and
    (setq attributes (fs:file-attribute-list pathname))
    (getf attributes :patch-file)
    (or (null *patch-file-name-rule*)
	(funcall *patch-file-name-rule* pathname))))

(defun excluding-patch-files(specs)
  "Given a list of pathname/plist SPECS (e.g. from FILES-MATCHING),
exclude files that satisfy PATCH-FILE-P."
  (loop for spec in specs
	as path = (first spec)
	when (not (patch-file-p path))
	collect spec))

(is-rule 'excluding-patch-files "remove patch-files from files list")

(defun only-patch-files(specs)
  "Given a list of pathname/plist SPECS (e.g. from FILES-MATCHING),
return only files that satisfy PATCH-FILE-P."
  (loop for spec in specs
	as path = (first spec)
	when (patch-file-p path)
	collect spec))

(is-rule 'only-patch-files "keep only patch files from files list")


(defun latest-patch-files-1 (name &key (source t) (binary t) (start 1) &aux system)
  "Given a system NAME, return the list of pathname//property plists
/(like FILES-MATCHING/) for the system, version, and patch files
corresponding to the loaded system."
  (setq system (si:find-system-named name))
  (setq name (si:system-name system))
  (format t "~&Checking on-line ~a system versions..." name)
  (multiple-value-bind(major minor)
      (si:get-system-version name)
    (if (and major minor)
	(progn (format t "Ok. Also load patches...")
	       (load-patches name :noselective)
	       (format t "Ok.~&"))
      (progn
	(format t "~&Try getting system versions from disk...")
	(multiple-value-setq (major minor)
	  (get-system-version-from-disk name))
	(if (and major minor)
	    (format t "Ok.~&")
	  (format t "Not available."))))
    (cond
      ((not(si:system-patchable-p system))
       (cerror "Return null files list and proceed anyway"
	       "System ~a is not patchable; no need to collect patch files"
	       name))
      ((not(numberp major))
       (cerror "Describe system, then return null files list and proceed anyway"
	       "Cannot determine major version for system ~a" name)
       (si:describe-system name :show-transformations nil))
      (t
       (format t "~&List latest patch files for ~A version ~D.~D"
	       name major minor)
       (append
	 (list (si:patch-system-pathname name :system-directory)
	       (si:patch-system-pathname name :version-directory major))
	 (do((patch start (1+ patch))
	     (files nil))
	    ((> patch minor)
	     (reverse files))
	   (if source (push (si:patch-system-pathname name :patch-file major patch :lisp) files))
	   (if binary (push (si:patch-system-pathname name :patch-file major patch :qfasl) files))))))))

(defun maybe-make-system (system &optional (make-system-p nil))
  (when make-system-p (make-system system :print-only :noconfirm)))

(defun latest-patch-files (system &optional (make-system-p nil))
  "Collect up-to-date patch directories and files for SYSTEM.
With MAKE-SYSTEM non-NIL, run MAKE-SYSTEM to load SYSTEM information into world."
  (maybe-make-system system make-system-p)
  (mapcar #'fs:file-properties (latest-patch-files-1 system)))

(is-rule 'latest-patch-files "collect patch files for system, whether loaded or not")


(defun system-files-1 (system &optional source-only &aux system-name nice-name system-files)
  "Return a list of pathnames for files that make up source and load modules for SYSTEM."
  (setq system (si:find-system-named system))
  (setq system-name (si:system-symbolic-name system))
  (setq nice-name (si:system-name system))
  (macrolet ((keep (file) `(pushnew ,file system-files)))
    ;;FOO.SYSTEM
;    (let ((system-file (make-pathname :defaults "SYS:SITE;"
;				      :name (string system-name)
;				      :type "SYSTEM")))
;      (if (probe-file system-file)
;	  (keep system-file)))
    ;;FOO.SYSDEF
    (let ((source-file (si:get-source-file-name system-name 'defsystem)))
      (if source-file (keep (send source-file :source-pathname))
	(multiple-value-bind (source-file source-origin)
	    (si:get-source-file-name system-name)
	  (if source-file
	      (progn
		(cerror "Use ~a as source for ~*~a anyway"
			"~s is the ~s source for system ~a, but not the ~a source"
			source-file source-origin system-name 'defsystem)
		(keep (send source-file :source-pathname)))
	    (error "The source file for system ~a cannot be determined")))))
    ;;Sources and binaries
    (dolist (file (si:system-source-files system (if source-only '(:lisp) :all) t t))
      (keep file))
    ;;I'm not sure the above will catch everything.  This is the
    ;;advertised way to get compile input/outputs, and I know it's not
    ;;complete, but it's insurance:
    (dolist (pair (si:transformations-that-compile (make-system system-name
								:reload
								:recompile :print-only :silent
								:no-reload-system-declaration)))
      (keep (first pair))
      (unless source-only (keep (second pair))))
    ;;Don't want warnings file
    (let ((warnings-pathname (si:system-warnings-pathname-default system)))
      (when warnings-pathname
	(setq system-files (remove warnings-pathname system-files))))
    ;;Finally, return list
    (remove-duplicates system-files)))

(defun system-files (system &optional source-only)
  (mapcar #'fs:file-properties (system-files-1 system source-only)))

(is-rule 'system-files "system definition, source, and load files")

(defun complete-system (system &optional (load nil))
  (when load (make-system system :noconfirm))
  (append (latest-patch-files system)
	  (system-files system)))

(is-rule 'complete-system "system definition, source, load, patch files, and patch directories")

;;;These might be useless 

(defun get-major-version-from-system-directory (file &aux token version)
  (with-open-file (input file)
    (setq token (read input)))
  (if (and (listp token)
	   (numberp (setq version (second token))))
      version
    (error "Invalid patch system token found in ~a: ~s" file (or version token))))

(defun get-minor-version-from-version-directory (file &aux token version)
  (with-open-file (input file)
    (setq token (read input)))
  (if (and (listp token)
	   (numberp (setq version (car (car (last (second token)))))))
      version
    (error "Invalid patch system token found in ~a: ~s" file (or version token))))

(defun get-system-version-from-disk (system)
  (declare (values major minor))
  (setq system (si:find-system-named system))
  (let (major minor)
    (setq major (get-major-version-from-system-directory
		  (si:patch-system-pathname (si:system-name system) :system-directory)))
    (setq minor (get-minor-version-from-version-directory
		  (si:patch-system-pathname (si:system-name system) :version-directory major)))
    (when (and (numberp major) (numberp minor))
	(values major minor))))    

(defun system-patch-directories-only-1(system &aux system-name)
  (setq system (si:find-system-named system))
  (setq system-name (si:system-name system))
  (if (not (si:system-patchable-p system))
      (warn "System ~a is not patchable; cannot collect system patch directories"
	    system-name))
    (let*((patchstuff (getf (si:system-plist system) :patch-directory))
	  (patchprefix (string (fourth patchstuff)))
	  (patchdir (si:patch-system-pathname system-name :system-directory))
	  (patchversion (or (si:get-system-version system)
			    (get-major-version-from-system-directory patchdir)
			    (error "Cannot get ~a system version from world or disk" system-name)))
	  (patchvdir (si:patch-system-pathname system-name :version-directory patchversion))
	  (patchname (format nil "~a-~d" patchprefix patchversion)))
      (when patchdir
	(if (> (length (directory (make-pathname :defaults patchdir
						 :name (string-append patchname "*")
						 :type :wild)))
	       1)
	    (cerror "Proceed anyway - include patch directories, but not patch files, on tapes."
		    "The ~a system has current patch files!"
		    (si:system-name system)))
	(list patchdir patchvdir))))

(defun system-patch-directories-only (system)
  (mapcar #'fs:file-properties (system-patch-directories-only-1 system)))

(is-rule 'system-patch-directories-only "system patch directories only, no patch files")

(defun old-system (system)
  (append (system-patch-directories-only system)
	  (system-files system)))

(is-rule 'old-system "xxx.0 version of system (system files, patch directories, no patch files")

;;;Miscellaneous rules

;;;Collect and mark a .DISTRIBUTION file - set :DISTRIBUTION-FILE-P property.

(defun distribution-file (dir name)
  "Calls FILES-MATCHING with DIR, NAME, type 'DISTRIBUTION'.
Returns a list of the (hopefully, only one) .DISTRIBUTION file for NAME
in DIR (relative to release source directory)."
  (loop for flist in  (files-matching dir name "DISTRIBUTION")
	as path = (car flist)
	do (setf (get flist :distribution-file-p) t)
	when path
	collect flist))

(is-rule 'distribution-file "xxxx.DISTRIBUTION tape installation file")

;;;Useful for testing - line print a pathname/plist list

(defun lprint (x)
  (format t "~2%----")
  (dolist (plist x)
    (format t "~&~A" (car plist)))
  (format t "~2%-----"))

(defun fprint (p &optional (func 'ignore))
  (let((time:*default-date-print-mode* :mm//dd//yy))
    (format t "~&  ~A~50,5T~4D ~5D(~D) ~@[~\time\~] ~A~@[ ~S~]"
	    (first p)
	    (get p :length-in-blocks)
	    (get p :length-in-bytes)
	    (get p :byte-size)
	    (get p :creation-date)
	    (get p :author)
	    (when func (funcall func p)))))

(defun lprint (x &optional func)
  (format t "~2%----")
  (dolist (plist x)
    (fprint plist func))
  (format t "~2%-----"))

(defun compare-flists (old new &aux diffs)
  (setq diffs
	(sort (set-difference old new :key #'car) #'product-file-lessp))
  (lprint diffs
	  #'(lambda(plist)
	      (if (member plist old) "- missing from NEW" "- missing from OLD"))))
  

;;; ;;;;
;;; Making tapes
;;;

(defvar *release-log-stream*)

(defun release-logfile-stream (&optional logfile &aux path)
  (etypecase logfile
    (null standard-output)
    (stream logfile)
    ((or string pathname)
     (setq path (merge-pathnames
		  logfile
		  (make-pathname
		    :defaults (fs:translated-pathname "sys:release;")
		    :host (or *release-file-host* 'local)
		    :name (string (or *release-product* "PRODUCT"))
		    :type "TAPELOG"
		    :version :highest)))
     (format t "~%>> Begin logging standard output simultaneously to ~a" path)
     (setq *release-log-stream* 
	   (make-broadcast-stream standard-output
				  (open path :direction :output))))))

(defmacro yes-with-timeout(fmt &rest args)
  `(progn (send query-io :clear-input)
	  (y-or-n-p-with-timeout ,(* 60 60 2) t ,fmt ,@args)))

(defmacro no-with-timeout(fmt &rest args)
  `(progn (send query-io :clear-input)
	  (y-or-n-p-with-timeout ,(* 60 60 2) nil ,fmt ,@args)))

(defun note-product-tape-information ()
  (putprop *release-product* *release-source-file-list* 'release-source-file-list)
  (putprop *release-product* *release-rules-no-files-list* 'release-rules-no-files-list)
  (putprop *release-product* *release-tape-finished* 'release-tape-finished)
  (putprop *release-product* *release-tape-verified* 'release-tape-verified))

(defun clear-product-tape-information ()
  (setq *release-source-file-list* nil
	*release-rules-no-files-list* nil
	*release-tape-finished* nil
	*release-tape-verified* nil)
  (note-product-tape-information))

(defun print-product-tape-information ()
  (format t "~%There are ~D file~:P for ~A"
	  (length *release-source-file-list*)
	  *release-product*)
  (cond ((and *release-tape-finished* *release-tape-verified*)
	 (format t "~%Output to tape was finished and files were verified"))
	(*release-tape-finished*
	 (warn "Tape was finished but files were not verified"))
	(*release-tape-verified*
	 (warn "???Tape verified but not finished??? Logic bug!"))
	(t (warn "~%Output to tape was not completed"))))


(defvar *release-source-file-abort-list* nil)

(defun make-product-tape(&optional logfile &aux got-done total-length)
  (set-release)
  (when (eq logfile t) (setq logfile (string *release-product*)))
  (clear-product-tape-information)
  (with-open-stream (standard-output (release-logfile-stream logfile))
    (unwind-protect
	(progn
	  (si:write-responsibility-comment standard-output)
	  (describe-release-settings)
	  (setq *release-rules-no-files-list* nil)
	  (let((sourcelist
		 (loop for spec in (release-files)
		       as msg = (format t "~2%*** Rule is ~s : " spec)
		       as files = (run-rule spec)
		       do
		       (format t "~%===== ~:[no files????~;~d file~:p.~]" files (length files))
		       (unless files
			 (push spec *release-rules-no-files-list*))
		       append files)))
	    (assert sourcelist () "No files found???")
	    (when *release-rules-no-files-list*
	      (beep)
	      (format t "~2%")
	      (pprint *release-rules-no-files-list*)
	      (format t "~2%")
	      (cerror "Proceed anyway."
		      "Some rule~p (listed above) produced no files: ~s"
		      (length *release-rules-no-files-list*)
		      *release-rules-no-files-list*))
	    (format t "~2%*** Removing duplicates from ~d file~:p..." (length sourcelist))
	    (setq sourcelist
		  (remove-duplicates sourcelist :key #'car))
	    (format t "~2%*** Sorting ~d file~:p..." (length sourcelist))
	    (setq sourcelist
		  (sort sourcelist #'product-file-lessp))
	    ;;Set global list
	    (setq *release-source-file-abort-list*
		  (setq *release-source-file-list* sourcelist))
	    (format t "~2%*** Done creating source list.")
	    (when (yes-with-timeout "~%List out the source files?")
	      (send-if-handles *standard-output* :set-more-p t)
	      (format t "~2%")
	      (loop for plist in sourcelist
		    do (format t "~&~a" (car plist))))
	    (format t "~2%*** Total length in blocks will be ~d."
		    (setq total-length
			  (loop for x in *release-source-file-list*
				as len = (length-in-blocks x) summing len)))
;;I need to fix this - estimate if stuff will fit on tape:
;	  (cond
;	    ((not (numberp total-length))
;	     (format t "~2%??? The data is no good."))
;	    ((< total-length 20000.)
;	     (format t "~2%... This ought to fit on a 1200' reel."))
;	    ((< total-length 40000.)
;	     (format t "~2%... This ought to fit on a 2400' reel."))
;	    (t (format t "~2%??? Will this fit on a tape???")))
	    (cond
	      ((yes-with-timeout "Go ahead and make tape?")
	       (make-tape-of-files *release-source-file-list*)
	       (format t "~%Done making tape."))
	      (:ELSE (format t "~%Done - no tape made."))))
	  (setq got-done t)
	  (print-product-tape-information))
      ;;Clean-up for UNWIND-PROTECT
      (if got-done
	  (note-product-tape-information)
	(clear-product-tape-information)))))

(defmacro handling-make-tape-errors (flag msg &body body)
  (let ((tag (gensym "RETRY-TAPE-")))
    `(condition-resume '((fs:file-error tape:tape-error sys:remote-network-error)
			 :retry-make-tape-operation T
			 (,msg)
			 (lambda (ignore) (throw ',tag :retry)))
       (block ,tag
	 (loop
	   (catch ',tag
	     (return-from ,tag
	       (tape:with-device-locked tape:*selected-device*
		   (setf ,flag nil)
		   ,@body
		   (setf ,flag t)))))))))

(defun make-tape-of-files (files)
  (handling-make-tape-errors *release-tape-finished*
			     "Retry making the tape from the beginning"
    (tape:rewind)
    (copy-files-to-tape files)
    (tape:finish-tape)
    (tape:rewind))
  (if (and *release-tape-finished*
	   (yes-with-timeout "Verify files on tape? "))
      (verify-files-on-tape files)
    *release-tape-finished*))

(defun verify-tape-of-files (files)
  (handling-make-tape-errors *release-tape-verified*
			     "Verify tape from the beginning"
    (tape:rewind)
    (verify-files-on-tape files)
    (tape:rewind))
  (format t "~&???Is release tape verified or no? ~s" *release-tape-verified*))

;;Below there be dragons

(defvar *standard-io-env*
	`((*package* ,(FIND-PACKAGE 'USER))
	  (*readtable* #+LMI ,(SI:FIND-READTABLE-NAMED "CL")
		       #+TI  ,SI:COMMON-LISP-READTABLE)
	  (base 10)
	  (ibase 10)
	  (*nopoint t)))


(defun list-release-logs (&optional name)
  (listf (fs:make-pathname :host *default-file-host*
			   :directory (append *default-root-dir* '("RELEASE-LOGS"))
			   :name name
			   :version :newest)))

(defun view-release-log (name)
  (viewf (fs:make-pathname :host *default-file-host*
			   :directory (append *default-root-dir* '("RELEASE-LOGS"))
			   :name name
			   :type "TEXT"
			   :version :newest)))
			   

(defvar *force-registration-id* nil)
(defvar *default-bin-directory* #+LMI 'lmi-rel-3 #+TI 'ti-rel-2)
(defvar *possible-bin-directories* '(lmi-rel-3 lmi-rel-2 ti-rel-2))
(defvar *release-bin-directories* (list *default-bin-directory*))

;(defun make-ai-tape (product-name &key log id)
;  (check-arg id (or (not id)
;		    (and (or (stringp id) (symbolp id))
;			 (registration-id-p id)))
;	     "a valid registration id, XXX-nnn")
;  (let ((*force-registration-id* id))
;    (cond (log
;   (with-open-file (stream (fs:make-pathname :host *default-file-host*
;						     :directory (append *default-root-dir* '("RELEASE-LOGS"))
;						     :name (multiple-value-bind (nil nil nil day month year)
;							       (time:decode-universal-time (time:get-universal-time))
;							     (format nil "~A~{-~A~}-~D-~A-~D"
;								     product-name
;								     *release-bin-directories*
;								     day (time:month-string month :short) (mod year 100)))
;					     :type "TEXT"
;						     :version :NEWEST)
;				   :direction :output)
;	     (make-ai-tape-1 product-name stream)))
;	  ('else
;	   (make-ai-tape-1 product-name)))))

(defun make-ai-tape-1 (product-name &optional log-stream)
  (tape-processing #'(lambda ()
		       (get-tape-registration-id)
		       (make-tape-of-files (get-files-for-product product-name log-stream)))))

(defvar *saved-file-properties*
	'(:author :creation-date :length-in-bytes :byte-size :characters :FILE-REGISTERED-P))

(defun get-files-for-product (product-name &optional log-stream)
  (cond ((stringp product-name)
	 (get-files-from-database product-name))
	('else
	 (get-files-from-current-copy product-name log-stream))))

(defun parse-database-pathname (x)
  (fs:parse-pathname x *default-file-host*))

(defun get-files-from-database (product-name &optional (check t) &aux files)
  (with-open-file (stream (fs:make-pathname :host *default-file-host*
					    :directory (append *default-root-dir* '("RELEASE-LOGS"))
					    :name product-name
					    :type "TEXT"
				    :version :newest))
    (progv (mapcar #'car *standard-io-env*)
	   (mapcar #'cadr *standard-io-env*)
      (do ((form)
	   (eof (ncons nil)))
	  ((eq eof (setq form (read stream eof))))
	(cond ((eq (car form) 'setq)
	       (eval form))
	      ('else
	       (SETQ FORM (cons (parse-database-pathname (car form))
				(cdr form)))
	       (WHEN (GET FORM :FILE-REGISTERED-P)
		 (PUTPROP FORM *tape-registration-marker* :FILE-REGISTRATION-MARKER))
	       (push FORM  files))))))
  (setq files (nreverse files))
  (when check
    (format t "~&Checking ~D files~%" (length files))
    (dolist (f files)
      (let ((p (open (car f) :direction nil)))
	(dolist (k *saved-file-properties*)
	  (or (MEMQ K '(:FILE-REGISTERED-P :FILE-REGISTRATION-MARKER))
	      (equalp (get f k)
		      (or (get p k)
			  ;; there is an incompatibility between chaos qfile probe streams
			  ;; and local probe streams in terms of the properties available.
			  ;; that is what this kludge is for.
			  (cond ((eq k :byte-size)
				 (get f k))
				((eq k :length-in-bytes)
				 (get p :length))
				((eq k :characters)
				 (get f k)))))
	      (cerror "continue anyway" "~A and ~A differ in the ~A property, ~D vs ~D"
	      (car f) p k
		      (get f k) (get p k)
		      ))))))
  files)

(defun get-files-from-current-copy (product-name log-stream &aux files)
  (let ((*standard-output* (if log-stream
			       (make-broadcast-stream *standard-output*
						      log-stream)
			     *standard-output*)))
    (format t "~&; Making ~A product tape~%" product-name)
    (describe-release-settings)
    (setq files (compute-files product-name)))
  (when log-stream
    (progv (mapcar #'car *standard-io-env*)
	   (mapcar #'cadr *standard-io-env*)
      (terpri log-stream)
      (dolist (v '(*release-author* *release-creation-date* *release-root-directory*
				    *release-bin-directories*))
	(format log-stream "(setq ~S '~S)~%" v (symeval v)))
      (terpri log-stream)
      (dolist (f files)
	(format log-stream "(~S" (send (car f) :string-for-printing))
	(do ((l (cdr f) (cddr l)))
	    ((null l))
	  (if (memq (car l) *saved-file-properties*)
	      (format log-stream "~% ~S ~S" (car l) (cadr l))))
	(format log-stream ")~2%")))
    (close log-stream))
  files)



(DEFUN FILE-REGISTRATION-MARKER (PLIST)
  (or (get plist :file-registration-marker)
      ""))

(defun transform-release-directory (dir)
  (cond ((null *release-root-directory*)
	 dir)
	((atom *release-root-directory*)
	 (cons *release-root-directory* (cdr dir)))
	(t
	 (append *release-root-directory* (cdr dir)))))

(defun tape-output-plist (plist)
  (let ((new (list* ;;this stopped working...??? :HOST (SEND SI:LOCAL-HOST :SHORT-NAME)
		    :directory (transform-release-directory (send (car plist) :directory))
		    :name (send (car plist) :name)
		    :type (send (car plist) :type)
		    :version (send (car plist) :version)
		    :characters (get plist :characters)
		    :byte-size (get plist :byte-size)
		    :length-in-bytes (+ (length (file-registration-marker plist))
					(get plist :length-in-bytes))
		    :author (if *generate-author*
				*release-author*
			      (get plist :author))
		    :creation-date (if *generate-creation-date*
				       *release-creation-date*
				     (get plist :creation-date))
	    :lmi-tid *tape-registration-id*
	    :not-backed-up *release-files-not-backed-up*
		    nil)))
    ;; optional properties
    (dolist (p '(:CRC))
      (when (get plist p)
	(setf (getf new p) (get plist p))))
    new))

(defun open-tape-output (plist)
  (#+TI  MT:MAKE-MT-FILE-STREAM
   #+LMI FS:MAKE-MT-FILE-STREAM
   :direction :output
   :plist plist))

(defun open-tape-input ()
  (#+TI  MT:MAKE-MT-FILE-STREAM
   #+LMI FS:MAKE-MT-FILE-STREAM
   :DIRECTION :INPUT
   :CHARACTERS :DEFAULT
   :BYTE-SIZE :DEFAULT))

(defvar *directory-list-cache* nil)

(defun compute-files (product)
  (check-arg product (and (symbolp product)
			  (get product 'release-files))
	     "an ai product name")
  (COMPUTE-FILES-R (get product 'release-files)))

(DEFUN COMPUTE-FILES-R (L)
  (let ((*directory-list-cache* (or *directory-list-cache* (make-hash-table))))
    (apply #'append
	   (mapcar #'(lambda (spec)
		       (cond ((and (consp spec) (symbolp (car spec)) (get (car spec) 'compute-files))
			      (apply (get (car spec) 'compute-files) (cdr spec)))
			     ('else
			      (ferror nil "Bad files spec: ~S" spec))))
		   L))))
		   

(defun (:property files-from-product compute-files) (p)
  (compute-files p))

(defun (:property files-matching compute-files) (dir name type)
  (compute-files-1 *default-file-host*
		   (append-dir *default-root-dir* dir)
		   name
		   type
		   #'identity))

(defun append-dir (d1 d2)
  (do ()
      ((or (null d2)
	   (not (eq (car d2) '^))))
    (setq d1 (butlast d1)
	  d2 (cdr d2)))
  (append d1 d2))

(DEFUN (:PROPERTY REGISTERING COMPUTE-FILES) (SPEC)
  (MAPCAR #'(LAMBDA (X)
	      (LIST* (CAR X)
		     :FILE-REGISTERED-P T
		     :FILE-REGISTRATION-MARKER *TAPE-REGISTRATION-MARKER*
		     (CDR X)))
	  (COMPUTE-FILES-R (LIST SPEC))))
	  

(DEFUN (:PROPERTY BINARIES-FOR-SYSTEM COMPUTE-FILES) (SYSTEM)
  (APPLY #'APPEND
	 (MAPCAR #'(LAMBDA (BDIR)
		     (LET ((MODULES (READ-MODULES SYSTEM BDIR)))
		       (LET ((FILES (COMPUTE-FILES-1 *DEFAULT-FILE-HOST*
						     (FUNCALL (OR (GET BDIR 'COMPUTE-BINARY-DIRECTORY)
								  #'(LAMBDA (BDIR)
								      (APPEND *DEFAULT-ROOT-DIR*
									      (LIST "BIN" (STRING BDIR)))))
							      BDIR)
						     :WILD
						     (GET BDIR 'BINARY-TYPE)
						     #'(LAMBDA (P)
							 (MEM #'STRING-EQUAL (SEND P :NAME) MODULES)))))
			 (OR (= (LENGTH FILES) (LENGTH MODULES))
			     (FORMAT T "~&; *** WARNING, ~D file~:*~p could be missing ***~%"
				     (- (LENGTH MODULES) (LENGTH FILES))))
			 FILES)))
		 *RELEASE-BIN-DIRECTORIES*)))

(DEFUN (:PROPERTY IF COMPUTE-FILES) (CONDITION SPEC)
  (IF (EVAL CONDITION)
      (COMPUTE-FILES-R (LIST SPEC))))

(defun compute-files-1 (host dir name type filter)
  (let ((p (fs:make-pathname :host host :directory dir :name name :type type :version :newest)))
    (format t "~&; ~A " p)
    (let ((files (subset #'(lambda (x) (and (car x) (not (get x :directory)) (funcall filter (car x))))
			 (directory-list-cached p))))
     (format t " ~d file~:*~p ~d block~:*~p.~%"
	      (length files)
	      (apply 'plus (mapcar #'length-in-blocks files)))
      files)))

(defun directory-list-cached (p)
  (cond ((not *directory-list-cache*)
	 (fs:directory-list p))
	((gethash p *directory-list-cache*))
	('else
	 (puthash p (fs:directory-list p) *directory-list-cache*))))

(defun copy-files-to-tape (list)
  (hack-files-on-tape "Copy" "=>" 'copy-one-file-to-tape list))

(defun verify-files-on-tape (list)
  (hack-files-on-tape "Compare" "=?=" 'compare-one-file-to-tape list))

(defun hack-files-on-tape (name ind f list)
  (let ((tm (get-universal-time)))
    (format t "~&~D file~:*~p to ~A~%" (length list) name)
    (do ((l list (cdr l))
	 (j 1 (1+ j)))
	((null l))
      (let ((from (car l))
	    (to (tape-output-plist (car l))))
	(format t "~&[~D, ~D block~:*~p] ~A ~A ~{~A~^.~};~A.~A#~D~%"
		j (length-in-blocks from) (car from) ind
		(getf to :directory) (getf to :name) (getf to :type) (getf to :version))
	(funcall f from to)))
    (format t "~&~A done, took ~A realtime.~%"
	    name
	    (time:print-interval-or-never (- (time:get-universal-time) tm) nil))))


(defun length-in-blocks (x)
  ;; actually length in Kbytes. Used for information printouts
  (ceiling (* (get x :byte-size) (get x :length-in-bytes))
	   8192))

(defun copy-one-file-to-tape (from to)
  (with-open-file (instream (car from) :byte-size (get from :byte-size) :characters (get from :characters))
    (with-open-stream (outstream (open-tape-output to))
      (do ((buffer)(offset)(limit))
	  ((null (MULTIPLE-VALUE (BUFFER OFFSET LIMIT)
		   (SEND INSTREAM :READ-INPUT-BUFFER))))
	(SEND OUTSTREAM :STRING-OUT BUFFER OFFSET LIMIT)
	(SEND INSTREAM :ADVANCE-INPUT-BUFFER))
      (send outstream :string-out (file-registration-marker from)))))

(defun compare-one-file-to-tape (from to)
  (with-open-stream (tape-stream (open-tape-input))
    (check-tape-plist to (tape-plist tape-stream))
    (with-open-file (file-stream (car from) :byte-size (get from :byte-size) :characters (get from :characters))
      (LET ((CHECK-STREAM FILE-STREAM))
	(do ((buffer)(offset)(limit))
    ((null (MULTIPLE-VALUE (BUFFER OFFSET LIMIT)
		     (SEND TAPE-STREAM :READ-INPUT-BUFFER))))
	  (do ((j offset (1+ j))
	       (C))
	      ((= j limit))
	    (WHEN (NULL (SETQ C (SEND CHECK-STREAM :TYI)))
      (SETQ CHECK-STREAM (MAKE-STRING-INPUT-STREAM (FILE-REGISTRATION-MARKER FROM)))
	      (SETQ C (SEND CHECK-STREAM :TYI)))
	    (or (= C (aref buffer j))
		(ferror nil "bad data on tape, should be ~D is ~D" c (aref buffer j))))
	  (send TAPE-STREAM :advance-input-buffer))))))


(defun tape-plist (tape-stream)
  (list* :directory (send tape-stream :directory)
	 :name (send tape-stream :name)
	 :type (send tape-stream :type)
	 :version (send tape-stream :version)
	 (plist tape-stream)))

(defun check-tape-plist (should-be is)
  (do ((l should-be (cddr l)))
      ((null l))
    (or (equalp (cadr l) (getf is (car l)))
	(ferror nil "Tape property ~S should be ~S but is ~S"
		(car l) (cadr l) (getf is (car l))))))

(defun tape-processing (f)
  (LET ((MORE-P (SEND TERMINAL-IO :MORE-P))
	(DTO (SEND TERMINAL-IO :DEEXPOSED-TYPEOUT-ACTION))
	(PRIO (SEND CURRENT-PROCESS :PRIORITY))
	(QUANT (SEND CURRENT-PROCESS :QUANTUM)))
    (UNWIND-PROTECT
	(let ((before (time:get-universal-time)))
	  (SEND TERMINAL-IO :SET-MORE-P NIL)
	  (SEND TERMINAL-IO :SET-DEEXPOSED-TYPEOUT-ACTION :PERMIT)
	  (SEND CURRENT-PROCESS :SET-QUANTUM 10)
	  (SEND CURRENT-PROCESS :SET-PRIORITY -1)
	  (prog1 (funcall f)
		 (format t "~&Tape processing took a total time of ~A~%"
			 (time:print-interval-or-never (- (time:get-universal-time) before) nil))))
      (SEND TERMINAL-IO :SET-MORE-P MORE-P)
      (SEND TERMINAL-IO :SET-DEEXPOSED-TYPEOUT-ACTION DTO)
      (SEND CURRENT-PROCESS :SET-QUANTUM QUANT)
      (SEND CURRENT-PROCESS :SET-PRIORITY PRIO))))


(DEFUN READ-MODULES (SYSTEM &OPTIONAL (BINARY-DIR *DEFAULT-BIN-DIRECTORY*))
  (WITH-OPEN-FILE (STREAM (FS:MAKE-PATHNAME :HOST *DEFAULT-FILE-HOST*
					    :DIRECTORY (APPEND *DEFAULT-ROOT-DIR* '("DEFINITION"))
					    :NAME (STRING-APPEND SYSTEM "-SYSTEM")
					    :TYPE "LISP"
					    :VERSION :NEWEST))
    (let ((features (MAPCAR #'(LAMBDA (X)
				(INTERN (STRING X) (FIND-PACKAGE "")))
			    (GET BINARY-DIR 'FEATURES))))
      (format t "~&; Reading definition of ~A modules from ~A~%; for ~A using features: ~{~A~^, ~}.~%"
	      system (send stream :truename) binary-dir features)
      (let ((*features* features))
	(progv (mapcar #'car *standard-io-env*)
	       (mapcar #'cadr *standard-io-env*)
	  (DO ((FORM)
	       (EOF (NCONS NIL)))
	      ((EQ EOF (SETQ FORM (READ STREAM EOF)))
	       (FERROR NIL "GOT TO END OF FILE WITHOUT FINDING MODULES FOR ~A" SYSTEM))
	    (COND ((NOT (AND (CONSP FORM) (EQ (CAR FORM) 'DEFINE-SYSTEM))))
		  ((NOT (EQ (CADR FORM) SYSTEM))
		   (FORMAT T "~&; Warning: ~A contains definition for system ~A~%"
			   (send stream :truename) (cadr form)))
		  ('else
		   (return (cdddr form))))))))))



(defun get-tape-registration-id ()
  (when (not *tape-registration-id*)
    (setq *random-state* (make-random-state t))
    (dotimes (j (mod (time:get-universal-time) 100))
      (random 1000000)))
  ;; one chance in 26*26*26*9*10*10 (15 million)
  ;; that an id will be duplicated.
  (cond (*force-registration-id*
	 (setq *tape-registration-id* (string *force-registration-id*)))
	('else
	 (setq *tape-registration-id* (intern (format nil "~C~C~C-~D~D~D"
						      (+ #\A (random 26))
						      (+ #\A (random 26))
						      (+ #\A (random 26))
						      (1+ (random 9))
						      (random 10)
						      (random 10))
					      (find-package "")))))
  (setq *tape-registration-marker* (format nil "(REGISTRATION-ID :~A)~%" *tape-registration-id*))
  (describe-tape-registration-id))


(defun describe-tape-registration-id ()
  (let ((mess (if *tape-registration-id*
		  (format nil "Tape has registration id ~A" *tape-registration-id*)
		(format nil "Tape has no registration id"))))
    (format t "~&~A~%" mess)
    mess))


(DEFUN VERIFY-AI-TAPE (PRODUCT-NAME)
  (TAPE-PROCESSING #'(LAMBDA ()
		       (prompt-read-registration-id)
		       (verify-tape-of-files (get-files-for-product product-name)))))


(defun registration-id-p (id)
  (let ((x (string id)))
    (when (AND (= (STRING-LENGTH X) 7)
	       (ALPHA-CHAR-P (AREF X 0))
	       (ALPHA-CHAR-P (AREF X 1))
	       (ALPHA-CHAR-P (AREF X 2))
	       (CHAR-EQUAL #\- (AREF X 3))
	       (DIGIT-CHAR-P (AREF X 4))
	       (DIGIT-CHAR-P (AREF X 5))
	       (DIGIT-CHAR-P (AREF X 6)))
      (INTERN (STRING-UPCASE X) (FIND-PACKAGE "")))))

(defun prompt-read-registration-id ()
  (SETQ *TAPE-REGISTRATION-ID*
	(DO ((X)(Y))
	    (NIL)
	  (SETQ X (PROMPT-AND-READ :STRING "~&Tape registration ID: "))
	  (COND ((SETQ Y (registration-id-p x))
		 (RETURN y))
		('ELSE
		 (FORMAT T "~&malformed registration id: ~S~%" x)))))
  (setq *tape-registration-marker* (format nil "(REGISTRATION-ID :~A)~%" *tape-registration-id*)))


(defun delete-protect-distribution (product-name)
  (dolist (p (get-files-from-database product-name))
    (cond ((get (open (car p) :direction nil) :dont-delete)
	   (format t "~&Already protected: ~A~%" (car p)))
	  ('else
	   (format t "~&Protecting: ~A" (car p))
	   (fs:change-file-properties (car p) t :dont-delete t)
	   (terpri)))))

(defun describe-product-differences (old-release new-release)
  (describe-file-differences (progn (format t "~&;Old release = ~A~%" old-release)
				    (get-files-from-database-v old-release))
			     (progn (format t "~&;New release = ~A~%" new-release)
				    (get-files-from-database-v new-release))))
					    
(defun get-files-from-database-v (p)
  (let (*RELEASE-AUTHOR*
	*RELEASE-CREATION-DATE*
	*RELEASE-ROOT-DIRECTORY*
	*RELEASE-BIN-DIRECTORIES*)
    (prog1 (get-files-from-database p nil)
	   (describe-release-settings))))


(defun describe-file-differences (old-release new-release)
  (let (deleted-files
	new-files
	new-version-files)
    (dolist (old old-release)
      (or (filep-member old new-release)
	  (push (car old) deleted-files)))
    (dolist (new new-release)
      (let ((m (filep-member new old-release)))
	(cond ((not m)
	       (push (car new) new-files))
	      ((not (equal (send (car new) :version)
			   (send (caar m) :version)))
	       (push (list (car new) (send (caar m) :version))
		     new-version-files)))))
    (when deleted-files
      (format t "~&;The following files are deleted in the new release~%")
      (dolist (f deleted-files)
	(format t "~S~%" (send f :string-for-host))))
    (when new-files
      (format t "~&;The following files are brand new in the new release~%")
      (dolist (f new-files)
	(format t "~S~%" (send f :string-for-host))))
    (when new-version-files
      (format t "~&;The following files have updated versions in the new release~%")
      (dolist (f new-version-files)
	(format t "~S ; used to be ~D~%" (send (car f) :string-for-host) (cadr f))))))
		
      



(defun filep-member (fp fpl)
  (do ((l fpl (cdr l))
       (f1d (send (car fp) :directory))
       (f1n (send (car fp) :name))
       (f2t (send (car fp) :type))
       (f2))
      ((null l)
       nil)
    (setq f2 (caar l))
    (when (and (equalp f1d (send f2 :directory))
	       (string-equal f1n (send f2 :name))
	       (string-equal f2t (send f2 :type)))
      (return l))))


	

(defun copy-files-to-new-root (product-name host root &optional filter-out-dir)
  (let ((l (get-files-from-database-v product-name)))
    (dolist (f l)
      (cond ((and filter-out-dir
		  (mem #'string-equal filter-out-dir (send (car f) :directory)))
	     (format t "~&Filtered out ~A~%" (car f)))
	    ('else
	     (copy-single-file (car f)
			       (send (car f) :new-pathname
				     :host host
				     :directory (append (if (atom root) (list root) root)
							(cdr (send (car f) :directory))))
			       (cdr f)))))))


(defun copy-single-file (input-pathname output-pathname plist)
  (FS:CREATE-DIRECTORY OUTPUT-PATHNAME)
  (COND ((PROBE-FILE OUTPUT-PATHNAME)
	 (FORMAT T "~&Already exists: ~S~%" OUTPUT-PATHNAME))
	('ELSE
	 (COPY-SINGLE-FILE-1 input-pathname output-pathname plist))))

(DEFVAR *COPY-SINGLE-FILE-PROPERTIES* '(:AUTHOR :CREATION-DATE)
  "Properties to carry over to the new file via a :CHANGE-PROPERTIES message")

(DEFUN COPY-SINGLE-FILE-1 (INPUT-PATHNAME OUTPUT-PATHNAME PLIST)
  (LET ((TIME (TIME)))
    (WITH-OPEN-FILE (INSTREAM INPUT-PATHNAME
			      :DIRECTION :INPUT
			      :CHARACTERS (GETF PLIST :CHARACTERS)
			      :BYTE-SIZE (GETF PLIST :BYTE-SIZE)
			      :ERROR NIL)
      (SETQ TIME (QUOTIENT (TIME-DIFFERENCE (TIME) TIME) 60.0))
      (COND ((ERRORP INSTREAM)
	     (SEND INSTREAM :REPORT *ERROR-OUTPUT*))
	    ('ELSE
	     (FORMAT T "~&~A (~\scientific\seconds)~%" (SEND INSTREAM :TRUENAME) TIME)
	     (SETQ TIME (TIME))
	     (WITH-OPEN-FILE (OUTSTREAM OUTPUT-PATHNAME
					:DIRECTION :OUTPUT
					:CHARACTERS (GETF PLIST :CHARACTERS)
					:BYTE-SIZE (GETF PLIST :BYTE-SIZE))
	       (LET ((COPY-PLIST NIL)
		     (NOT-VALUE (LIST NIL)))
		 (DOLIST (P *COPY-SINGLE-FILE-PROPERTIES*)
		   (LET ((VALUE (GETF PLIST P NOT-VALUE)))
		     (OR (EQ VALUE NOT-VALUE)
			 (SETF (GETF COPY-PLIST P) VALUE))))
		 (WHEN COPY-PLIST
		   (LEXPR-SEND OUTSTREAM :CHANGE-PROPERTIES NIL COPY-PLIST)))
	       (SETQ TIME (QUOTIENT (TIME-DIFFERENCE (TIME) TIME) 60.0))
	       (FORMAT T "  ==> ~A (~\scientific\seconds)~%" (SEND OUTSTREAM :TRUENAME) TIME)
	       (SETQ TIME (TIME))
	       (DO ((BUFFER)
		    (OFFSET)
		    (LIMIT)
		    (BYTES 0))
		   (())
		 (MULTIPLE-VALUE (BUFFER OFFSET LIMIT)
		   (SEND INSTREAM :READ-INPUT-BUFFER))
		 (WHEN (NULL BUFFER)
		   (SETQ TIME (QUOTIENT (TIME-DIFFERENCE (TIME) TIME) 60.0))
		   (FORMAT T
			   " copy: ~\scientific\seconds, ~\scientific\bytes per second~%"
			   TIME (QUOTIENT BYTES (IF (ZEROP TIME) 1 TIME)))
		   (RETURN NIL))
		 (INCF BYTES (- LIMIT OFFSET))
		 (SEND OUTSTREAM :STRING-OUT BUFFER OFFSET LIMIT)
		 (SEND INSTREAM :ADVANCE-INPUT-BUFFER))
	       (SETQ TIME (TIME)))
	     (SETQ TIME (QUOTIENT (TIME-DIFFERENCE (TIME) TIME) 60.0))
	     (FORMAT T " output-close: ~\scientific\seconds" TIME)))
      (SETQ TIME (TIME)))
    (SETQ TIME (QUOTIENT (TIME-DIFFERENCE (TIME) TIME) 60.0))
    (FORMAT T " input-close: ~\scientific\seconds." TIME)))