;;; -*- Mode:LISP; Package:USER; Fonts:(MEDFNT MEDFNB); Base:10; Readtable:ZL -*-

;1;;DOC-TAPES*

(defvar *docdir*
	(make-pathname :host 'it
		       :directory '("BACKUP-LOGS" "ANGEL-ARCHIVES")))

(defun docl() (listf *docdir*))

(defun doct(from to &key (fcn #'ignore))
  1"FROM and TO are used to name the tape listing, e.g. archive-A-B.
If FCN is a function, it gets applied to the result of running
TAPE:LIST-FILES on the tape.  The function should take one argument,
which is a tape file property list.  The CAR of the list is the tape file's
pathname; the rest of the list consists of property/value pairs."*
  (let((path (make-pathname :defaults *docdir*
			    :name (format nil
					  "~:@(~a-~a-~a~)"
					  "angel"
					  from to)
			    :type "TEXT"
			    :version :highest)))
    (let((truename (probe-file path)))
      (cond
	((null truename)
	 (setq truename path))
	((yes-or-no-p "~a already exists - supersede?" truename)
	 (format t "~%Ok."))
	(t (error "~a already exists" truename)))
      (format t "~%Output to ~a" truename)
      (with-open-file(outfile truename :direction :output)
	(with-open-stream(outstream (make-broadcast-stream outfile *standard-output*))
	  (format outstream "~&;;;Listing tape, logging to ~a" truename)
	  (let((tape:*selected-format* (tape:parse-format "TAR")))
	    (tape:set-format-options
	      `(:default-dummy-transform-pathname ,*docdir*))
	    (tape:set-format-options)
	    (tape:rewind)
	    (condition-case()
		(mapcar
		 (if (functionp fcn) fcn
		   (error "~s is not a function" fcn))
		 (tape:list-files :output-to outstream))
	      (sys:abort
	       (format outstream "~%User aborted.")))
	    (format outstream "~&Rewinding tape.")
	    (tape:rewind)))
	truename))))