#| -*- Mode:LISP; Package:SI; Base:10; FONTS: (CPTFONTB) -*-

|#


(DEFUN SAVE-DIRECTORY-SNAPSHOT-AS-UPDATE-FILE (DIRSPEC NAME)
  "This makes a list of files as if SI:*SAVED-PATCH-UPDATE-FILES*
which can be used by the distribution utility"
  (SAVE-FILE-LIST-AS-UPDATE-FILE
    (SNAPSHOT-FILES-IN-DIRECTORY DIRSPEC)
    NAME))


;; THIS DIRECTORY SNAPSHOT WILL DO, ALTHOUGH WHAT WE REALLY MIGHT WANT
;; IS A MAKE-SYSTEM SNAPSHOT, WITH SPECIFICATION OF SOURCES TO INCLUDE
;; AND OTHER OPTIONAL FILES SUCH AS DOCUMENTATION.

(DEFUN SNAPSHOT-FILES-IN-DIRECTORY (DIRSPEC)
  (DO ((L (VDIRECTORY-LIST (SEND (FS:PARSE-PATHNAME DIRSPEC)
				      :NEW-PATHNAME
				      :NAME :WILD
				      :TYPE :WILD
				      :VERSION :NEWEST))
	  (CDR L))
       (FILES NIL)
       (SUBDIRECTORIES NIL))
      ((NULL L)
       (NRECONC FILES (MAPCAN #'SNAPSHOT-FILES-IN-DIRECTORY
			      (NREVERSE SUBDIRECTORIES))))
    (COND ((GET (CAR L) :DIRECTORY)
	   (PUSH (SEND (CAAR L) :NEW-PATHNAME
		       :DIRECTORY (IF (ATOM (SEND (CAAR L) :DIRECTORY))
				      (LIST (SEND (CAAR L) :DIRECTORY)
					    (SEND (CAAR L) :NAME))
				    (APPEND (SEND (CAAR L) :DIRECTORY)
					    (LIST (SEND (CAAR L) :NAME))))
		       :NAME :WILD
		       :TYPE :WILD
		       :VERSION :NEWEST)
		 SUBDIRECTORIES))
	  ('ELSE
	   (PUSH (CAAR L) FILES)))))

(DEFUN VDIRECTORY-LIST (X)
  (FORMAT T "~&;Descending ~A..." X)
  (LET ((L (CDR (FS:DIRECTORY-LIST X))))
    (FORMAT T " ~D item~p~%" (length l) (length l))
    l))

(DEFUN SAVE-FILE-LIST-AS-UPDATE-FILE (LIST NAME)
  (LET ((F (make-utility-filename name :LISP)))
    (WITH-OPEN-FILE (s f :out)
      (LET ((BASE 10)
	    (PACKAGE (FIND-PACKAGE "USER")))
	(FORMAT s ";;-*-MODE:LISP;PACKAGE:USER;BASE:10-*-~%")
	(FORMAT s ";; FAKE patch update file list dumped by ~A from ~A~%"
		si:user-id
		(send si:local-host :name))
	(format s ";; on ~A~%" (time:print-current-date nil))
	(format s "(SET 'SI:*SAVED-PATCH-UPDATE-FILES* '(~%")
	(dolist (file list)
	  (format s " ~S~%" file))
	(format s "))~%"))
      (CLOSE S)
      (SEND S :TRUENAME))))


(DEFUN LOAD-SAVED-PATCH-UPDATE-FILE (INFO-FILENAME)
  (let ((*SAVED-PATCH-UPDATE-FILES*))
    (load INFO-FILENAME)
    *SAVED-PATCH-UPDATE-FILES*))

(DEFUN MAKE-COMBINED-UPDATE-TAPE (&REST INFO-FILENAMES)
  (LET ((FILES (MAPCAN #'LOAD-SAVED-PATCH-UPDATE-FILE INFO-FILENAMES)))
    (format t "~&Rewinding Tape~%")
    (fs:mt-rewind)
    (format t "~&Writing ~D files." (length FILES))
    (dolist (file FILES)
      (copy-file-to-tape file))
    (format t "~&Writing EOF marker~%")
    (fs:mt-write-eof)
    (format t "~&Rewinding Tape~%")
    (fs:mt-rewind)
    (format t "~&Done~%")))

(DEFUN VERIFY-COMBINED-UPDATE-TAPE (&REST INFO-FILENAMES)
  (LET ((FILES (MAPCAN #'LOAD-SAVED-PATCH-UPDATE-FILE INFO-FILENAMES)))
    (format t "~&Rewinding Tape~%")
    (VERIFY-MAGTAPE :Expected-files files)))

(DEFVAR *VERIFY-MAGTAPE-ERRORS* NIL)

(DEFUN VERIFY-MAGTAPE (&optional &key expected-files (file-host si:local-host))
  (do ((l expected-files (cdr l))
       (*VERIFY-MAGTAPE-ERRORS* NIL))
      (nil)
    (with-open-stream (tape-stream (fs:make-mt-file-stream
				     :direction :input
				     :error nil))
      (cond ((errorp tape-stream)
	     (return-from VERIFY-MAGTAPE (REVERSE *VERIFY-MAGTAPE-ERRORS*)))
	    ('else
	     (compare-tape-file-to-disk tape-stream (car l) file-host))))))

(defun verify-magtape-error (string &rest args)
  (lexpr-funcall #'format t string args)
  (push (lexpr-funcall #'format nil string args) *VERIFY-MAGTAPE-ERRORS*)
  t)

(defun compare-tape-file-to-disk (tape-stream expected-file file-host)
  (let* ((plist-sort-of (send tape-stream :plist))
	 (plist (locf plist-sort-of))
	 (directory (get plist ':directory))
	 (name (get plist ':name))
	 (type (get plist ':type))
	 (version (get plist ':version))
	 (characters? (get plist ':characters))
	 (byte-size (get plist ':byte-size))
	 (pathname
	   (fs:make-pathname
	     :host (if expected-file (send expected-file :host) file-host)
	     :directory directory
	     :name name
	     :type type
	     :version version)))
    (when expected-file
      (or (verify-pathname-equal pathname expected-file)
	  (verify-magtape-error "~&%%ERROR%% expected file ~A but got ~A~%"
				expected-file pathname)))
    (with-open-file (file-stream pathname
				 :direction :input
				 :characters characters?
				 :byte-size byte-size)
      (format t "~&Verifying tape version of /"~A/"" pathname)
      (stream-compare tape-stream file-stream))))

(defun verify-pathname-equal (a b)
  (dolist (slot '(:directory :name :type :version))
    (or (equalp (send a slot) (send b slot))
	(return-from verify-pathname-equal nil)))
  t)

(defmacro post-incf (x)
  `(prog1 ,x (incf ,x)))

(defun stream-compare (s1 s2)
  (prog (buffer1 index1 limit1 buffer2 index2 limit2)
	(multiple-value (buffer1 index1 limit1) (send s1 :read-input-buffer))
	(multiple-value (buffer2 index2 limit2) (send s2 :read-input-buffer))
	(cond ((and (null buffer1) (null buffer2))
	       (return t))
	      ((null buffer1)
	       (go eof1))
	      ((null buffer2)
	       (go eof2)))
	(when (not (eq (array-type buffer1) (array-type buffer2)))
	  (return (verify-magtape-error "~&different buffer types ~S and ~S"
					(array-type buffer1) (array-type buffer2))))
     check-value
	(when (not (= (aref buffer1 (post-incf index1))
		      (aref buffer2 (post-incf index2))))
	  (return (verify-magtape-error "~&difference between ~S and ~S" s1 s2)))
	(when (= index1 limit1)
	  (send s1 :advance-input-buffer)
	  (or (multiple-value (buffer1 index1 limit1) (send s1 :read-input-buffer))
	      (go eof1)))
	(when (= index2 limit2)
	  (send s2 :advance-input-buffer)
	  (or (multiple-value (buffer2 index2 limit2) (send s2 :read-input-buffer))
	      (go eof2)))
	(go check-value)
	eof1
	(when (= index2 limit2)
	  (send s2 :advance-input-buffer)
	  (multiple-value (buffer2 index2 limit2) (send s2 :read-input-buffer))
	  (cond ((not buffer2) (return t))
		((get s2 :characters)
		 (return (verify-magtape-error "~&extra stuff at end of ~S" s2)))))
	(cond ((zerop (aref buffer2 (post-incf index2)))
	       (go eof1))
	      ('else
	       (return (verify-magtape-error "~&non null padding at end of ~S" s2))))
	eof2
	(setq s2 s1 buffer2 buffer1 index2 index1 limit2 limit1)
	(go eof1)))