#!/bin/sh
exec ${GUILE-guile} -e "(ttn-do display-state-summary)" -s $0 "$@" # -*-scheme-*-
!#
;; Copyright (C) 2007, 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: display-state-summary [DIR]
;;
;; For each file under and in directory DIR ("." if unspecified),
;; display a one-line summary of the form:
;;
;; STATE MTIME FILENAME
;;
;; where STATE is a version control state, typically "Rel" or "Exp";
;; MTIME is formatted using "%F %T" (eg, "2007-09-01 03:27:14"); and
;; FILENAME is the relative filename from DIR.
;;
;; At this time, there is support for RCS and CVS, detected by the
;; presence of subdir RCS or CVS in DIR.  If no such subdir exists,
;; display an error message and exit failurefully.

;;; Code:

(define-module (ttn-do display-state-summary)
  #:export (main)
  #:use-module ((ttn-do zzz banalities) #:select (check-hv))
  #:use-module ((ttn-do zzz personally) #:select (accumulator
                                                  FE))
  #:use-module ((ttn-do zzz lookingfor) #:select (grep-matches))
  #:use-module ((ttn-do zzz subprocess) #:select (shell-command->string
                                                  shell-command->list
                                                  file-lines))
  #:use-module ((ttn-do zzz filesystem) #:select (directory-vicinity
                                                  not-dot-not-dotdot
                                                  filtered-files
                                                  with-cwd))
  #:use-module ((srfi srfi-13) #:select (string-prefix?
                                         string-map
                                         string-drop-right))
  #:use-module ((ice-9 regex) #:select (match:substring))
  #:use-module ((ttn-do mogrify) #:select (editing-buffer)))

(define (mkrx . parts)
  (make-regexp (apply string-append parts) regexp/newline))

(define *working-file-rx*
  (mkrx "\nWorking file: ([^ ]+)\n"))

(define *date/state-rx*
  (mkrx "\ndate:"
        ;; classic RCS, CVS 1.11 and prior: "2005/09/16 10:09:06;"
        ;;              CVS 1.12 and later: "2004-10-27 12:52:57 +0000;"
        ;; actually, CVS "later" may do something else weird, who knows...
        " (....[-/]..[-/].. ..:..:..)[^;]*;"
        ".+ state:"
        " ([^;]+);"))

(define (slash-to-dash s)
  (string-map (lambda (c)
                (case c
                  ((#\/) #\-)
                  (else c)))
              s))

(define (scan/spew be-dir command getfiles)

  (define (state-info files)
    (let ((acc (accumulator)))
      (editing-buffer (shell-command->string
                       (apply string-append command
                              (apply append (map (lambda (file)
                                                   (list " " file))
                                                 files))))
        (goto-char (point-min))
        (while (re-search-forward *working-file-rx* #f #t)
          (let ((filename (match-string 1)))
            (re-search-forward *date/state-rx*)
            (acc (cons (string-append
                        ;; State.
                        (match-string 2)
                        " "
                        ;; Ensure ISO date.
                        (slash-to-dash (match-string 1))
                        " ")
                       filename)))))
      (acc)))

  (define (one tag filename)
    (display tag)
    (display (if (string-prefix? "./" filename)
                 (substring filename 2)
                 filename))
    (newline))

  (FE (sort (shell-command->list
             (string-append "find . -name "
                            be-dir
                            " -printf '%h\\n'"))
            string<?)
      (lambda (dir)
        (let* ((files (getfiles (directory-vicinity dir)))
               (all (sort (if (null? files)
                              '()
                              (state-info files))
                          (lambda (x y)
                            (string>? (car x) (car y))))))
          (FE (map car all)
              (map cdr all)
              one)))))

(define *methods*
  ;; (BE-DIR COMMAND GETFILES)
  `(("RCS" "rlog -r. -N"
     ,(lambda (in)
        (map (lambda (file)
               (in (string-drop-right file 2)))
             (filtered-files not-dot-not-dotdot (in "RCS")))))
    ("CVS" "cvs log -N -r"
     ,(lambda (in)
        (map (lambda (m)
               (in (match:substring m 1)))
             (grep-matches "^/([^/]+)/" (file-lines (in "CVS/Entries"))))))))

(define (do-it! top)

  (define (dir-ok? name strict?)
    (and (or (file-exists? name)
             (and strict? (error "no such file:" name)))
         (or (file-is-directory? name)
             (and strict? (error "not a directory:" name)))
         (assoc name *methods*)))

  (dir-ok? top #t)
  (with-cwd top
    (cond ((or (dir-ok? "RCS" #f)
               (dir-ok? "CVS" #f))
           => (lambda (be-entry)
                (apply-to-args be-entry scan/spew)))
          (else (error "cannot find RCS/ or CVS/ under" top)))))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "1.1")
                   (help . commentary)))
  (do-it! (if (null? (cdr args))
              "."
              (cadr args))))

;;; display-state-summary ends here