(use posix ssax sxpath sxpath-lolevel files)

(define (usage code)
  (print #<#EOF
usage: svn-update-meta

  -h   -help                    Show this message

svn-update-meta will ask Subversion for all files that are managed by
it and put those in the meta-file's FILES entry.  Files that are
unversioned are ignored.

EOF
)
(exit code))

(define (call-with-input-pipe* cmd proc)
  (let* ([p (open-input-pipe cmd)]
         [res (proc p)])
    (unless (zero? (close-input-pipe p))
      (error "Got an error while executing command " cmd))
    res))

(define (svn-xml cmd)
  (call-with-input-pipe* cmd (lambda (i) (ssax:xml->sxml i '()))))

(define (ensure-meta-file-exists!)
  (let* ((metas (glob "*.meta")))
    (cond ((null? metas)
           (fprintf (current-error-port)
                    "Error: No meta-file found! Please create one first~%")
           (exit 1))
          ((> (length metas) 1)
           (fprintf (current-error-port)
                    "Error: ~A meta files found. Can only deal with one!~%"
                   (length metas))
           (exit 1))
          (else #t))))

(define (valid-meta-data? port)
  (handle-exceptions exn
    #f
    (let ((meta (read-file port)))
      (and (= 1 (length meta))
           (list? (car meta))
           (>= 1 (length (filter (lambda (e)
                                   (eq? 'files (car e)))
                                 (car meta))))))))

(define (update-meta! files-list)
  (let* ((files-list (sort files-list string<?))
	 (meta-file (car (glob "*.meta")))
         (meta-data (read-all meta-file)))
    (unless (call-with-input-string meta-data valid-meta-data?)
      (fprintf (current-error-port) "Error: invalid meta data in ~A~%" meta-file)
      (exit 1))
    (let* ((in (open-input-string meta-data))
           (el #f)
           (end #f))
      (receive (start end)
        (call/cc 
         (lambda (found)
           (##sys#read in (lambda (class data val)
                            (if (eq? class 'list-info)
                                (if (and el (eq? (car el) 'files))
                                    (found (cdr el) (##sys#slot in 10))
                                    (begin (set! el #f) (set! end (##sys#slot in 10))))
                                (unless el
                                  (set! el (cons data (##sys#slot in 10)))))))
           (values #f end)))
        (print "Updating " meta-file)
        (with-output-to-file meta-file
          (lambda ()
            (if start
                (begin
                  (display (substring meta-data 0 start))
                  (display #\space)
                  (let ((s (with-output-to-string (lambda ()
                                                    (write files-list)))))
                   (display (substring s 1 (sub1 (string-length s)))))
                  (display (substring meta-data (sub1 end))))
                (begin
                  (display (substring meta-data 0 (sub1 end)))
                  (display "\n ")
                  (write (cons 'files files-list))
                  (display (substring meta-data (sub1 end)))))))))))

(define (list-egg-files)
  (remove directory?
          ((sxpath `(status target
                            (entry (wc-status
                                    ;; There has to be a better way :(
                                    ,(lambda (x y)
                                       ((sxml:filter
                                         (lambda (x)
                                           (let ((s ((sxpath '(@ item)) x)))
                                             (not (string=? (sxml:text s)
                                                            "unversioned"))))) x))))
                            @ path (*text* 1)))
           (svn-xml "svn status -v --xml"))))

(define *short-options* '(#\h))

(define (main args)
  (let loop ((args args))
    (if (null? args)
        (begin
          (ensure-meta-file-exists!)
          (update-meta! (list-egg-files)))
        (let ((arg (car args)))
          (cond ((or (string=? arg "-help")
                     (string=? arg "-h")
                     (string=? arg "--help"))
                 (usage 0))
                ((and (positive? (string-length arg))
                      (char=? #\- (string-ref arg 0)))
                 (if (> (string-length arg) 2)
                     (let ((sos (string->list (substring arg 1))))
                       (if (null? (lset-intersection eq? *short-options* sos))
                           (loop (append (map (cut string #\- <>) sos) (cdr args)))
                           (usage 1)))
                     (usage 1)))
                (else (usage 1)))))))

(main (command-line-arguments))