;;; -*- 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
	     ))

(defconst *default-lambda-pathname-filters*
	  `("sys:cold;*.*#*"))

(defconst *default-lambda-additional-pathnames*
	  ())
	  
(defconst *default-lambda-additional-functions*
	  `(
	    mark-font-files
	    mark-gateway-data-files
	     ))

(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))))))

(defsubst 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 'string-lessp)))

(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))))
    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 files: " (length si:fasloaded-file-truenames))
  (do* ((pos (cursorpos))
	(flist si:fasloaded-file-truenames (cdr flist))
	(count (length flist) (sub1 count))
	(stray-count 0)
	(translator (fs:parse-pathname "sys:"))
	(logical-pathname
	  (when flist
	    (send (send translator :back-translated-pathname
			(fs:parse-pathname (car flist)))
		  :new-pathname :canonical-type :lisp :version :newest))
	  (when flist
	    (send (send translator :back-translated-pathname
			(fs:parse-pathname (car flist)))
		  :new-pathname :canonical-type :lisp :version :newest))))
       ((null flist)
	(format t "~D stray files" stray-count)
	stray-count)
    (cursorpos (car pos) (cdr pos))
    (cursorpos 'l)
    (princ count)
    (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 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*))

(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;* gate >")))
	(byte-count 0)
	collection)
    (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 (push (car file) collection)
		 (incf byte-count (* (or (get file :length-in-bytes)
					 (* (or (get file :length-in-blocks) 1) si:page-size 4))
				     (/ (tape:file-byte-size file) 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.")
	    (setq found-one (push (car file) collection))))))
    (format t "~D files (~:D bytes)."
	    (length collection) 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)))))