;;; -*- Mode:LISP; Base:10 -*-

(defconst source-machine "angel")
(defconst source-base "//lmi//pace//t//t3//comp")

(defconst dest-machine "lad")
(defconst dest-base "orbit.")

(defconst dir-names '("assembler" "back_end" "build" "front_end" "primops" "top"))

;foo length(bytesize) date time owner filename

(defun do-tree ()
  (mapcar 'get-file-list dir-names))

(defun get-file-list (dir-name &optional copy-even-if-already-present just-print)
  (let ((file-list-name (string-append source-machine ":" source-base "//" dir-name "//files"))
	(ubase (parse-unix-pathname source-base)))
    (with-open-file (s file-list-name)
;     (format t "~&~s" (send s :pathname))
;     (format t "~&~s" (send s :creation-date))
      (do ((line (get-line s) (get-line s)))
	  ((null line))
	(let ((line-list (strip-garbage (parse-string-into-list line))))
	  (when line-list
	    (let* ((uname (parse-unix-pathname (nth 5 line-list)))
		   (mname (merge-name ubase uname))
		   (lname (lisp-name (trailing-part ubase mname)))
		   (creation-date (time:parse-universal-time (string-append (nth 2 line-list)
									    " "
									    (nth 3 line-list))))
		   (author (nth 4 line-list)))
;	      (format t "~&~s" line-list)
;	      (format t "~&   src=~s  lname=~s" mname lname)
	      
	      (let ((source-name (string-append source-machine ":" (unix-name mname)))
		    (dest-name (string-append dest-machine ":" dest-base lname)))
		(cond (just-print
		       (format t "~&copy: ~s~&  to: ~s" source-name dest-name))
		      ((and (null copy-even-if-already-present)
			    (probe-file dest-name))
		       (format t "~&file ~s already exists." dest-name))
		      ((probe-file source-name)
		       (fs:copy-file source-name
				     dest-name
				     :create-directories t
				     :report-stream *standard-output*)
		       (fs:change-file-properties dest-name
						  t	;error-p
						  :author author
						  :creation-date creation-date)
		       (format t "~&setting author to ~s, date to ~s"
			       author
			       (time:print-universal-time creation-date nil)))
		      (t
		       (format t "~&file ~s does not exist." source-name)))
		)))))
      )))

;trim last to 14
(defun unix-name (strings)
  (do ((s strings (cdr s))
       (r ""))
      ((null s)
       (string-downcase r))
    (setq r (string-append r "//" (substring (car s) 0 (min 14. (string-length (car s))))))
    ))

;if no "." in last part, append ".#>"
(defun lisp-name (name)
  (setq name (copylist name))
  (do* ((n name (cdr n))
	(l ""))
       ((null n)
	(string-subst-char #\- #\_ l))
    (setq l (string-append l (car n)))
    (if (cdr n)
	(if (cddr n)
	    (setq l (string-append l "."))
	  (setq l (string-append l ";"))
	  (if (null (string-search-char #\. (cadr n)))
	      (setf (cadr n) (string-append (cadr n) ".#>"))))
      )))

(defun trailing-part (base-name file-name)
  (do ((b base-name (cdr b))
       (f file-name (cdr f)))
      ((null b)
       f)))

(defun merge-name (base-name file-name)
  (do ((b base-name (cdr b))
       (start nil (push (car b) start)))
      ((or (null b)
	   (match-name b file-name))
       (append (reverse start) file-name))))

(defun match-name (base-name file-name)
  (do ((b base-name (cdr b))
       (f file-name (cdr f)))
      ((null b)
       t)
    (if (not (equal (car b) (car f)))
	(return nil))))

(defun strip-garbage (l)
  (if (string-equal (car l) "cftp>" :end1 5)
      (cdr l)
    l))

(defun get-line (s)
  (multiple-value-bind
    (line eof-p)
      (send s :line-in)
    (if eof-p
	nil
      line)))

(defconst white-space-chars '(#/SPACE #/TAB #/RETURN #o15 #o12 #o11))

(defun parse-string-into-list (str)
  "parse ascii string; return list of white-space-separated components"
  (do ((return-list nil)
       (start)
       (end 0))
      ((or (null end)
	   (null (setq start (string-search-not-set white-space-chars str end))))
       return-list)
    (setq end (string-search-set white-space-chars str start))
    (setq return-list (append return-list (list (substring str start end))))))

(defconst *dummy-unix-host* (si:make-dummy-host :unix))

(defun parse-unix-pathname (pathname)
  "parse pathname into list of component names"
  (let* ((path (fs:parse-pathname pathname *dummy-unix-host*))
	 (return-list (list (fs:unix-filename (send path :name) (send path :type))))
	 (dir (send path :directory)))
    (if (listp dir)
	(append dir return-list)
      (if (and dir (neq dir :root))
	  (push dir return-list))
      (if (equal (car return-list) "")
	  '(".")
	return-list))))