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

1;;; DELETER -- vile* 1rile file master blaster

;;; Use (deleter <pathname>) -- watch out!* 1everything must go!*

;; Utility functions

(defun directory-as-file-p(p)
  (get (cadr(fs:directory-list p)) :directory))

(defun my-delete-file(p)
  (when (probef p)
    (format t "~&Deleting ~s" p)
    (delete-file p)))

(defun my-delete-empty-directories(p)
  (when (not(errorp(fs:directory-list p :noerror)))
    (format t "~&Deleting empty subdirectories of ~s" p)
    (fs:lmfs-delete-empty-directories nil (send p :directory))))

(defun my-delete-directory(p)
  (when (not(errorp(fs:directory-list p :noerror)))
    (format t "~&Deleting empty directory ~s" p)
    (fs:lmfs-delete-empty-directory (fs:lookup-directory (send p :directory)) nil)))

(defun my-expunge-directory(p)
  (when (not(errorp(fs:directory-list p :noerror)))
    (format t "~&Expunging files in ~s" p)
    (fs:expunge-directory p)))

(defun parent-dir(p)
  (let* ((pathname (fs:translated-pathname p))
	 (directory (send pathname :directory)))
    (if (or (not (consp directory)) (= 1 (length directory)))
	(pathname (fs:merge-pathname-defaults "~;*.*" pathname))
      (send (send pathname :directory-pathname-as-file) :new-pathname
	    :directory (butlast directory)
	    :name :wild :type :wild :version :wild))))

1;; Main routines*

(defun delete-recursively(l kill-dirs &aux d)
  (cond
    ((null l) nil)
    ((listp l) (mapcan #'delete-recursively l (circular-list kill-dirs)))
    ((directory-as-file-p l)
     (setq d (merge-pathnames
	       "*.*#*" (send l :pathname-as-directory)))
     (delete-recursively (directory d) kill-dirs)
     (my-expunge-directory d)
     (when kill-dirs (my-delete-directory d)))
    (t (my-delete-file l))))

(defun deleter(pathname &key (kill-directories t))
  (let* ((p (fs:translated-pathname pathname))
	 (n (send p :name)))
    (cond
      ((errorp(fs:directory-list p :noerror))
       (ferror nil "There is no directory ~s" p))
      ((not(or (eq (send p :host) si:local-host)
	       (eq (send p :host) (send (pathname "lm:~;") :host))))
       (ferror nil "DELETER only works on the local file system"))
      ((null (yes-or-no-p
	       "~&Are you sure you want to blast the directory ~s? " p)))
      (t
1            ;;Do it*
       (delete-recursively (directory p) kill-directories)
       (my-expunge-directory p)
1            ;;Only delete directory...*
       (when (and kill-directories		1;if user said so and*
		  (or (null n) (eq n :wild)))	1;no files specified*
	 (my-delete-directory p)
	1  ;;Clean up parent directory*
	 (my-expunge-directory (parent-dir p))))
      )))


(provide :deleter)

#|

1;; Routines for testing DELETER -- run (maker)*

(defun create-file(p)
  (with-open-file (s p :direction :output) s))

(defun maker()
  (fs:create-directory "lm:test;")
  (create-file "lm:test;afile.text")
  (create-file "lm:test;zfile.text")
  (create-file "lm:test;a.lisp")
  (fs:create-directory "lm:test.a;")
  (create-file "lm:test.a;afile.text")
  (create-file "lm:test.a;zfile.text")
  (fs:create-directory "lm:test.b;")
  (create-file "lm:test.b;afile.text")
  (create-file "lm:test.b;zfile.text")
  (fs:create-directory "lm:test.c;")
  (create-file "lm:test.c;afile.text")
  (create-file "lm:test.c;zfile.text")
  (fs:create-directory "lm:test.c.d;")
  (create-file "lm:test.c.d;afile.text")
  (create-file "lm:test.c.d;zfile.text")
  (fs:create-directory "lm:test.c.d.e;")
  )

|#