Megatest

fossilrebase.scm at [21aa6b995f]
Login

File fossil-utils/fossilrebase.scm artifact 7fd6410b95 part of check-in 21aa6b995f


(use yaml matchable srfi-1)

(define (get-timeline)
  (let* ((inp (open-input-pipe "fossil json timeline checkin -n 0"))
	 (res (yaml-load inp)))
    (close-input-pipe inp)
    res))

(define (get-val data key)
  (alist-ref key data equal?))

(define (any->string val)
  (if (string? val)
      val
      (conc val)))

(define (branch-match branches tags)
  (if (list? tags)
      (any (lambda (x)
	     (member x branches))
	   tags)
      (member tags branches)))

(define (refdb-set-value dbname sheetname row col value)
  (let ((pid (process-run "refdb" `("set" ,dbname ,sheetname ,row ,col ,value))))
    (let-values (((a b c)(process-wait pid)))
      b)))

(define (seconds->std-time-str sec)
  (time->string 
   (seconds->local-time sec)
   "%Y-%m-%d %H:%M:%S"))

(define (gen-refdb dbname branches)
  (if (not (file-exists? (conc dbname "/sheet-names.cfg")))
      (begin
	(print "ERROR: You must precreate the refdb with \"refdb edit <dbname>\"")
	(exit 1)))
  (print "Getting data from timeline...")
  (let* ((data (get-timeline))
	 (branches (string-split branches ",")))
    (print "Got data from timeline...")
    (let* ((timeline (get-val (get-val data "payload") "timeline")))
      (print "Got " (length timeline) " timeline records. Filling refdb...")
    (for-each
     (lambda (rec)
       (let ((uuid (get-val rec "uuid")))
	 (if (branch-match branches (get-val rec "tags"))
	     (let ((tagnum 0)
		   (tags   (get-val rec "tags")))
	       (print "uuid: " uuid " tags: " (get-val rec "tags"))
	       ;; First the tags so they are visible to left
	       (for-each
		(lambda (tagv)
		  (refdb-set-value dbname "timeline" uuid (conc "tag" tagnum) tagv)
		  (set! tagnum (+ tagnum 1)))
		(if (list? tags)
		    tags
		    (list tags)))
	       (for-each
		(lambda (key)
		  (refdb-set-value dbname "timeline" uuid key (any->string (get-val rec key))))
		'("user" "comment"))
	       (refdb-set-value dbname "extra" uuid "parents" (string-intersperse (get-val rec "parents") ","))
	       (refdb-set-value dbname "timeline" uuid "timestamp" (seconds->std-time-str (get-val rec "timestamp")))
	       (refdb-set-value dbname "timeline" uuid "timestamp_sec" (any->string (get-val rec "timestamp")))
	       ))))
     timeline))))

(define help
"fossilrebase - register commits in a refdb, edit them by hand then execute them

WARNING: It is highly recommended you do this on a disconnected copy of your fossil database!!

Usage: fossilrebase cmd [params ...]
  where cmd is one of:
    genrefdb fname b1,b2... : generate a refdb of all the commits for branches matching patterns listed, edit with \"refdb edit fname\"
    dumpcmds fname          : from refdb fname dump fossil commands to implement the rebase you want to do.
")

(define (main)
  (if (< (length (command-line-arguments)) 1)
      (begin
	(print help)
	(exit 1))
      (match (command-line-arguments)
	(("genrefdb" fname branches) (gen-refdb fname branches))
	(("dumpcmds" fname) (dump-cmds))
	(else
	 (print "Sorry, didn't know what to do with \"" (string-intersperse (command-line-arguments) " ") "\"")
	 (exit 1)))))


(main)