;;; -*- Mode:LISP; Package:USER; Readtable:CL -*-

(require :deleter "dj:keith;deleter")

(defvar dirlist)

(setq dirlist
	'(
	  bobp				;Bob Powell
	  cdi-lambda			;obsolete tape s/w development project?
	  ct-ada			;Computer Thought Inc. ADA compiler; proprietary, not ours!!
	  dawna				;Dawna Carrette
	  gjc				;George Carrette
	  gjcx				; "      "
	  hyper				;HyperCalc product (whose??)
	  interlisp			;InterLISP product (LMI's? obsolete?)
	  jrm				;Joe Marshall
	  nick				;???
	  pace				;Pace Willison
	  pld				;Peter DeWolf
	  ptm				;??? old personal directory?
	  rauen				;Jim Rauen
	  release			;useful stuff copied to L.RELEASE;
					;(the "real" release directory, for now)
	  rms				;Richard Stallman
	  rsg				;??? personal directory
	  wlh				;William Hayward
	  youcef			;Youcef el Bennour
	  ))

(defvar pathlist)

(setq tapelist (loop for dir in dirlist
		     as  path = (make-pathname :defaults "dj:foo;*.*#>"
					       :directory (ncons (string dir)))
		     collect path))

(defvar deletelist)

(setq deletelist (loop for dir in dirlist
		       as  path = (make-pathname :defaults "dj:foo;*.*#*"
						 :directory (ncons (string dir)))
		       collect path))


(defun archivem ()
  (format t "~&Mount a tape in the tape drive. Use a large tape.")
  (when (yes-or-no-p "Proceed to archive directories to tape?")
    (tape:write-files tapelist)
    (tape:finish-tape)
    (when (yes-or-no-p "Verify files on tape?")
      (tape:rewind)
      (tape:compare-files))
    (when (yes-or-no-p "Proceed to unload tape?")
      (tape:unload))
    (when (yes-or-no-p "Proceed to delete all archived directories?")
      (when (yes-or-no-p "Are you sure you want to proceed?")
	(loop for path in deletelist do (deleter path))))))

(provide :archivem)