Utilities for copying smbx directories and systems to non-smbx use

[<@IU.AI.SRI.COM:slug-admin@iu.ai.sri.com>]

;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 8; Package: USER -*-
;;;
;;;Functions for copying files from a symbolics' system that may use fonts to another
;;;directory structure.
;;;
;;;Author: Donald H. Mitchell
;;;
;;;I hereby give permission to copy, change, publish, or otherwise use this code to
;;;everyone.  Neither Proactive Solutions, Amoco, nor I shall be responsible for how you
;;;use this code or for whether it performs any useful function.
;;;
;;;dos-copy-system system destination-dir &key version include-components source-root
;;;strip-copy-system system destination-dir &key version include-components source-root
;;;
;;; Copies all the source files used by system into the destination-dir and in the
;;; process strips all the fonts from those files.  Will create subdirectories under
;;; destination-dir to mimic the file directory structure under either source-root or the
;;; system's default pathname.  system may be either a system object, a keyword
;;; identifying the system, or a string identifying the system.  destination-dir can be
;;; any pathname (logicals work).  :version is :released by default, but you may use any
;;; version identifier that will work with :load system or other system commands.
;;; :include-components is nil by default. If it is t, then it will also copy the
;;; component systems.  source-root is any pathname and identifies what file directory
;;; structure to duplicate.  By default, it is the system's default directory.
;;;
;;; dos-copy-system renames the files and directories to be no more than 8 characters. It
;;; also creates and writes out a file name mapping file showing the original name and
;;; the new name for each file that it copies.  The mapping file is put in the
;;; source-root directory and is named rename.map.  The renaming algorithm uses at least
;;; two letters from each "word" or the original name plus the whole last word.  It also
;;; strips out the value of *strip-name* from the left hand side of each filename or
;;; directory name.  That is, if *strip-name* is "proact-", then the file
;;; "proact-interface-macros" becomes "inmacros".
;;;
;;;strip-copy-directories source-pattern destination-root
;;;
;;; Copies all the non-binary (i.e., not "ibin" or "bin") files in the directory
;;; source-pattern to destination-root duplicating the directory structure as necessary
;;; and stripping the fonts from each file.  source-pattern may include the **
;;; wild-inferiors directory indicator.  examples,
;;;   (strip-copy-directories "jumble:**;" "clarity:~proghome/")
;;;   (strip-copy-directories "jumble:**;*.lisp.*" "clarity:~proghome/")
;;;   

(defun dos-copy-system (system destination-dir &key (version :released)
			(include-components nil)
			(source-root (sct:system-default-pathname
				       (sct:find-system-named system nil))))
  (write-name-key
    destination-dir
    (loop with system-default-pathname = source-root
	  for file in (sct:get-all-system-input-files system :version version
						      :include-components include-components)
	  as output-file = (generate-output-file-name
			     destination-dir system-default-pathname file t)
	  collect (cons (namestring file) output-file)
	  do (fs:create-directories-recursively (pathname output-file))
	     (strip-fonts-from-file file output-file)))) 

(defun strip-copy-system (system destination-dir &key (version :released)
			  (include-components nil)
			  (source-root (sct:system-default-pathname
				       (sct:find-system-named system nil))))
  (loop with system-default-pathname = source-root
	for file in (sct:get-all-system-input-files system :version version
						    :include-components include-components)
	as output-file = (generate-output-file-name
			   destination-dir system-default-pathname file)
	do (fs:create-directories-recursively (pathname output-file))
	   (strip-fonts-from-file file output-file)))

(defun strip-copy-directories (source-pattern destination-root)
  (loop for (file . props) in (fs:directory-list (make-pathname
						 :defaults source-pattern
						 :version :newest)
					       :no-extra-info)
	as output-file = (and file
			      (generate-output-file-name
				destination-root source-pattern file))
	if (and file
		(not (getf props :directory))
		(not (member (pathname-type file) '("ibin" "bin")
				  :test #'string-equal)))
	  do (fs:create-directories-recursively (pathname output-file))
	     (if (= 8 (getf props :byte-size))
		 (strip-fonts-from-file file output-file)
		 (copy-file file output-file))))

(defun generate-output-file-name (destination-dir system-default-pathname input-file
				  &optional dosify)
  (make-pathname :host (or (pathname-host destination-dir)
			   (pathname-host input-file))
		 :directory (funcall (if dosify #'dos-directories #'identity)
				     (append (pathname-directory destination-dir)
					     (directory-subtree input-file
								system-default-pathname)))
		 :name (funcall (if dosify #'generate-file-name #'identity)
				(pathname-name input-file))
		 :type (if (string=
			     (pathname-type input-file)
			     "LISP")
			   (if dosify "LSP" :lisp)
			   (pathname-type input-file))))

(defun directory-subtree (input-file default-pathname)
  (let ((input-path (remove-export (pathname-directory input-file))))
    (subseq
      input-path
      (or (mismatch
	    input-path
	    (remove-export (pathname-directory default-pathname))
	    :test #'equal)
	  (length input-path)))))

(defun remove-export (directory-list)
  (if (equal (car directory-list) "EXPORT")
      (cdr directory-list)
      directory-list))

(defvar *strip-name* "proact-")

(defun generate-file-name (name)
  (if (string-equal *strip-name* name :end2 7)
      (setf name (subseq name 7)))
  (if (find #\- name)
      (loop with result = (subseq name (1+ (position #\- name :from-end t)))
	    and position = 0
	    and count = (count #\- name)
	    with seq-size = (max 2 (floor (/ (- 8 (length result)) count)))
	    repeat count
	    do (setf result
		     (concatenate 'string (subseq name position (+ position seq-size))
				  result))
	       (setf position (1+ (position #\- name :start position)))
	    finally (return result))
      name))

(defun dos-directories (dir-list)
  (map-into dir-list #'(lambda (dir)
			 (subseq (generate-file-name dir) 0 (min 8 (length dir))))
	    dir-list))

(defun write-name-key (destination-dir name-alist)
  (with-open-file (output (merge-pathnames "rename.map" destination-dir)
			  :direction :output)
    (loop for (in . out) in name-alist
	  do (format output "~A~50T~A~%" in out))))



(si:allow-redefinition 'get-system-input-and-output-defsystem-files)
sct:(defun get-system-input-and-output-defsystem-files (system &optional (version nil)
							&key system-branch)
      (when (eq version :newest)
	(setq version nil))
      (let* ((*system* 
	       (with-stack-list (s system version system-branch)
		 (find-system-named s nil nil)))
	     (system-name (system-name *system*))
	     ;; Currently, DEFSYSTEMs are only written in Lisp
	     (stype :lisp))
	;;--- Someday make this (and its callers) understand :SYSTEM-BRANCH
	#---ignore (ignore system-branch)
	#+++ignore (assure-system-branch *system* system-branch)
	(if (null version)
	    ;; Prefer the :source-file-name over the 'system-source-file
	    (let ((source (or (si:get-source-file-name system-name 'defsystem)
			      (get system-name 'system-source-file))))
	      (unless source
		(signal 'system-declaration-not-found :system system))
	      (when (null (send source :type))
		(setq source (send source :new-type stype)))
	      (list (list (send (fs:parse-pathname (system-journal-directory
						     (subsystem-parent-system *system*)))
				;; This backtranslation works by the skin of its teeth
				:back-translated-pathname source)
			  nil)))
	    (multiple-value-bind (nil file-alist)
		(get-system-major-version *system* version)
	      (destructuring-bind (file input-version)
		  (cadr (assq :defsystem file-alist))
		(let* ((ipath (fs:parse-pathname file)))
		  (setq ipath (if (send ipath :canonical-type)
				  (send ipath :new-version input-version)
				  (send ipath :new-pathname
					:type stype
					:version input-version)))
		  (list (list ipath nil))))))))

;Date: Wed, 11 Dec 1991 19:06 CST
;From: Marty Hall <hall@aplcen.apl.jhu.edu>
;In-Reply-To: Mark Tait's message of Dec 11, 15:21
;X-Mailer: Mail User's Shell (6.1 4/26/88)
;To: TAIT@intellicorp, slug@ai.sri
;Subject: Re: Removing character styles from files.
;
;Mark Tait asked about a function for stripping character styles out
;of files. Here is one I wrote some time ago. Note that it only works if
;you run it on the Symbolics *before* shipping the file over to the Sun,
;as it makes use of the Symbolics-specific "string-thin". A more useful one
;would work on the Sun after the file is already there, but, hey, this is
;what I already had. :-)
;
;					- Marty Hall
;------------------------------------------------------
;hall@aplcen.apl.jhu.edu, hall%aplcen@jhunix.bitnet, ..uunet!aplcen!hall
;Artificial Intelligence Lab, AAI Corp, PO Box 126, Hunt Valley, MD 21030
;
;(setf (need-p 'disclaimer) NIL)
;
;;;Since receving this from Marty, I've made some minor changes, but the credit still
;;;must go to him.
(defun Strip-Fonts-from-File (Input-File &optional (Output-File Input-File))
  (let (Line)
    (with-open-file (Input Input-File)
      (with-open-file (Output Output-File
			      :direction :output
			      :if-exists :new-version)
	(loop
	  (setq Line (read-line Input nil 'Done))
	  (if
	    (equal Line 'Done)
	    (return "All Done")
	    (format Output "~A~%" (string-thin Line)))) ))
    ))

;Don Mitchell			dmitchell@trc.amoco.com
;Proactive Solutions, Inc.	(918) 660-4270
;10814 S. Quebec Ave.
;Tulsa, OK 74137