;;; -*- Mode:LISP; Package:FILE-SYSTEM; Readtable:CL; Base:10. -*-
;;;
;;; Hack for restoring TAR tapes.
;;;
;;; -dg 8/14/85
;;;

(defmacro defstring (name length)
  `(defvar ,name (make-string ,length)))

(defstring *name* 100)
(defstring *mode* 8)
(defstring *uid* 8)
(defstring *gid* 8)
(defstring *size* 12)
(defstring *time* 12)
(defstring *checksum* 8)
(defstring *link-flag* 1)
(defstring *link-name* 100)
(defstring *header-filler* 255)
(defstring *moby-string* 1000000)

(defvar *debug-plist* nil)

(defconst *dummy-unix-host*
	  (progn (si:define-host "dummy"
				 :host-names (list "dummy")
				 :machine-type :unix
				 :system-type :unix
				 :chaos '(#o01))
		 (add-file-computer '("dummy" :lmfs))
		 (si:parse-host "dummy")))

(defflavor tar-tm-input-stream () (tm-input-stream)
  (:default-init-plist :record-size 10240.))

(defflavor tar-tm-output-stream () (tm-output-stream)
  (:default-init-plist :record-size 10240.))

(defun pathname-translate-simple (namestring &optional (to-host si:local-host))
  (let ((pn (fs:parse-pathname namestring *dummy-unix-host*)))
    (fs:make-pathname :host to-host
		      :directory (pathname-directory pn)
		      :name (pathname-name pn)
		      :original-type (pathname-type pn)
		      :canonical-type (send pn :canonical-type)
		      :version (pathname-version pn))))

(defsubst read-from-string-octal (string) (parse-integer string :radix 8 :junk-allowed 't))

;  (let ((*read-base* 8.))
;    (read-from-string (string-trim '(0 #\space) string))))

(defun get-file-header-as-plist (&optional (stream (make-instance 'tar-tm-input-stream)))
  (dolist (string
	    (list *name* *mode* *uid* *gid* *size* *time* *checksum* *link-flag* *link-name*))
    (fill string 0)
    (send stream :string-in nil string))
  (send stream :string-in nil *header-filler*)
  (setq *debug-plist*
	(list *name* *mode* *uid* *gid* *size* *time* *checksum* *link-flag* *link-name*))
  (list (string-trim '(0) *name*)
	:mode (read-from-string-octal *mode*)
	:uid (read-from-string-octal *uid*)
	:gid (read-from-string-octal *gid*)
	:length-in-bytes (read-from-string-octal *size*)
	:creation-date (+ #.(time:parse-universal-time "January 1, 1970")
			  (read-from-string-octal *time*) 0)
	:checksum (read-from-string-octal *checksum*)
	:link-flag (not (memq (char *link-flag* 0) `(#\center-dot #\space)))
	:link-name (string-trim '(0) *link-name*)))

(defun print-header (plist &optional (stream *standard-output*))
  (format stream "~&File relative name: ~A" (car plist))
  (do ((list (cdr plist) (cddr list)))
      ((null list))
    (format stream "~&~A: ~S" (car list) (cadr list)))
  (format stream "~2%"))

(defsubst moby-indirect-string (size)
  (when (> size (length *moby-string*))
    (setq *moby-string* (make-string size)))
  (nsubstring *moby-string* 0 size))

(defun list-tar-image (input-stream &optional (output-stream *standard-output*))
  (condition-case ()
      (do-forever
	(let ((plist (get-file-header-as-plist input-stream)))
	  (print-header plist output-stream)
	  (unless (get plist :link-flag)
	    (send input-stream :string-in nil
		  (moby-indirect-string (* (ceiling (get plist :length-in-bytes) 512.) 512.))))))
    (fs:end-of-tape (close input-stream))))

(defun list-tar-tape (&optional (output-stream *standard-output*))
  (tm-rewind)
  (let ((stream (make-instance 'tar-tm-input-stream)))
    (list-tar-image stream output-stream)))

(defun list-tar-file (filename &optional (output-stream *standard-output*))
  (with-open-file (stream filename)
    (list-tar-image stream output-stream)))

(defun dump-tar-tape (stream &key
		      (record-size 10240.)
		      (ascii-translate t))
  (let ((istream (make-instance 'tar-tm-input-stream))
	(string (make-string record-size)))
    (condition-case ()
	(do-forever
	  (send istream :string-in nil string)
	  (when ascii-translate 
	    (string-subst-char #\return #\delta string nil nil)
	    (string-subst-char #\tab #\gamma string nil nil))
	  (send stream :string-out string))
      (fs:end-of-tape))))

(defun dump-tar-tape-to-file (filename &optional ascii-translate)
  (tm-rewind)
  (with-open-file (file filename :direction :output)
    (dump-tar-tape file :ascii-translate ascii-translate)))

(defun print-tar-tape ()
  (dump-tar-tape *standard-output*))

(defun restore-tar-file (stream &key
			 (pathname-function)
			 ignore-links
			 overwrite
			 (ascii-translate t))
  (let ((plist (get-file-header-as-plist stream)))
    (format t "~&Found file [~A] - " (car plist))
;    (when (neq (tyi) #\space)
;      sldkj)
    (if (and (get plist :link-flag) ignore-links) (format t "[link] ignoring.~%")
      (multiple-value-bind (pathname characters-p) (funcall pathname-function (car plist))
	(send stream :string-in nil
	      (moby-indirect-string (* (ceiling (get plist :length-in-bytes) 512.) 512.)))
	(if (not pathname)
	    (format t "filtered-out.~%")
	  (when (if (typep (send pathname :truename nil) 'fs:pathname)
		    (case overwrite
		      (:ask (y-or-n-p "File ~A already exists; Overwrite it?" pathname))
		      (nil (format t "not overwriting.~%") nil)
		      (t (format t "overwriting to [~A].~%" pathname) t))
		  (format t "writing to [~a]" pathname)
		  t)
	    (with-open-file (filestream pathname :characters characters-p :direction :output)
	      (let ((string-to-output (moby-indirect-string (get plist :length-in-bytes))))
		(when ascii-translate
		  (string-subst-char #\return #\delta string-to-output nil nil)
		  (string-subst-char #\tab #\gamma string-to-output nil nil))
		(send filestream :string-out string-to-output)))))))))


(defun restore-tar-tape (pathname-function &key
			 overwrite ignore-links
			 (ascii-translation t))
  (tm-rewind)
  (with-open-file (ignore "half-inch-tape:")
    (let ((tar-stream (make-instance 'tar-tm-input-stream)))
      (condition-case ()
	  (do-forever
	    (restore-tar-file tar-stream
			      :ignore-links ignore-links
			      :pathname-function pathname-function
			      :overwrite overwrite
			      :ascii-translate ascii-translation))
	(fs:end-of-tape)))))

(defun write-tar-tape (directory)
  (tm-rewind)
  (with-open-file (ignore "half-inch-tape:")
    (let ((tar-stream (make-instance 'tar-tm-output-stream)))
      (condition-case ()
	  (write-tar-directory directory tar-stream)
	(fs:end-of-tape)))))

(defun write-tar-directory (directory stream)
  (let ((files (cdr (fs:directory-list directory))))
    (loop for file in files unless (get files :directory) do
	  (write-tar-file (first file) (cdr file) stream))
    (loop for file in files when (get files :directory) do
	  (write-tar-directory (send (send (first file) :pathname-as-directory) :new-pathname
				     :name (send directory :name)
				     :type (send directory :type)
				     :version (send directory :version))
			       stream))))

(defun add-to-*name* (offset string)
  (let* ((lth (string-length string))
	 (end (+ offset lth)))
    (loop for findex from 0 below lth and tindex upfrom offset do
	  (setf (aref *name* tindex) (char-downcase (aref string findex))))
    end))

(defun generate-tar-file-name (path)
  (fill *name* 0)
  (let ((dirs (send path :directory)) (offset 0))
    (cond ((not (listp dirs)) (setq offset (add-to-*name* offset dirs)))
	  (t (setq offset (add-to-*name* offset (first dirs)))
	     (loop for subdir in (cdr dirs) do
		   (setq offset (add-to-*name* offset "/"))
		   (setq offset (add-to-*name* offset subdir)))))
    (setq offset (add-to-*name* offset "/"))
    (setq offset (add-to-*name* offset (send path :name)))
    (setq offset (add-to-*name* offset "."))
    (setq offset (add-to-*name* offset (send path :type)))))

;(defun write-tar-file (file properties stream)
;  (generate-tar-file-name (first-file))
;  (fill *mode* #\7)
;  (copy-array-contents "100" *uid*)
;  (copy-array-contents "100" *gid*)
;  (format