;;; -*- Mode:LISP; Package:(RELEASE GLOBAL); Readtable:CL; Base:10 -*-
;;;
;;; Utility for making source release
;;;
;;; -dg 12/4/86

(defconst *default-lambda-ucode-types-to-release*
	  '("LMC" "LMC-LOCS" "LMC-DCL" "LMC-SYM" "LMC-TBL"))

(defconst *default-explorer-ucode-types-to-release*
	  '("EMC" "EMC-LOCS" "EMC-DCL" "EMC-SYM" "EMC-TBL"))

(defconst *default-lambda-system-filters*
	  '(cadr-micro-assembler
	     cadr-debugger
	     cadr
	     lambda-ucode
	     magtape
	     ))

(defconst *default-lambda-pathname-filters*
	  `("sys:cold;* * *"			; sensitive
	    "sys:lambda-diag;* * *"		; sensitive
	    "sys:fonts;equivalence * *"		; random MIT
            "sys:fonts;color* * *"		; old CADR
	    "sys:micro-compiler;* * *"		; option
	    "sys:sys2;gc * *"			; mystique
	    "sys:sys;config* * *"		; GJC
	    "sys:ulambda;* * *"			; sensitive
	    "sys:lmi-site;* * *"		; unnecessary
	    "sys:file2;* * *"			; RMS filesystem
	    "sys:gateway;SYSTEM-BOOKREPORTS * *"	;LMI sensitive
	    ))

(defconst *default-lambda-additional-pathnames*
	  '("SYS: DEMO; TVBGAR QFASL >"
	    "SYS: DEMO; WORMCH QFASL >"
	    "SYS: GATEWAY; ZINFONT QFASL >"
	    "SYS: IO; CRDTBL LISP >" ;; is actually a source, processed by readtable compiler.
	    "SYS: IO; RDTBL LISP >"
	    "SYS: ZMAIL; LEX733 LISP >" ;; is actually a source, processed by readtable compiler.
	    "SYS: CUSTOMER-SITE; SITE LISP >"
	    "SYS: CUSTOMER-SITE; SITE QFASL >"
	    "SYS: CUSTOMER-SITE; HOSTS TEXT >"
	    "SYS: CUSTOMER-SITE; HSTTBL LISP >"
	    "SYS: CUSTOMER-SITE; HSTTBL QFASL >"
	    "SYS: CUSTOMER-SITE; LMLOCS LISP >"
	    "SYS: CUSTOMER-SITE; LMLOCS QFASL >"
	    "SYS: CUSTOMER-SITE; SYS TRANSLATIONS >"
	    "SYS: RELEASE; BETA-I-S3P29 PDATA >"
	    ))
	  
(defconst *default-lambda-additional-functions*
	  `(
	    mark-font-files
	    mark-gateway-data-files
	    mark-directory-copyright-files
	    check-for-copyrights
	    mark-examples
	     ))

(defconst *default-report-pathname* "dj:release.reports;")

(defun get-system-patch-filters (&rest systems)
  (let (collection
	(logical-translator (fs:parse-pathname "sys:")))
    (dolist (system (or systems si:*systems-list*) collection)
      (let ((object (si:find-system-named system t t)))
	(when (and object (si:system-patchable-p object))
	  (push (send logical-translator :back-translated-pathname
		      (si:patch-system-pathname (si:system-name object) :patch-file '* '* :wild))
		collection))))))

(defun filter-file (pathname &optional filter-list)
  (block filter-file
    (dolist (filter filter-list)
      (when (send filter :pathname-match pathname)
	(return-from filter-file t)))))

(defsubst mark-released (pathname)
  (putprop pathname t :source-file-released))

(defsubst clear-released (pathname)
  (putprop pathname nil :source-file-released))

(defsubst mark-restrained (pathname)
  (putprop pathname t :source-file-restrained))

(defsubst clear-restrained (pathname)
  (putprop pathname nil :source-file-restrained))

(defsubst mark-stray (pathname)
  (putprop pathname t :source-file-stray))

(defsubst clear-stray (pathname)
  (putprop pathname nil :source-file-stray))

(defun clear-source-pathname-flags (&optional (hash-table fs:*pathname-hash-table*))
  (maphash #'(lambda (ignore thing)
	       (clear-released thing)
	       (clear-restrained thing))
	   hash-table))

(defun clear-stray-pathname-flags  (&optional (hash-table fs:*pathname-hash-table*))
  (maphash #'(lambda (ignore pn)
	       (clear-stray pn))
	   hash-table))

(defun sorted-list-marked-pathnames (prop &optional (hash-table fs:*pathname-hash-table*))
  (let (return)
    (maphash #'(lambda (ignore pn)
		 (when (get pn prop)
		   (push pn return)))
	     hash-table)
    (sort return 'release-order-lessp)))

(defconst *gateway-root-directory-name* "gateway")

(defun release-order-lessp (pn1 pn2)
  (let ((dir1 (let ((temp (send pn1 :directory)))
		(if (consp temp) (car temp) temp)))
	(dir2 (let ((temp (send pn2 :directory)))
		(if (consp temp) (car temp) temp))))
    (cond ((string-equal *gateway-root-directory-name* dir1) nil)
	  ((string-equal *gateway-root-directory-name* dir2) t)
	  (t (string-lessp pn1 pn2)))))
	  
(defun list-stray-files (&optional (hash-table fs:*pathname-hash-table*))
  (sorted-list-marked-pathnames :source-file-stray hash-table))

(defun list-restrained-files (&optional (hash-table fs:*pathname-hash-table*))
  (sorted-list-marked-pathnames :source-file-restrained hash-table))

(defun list-release-files (&optional (hash-table fs:*pathname-hash-table*))
  (sorted-list-marked-pathnames :source-file-released hash-table))

(defun mark-source-files-from-environment (&key (systems si:*systems-list*)
					  ucode-types
					  pathname-filters
					  system-filters)
  (let (relevant-systems
	systems-to-restrain
	pathnames-to-restrain
	restrained-pathnames)
    ;;; setup system filters
    (dolist (system system-filters)
      (pushnew (si:find-system-named system t t) systems-to-restrain))
    ;;; setup pathname filters
    (dolist (desc pathname-filters)
      (pushnew (fs:parse-pathname desc) pathnames-to-restrain))
    ;;; determine relevant systems
    (dolist (system systems)
      (when (and (typep system 'si:system)
		 (not (memq system systems-to-restrain))
		 (symbol-package (si:system-symbolic-name system)))
	(push system relevant-systems)))
    ;;; Get files from systems
    (dolist (system relevant-systems)
      (do* ((files (si:system-source-files system) (cdr files))
	    (number-of-files (length files))
	    (file (car files) (car files))
	    (number-restrained 0)
	    (system-restrained-p (memq system systems-to-restrain)))
	   ((null file)
	    (format t "~&~10T~A~40T~D files.~53T(~D restrained | ~D released)"
		    (si:system-name system)
		    number-of-files
		    number-restrained
		    (- number-of-files number-restrained)))
	(if (not (or system-restrained-p
		     (block filter-by-pathname
		       (dolist (pf pathnames-to-restrain)
			 (when (send pf :pathname-match file)
			   (return-from filter-by-pathname t))))))
	    (mark-released file)
	  (mark-restrained file)
	  (incf number-restrained))))
    ;;; add micrcode files
    (dolist (type ucode-types)
      (mark-released (fs:parse-pathname
		       (format nil "SYS:UBIN;ULAMBDA ~A ~D" type
			       %microcode-version-number))))
    ;;; add patch directories
    (mark-patch-directories relevant-systems)
    restrained-pathnames))

(defun check-for-stray-files (filters)
  (format t "~&Clearing stray file flags from all pathnames ...")
  (clear-stray-pathname-flags)
  (format t "~&~10TChecking ~d fasloaded files for strays: "
	  (length si:fasloaded-file-truenames))
  (do* ((pos (cursorpos))
	(flist si:fasloaded-file-truenames (cdr flist))
	(count (length flist) (sub1 count))
	(stray-count 0)
	(pathname (fs:parse-pathname (car flist))
		  (fs:parse-pathname (car flist)))
	(translator (fs:parse-pathname "sys:"))
	(translated-pathname
	  (when flist
	    (send translator :back-translated-pathname
		  (fs:parse-pathname (car flist))))
	  (when flist
	    (send translator :back-translated-pathname
		  (fs:parse-pathname (car flist)))))
	(logical-pathname
	  (when translated-pathname
	    (send translated-pathname :new-pathname
		  :canonical-type :lisp :version :newest))
	  (when translated-pathname
	    (send translated-pathname :new-pathname
		  :canonical-type :lisp :version :newest)))
	non-logical-pathnames)
       ((null flist)
	(cursorpos (car pos) (cdr pos))
	(cursorpos 'l)
	(format t "~D stray files" stray-count)
	(when non-logical-pathnames
	  (dolist (pn non-logical-pathnames)
	    (format t "~&Warning: The pathname \"~A\" is not logical!" pn)))
	stray-count)
    (cursorpos (car pos) (cdr pos))
    (cursorpos 'l)
    (princ count)
    (if (null translated-pathname)
	(push pathname non-logical-pathnames)
      (unless (or (get logical-pathname :source-file-released)
		  (get logical-pathname :source-file-restrained)
		  (let ((np (send logical-pathname :new-canonical-type :qfasl)))
		    (or (get np :source-file-released)
			(get np :source-file-restrained)))
		  (filter-file logical-pathname filters))
	(mark-stray logical-pathname)
	(incf stray-count)))))

(defun mark-patch-directories (systems &aux (translator (fs:parse-pathname "sys:")))
  (dolist (slist si:patch-systems-list)
    (when (and (memq (si:find-system-named (car slist)) systems)
	       (not (mem 'equal slist si:frozen-patch-systems-list)))
      (mark-released (send translator :back-translated-pathname
			   (si:patch-system-pathname (car slist) :system-directory)))
      (mark-released (send translator :back-translated-pathname
			   (car (si:patch-directory-loaded-id slist)))))))

(defun assess-release-sources (systems
			       ucode-types
			       pathname-filters
			       system-filters
			       additional-pathnames
			       additional-functions)
  (format t "~&Clearing release status flags on all pathnames ...")
  (clear-source-pathname-flags)
  (format t "~&Checking loaded systems ...")
  (mark-source-files-from-environment
    :systems systems
    :ucode-types ucode-types
    :pathname-filters pathname-filters
    :system-filters system-filters)
  (format t "~&Adding additional pathnames...")
  (dolist (pn additional-pathnames)
    (let ((pathname (fs:parse-pathname pn)))
      (when (probef pathname)
	(mark-released pathname))))
  (format t "~&Adding additional functions...")
  (dolist (fn additional-functions)
    (dolist (file (funcall fn))
      (mark-released file)))
  (format t "~&Checking for stray files...")
  (check-for-stray-files (get-system-patch-filters))
  nil)

(defun assess-lambda-release-sources ()
  (assess-release-sources
    si:*systems-list*
    *default-lambda-ucode-types-to-release*
    *default-lambda-pathname-filters*
    *default-lambda-system-filters*
    *default-lambda-additional-pathnames*
    *default-lambda-additional-functions*))

(defun make-release-report (pathname-list &key (pathname *default-report-pathname*))
  (let* ((release-name (string-subst-char
			 #\- #\space
			 (prompt-and-read :string "~&Name for this release >> ")
			 nil))
	 (real-path (send (fs:parse-pathname pathname) :new-pathname
			  :name (string-append release-name "-source-release")
			  :canonical-type :text
			  :version :newest)))
    (with-open-file (stream real-path :direction :output :characters t)
      (format stream ";;; Release ~S Source File Report~@
                      ;;; Made by ~S~@
                      ;;; ~\\date\\~@
                      ;;; ~D files~3%"
	      release-name
	      si:user-id
	      (time:get-universal-time)
	      (length pathname-list))
      (dolist (pn pathname-list)
	(format stream "~A~%" pn)))))

(defun dump-source-list (pathname-list &key (pathname *default-report-pathname*)) 
  (let* ((release-name (string-subst-char
			 #\- #\space
			 (prompt-and-read :string "~&Name for this release >> ")
			 nil))
	 (real-path (send (fs:parse-pathname pathname) :new-pathname
			  :name (string-append release-name "-source-release")
			  :canonical-type :qfasl
			  :version :newest))
	 (*saved-file-list* pathname-list)) 
    (declare (special *saved-file-list*))
    (compiler:fasd-symbol-value real-path '*saved-file-list*)))

(defun restore-source-list (&optional (pathname *default-report-pathname*))
  (let* ((release-name (string-subst-char
			 #\- #\space
			 (prompt-and-read :string "~&Release name >> ")
			 nil))
	 (real-path (send (fs:parse-pathname pathname) :new-pathname
			  :name (string-append release-name "-source-release")
			  :canonical-type :qfasl
			  :version :newest))
	 *saved-file-list*)
    (declare (special *saved-file-list*))
    (load real-path)
    *saved-file-list*))

(defun check-for-copyrights (&optional (pathname-list (list-release-files)))
  (let (directory-pathnames
	no-file-list)
    (format t "~&Creating directory copyright file list...")
    (setq directory-pathnames (get-directory-copyright-files pathname-list))
    (format t " ~D files.~%Probing for files..."
	    (length directory-pathnames))
    (dolist (pn directory-pathnames no-file-list)
      (format t "~&~5T~A - " pn)
      (if (probef pn)
	  (format t "ok.~%")
	(push pn no-file-list)
	(format t "*** missing ***~%")))
    (format t "~D files missing.~%" (length no-file-list))
    (when no-file-list
      (copy-over-copyright-files
	no-file-list (set-difference directory-pathnames no-file-list) ))
    ;;; eventually this should check for COPYRIGHT lines and attribute lines
    ;;; in LISP files
    ))

(defun get-directory-copyright-files (pathname-list)
  (let (directory-cache
	collection)
    (dolist (pn pathname-list collection)
      (unless (member (send pn :directory) directory-cache :test 'equal)
	(push (send pn :directory) directory-cache)
	(let ((cpn (send pn :new-pathname
			 :device :unspecific
			 :name "COPYRIGHT"
			 :canonical-type :text
			 :version :newest)))
	  (pushnew cpn collection))))))

(defun mark-directory-copyright-files (&key
				       (hash-table fs:*pathname-hash-table*)
				       &aux
				       (count 0))
  (format t "~&~10TAssessing Copyright Files per directory  ... ")
  (maphash 'mark-directory-copyright-file-internal
	   hash-table (locf count) (list nil))
  (format t "~D copyright files released." count))

(defun mark-directory-copyright-file-internal (ignore pathname count-locative dir-cache)
  (unless (or (not (get pathname :source-file-released))
	      (member (send pathname :directory) dir-cache :test 'equal))
    (nconc dir-cache (ncons (send pathname :directory)))
    (let ((cpath (send pathname :new-pathname
		       :device :unspecfic
		       :name "COPYRIGHT"
		       :canonical-type :text
		       :version :newest)))
      (unless (get cpath :source-file-released)
	(incf (car count-locative))
	(mark-released cpath)))))

(defun copy-over-copyright-files (pathnames-not-present pathnames-present)
  (multiple-value-bind (copy-source overwrite-all)
      (do* ((l pathnames-present (cdr l))
	    (file (car l) (car l))
	    selected-pathname)
	   ((or (null file) selected-pathname)
	    (when selected-pathname
	      (values selected-pathname nil)))
;     (y-or-n-p "~&Overwrite all directories files with selected file? ")))) shouldn't do this really.
	(send *standard-output* :clear-screen)
	(format t "Examining copright file: ~A~2%" file)
	(viewf file)
	(when (y-or-n-p "~&~2%Use this file for directories missing a copyright file? ")
	  (setq selected-pathname file)))
    (if (not (or pathnames-not-present overwrite-all))
	(format t "~&No copyright files to be overwritten.")
      (format t "~&Using \"~A\" to overwrite ~:[NON-EXISTING~;ALL~] files..."
	      copy-source overwrite-all)
      (dolist (target (if overwrite-all
			  (delq copy-source (union pathnames-not-present pathnames-present))
			pathnames-not-present))
	(format t "~&Copying \"~A\" to \"~A\"" copy-source target)
	(fs:copy-file copy-source target)))))

;(tframe:define-command MAKE-LMI-SOURCE-RELEASE distribution
;  "Make a release source tape from the loaded environment."
;  :left (let* ((file-list (list-files-for-release))
;	       (length (length file-list))
;	       (start (time:get-universal-time)))
;	  (format t "~&~2%Dumping ~D files ... " length)
;	  (do* ((list file-list (cdr list))
;		(pathname (car list) (car list))
;		(to-go length (sub1 to-go)))
;	       ((null list))
;	    (tframe:with-status ("Writing source \"~A\"... [~D files to go]" pathname to-go)
;	      (send tape:*selected-format* :write-file
;		    tape:*selected-device*
;		    pathname
;		    :silent t)))
;	  (format t "done.  Took ~\\time-interval\\" (- (time:get-universal-time) start))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Special functions to mark additional files
;;;
;;;

(defun mark-gateway-data-files ()
  (format t "~&~10TAssessing Gateway files ... ")
  (si:find-system-named 'gateway)
  (let ((gateway-data-files (cdr (fs:directory-list  "gateway:data;* * >")))
	(byte-count 0)
	(file-count 0)
	(translator (fs:parse-pathname "sys:")))
    (dolist (file gateway-data-files)
      (if (not (zerop (or (get file :length-in-bytes)
			  (get file :length)
			  (get file :length-in-blocks)
			  (ferror nil "Bad file plist from FS:DIRECTORY-LIST: ~a" file))))
	  (progn (mark-released (send translator :back-translated-pathname (car file)))
		 (incf file-count)
		 (incf byte-count (* (or (get file :length-in-bytes)
					 (* (or (get file :length-in-blocks) 1) si:page-size 4))
				     (/ (get file :byte-size) 8))))
	(format t "~&File \"~A\" has zero length, looking for a good version ..."
		(car file))
	(do* ((list (butlast (cdr (fs:directory-list
				    (send (car file) :new-version :wild))))
		    (cdr list))
	      (file (car list) (car list))
	      found-one)
	     ((or (null file) found-one)
	      (unless found-one
		(when (and (not found-one)
			   (yes-or-no-p "~&Sorry no more files, should I abort?"))
		  (signal 'sys:abort :format-string "Abort from lossage!!!"))))
	  (when (not (zerop (or (get file :length-in-bytes)
				(get file :length)
				(get file :length-in-blocks)
				(ferror nil "Bad file plist from FS:DIRECTORY-LIST: ~a" file))))
	    (format t "found one.")
	    (incf file-count)
	    (setq found-one
		  (mark-released (send translator :back-translated-pathname
				       (car file))))))))
    (format t "~D files (~:D bytes)."
	    file-count byte-count)))

(defun mark-font-files ()
  (format t "~&~10TAssessing Fonts ... ")
  (let ((translator (fs:parse-pathname "sys:"))
	(files (cdr (fs:directory-list "sys:fonts;*.qfasl#>"))))
    (dolist (file files (format t "Releasing ~D font files." (length files)))
      (mark-released
	(send (send translator :back-translated-pathname (car file))
	      :new-version :newest)))))

(defun mark-examples ()
  (format t "~&~10TAssessing Examples ... ")
  (let ((translator (fs:parse-pathname "sys:"))
	(files (cdr (fs:directory-list "sys:examples;* * >"))))
    (dolist (file files (format t "Releaseing ~D examples files." (length files)))
      (mark-released
	(send (send translator :back-translated-pathname (car file))
	      :new-version :newest)))))

(defun print-non-logical-pathnames ()
  (mapatoms-all #'find-non-logical-source-pathname))

(defun find-non-logical-source-pathname (symbol &key
					 (function #'print-non-logical-source)
					 &aux sfn)
  (typecase (setq sfn (get symbol :source-file-name))
    (cons (find-non-logical-source-pathname (car sfn) :function function)
	  (find-non-logical-source-pathname (cdr sfn) :function function))
    (fs:logical-pathname)
    (pathname (funcall function symbol sfn))))
    
(defun print-non-logical-source (symbol pathname)
  (format t "~&~A:~A ~30T- ~A"
	  (symbol-package symbol)
	  symbol
	  pathname))