#!/bin/sh
#| -*- scheme -*-
exec mzscheme -r "$0" "$@"

* get more ideas from http://www.cis.upenn.edu/~bcpierce/unison/index.html

|#

;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)

;; (require (lib "errortrace.ss" "errortrace"))

;; Configuration

(define rc-file-name ".syncfiles")
(define (get-tmp-name) (rc-file ".tmp"))
(define indent        " | ")
(define emtz-files    '())
(define output-file   #f)
(define cd-to-info?   #t)
(define verbose?      #t)
(define extended-mtz? #t)
(define swindle-mtz?  #f)
(define write-info?   #t)
(define write-info-anyway? #f)
(define no-op?        #f)
(define no-op-update? #f)
(define ignore-links? #f)
(define ignore-modes? #f)
(define added-scans   '())
(define deleted-scans '())
(define delete-emtz?  #f)
(define messages0     '())
(define messages1     '())
(define only-current? #f)
(define show-rsync-patterns? #f)

;; Error management

(define (eprintf . args)
  (apply fprintf (current-error-port) args))

(define end-file-counter #f)
(define (error-exit . args)
  (when end-file-counter (end-file-counter #t))
  (apply eprintf args) (exit 1))

(current-exception-handler
 (lambda (e) (error-exit "~a\n" (if (exn? e) (exn-message e) e))))
(initial-exception-handler (current-exception-handler))

;; Globals

(define scans         #f)
(define minimal-scans #f)
(define scan-tree     #f)
(define old-info      #f)
(define new-info      #f)
(define changes       #f)
(define other-info    #f)
(define scan-ignores  #f)

;; Utilities

(require (lib "list.ss") (lib "port.ss") (lib "string.ss"))

(define (printff . args)
  (apply printf args) (flush-output))

(define concat string-append)

(define (pwd) (path->string (current-directory)))

(define (negate f)
  (lambda (x) (not (f x))))

(define (mappend f lists)
  (apply append (map f lists)))

(define (rcons x y)
  (append x (list y)))

(define (some pred? l)
  (and (not (null? l)) (or (pred? (car l)) (some pred? (cdr l)))))

(define (remove-duplicates lst)
  (if (null? lst)
    '()
    (cons (car lst) (remove-duplicates (remove (car lst) (cdr lst))))))

;; Sort when sometimes the input is sorted or just the 1st one needs relocation
(define (smart1-sort l p?)
  (define (sorted? l)
    (and (p? (1st l) (2nd l)) (or (null? (cddr l)) (sorted? (cdr l)))))
  (define (insert x l)
    (let loop ((l l) (r '()))
      (cond ((null? l) (reverse! (cons x r)))
            ((p? x (car l)) (append (reverse! r) (cons x l)))
            (else (loop (cdr l) (cons (car l) r))))))
  (cond ((or (null? l) (null? (cdr l))) l)
        ((null? (cddr l)) (if (sorted? l) l (quicksort l p?)))
        ((not (sorted? (cdr l))) (quicksort l p?))
        ((p? (1st l) (2nd l)) l)
        (else (insert (car l) (cdr l)))))

(define (ls . dir)
  (smart1-sort (map path->string (apply directory-list dir)) string<?))

(define (maybe-read default)
  (with-handlers ((void (lambda (_) default)))
    (let ((x (read))) (if (eof-object? x) default x))))

(define (rc-file . args)
  (apply concat rc-file-name args))

(define (with-output-to-string thunk)
  (let ((str (open-output-string)))
    (parameterize ((current-output-port str))
      (thunk))
    (close-output-port str)
    (get-output-string str)))

(define (read-from-string str)
  (read (open-input-string str)))

(define (cat . n)
  (copy-port (if (null? n)
               (current-input-port)
               (make-limited-input-port (current-input-port) (car n)))
             (current-output-port)))

(define (display-file path)
  (with-input-from-file (list->path path) cat))

(define identity (lambda (x) x))
(define 1st car)
(define 2nd cadr)
(define 3rd caddr)
(define 4th cadddr)
(define 5th (lambda (x) (car (cddddr x))))
(define 6th (lambda (x) (cadr (cddddr x))))
(define 7th (lambda (x) (caddr (cddddr x))))
(define 8th (lambda (x) (cadddr (cddddr x))))

;; simple definition -- assume global ports are streams
(define (system* exe . args)
  (let-values (((p pout pin perr)
                (apply subprocess (current-output-port) (current-input-port)
                       (current-error-port) exe args)))
    (subprocess-wait p)
    (eq? (subprocess-status p) 0)))

(define (get-process-output-lines exe . args)
  (let-values (((p pout pin perr)
                (apply subprocess #f (current-input-port) (current-error-port)
                       exe args)))
    (let loop ((lines '()))
      (let ((line (read-line pout)))
        (if (eof-object? line)
          (begin (close-input-port pout) (subprocess-wait p) (reverse! lines))
          (loop (cons line lines)))))))

(define (find-exe exe) (find-executable-path exe #f))
(define (make-exe>> exe pred?)
  (let ((exe (find-exe exe)))
    (if pred?
      (lambda args (apply system* exe args))
      (lambda args (apply get-process-output-lines exe args)))))

(define ls>    (make-exe>> "ls"    #f))
(define cksum> (make-exe>> "cksum" #f))
(define chmod> (make-exe>> "chmod" #f))
(define ln>    (make-exe>> "ln"    #f))
(define tty?>  (make-exe>> "tty"   #t))
(define stty>  (make-exe>> "stty"  #f))

(define gunzip-exe   (find-exe "gunzip"))
(define gzip-exe     (find-exe "gzip"))
(define mmencode-exe (find-exe "mmencode"))

(define yes/no?
  (if (tty?> "-s")
    ;; tty -> interactive version using raw mode
    (let ((tty-settings (car (stty> "-g"))))
      (lambda (str . args)
        (parameterize ((current-output-port (current-error-port)))
          (printff "~a [Y/N] <?>~a~a"
                   (apply format str args) #\backspace #\backspace)
          (dynamic-wind
            (lambda () (stty> "-icanon" "-echo" "min" "1"))
            (lambda ()
              (let loop ()
                (let ((ch (char-downcase (read-char))))
                  (if (memq ch '(#\y #\n))
                    (begin (write-char ch) (flush-output) (eq? ch #\y))
                    (loop)))))
            (lambda () (stty> tty-settings) (newline))))))
    ;; not a tty -> simple version
    (lambda (str . args)
      (parameterize ((current-output-port (current-error-port)))
        (let ((msg (apply format str args)))
          (let loop ((inp #f))
            (case inp
              ((#\y) #t)
              ((#\n) #f)
              (else
               (printff "~a [Yes/No] " msg)
               (loop
                (cond ((regexp-match #rx"[^ \t]" (read-line))
                       => (lambda (x) (char-downcase (string-ref (car x) 0))))
                      (else #f)))))))))))

;; Ignore links
(define original-link-exists? link-exists?)
(define (link-exists? . args)
  (eprintf "Warning: called ~s, using my version.\n" `(link-exists? ,@args))
  (apply my-link-exists? args))
(define normal-link-exists? original-link-exists?)
(define bogus-link-exists?  (lambda args #f))
(define my-link-exists?
  (lambda args
    (set! my-link-exists?
          (if ignore-links? bogus-link-exists? original-link-exists?))
    (apply my-link-exists? args)))

;; File utilities

(define (split-path* path)
  (let-values (((dir name dir?) (split-path path)))
    (values (if (symbol? dir) dir (path->string dir))
            (path->string name)
            dir?)))
(define (basename path)
  (let-values (((_1 name _2) (split-path* path))) name))
(define (dirname path)
  (let-values (((dir _1 _2) (split-path* path)))
    (if (symbol? dir)
      dir (regexp-replace #rx"(.)/$" dir "\\1"))))

(define (path->list name)
  (let* ((name (if (path? name) (path->string name) name))
         (subs (regexp-match #rx"^([^/]*)/(.*)$" name)))
    (if subs
      (cons (2nd subs) (path->list (3rd subs)))
      (list name))))

(define (list->path pathlist)
  (if (equal? (car pathlist) "")
    (string-append "/" (path->string (apply build-path (cdr pathlist))))
    (path->string (apply build-path pathlist))))

(define (normalize-path path)
  (let* ((path (if (path? path) (path->string path) path))
         (absolute? (and (> (string-length path) 0)
                         (char=? (string-ref path 0) #\/))))
    (list->path
     (let loop ((l (path->list path)) (r '()))
       (cond ((null? l) (let ((r (if (null? r) '(".") (reverse! r))))
                          (if absolute? (cons "" r) r)))
             ((member (car l) '("" ".")) (loop (cdr l) r))
             ((and (not (null? r))
                   (equal? (car l) "..")
                   (not (equal? (car r) "..")))
              (loop (cdr l) (cdr r)))
             (else (loop (cdr l) (cons (car l) r))))))))

(define (resolve*-path path)
  (let loop ((l (path->list path)))
    (define (next dir)
      (parameterize ((current-directory dir))
        (loop (cdr l))))
    (cond
     ((null? l) (pwd))
     ((equal? (car l) "") (next "/"))
     ((null? (cdr l))
      (build-path
       (pwd)
       (if (or (file-exists? (car l)) (directory-exists? (car l)))
         (resolve-path (car l))
         (car l))))
     (else (next (resolve-path (car l)))))))

(define (my-expand-path path)
  (normalize-path (resolve*-path (simplify-path (expand-path path)))))

(define (relativize-path path . base)
  (define path0 (my-expand-path path))
  (let loop ((base (path->list
                    (normalize-path
                     (if (not (null? base))
                       (my-expand-path base)
                       (pwd)))))
             (path (path->list path0)))
    (cond ((null? base) (list->path path))
          ((equal? (car base) (car path)) (loop (cdr base) (cdr path)))
          (else path0))))

(define file/dir-time file-or-directory-modify-seconds)

(define (delete-if-exists file)
  (when (or (file-exists? file) (my-link-exists? file)) (delete-file file)))

(define (chmod path mode)
  (chmod> "--" (format "~a" mode) path))

(define (make-link src dst)
  (parameterize ((current-directory (let ((dir (dirname src)))
                                      (if (string? dir) dir "."))))
    (ln> "-sf" "--" dst (basename src))))

(define (dotname? str)
  (and (> (string-length str) 0) (char=? (string-ref str 0) #\.)))

;; Get a path-list and return a list of matching pathlists
(define (expand-globs path)
  (if (null? path)
    path
    (let* ((glob    (car path))
           (re      (glob->regexp (car path)))
           (matches (let ((files (ls)))
                      (filter (lambda (f) (regexp-match? re f))
                              (if (dotname? glob)
                                files
                                (filter (negate dotname?) files))))))
      (if (null? (cdr path))
        (map list matches)
        (begin
          (when (null? matches)
            (eprintf "\nWarning: ignoring inexistent dir ~a/~a.\n"
                     (pwd) glob))
          (mappend (lambda (m)
                     (if (directory-exists? m)
                       (map (lambda (p) (cons m p))
                            (parameterize ((current-directory m))
                              (expand-globs (cdr path))))
                       '()))
                   matches))))))

(define (glob path)
  (map list->path (expand-globs (path->list path))))

(define mode-cache (make-parameter '()))
(define (mode file)
  (cond
   ((string? file)
    (let ((permissions
           (2nd (regexp-match
                 #rx"^[^ ]([^ ][^ ][^ ][^ ][^ ][^ ][^ ][^ ][^ ])[ +]"
                 (cond ((assoc file (mode-cache)) => cdr)
                       (else (car (ls> "-fld" "--" file)))))))
          (mode 0)
          (i 0))
      (define (add alist)
        (set! mode
              (+ mode (cond ((assq (string-ref permissions i) alist) => 2nd)
                            (else 0))))
        (set! i (add1 i)))
      (for-each add
                '(((#\r 400)) ((#\w 200)) ((#\x 100) (#\s 4100) (#\S 4000))
                  ((#\r 40)) ((#\w 20))
                  ((#\x 10) (#\s 2010) (#\S 2000) (#\l 2000))
                  ((#\r 4)) ((#\w 2)) ((#\x 1) (#\t 1001) (#\T 1000))))
      mode))
   ((list? file)
    (let ((files (filter
                  (lambda (f) (or (file-exists? f) (directory-exists? f)))
                  file)))
      (if (null? files)
        '()
        (map cons files (apply ls> "-fld" "--" files)))))))

(define cksum-cache (make-parameter '()))
(define (cksum file)
  (cond
   ((string? file)
    (let ((cache-entry (assoc file (cksum-cache))))
      (if (fileinfo? cache-entry)
        (fileinfo-cksum cache-entry)
        (read-from-string
         (car (regexp-match
               #rx"^[0-9]*"
               (if cache-entry
                 (cdr cache-entry)
                 (car (cksum> "--" file)))))))))
   ((list? file)
    (let ((files (filter (lambda (f) (and (string? f) (file-exists? f))) file))
          (infos (filter (lambda (x) (not (string? x))) file)))
      (append
       ;; normal files to cksum
       (if (null? files)
         '()
         (map cons files (apply cksum> "--" files)))
       ;; reused old entries
       infos)))))

(define (with-output-to-file* file thunk)
  (delete-if-exists file)
  (with-output-to-file file (lambda () (display "")))
  (chmod file "600")
  (with-output-to-file file thunk 'truncate))

;; Info utilities

(define (make-info tag name . data)
  (list* name tag data))
(define (make-info-predicate tag len)
  (lambda (x)
    (and (list? x) (>= (length x) len) (eq? (2nd x) tag))))
(define info-name 1st)
(define info-tag  2nd)
(define (info-name<? x y)
  (string<? (info-name x) (info-name y)))

;; dirinfo: (name 'dir time mode infos...)
(define (make-dirinfo name time mode infos)
  (apply make-info 'dir name time mode infos))
(define dirinfo? (make-info-predicate 'dir 4))
(define dirinfo-time     3rd)
(define dirinfo-mode     4th)
(define dirinfo-contents cddddr)

;; fileinfo: (name 'file time mode size cksum)
(define (make-fileinfo name time mode size cksum)
  (make-info 'file name time mode size cksum))
(define fileinfo? (make-info-predicate 'file 6))
(define fileinfo-time  3rd)
(define fileinfo-mode  4th)
(define fileinfo-size  5th)
(define fileinfo-cksum 6th)

(define (fileinfo-same-contents? info1 info2)
  (and (equal? (fileinfo-cksum info1) (fileinfo-cksum info2))
       (equal? (fileinfo-size  info1) (fileinfo-size  info2))))

;; linkinfo: (name 'link dest)
(define (make-linkinfo name dest)
  (make-info 'link name dest))
(define linkinfo? (make-info-predicate 'link 3))
(define linkinfo-dest 3rd)

(define (count-infos info)
  (if (dirinfo? info)
    (apply + 1 (map count-infos (dirinfo-contents info)))
    1))

(define (find-info info path)
  (cond ((null? path) info)
        ((not info) #f)
        ((not (dirinfo? info))
         ;;(error 'find-info "got a non-dirinfo ~s when looking for ~s"
         ;;       info path)
         #f)
        ((assoc (car path) (dirinfo-contents info)) =>
         (lambda (x) (find-info x (cdr path))))
        (else #f)))

;; Indented version
;; (define (write-info info)
;;   (define (disp x indent)
;;     (if (and (list? x) (some pair? x))
;;       (begin
;;         (printf "~a(" indent)
;;         (let loop ((x x) (1st? #t))
;;           (if (pair? (car x))
;;             (let ((indent (concat indent "  ")))
;;               (for-each (lambda (x) (newline) (disp x indent)) x))
;;             (begin (printf "~a~s" (if 1st? "" " ") (car x))
;;                    (loop (cdr x) #f))))
;;         (printf ")"))
;;       (printf "~a~s" indent x)))
;;   (disp info "")
;;   (newline))
;; A little faster
(define (write-info info)
  (write info) (newline))

;; Data processing

(define-values (start-file-counter end-file-counter dec-files-left)
  (let* ((files-num  #f)
         (files-left #f)
         (cur-scan   "")
         (cur-dir    "")
         (width      50)
         (backstr    (make-string (+ 5 width) #\backspace))
         (spacestr   (make-string (+ 5 width) #\space))
         (display-thread #f) (busy (make-semaphore 1)))
    (define (show)
      (let* ((p (max (inexact->exact
                      (round (* 100 (/ files-left files-num))))
                     0))
             (file (string-append cur-dir "/" cur-scan))
             (file (cond
                    ((> (string-length file) width)
                     (string-append (substring file 0 (- width 3)) "..."))
                    ((< (string-length file) width)
                     (string-append file
                                    (make-string
                                     (- width (string-length file))
                                     #\space)))
               (else file))))
        (printff "~a~a~a% ~a"
                 backstr
                 (cond ((< p 10) "  ") ((< p 100) " ") (else ""))
                 p
                 file)))
    (values (lambda (n)
              (set! files-num  n)
              (set! files-left n)
              (printf spacestr)
              (set! display-thread
                    (thread
                     (lambda ()
                       (let loop ()
                         (semaphore-wait busy)
                         (show)
                         (semaphore-post busy)
                         (sleep 0.25)
                         (loop))))))
            (lambda nl?
              (semaphore-wait busy)
              (when display-thread
                (kill-thread display-thread)
                (set! display-thread #f)
                (printf "~a~a~a" backstr spacestr backstr)
                (when (and (not (null? nl?)) (car nl?)) (newline)))
              (semaphore-post busy))
            (lambda (cur)
              (set! files-left (sub1 files-left))
              (set! cur-scan cur)
              (set! cur-dir (pwd))))))

(define (scan-ignore-string? str)
  (char=? (string-ref str 0) #\-))

(define (scans->tree scans)
  (define (merge-1sts lst)
    (cond
     ((null? lst) '())
     ((null? (car lst))
      ;; can happen if the filter below removes "/" from the end of a dirname
      (merge-1sts (cdr lst)))
     (else
      (let ((a (filter (lambda (x) (equal? (car x) (caar lst))) lst))
            (b (filter (lambda (x) (not (equal? (car x) (caar lst)))) lst)))
        (cons (cond
               ((and (null? (cdr a)) (null? (cdar a))) (caar a))
               ((some (lambda (x) (and (null? (cdr x)) x)) a)
                => (lambda (x) (car x)))
               (else (cons (caar a)
                           (merge-1sts
                            (map (lambda (x)
                                   (filter (lambda (x) (not (equal? x "")))
                                           (cdr x)))
                                 a)))))
              (merge-1sts b))))))
  (let ((scans
         (merge-1sts (mappend (lambda (x) (expand-globs (path->list x)))
                              (filter (negate scan-ignore-string?) scans)))))
    (if (null? scans) "." (cons "." scans))))

(define (scan->ignores scans)
  (append
   (map (lambda (x) (path->list (relativize-path x)))
        (list* (rc-file) (rc-file ".bak")
               (if no-op? '() (list output-file))))
   (map (lambda (f) (path->list (relativize-path f))) emtz-files)
   (mappend (lambda (x)
              (expand-globs (path->list (substring x 1 (string-length x)))))
            (filter scan-ignore-string? scans))))

(define (scan->info scan old-info path)
  (define (make-new-dirinfo dir files)
    (let* (;; we can have an old file that is replaced by a dir:
           (old-info (if (dirinfo? old-info) old-info #f))
           (subfiles (if files
                       (map (lambda (x) (if (list? x) (car x) x)) files)
                       (ls dir)))
           (files (or files subfiles))
           (old-infos (if old-info
                        (let ((infos (dirinfo-contents old-info)))
                          (map (lambda (f) (or (assoc f infos) f)) subfiles))
                        subfiles)))
      (make-dirinfo
       dir (file/dir-time dir) (mode dir)
       (parameterize ((current-directory dir))
         (let ((changed-files
                ;; changed files are just their names, unchanged have their
                ;; entries - this is used in cksum above (determined by
                ;; modification time)
                (filter
                 identity
                 (map (lambda (f-or-info)
                        (if (string? f-or-info)
                          ;; no old-info - only regular files
                          (and (not (my-link-exists? f-or-info))
                               (file-exists? f-or-info)
                               f-or-info)
                          ;; only regulars with...
                          (let ((f (car f-or-info)))
                            (and (not (my-link-exists? f))
                                 (file-exists? f)
                                 (if (and (fileinfo? f-or-info)
                                          (= (file/dir-time f)
                                             (fileinfo-time f-or-info)))
                                   ;;... unchanged -> use old entry in cache
                                   f-or-info
                                   ;; else -> use file name
                                   f)))))
                      old-infos))))
           (parameterize ((mode-cache  (mode  subfiles))
                          (cksum-cache (cksum changed-files)))
             (map (lambda (x old-info)
                    (scan->info
                     x
                     (and (not (string? old-info)) old-info)
                     (if (equal? dir ".") path (concat path dir "/"))))
                  files old-infos)))))))
  (define (make-new-fileinfo file)
    (make-fileinfo
     file (file/dir-time file) (mode file) (file-size file) (cksum file)))
  (define (make-new-linkinfo link)
    (make-linkinfo link (path->string (resolve-path link))))
  (define (not-found)
    (error-exit "Error: \"~a~a\" doesn't exist, fix your ~a.\n"
                path (if (list? scan) (car scan) scan) (rc-file)))
  (when (string? scan) (dec-files-left scan))
  (cond ((list? scan) (if (directory-exists? (car scan))
                        (make-new-dirinfo (car scan) (cdr scan))
                        (not-found)))
        ((my-link-exists? scan)   (make-new-linkinfo scan))
        ((file-exists? scan)      (make-new-fileinfo scan))
        ((directory-exists? scan) (make-new-dirinfo scan #f))
        (else (not-found))))

(define (filter-info info scan-trees)
  (and
   info
   (let* ((name (info-name info))
          (scan (some (lambda (s)
                        (and (or (and (string? s) (equal? s name))
                                 (and (list? s) (equal? (car s) name)))
                             s))
                      scan-trees)))
     (cond
      ((not scan) #f)
      ((string? scan) info)
      ((list? scan) (if (dirinfo? info)
                      (let ((subscan (cdr scan)))
                        (make-dirinfo
                         name (dirinfo-time info) (dirinfo-mode info)
                         (filter identity
                                 (map (lambda (i) (filter-info i subscan))
                                      (dirinfo-contents info)))))
                      info))))))

;; Info changes

(define (change-maker optag)
  (lambda (path info) (list optag path info)))

(define change-op    1st)
(define change-path  2nd)
(define change-info  3rd)

(define (change-ftype c)
  (info-tag (change-info c)))
(define (change-fpath c)
  (list->path (change-path c)))

(define make-add-change    (change-maker 'add))
(define make-del-change    (change-maker 'del))
(define make-mode-change   (change-maker 'mode))
(define make-modify-change (change-maker 'modify))

(define (info-changes old-info new-info)
  (define changes '())
  (define (add-entry! maker)
    (lambda (path info)
      (set! changes
            (cons (maker (reverse (cons (info-name info) path)) info)
                  changes))))
  (define add!    (add-entry! make-add-change))
  (define del!    (add-entry! make-del-change))
  (define mode!   (if ignore-modes? void (add-entry! make-mode-change)))
  (define modify! (add-entry! make-modify-change))
  (let scan ((old old-info) (new new-info) (path '()))
    (cond ((not (or old new)) #f) ; make sure we get something
          ;; no new file: delete old
          ((not new) (del! path old))
          ;; no old file: add new
          ((not old) (add! path new))
          ;; same exact entry - do nothing
          ((equal? old new) #f)
          ;; different entry types: delete old, add new
          ((not (equal? (info-tag old) (info-tag new)))
           (del! path old) (add! path new))
          ;; link: different dest => delete old, add new
          ((linkinfo? old)
           (and (not (equal? (linkinfo-dest old) (linkinfo-dest new)))
                (modify! path new)))
          ;; file: all change or mode
          ((fileinfo? old)
           (if (and (equal? (fileinfo-size old) (fileinfo-size new))
                    (equal? (fileinfo-cksum old) (fileinfo-cksum new)))
             (and (not (equal? (fileinfo-mode old) (fileinfo-mode new)))
                  (mode! path new))
             (modify! path new)))
          ;; directory: recurse down
          ((dirinfo? old)
           (unless (equal? (dirinfo-mode old) (dirinfo-mode new))
             (mode! path new))
           (let ((newpath (if (equal? (info-name old) ".")
                            path
                            (cons (info-name old) path))))
             (let loop ((olds (dirinfo-contents old))
                        (news (dirinfo-contents new)))
               (cond
                ((and (null? olds) (null? news)) #f)
                ((null? olds)
                 (scan #f (car news) newpath)
                 (loop olds (cdr news)))
                ((null? news)
                 (scan (car olds) #f newpath)
                 (loop (cdr olds) news))
                ((equal? (caar olds) (caar news))
                 (scan (car olds) (car news) newpath)
                 (loop (cdr olds) (cdr news)))
                ((string<? (caar olds) (caar news))
                 (scan (car olds) #f newpath)
                 (loop (cdr olds) news))
                ((string>? (caar olds) (caar news))
                 (scan #f (car news) newpath)
                 (loop olds (cdr news)))
                (else #f)))))
          ;; just in case
          (else #f)))
  (reverse! changes))

(define (recurse-changes changes)
  (define (recurse change)
    (if (dirinfo? (change-info change))
      (case (change-op change)
        ((add)
         (cons change
               (mappend (lambda (i)
                          (recurse
                           (make-add-change
                            (rcons (change-path change) (info-name i)) i)))
                        (dirinfo-contents (change-info change)))))
        ((del)
         (rcons (mappend (lambda (i)
                           (recurse
                            (make-del-change
                             (rcons (change-path change) (info-name i)) i)))
                         (dirinfo-contents (change-info change)))
                change))
        (else (list change)))
      (list change)))
  (cond
   ((null? changes) '())
   ((and (memq (change-op (car changes)) '(add del))
         (dirinfo? (change-info (car changes))))
    (append (recurse (car changes)) (recurse-changes (cdr changes))))
   (else (cons (car changes) (recurse-changes (cdr changes))))))

(define (write-mtz changes)
  (define (write-changes changes)
    (for-each
     (lambda (c)
       (let ((op    (change-op    c))
             (ftype (change-ftype c))
             (path  (change-path  c))
             (info  (change-info  c)))
         (unless (equal? path '("Swindle" "version"))
           (case op
             ((add)
              (case ftype
                ((dir)  (printf "dir\n~s\n" path))
                ((file) ;(printf "file\n~s\n~s\n*" path (fileinfo-size info))
                        (printf "file\n~s\n~s\n*" path (file-size path))
                        (display-file path))))
             ((del)
              (case ftype
                ((dir)  (printf "delete-directory\n~s\n" path))
                ((file) (printf "delete-file\n~s\n" path))
                ((link) (printf "delete-file\n~s\n" path))))
             ((modify)
              (case ftype
                ((file) ;(printf "file\n~s\n~s\n*" path (fileinfo-size info))
                        (printf "file\n~s\n~s\n*" path (file-size path))
                        (display-file path))))))))
     changes))
  (printf "MZTAR\n")
  (for-each (lambda (m) (printf "message\n~s\n" m)) messages0)
  (if swindle-mtz?
    ;; in a swindle mtz, must make compiled files newer than sources
    (let* ((compiled? (lambda (c) (member "compiled" (change-path c))))
           (ncompiled? (lambda (c) (not (compiled? c))))
           (normal-changes (filter ncompiled? changes))
           (compiled-changes (filter compiled? changes)))
      (write-changes normal-changes)
      (unless (null? compiled-changes)
        (printf "eval\n(sleep 2)\n")
        (write-changes compiled-changes)))
    (write-changes changes))
  (for-each (lambda (m) (printf "message\n~s\n" m)) messages1))

(define (write-extended-mtz changes)
  (printf "EMZTAR\n")
  (printf "~s\n" scans)
  (printf "~s\n" (and write-info? new-info))
  (for-each
   (lambda (c)
     (let ((op    (change-op    c))
           (ftype (change-ftype c))
           (path  (change-path  c))
           (info  (change-info  c)))
       (define (print-record tag)
         (printf "~a\n~s\n~s\n"
                 tag path
                 (if (dirinfo? info)
                   (make-dirinfo (info-name info) (dirinfo-time info)
                                 (dirinfo-mode info) '())
                   info))
         (when (eq? tag 'file)
           (when verbose?
             (eprintf "  Adding ~a (~a bytes)\n"
                      (list->path path) (fileinfo-size info)))
           (printf "*") (display-file path)))
       (case op
         ((add)    (case ftype ((dir)  (print-record 'dir))
                               ((file) (print-record 'file))
                               ((link) (print-record 'link))))
         ((del)                        (print-record 'delete))
         ((mode)                       (unless ignore-modes?
                                         (print-record 'mode)))
         ((modify) (case ftype ((file) (print-record 'file))
                               ((link) (print-record 'link)))))))
   changes))

;; Run-time stuff

(define (find-changes old-info new-info)
  (let* ((minimal-scan-tree (scans->tree minimal-scans))
         (old-info (filter-info old-info (list minimal-scan-tree)))
         (new-info (filter-info new-info (list minimal-scan-tree)))
         (changes (recurse-changes (info-changes old-info new-info))))
    (if (or (null? changes) (not (equal? '(".") (change-path (car changes)))))
      changes
      (cdr changes))))

;; Process an input EMTZ

(define (update-info info some-info path dir)
  (unless (null? path) (set! dir (build-path dir (car path))))
  (cond
   ((or (null? path) (not some-info))
    (if (and (dirinfo? info) (dirinfo? some-info)
             (null? (dirinfo-contents info)))
      (make-dirinfo (info-name info) (dirinfo-time info) (dirinfo-mode info)
                    (dirinfo-contents some-info))
      info))
   ((not (dirinfo? some-info))
    ;;(error-exit "update-info: got a non-dirinfo ~s.\n" some-info)
    info)
   ((or (assoc (car path) (dirinfo-contents some-info)) (null? (cdr path)))
    => (lambda (the-info)
         ;; note that null? might get #t as the-info but this doesn't matter
         ;; since remq won't do anything and the recursive call will just
         ;; return info.  This is to prevent going to the next case that
         ;; requires a physical directory to exist.
         (make-dirinfo
          (info-name some-info)
          (dirinfo-time some-info)
          (dirinfo-mode some-info)
          (smart1-sort (cons (update-info info the-info (cdr path) dir)
                             (remq the-info (dirinfo-contents some-info)))
                       info-name<?))))
   (else
    (let ((the-info
           (make-dirinfo (car path) (file/dir-time dir) (mode dir) '())))
      (make-dirinfo
       (info-name some-info)
       (dirinfo-time some-info)
       (dirinfo-mode some-info)
       (smart1-sort (cons (update-info info the-info (cdr path) dir)
                          (dirinfo-contents some-info))
                    info-name<?))))))

(define (update-old-info info path)
  (set! old-info (update-info info old-info path ".")))
(define (update-new-info info path)
  (set! new-info (update-info info new-info path ".")))
(define (update-other-info info path)
  (set! other-info (update-info info other-info path ".")))
(define (maybe-update-old-info info path)
  (unless other-info (update-old-info info path)))
(define (update-infos info path)
  (maybe-update-old-info info path)
  (update-new-info info path))

(define (delete-info some-info path)
  (cond
   ((not (dirinfo? some-info))
    (error-exit "delete-info: got a non-dirinfo ~s.\n" some-info))
   ((assoc (car path) (dirinfo-contents some-info))
    => (lambda (the-info)
         (make-dirinfo
          (info-name some-info)
          (dirinfo-time some-info)
          (dirinfo-mode some-info)
          (let ((i (remq the-info (dirinfo-contents some-info))))
            (if (null? (cdr path))
              i
              (smart1-sort (cons (delete-info the-info (cdr path)) i)
                           info-name<?))))))
   (else some-info)))

(define (delete-old-info path)
  (set! old-info (delete-info old-info path)))
(define (delete-new-info path)
  (set! new-info (delete-info new-info path)))
(define (delete-other-info path)
  (set! other-info (delete-info other-info path)))
(define (maybe-delete-old-info path)
  (unless other-info (delete-old-info path)))
(define (delete-infos path)
  (maybe-delete-old-info path)
  (delete-new-info path))

(define (write-tmp-file info input)
  (let loop ((ch (read-char input)))
    (unless (eq? ch #\*) (loop (read-char input))))
  (with-output-to-file* (get-tmp-name)
    (lambda ()
      (parameterize ((current-input-port input))
        (cat (fileinfo-size info))))))

(define ok-dirs '(relative))
(define skipped-dirs '())

(define (rm! x)
  (delete-infos (path->list x))
  (cond
   ((or (my-link-exists? x) (file-exists? x))
    (delete-file x))
   ((directory-exists? x)
    (for-each (lambda (y) (rm! (build-path x y))) (ls x))
    (set! ok-dirs (remove x ok-dirs))
    (delete-directory x))))

(define (verify-path path)
  (define (in-scans path scan-trees)
    (or (null? path)
        (some (lambda (t)
                (or (equal? t (car path))
                    (and (list? t) (equal? (car path) (car t))
                         (in-scans (cdr path) (cdr t)))))
              scan-trees)))
  (define (verify dir)
    (define (ok!)   (set! ok-dirs      (cons dir ok-dirs))      #t)
    (define (skip!) (set! skipped-dirs (cons dir skipped-dirs)) #f)
    (define (make-ok!) (make-directory dir) (ok!))
    (cond
     ((member dir ok-dirs) #t)
     ((member dir skipped-dirs) #f)
     ((not (verify (dirname dir))) (skip!))
     ((directory-exists? dir) (ok!))
     ((or (my-link-exists? dir) (file-exists? dir))
      (and (yes/no? "~aGot something in ~s but locally it is a ~a - remove?"
                    indent dir (if (my-link-exists? dir) "link" "file"))
           (begin (rm! dir) (make-ok!))))
     (else (make-ok!))))
  (or (equal? scan-tree ".")
      (member "." (cdr scan-tree))
      (and (or (in-scans path (cdr scan-tree))
               (yes/no?
                "~aGot remote ~s which is not in the current scans, accept?"
                indent (list->path path)))
           (verify (dirname (list->path path))))))

(define (add-directory path info)
  (define dir (list->path path))
  (define old-entry (find-info old-info path))
  (define new-entry (find-info new-info path))
  (define (doit)
    (printf "~a> creating directory ~s\n" indent dir)
    (unless (directory-exists? dir) (make-directory dir))
    (chmod dir (dirinfo-mode info))
    (update-infos info path))
  (cond
   ((and old-entry (not new-entry))
    ;; something by that name deleted, if it was a dir - ask, otherwise update
    (if (or (not (dirinfo? old-entry))
            (yes/no? "~aGot directory ~s - locally deleted, recreate?"
                     indent dir))
      (doit)
      (begin (printf "~a> skipping directory ~s\n" indent dir)
             (maybe-update-old-info info path))))
   ((not new-entry)
    ;; never heard of this dir
    (doit))
   ((not (dirinfo? new-entry))
    ;; oops - got something different
    (if (yes/no? "~aGot updated dir ~s but locally it is a ~a, use remote?"
                 indent dir (if (fileinfo? new-entry) "file" "link"))
      (begin (rm! dir) (doit))
      (begin (printf "~a> skipping directory ~s\n" indent dir)
             (maybe-update-old-info info path))))
   ((not (equal? (dirinfo-mode info) (dirinfo-mode new-entry)))
    ;; remote dir has different mode than current
    (if (or (and old-entry
                 (equal? (dirinfo-mode old-entry) (dirinfo-mode new-entry)))
            (yes/no? "~aRemote dir ~s has mode ~a but ~a, use remote?"
                     indent dir (dirinfo-mode info)
                     (if old-entry
                       (format "local changed (~a->~a)"
                               (dirinfo-mode old-entry)
                               (dirinfo-mode new-entry))
                       (format "new local is different (~a)"
                               (dirinfo-mode new-entry)))))
      (begin (printf "~a> setting mode of directory ~s\n" indent dir)
             (chmod dir (dirinfo-mode info))
             (update-infos info path))
      (begin (printf "~a> skipping directory ~s\n" indent dir)
             (maybe-update-old-info info path))))
   (else
    (printf "~a> skipping redundant directory ~s\n" indent dir)
    (maybe-update-old-info info path))))

(define (add-file path info)
  (define file (list->path path))
  (define old-entry (find-info old-info path))
  (define new-entry (find-info new-info path))
  (define (doit)
    (printf "~a> updating file ~s\n" indent file)
    (delete-if-exists file)
    (chmod (get-tmp-name) (fileinfo-mode info))
    (rename-file-or-directory (get-tmp-name) file)
    (update-infos info path))
  (cond
   ((and old-entry (not new-entry))
    ;; something by that name deleted, if it was a file - ask, otherwise update
    (if (or (not (fileinfo? old-entry))
            (yes/no?
             "~aGot file ~s - locally deleted (remote ~a deleted), recreate?"
             indent file
             (if (fileinfo-same-contents? info old-entry)
               "same as"
               "different from")))
      (doit)
      (begin (printf "~a> skipping file ~s\n" indent file)
             (maybe-update-old-info info path))))
   ((not new-entry)
    ;; never heard of this file
    (doit))
   ((not (fileinfo? new-entry))
    ;; oops - got something different
    (if (yes/no? "~aGot updated file ~s but locally it is a ~a, use remote?"
                 indent file (if (dirinfo? new-entry) "DIRECTORY" "link"))
      (begin (rm! file) (doit))
      (begin (printf "~a> skipping file ~s\n" indent file)
             (maybe-update-old-info info path))))
   ((not (fileinfo-same-contents? info new-entry))
    ;; remote file updated, if local also - ask, otherwise update
    (if (or (not (fileinfo? old-entry))
            (fileinfo-same-contents? new-entry old-entry)
            (yes/no?
             "~aBoth local and remote ~s updated (check ~s)~a, get remote?"
             indent file (get-tmp-name)
             (if (equal? (fileinfo-mode new-entry)
                         (fileinfo-mode old-entry))
               ""
               " (mode was also changed here)")))
      (doit)
      (begin (printf "~a> skipping file ~s\n" indent file)
             (maybe-update-old-info info path))))
   (else
    (printf "~a> skipping redundant update of ~s\n" indent file)
    ;; check if local mode was changed
    (if (and (not ignore-modes?)
             (not (equal? (fileinfo-mode info) (fileinfo-mode new-entry)))
             (yes/no?
              "~aRemote mode ~a different from local ~a~a, use remote?" indent
              (fileinfo-mode info)
              (fileinfo-mode new-entry)
              (if (and (fileinfo? old-entry)
                       (not (equal? (fileinfo-mode old-entry)
                                    (fileinfo-mode new-entry))))
                (format " (changed from ~a)"
                        (fileinfo-mode old-entry))
                "")))
      (begin (printf "~a> setting mode of file ~s\n" indent file)
             (chmod file (fileinfo-mode info))
             (update-infos info path))
      (begin (printf "~a> skipping mode of file ~s\n" indent file)
             (maybe-update-old-info info path))))))

(define (add-link path info)
  (define link (list->path path))
  (define old-entry (find-info old-info path))
  (define new-entry (find-info new-info path))
  (define (doit)
    (printf "~a> linking ~s -> ~s\n" indent link (linkinfo-dest info))
    (make-link link (linkinfo-dest info))
    (update-infos info path))
  (cond
   ((and old-entry (not new-entry))
    ;; something by that name deleted, if it was a link - ask, otherwise update
    (if (or (not (linkinfo? old-entry))
            (yes/no? "~aGot link ~s - locally deleted, recreate?" indent link))
      (doit)
      (begin (printf "~a> skipping link ~s\n" indent link)
             (maybe-update-old-info info path))))
   ((not new-entry)
    ;; never heard of this link
    (doit))
   ((not (linkinfo? new-entry))
    ;; oops - got something different
    (if (yes/no? "~aGot updated link ~s but locally it is a ~a, use remote?"
                 indent link (if (dirinfo? new-entry) "DIRECTORY" "file"))
      (begin (rm! link) (doit))
      (begin (printf "~a> skipping link ~s\n" indent link)
             (maybe-update-old-info info path))))
   ((not (equal? (linkinfo-dest info) (linkinfo-dest new-entry)))
    ;; remote link has different dest than current
    (if (or (not (linkinfo? old-entry))
            (equal? (linkinfo-dest old-entry) (linkinfo-dest new-entry))
            (yes/no? "~aRemote link ~s has dest ~s but local changed ~
                        (~s->~s), use remote?"
                     indent link (linkinfo-dest info)
                     (linkinfo-dest old-entry) (linkinfo-dest new-entry)))
      (begin (rm! link) (doit))
      (begin (printf "~a> skipping link ~s\n" indent link)
             (maybe-update-old-info info path))))
   (else
    (printf "~a> skipping redundant link ~s\n" indent link)
    (maybe-update-old-info info path))))

(define (del-something path info)
  (define something (list->path path))
  (define old-entry (find-info old-info path))
  (define new-entry (find-info new-info path))
  (cond
   ((not new-entry)
    (printf "~a> skipping redundant deletion of ~a ~s\n"
            indent (info-tag info) something)
    (when old-entry (maybe-delete-old-info path)))
   ((not (eq? (info-tag info) (info-tag new-entry)))
    (printf "~a> skipping deletion of ~a ~s, here it is a ~a\n"
            indent (info-tag info) something (info-tag new-entry))
    (when (and old-entry (eq? (info-tag info) (info-tag old-entry)))
      (maybe-delete-old-info path)))
   ((yes/no? "~aDelete ~a ~s?" indent (info-tag info) something)
    (printf "~a> deleting ~a ~s\n" indent (info-tag info) something)
    (rm! something))
   (else
    (printf "~a> skipping deletion of ~a ~s\n"
            indent (info-tag info) something)
    (when (and old-entry (eq? (info-tag info) (info-tag old-entry)))
      (maybe-delete-old-info path)))))

(define (mode-something path info)
  (define something (list->path path))
  (define old-entry (find-info old-info path))
  (define new-entry (find-info new-info path))
  (define (info-mode i) ((if (fileinfo? info) fileinfo-mode dirinfo-mode) i))
  (cond
   (ignore-modes? #t)
   ((not new-entry)
    (printf "~a> skipping redundant mode for nonexistent ~a ~s\n"
            indent (info-tag info) something))
   ((not (eq? (info-tag info) (info-tag new-entry)))
    (printf "~a> skipping mode of ~a ~s, here it is a ~a\n"
            indent (info-tag info) something (info-tag new-entry))
    (when (and old-entry (eq? (info-tag info) (info-tag old-entry)))
      (maybe-update-old-info info path)))
   ((equal? (info-mode info) (info-mode new-entry))
    (printf "~a> skipping redundant mode for ~a ~s\n"
            indent (info-tag info) something)
    (when (and old-entry (eq? (info-tag info) (info-tag old-entry)))
      (maybe-update-old-info info path)))
   ((or (not old-entry)
        (not (eq? (info-tag info) (info-tag old-entry)))
        (equal? (info-mode old-entry) (info-mode new-entry))
        (yes/no? "~aRemote ~a ~s has mode ~a but local mode changed ~
                    (~a->~a), use remote?"
                 indent (info-tag info) something (info-mode info)
                 (info-mode old-entry) (info-mode new-entry)))
    (printf "~a> setting mode of ~a ~s\n" indent (info-tag info) something)
    (chmod something (info-mode info))
    (update-infos info path))
   ;; old-entry exists, same type as new, different mode than new, and user
   ;; doesn't want to use remote.
   (else
    (printf "~a> skipping mode for ~a ~s\n" indent (info-tag info) something)
    (maybe-update-old-info info path))))

(define (process-emtz emtz)
  (printf "Processing ~s...\n" emtz)
  (let-values (((p pout pin perr)
                (subprocess #f (open-input-file emtz) (current-error-port)
                            gunzip-exe "-c")))
    (unless (equal? "EMZTAR" (read-line pout))
      (error-exit "Error: ~s is not an EMTZ file.\n" emtz))
    (let contents-loop ()
      (let* ((otherscans (read pout))
             (added      (remove* scans otherscans))
             (deleted    (remove* otherscans scans)))
        (set! other-info
              (let ((i (read pout)))
                (cond ((list? i) i)
                      ;; if we had an other-info - put it back in old-info
                      (other-info (set! old-info other-info) #f)
                      (else #f))))
        (when other-info (for-each delete-other-info scan-ignores))
        (unless (and (null? added) (null? deleted))
          (unless (null? added)
            (printf "~aAdded scans: ~s\n" indent added))
          (unless (null? deleted)
            (printf "~aDeleted scans: ~s\n" indent deleted))
          (when (yes/no? "~a  -- Accept these scan changes? " indent)
            (set! minimal-scans
                  (smart1-sort (remove* deleted minimal-scans) string<?))
            (set! scans otherscans)
            (set! scan-tree (scans->tree scans))
            (set! scan-ignores (scan->ignores scans))))
        (let loop ()
          (let ((tag (parameterize ((read-case-sensitive #t)) (read pout))))
            (cond
             ((eof-object? tag) #t)
             ((equal? (symbol->string tag) "EMZTAR")
              (contents-loop))
             (else
              (let ((path (read pout)) (info (read pout)))
                (when (eq? tag 'file) (write-tmp-file info pout))
                (if (verify-path path)
                  ((case tag
                     ((dir)    add-directory )
                     ((file)   add-file      )
                     ((link)   add-link      )
                     ((delete) del-something )
                     ((mode)   mode-something)
                     (else
                      (error-exit "process-emtz: got unknown tag ~s.\n" tag)))
                   path info)
                  (printf "~a~s skipped.\n" indent (list->path path))))
              (loop)))))))
    (subprocess-wait p))
  (when (or delete-emtz? (yes/no? "Done with ~s, delete?" emtz))
    (when delete-emtz? (printf "Done with ~s, deleting.\n" emtz))
    (delete-if-exists emtz)))

;; Command-line args

(require (lib "cmdline.ss"))
(command-line "syncfiles" argv
  (multi
   (("-i" "--info-file") f
    "use <f> as the info file (default: .syncfiles)"
    (let ((f (my-expand-path f)))
      (set! rc-file-name (if (directory-exists? f)
                           (build-path f (basename rc-file-name))
                           f))))
   (("-C" "--cd-to-info")
    "don't cd to the location of the info-file"
    (set! cd-to-info? #f))
   (("+C" "++cd-to-info")
    "cd to the location of the info-file (default)"
    (set! cd-to-info? #t))
   (("-o" "--output") file
    "the [extended] mtz output file"
    (set! output-file (path->string (path->complete-path file))))
   (("-t" "--temp-file") f
    "use <f> for temporary files"
    (set! get-tmp-name (lambda () f)))
   (("+e" "++extended-mtz")
    "use an extended mtz format (default)"
    (set! swindle-mtz?  #f)
    (set! extended-mtz? #t))
   (("-e" "--extended-mtz")
    "use normal mtz format (no chmods and links)"
    (set! extended-mtz? #f))
   (("+w" "++write-info")
    "write updated info to emtz file (default)"
    (set! write-info? #t))
   (("-w" "--write-info")
    "don't write updated info to emtz file"
    (set! write-info? #f))
   (("+W" "++write-info-anyway")
    "write updated info to emtz file even if no changes (implies +w)"
    (set! write-info-anyway? #t)
    (set! write-info? #t))
   (("-W" "--write-info-anyway")
    "don't write updated info to emtz if no changes (default)"
    (set! write-info-anyway? #f))
   (("-S" "--swindle")
    "Generate a Swindle-compatible mtz file (implies -e)"
    (set! extended-mtz? #f)
    (set! swindle-mtz?  #t))
   (("-v" "--verbose")
    "print less stuff"
    (set! verbose? #f))
   (("+v" "++verbose")
    "print more stuff (default)"
    (set! verbose? #t))
   (("-n" "--no-op")
    "don't update stored information, don't generate files"
    (set! no-op? #t)
    (set! no-op-update? #f))
   (("-N" "--no-op-but-update")
    "same as -n but stored information is updated"
    (set! no-op? #t)
    (set! no-op-update? #t))
   (("-I" "--ignore-links")
    "ignore links (treat them as files/dirs)"
    (set! ignore-links? #t))
   (("-D" "--ignore-mode")
    "ignore mode changes"
    (set! ignore-modes? #t))
   (("+s" "++scan") scan
    "add a scan"
    (set! added-scans (cons (normalize-path scan) added-scans)))
   (("-s" "--scan") scan
    "delete a scan"
    (set! deleted-scans (cons (normalize-path scan) deleted-scans)))
   (("+d" "++delete-emtz")
    "delete emtz after processing - no questions asked"
    (set! delete-emtz? #t))
   (("-d" "--delete-emtz")
    "ask permission to delete emtz after processing (default)"
    (set! delete-emtz? #f))
   (("-m" "--message") str
    "Add a `message' filed at the end of the mtz file"
    (set! messages1 (cons str messages1)))
   (("-M" "--end-message") str
    "Add a `message' filed at the beginning of the mtz file"
    (set! messages0 (cons str messages0)))
   (("-r" "--current")
    "Do NOTHING at all, just pack current info"
    (set! only-current? #t))
   (("--show-rsync-patterns")
    "Show rsync-compatible templates of synchronized files (doesn't work yet)"
    (set! show-rsync-patterns? #t)))
  (args emtz-file
        (for-each (lambda (f)
                    (unless (file-exists? f)
                      (eprintf "Warning: Couldn't find ~s.\n" f)))
                  emtz-file)
        (set! emtz-files
              (map (lambda (p) (path->string (path->complete-path p)))
                   (filter file-exists? emtz-file)))))

(set! rc-file-name (my-expand-path rc-file-name))
(let-values (((base name dir?) (split-path* rc-file-name)))
  (when (or dir? (not (string? name)))
    (error-exit "Invalid input file: ~s.\n" rc-file-name))
  (when (and cd-to-info? (string? base))
    (current-directory base))
  (when (directory-exists? name)
    (error-exit "Invalid input file: ~s.\n" rc-file-name))
  (when cd-to-info?
    (set! rc-file-name name)))

(set! output-file
      (or output-file (rc-file (if extended-mtz? ".emtz" ".mtz"))))

;; Begin

(when show-rsync-patterns?
  (with-input-from-file (rc-file)
    (lambda () (set! scans (maybe-read '()))))
  (for-each (lambda (s) (printf "~a\n" s)) scans)
  (exit 0))

(when (and (file-exists? (get-tmp-name))
           (not (yes/no? "~s exists, delete?" (get-tmp-name))))
  (error-exit "Abort!\n"))
(delete-if-exists (get-tmp-name))

;; Get rc data

(printff "Reading data... ")
(if (file-exists? (rc-file))
  (with-input-from-file (rc-file)
    (lambda ()
      (set! scans (maybe-read '()))
      (set! scans (and scans (map normalize-path scans)))
      (set! old-info (maybe-read #f))))
  (begin (set! scans '()) (set! old-info #f)))
(set! minimal-scans
      (smart1-sort (remove-duplicates (remove* deleted-scans scans)) string<?))
(set! scans
      (smart1-sort
       (remove-duplicates (remove* deleted-scans (append added-scans scans)))
       string<?))
(set! scan-tree (scans->tree scans))
(set! scan-ignores (scan->ignores scans))
(when old-info (for-each delete-old-info scan-ignores))
(printff "Done.\n")

;; Do nothing if only-current?
(if only-current?
  (begin (set! no-op? #f) (set! write-info-anyway? #t)
         (set! changes '()) (set! new-info old-info))
  (begin

;; Do the work

;; Read local info
(printff "Getting new checksums... ")
(set! new-info
      (dynamic-wind
        (lambda () (start-file-counter (count-infos old-info)))
        (lambda () (scan->info scan-tree old-info ""))
        end-file-counter))
(for-each delete-new-info scan-ignores)
(printff "Done.\n")

;; Process input EMTZs
(for-each process-emtz emtz-files)

;; Find changes
(printff "Finding changes... ")
(set! changes (find-changes (or other-info old-info) new-info))
(printff "Done.\n")
(when verbose?
  (for-each (lambda (x)
              (printf "~a~a-~a: ~a\n"
                      indent (change-op x) (change-ftype x) (change-fpath x)))
            changes))

))

;; Produce an [E]MTZ
(unless no-op?
  (if (and (null? changes) (not write-info-anyway?))
    (printff "No changes -- no MTZ.\n")
    (begin
      (when (and (file-exists? output-file)
                 (not (yes/no? "~s exists, delete?" output-file)))
        (error-exit "Abort!\n"))
      (delete-if-exists output-file)
      (printff "Generating ~s...\n" output-file)
      (let*-values (((out) (open-output-file output-file))
                    ((mm mmout mmin mmerr)
                     (if extended-mtz?
                       (values #f #f #f #f)
                       (subprocess out #f (current-error-port)
                                   mmencode-exe "-b")))
                    ((gz gzout gzin gzerr)
                     (subprocess (if mm mmin out) #f (current-error-port)
                                 gzip-exe "-c")))
        (parameterize ((current-output-port gzin))
          ((if extended-mtz? write-extended-mtz write-mtz) changes))
        (close-output-port gzin)
        (subprocess-wait gz)
        (when mm (close-output-port mmin) (subprocess-wait mm)))
      (printff "Done.\n"))))

(unless only-current?

;; Write results
(printff "Writing data... ")
(delete-if-exists (get-tmp-name))
(delete-if-exists (rc-file ".bak"))
(with-output-to-file* (rc-file ".tmp")
  (lambda ()
    (printf ";; Automatically generated ~a.\n" (rc-file))
    (printf ";; Scans (begin with a '-' to avoid a scan)\n(\n")
    (for-each (lambda (s) (printf "  ~s\n" s)) scans)
    (printf ")\n\n;; Local info\n")
    (let ((info
           (filter-info (if (and no-op? (not no-op-update?)) old-info new-info)
                        (list scan-tree))))
      (unless (or info
                  (yes/no? "I'm about to write #f as new-info, continue?"))
        (error-exit "Abort!\n"))
      (write-info info))))
(when (file-exists? (rc-file))
  (rename-file-or-directory (rc-file) (rc-file ".bak")))
(rename-file-or-directory (rc-file ".tmp") (rc-file))
(printff "Done.\n")

)