#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do rm-rf)' -s $0 "$@" # -*-scheme-*-
!#
;;; rm-rf

;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Commentary:

;; Usage: rm-rf [-v | --verbose] DIR
;;
;; Like shell command ‘rm -rf DIR’.
;;
;; From Scheme, there is one proc exported (besides ‘main’):
;;
;;   (rm-rf! verbose? dir)
;;
;; DIR can actually be a single filename.  VERBOSE? non-#f means display
;; messages of the form "removing ..." to the current output port for each
;; file and directory deleted.  The messages are similar to those produced
;; by GNU rm(1), but not an exact duplicate.

;;; Code:

(define-module (ttn-do rm-rf)
  #:export (rm-rf! main)
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ice-9 ftw) #:select (nftw))
  #:use-module ((ttn-do zzz personally) #:select (FE fs fso)))

(define (pall prefix)
  (define (msg<- s)
    (and prefix (fs s prefix)))
  (let ((bye-dir (msg<- "removing the directory itself: ‘~A’~%"))
        (bye-entry (msg<- "removing ‘~A’~%")))
    ;; ...of death (rv)
    (lambda (full si flag base level)
      (case flag
        ((regular symlink stale-symlink)
         (and prefix (fso bye-entry full))
         (delete-file full)
         #t)
        ((directory-processed)
         (and prefix (fso bye-dir full))
         (rmdir full)
         #t)
        (else
         (error (fs "~A:" flag) full)
         #f)))))

;; Recursively delete @var{dir}.
;; Display progress messages if @var{verbose?} is non-@code{#f}.
;;
(define (rm-rf! verbose? dir)
  (or (not (file-exists? dir))
      (nftw dir (pall (and verbose?
                           (string-append
                            (if (char=? #\/ (string-ref dir 0))
                                ""
                                (in-vicinity (getcwd) ""))
                            "~A")))
            'physical 'depth)))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "1.0")
                   (help . commentary)))
  (let ((qop (qop<-args args '((verbose (single-char #\v))))))
    (and (null? (qop '()))
         (error "too few arguments"))
    (FE (qop '()) (lambda (filename)
                    (rm-rf! (qop 'verbose) filename)))))

;;; rm-rf ends here