#!/usr/bin/scsh \
-e main -o srfi-8 -o srfi-23 -o srfi-37 -s

;; rename --- Batch-rename files

;; Copyright (C) 2006 Jorgen Schaefer

;; Author: Jorgen Schaefer <forcer@forcix.cx>

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License
;; as published by the Free Software Foundation; either version 2
;; of the License, or (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
;; 02110-1301  USA

;;; Commentary:

;; rename is a batch file renaming script which uses POSIX regexes.
;; Prior solutions to this problem allowed only limited regular
;; expressions (mmv) or only a single one (rename.pl). This script
;; allows multiple expressions, and provides a few more useful command
;; line options.

;; In the future, it might be worthwhile to provide a configuration
;; file for self-written rewriting patterns.

!#

(define rename-version "0.5")

;;; The main entry function. Parse arguments and act accordingly.
(define (main args)
  (receive (patterns files test? verbose? interactive?)
      (parse-args (cdr args))
    (cond
     ((and (null? patterns)
           (null? files))
      (help (current-error-port))
      (exit 1))
     ((null? patterns)
      (error "No rename pattern given.")))
    (for-each (make-file-handler patterns test? verbose? interactive?)
              (if (null? files)
                  (port->string-list (current-input-port))
                  files)))
  0)

;;; DISPLAY for multiple arguments.
(define (print . args)
  (for-each display args))

;;; Emit version information according to GNU standards.
(define (version)
  (print "rename version " rename-version "\n"
         "Copyright (C) Jorgen Schaefer\n"
         "rename comes with ABSOLUTELY NO WARRANTY.\n"
         "You may redistribute copies of rename\n"
         "under the terms of the GNU General Public License.\n"
         "For more information about these matters, see the file named COPYING.\n"))

;;; Display the canonical help to a port.
(define (help . portl)
  (let* ((port (if (null? portl)
                  (current-output-port)
                  (car portl)))
         (print (lambda strings
                  (for-each (lambda (string)
                              (display string port))
                            strings))))
    (print "usage: rename [OPTIONS] files ...\n"
           "Rename files ... according to patterns given in OPTIONS.\n"
           "If no files are given, file names are read from stdin, one per line.\n"
           "\n"
           "Options:\n"
           "  -e, --expression=EXPR  Rename according to EXPR. EXPR is in the form\n"
           "                         s/pattern/substitute/[gi]. Option g means global,\n"
           "                         i means case-insensitive, and the separator /\n"
           "                         can be any ASCII character.\n"
           "  -t, --test             Just print renames, don't actually do it.\n"
           "  -i, --interactive      Ask before renaming.\n"
           "  -v, --verbose          Show every rename.\n"
           "      --help             Print this help.\n"
           "      --version          Display version and copyright information.\n")))

;;; Parse arguments (uses SRFI-37).
(define (parse-args args)
  (args-fold args
             (list (option '("help") #f #f
                           (lambda (option name arg . ignored)
                             (help)
                             (exit 0)))
                   (option '("version") #f #f
                           (lambda (option name arg . ignored)
                             (version)
                             (exit 0)))
                   (option '(#\e #\r "expression") #t #f
                           (lambda (option name arg patterns files test? verbose? interactive?)
                             (values (append patterns
                                             (list (parse-pattern arg)))
                                     files test? verbose? interactive?)))
                   (option '(#\t "test") #f #f
                           (lambda (option name arg patterns files test? verbose? interactive?)
                             (values patterns files #t verbose? interactive?)))
                   (option '(#\i "interactive") #f #f
                           (lambda (option name arg patterns files test? verbose? interactive?)
                             (values patterns files test? verbose? #t)))
                   (option '(#\v "verbose") #f #f
                           (lambda (option name arg patterns files test? verbose? interactive?)
                             (values patterns files test? #t interactive?)))
                   )
             (lambda (option name arg . ignored)
               (display "Unknown command line option " (current-error-port))
               (display name (current-error-port))
               (newline (current-error-port))
               (newline (current-error-port))
               (help (current-error-port))
               (exit 0))
             (lambda (operand patterns files test? verbose? interactive?)
               (values patterns (cons operand files)
                       test? verbose? interactive?))
             '() ; Patterns
             '() ; Files
             #f  ; Test?
             #f  ; Verbose?
             #f  ; Interactive?
             ))

;;; Parse a single pattern. A pattern is in the form
;;; "s/from/to/options", where the "/" can be any character. The FROM
;;; part is any POSIX extended regular expression, while the TO part
;;; is any string, possibly using \1 backrefs. Options can be any
;;; combination of the two characters "i" (case-insensitive) and "g"
;;; (global).
(define (parse-pattern pattern)
  (if (not (and (<= 3 (string-length pattern))
                (char=? #\s (string-ref pattern 0))))
      (error "Bad pattern" pattern))
  (let ((parsed (parse-pattern-string (string-ref pattern 1)
                                      (substring pattern
                                                 2
                                                 (string-length pattern)))))
    (if (not (= (length parsed)
                3))
        (error "Bad pattern" pattern))
    (let ((pattern (posix-string->regexp (car parsed)))
          (substitute (parse-substitute (cadr parsed)))
          (options (string->list (caddr parsed))))
      (vector (if (memv #\i options)
                  (uncase pattern)
                  pattern)
              substitute
              (if (memv #\g options)
                  #t
                  #f)))))

;;; This does the basic parsing of a list of SEPARATOR-separated
;;; substrings into a list of strings. It also handles escape
;;; characters for the separator, but ignores backslashes otherwise.
;;; I.e. "fo\\/o/b\\1ar/baz" => ("fo/o" "b\\1ar" "baz").
(define (parse-pattern-string separator pattern)
  (let loop ((i 0)
             (field '())
             (fields '()))
    (cond
     ((>= i (string-length pattern))
      (reverse (cons (list->string (reverse field))
                     fields)))
     ((char=? #\\ (string-ref pattern i))
      (cond
       ((>= (+ i 1) (string-length pattern))
        (error "Trailing escape character in pattern."))
       ((char=? separator (string-ref pattern (+ i 1)))
        (loop (+ i 2)
              (cons separator field)
              fields))
       (else
        (loop (+ i 2)
              (cons (string-ref pattern (+ i 1))
                    (cons (string-ref pattern i)
                          field))
              fields))))
     ((char=? separator (string-ref pattern i))
      (loop (+ i 1)
            '()
            (cons (list->string (reverse field))
                  fields)))
     (else
      (loop (+ i 1)
            (cons (string-ref pattern i)
                  field)
            fields)))))

(define (parse-substitute subst)
  `(pre
    ,@(reverse
       (regexp-fold (rx "\\" (submatch any))
                    (lambda (start m lis)
                      (let* ((str (match:substring m 1))
                             (num (string->number str)))
                        (cons (or num
                                  str)
                              (cons (substring subst start (match:start m))
                                    lis))))
                    '()
                    subst
                    (lambda (start lis)
                      (cons (substring subst start (string-length subst))
                            lis))))
    post))

(define (apply-multiple-patterns patterns string)
  (fold apply-pattern string patterns))

(define (apply-pattern pattern string)
  (let ((re (vector-ref pattern 0))
        (items (vector-ref pattern 1))
        (global? (vector-ref pattern 2)))
    (if global?
        (apply regexp-substitute/global #f re string items)
        (let ((match (regexp-search re string)))
          (if match
              (apply regexp-substitute #f match items)
              string)))))

(define (make-file-handler patterns test? verbose? interactive?)
  (lambda (file)
    (let ((new-name (apply-multiple-patterns patterns file)))
      (cond
       ((file-exists? new-name)
        (print "Not overwriting target file " new-name "\n"))
       (test?
        (display-rename file new-name))
       (interactive?
        (display-rename file new-name)
        (cond
         ((query-user)
          => (lambda (reply)
               (if (eq? reply 'dont-ask-again)
                   (set! interactive? #f))
               (save-rename file new-name)))))
       (else
        (if verbose?
            (display-rename file new-name))
        (save-rename file new-name))))))

(define (display-rename from to)
  (print "\n"
         "Renaming file\n"
         "   " from "\n"
         "=> " to "\n"))

(define (query-user)
  (display "Really do? [(Y)es, (N)o, (D)on't ask again] ")
  (let ((line (read-line)))
    (cond
     ((string-ci=? line "y")
      #t)
     ((string-ci=? line "d")
      'dont-ask-again)
     (else
      #f))))

(define (save-rename from to)
  (if (file-exists? to)
      (print "Not overwriting target file " to "\n")
      (rename-file from to)))