#! /usr/bin/env gosh

(use srfi-1)           ;; list library
(use srfi-2)           ;; and-let*
(use srfi-13)          ;; string library
(use file.util)        ;; file and path utils
(use gauche.parseopt)  ;; parse-options

;; autoload various rename rules
(autoload gauche.charconv ces-convert)
(autoload text.kakasi kakasi-wakati-roman)
(autoload text.tr string-tr)
(autoload rfc.uri uri-encode-string uri-decode-string)
(autoload rfc.base64 base64-encode-string base64-decode-string)
(autoload rfc.quoted-printable quoted-printable-encode-string
          quoted-printable-decode-string)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; help

(define (print-help)
  (print "usage: grename [options] files")
  (print "  -h, --help                this message")
  (print "  -from <charset>           source charset of file names")
  (print "  -to <charset>             dest charset of file names")
  (print "  -j, --join <str>          join string for multi-word rules")
  (print "  -f, --force               force rename")
  (print "  -i, --interactive         force interactive (overrides -f)")
  (print "  -r, --recursive           recursively rename directories")
  (print "  -u, --uri-encode          uri-encode special chars")
  (print "  -U, --uri-decode          uri-decode special chars")
  (print "  -b, --base64-encode       base64-encode special chars")
  (print "  -B, --base64-decode       base64-decode special chars")
  (print "  -q, --quoted-encode       quoted-printable-encode special chars")
  (print "  -Q, --quoted-decode       quoted-printable-decode special chars")
  (print "  -k, --kakasi              convert kanji to ascii pronunciation")
  (print "  --13, --rot13             rot13 file name")
  (print "  -s, --strip               strip unsafe chars")
  (print "  -S, --safe <chars>        specify which characters are safe")
  (print "  -x, --regexp <from> <to>  rename by regexp-replace")
  (print "  -y, --tr <from> <to>      translate characters like tr")
  (print "  -p, --procedure <proc>    rename by arbitrary procedure")
  (print "  -v, --verbose             verbose output")
  (exit))

(define (print-commands)
  (print "Rename commands:")
  (print "  y  -  yes")
  (print "  n  -  no")
  (print "  i  -  input new name")
  (print "  q  -  quit")
  (print "  !  -  yes to all")
  (print "  a  -  abort (undo all and quit)")
  (print "  ?  -  help"))

(define (main args)
  (define (default-encoding)
    (or (sys-getenv "LC_CHARSET")
        (and-let* ((lang (or (sys-getenv "LANG")))
                   (m (#/\.([^.]+)$/ lang)))
          (m 1))
        (gauche-character-encoding)))
  (call/cc
   (lambda (quit)
     (define ordered? #f)
     (define charconv? #f)
     (define from-cs (default-encoding))
     (define to-cs (default-encoding))
     (define term-cs #f)
     (define (maybe-conv s a b)
       (if (equal? a b) s (ces-convert s a b)))
     (define (charconv s) (maybe-conv s from-cs to-cs))
     (define (from->term s) (maybe-conv s from-cs term-cs))
     (define (to->term s) (maybe-conv s to-cs term-cs))
     (define (<-term s) (maybe-conv s term-cs to-cs))
     (define trans identity)
     (define trans-ls '())
     (define (wrap f . opt)
       (if ordered?
         (set! trans (compose f trans))
         (push! trans-ls (cons f (get-optional opt 50)))))
     (define safe "-+.\\w")
     (define joiner "-")
     (define (kakasi-trans s)
       (let ((w (map
                 (cut maybe-conv <> (gauche-character-encoding) to-cs)
                 (kakasi-wakati-roman
                  (maybe-conv s to-cs (gauche-character-encoding))))))
         (if (#/^\./ (last w))
           (string-append
            (string-join (drop-right w 1) joiner)
            (last w))
           (string-join w joiner))))
     (define undo-ls '())
     (let-args (cdr args)
         ((from "f|from|from-charset=s"
             => (lambda (s) (set! from-cs s) (unless charconv? (wrap charconv 30))))
          (to "t|to|to-charset=s"
             => (lambda (s) (set! to-cs s) (unless charconv? (wrap charconv))))
          (term "T|term|term-charset=s" (lambda (s) (set! term-cs s)))
          (uri-encode? "u|uri|uri-encode" => (cut wrap uri-encode-string))
          (uri-decode? "U|uri-decode" => (cut wrap uri-decode-string))
          (base64-encode? "b|base64|base64-encode"
             => (cut wrap base64-encode-string 80))
          (base64-decode? "B|base64-decode"
             => (cut wrap base64-decode-string 20))
          (qp-encode? "q|quoted|quoted-encode|quoted-printable-encode"
             => (cut wrap quoted-printable-encode-string 75))
          (qp-decode? "Q|quoted-decode|quoted-printable-decode"
             => (cut wrap quoted-printable-decode-string 25))
          (strip? "s|strip"
             => (cut wrap (lambda (s) (regexp-replace-all (format "[^~A]" safe) s ""))))
          (safe "S|safe|safe-chars=s"
             => (lambda (s) (set! safe s)))
          (kakasi? "k|kakasi" => (cut wrap kakasi-trans 40))
          (tr "y|tr|transliterate=ss" => (lambda (f t) (wrap (cut string-tr <> f t))))
          (rot13? "13|rot13" => (cut wrap (cut string-tr <> "A-Za-z" "N-ZA-Mn-za-m")))
          (join "j|join" => (lambda (s) (set! joiner s)))
          (regexp "x|regexp=ss"
             => (lambda (r v) (wrap (lambda (s) (regexp-replace-all r s v)))))
          (proc "p|procedure=s" => (lambda (s) (wrap (eval (read-from-string s) (current-module)))))
          (order "o|ordered" => (set! ordered? #t))
          (unorder "O|unordered" => (set! ordered? #f))
          (force? "F|force")
          (interactive? "i|interactive")
          (recurse? "r|recurse|recursive")
          (verbose? "v|verbose")
          (testing? "n|no-action")
          (help? "h|help" => (cut print-help))
          (else (opt . _) (error "unknown option:" opt))
          . rest)
       ;; either print help or process
       (cond
         ((null? rest)
          (print-help))
         (else
          (set! interactive? (or interactive? (not force?)))
          (set! term-cs (or term-cs to-cs))
          (when (pair? trans-ls)
            (let ((procs (map car (sort trans-ls (lambda (a b) (< (cdr a) (cdr b)))))))
              (set! trans (apply compose (cons trans procs)))))
          ;; main rename loop
          (let loop ((sources rest))
            (let ((file (car sources)))
              (let ((files (if (file-is-directory? file)
                             (cddr (sys-readdir file))
                             (list file)))
                    (base (if (file-is-directory? file) file "")))
                (define (move old new)
                  (let ((f1 (build-path base old))
                        (f2 (build-path base new)))
                    (with-error-handler
                        (lambda (err . args)
                          (warn "couldn't rename: ~S" err))
                      (lambda ()
                        (sys-rename f1 f2)
                        (if interactive? (push! undo-ls (cons f1 f2)))
                        (if verbose?
                          (format #t "rename: ~A => ~A\n" (from->term f1)
                                  (to->term f2)))))))
                (for-each
                 (lambda (f)
                   (let ((new (with-error-handler
                                  (lambda (err . opts)
                                    (warn "error translating: ~S" err)
                                    f)
                                (cut trans f))))
                     (unless (equal? f new)
                       (if interactive?
                         (let input ()
                           (if (file-exists? new)
                             (format #t "File '~A' already exists\n" new))
                           (format #t "Rename '~A' to '~A'? [yniqa!?] "
                                   (from->term f) (to->term new))
                           (flush)
                           (let* ((line (read-line))
                                  (c (string-ref line 0)))
                             (case c
                               ((#\y #\Y) (move f new))
                               ((#\n #\N) #f)
                               ((#\q #\Q) (quit #t))
                               ((#\!)
                                (move f new)
                                (set! interactive? #f))
                               ((#\i #\i)
                                (format #t "Enter new name: ")
                                (flush)
                                (set! new (<-term (read-line)))
                                (input))
                               ((#\? #\h #\H)
                                (print-commands)
                                (input))
                               ((#\a #\A)
                                (with-error-handler
                                    (lambda (err . args) (warn "error undoing"))
                                  (lambda ()
                                    (for-each
                                     (lambda (x) (sys-rename (cdr x) (car x)))
                                     undo-ls)))
                                (quit #t))
                               ((#\newline #\return #\space \#tab)
                                (input))
                               (else
                                (print "Press 'h' for help")
                                (input)))))
                         (move f new)))))
                 files)
                ;; maybe recurse
                (if (and recurse? (file-is-directory? file))
                  (loop (filter file-is-directory? (cddr (sys-readdir file)))))))
            (unless (null? (cdr sources))
              (loop (cdr sources)))))))))
  0)