;;; monotone-nav.el --- A navigator of monotone revision histories.
;;
;; ~/share/emacs/pkg/monotone/monotone-db.el ---
;;
;; $Id: monotone-nav.el,v 1.18 2005/04/26 07:42:22 harley Exp $
;;
;;; Commentary:
;; "monotone-nav" is a database browser for monotone databases.
;; Using the sql option of monotone it extacts the data into
;; emacs which you may browse using the arrow keys.
;; You can also mark revisons to run diffs or do other work.
;;; EXAMPLE USAGE:
;; (mnav-revdb-reload)
;; (message "mnav-pick: %s" (mnav-rev-id (mnav-pick)))
(require 'base64)
(require 'cl)
(require 'monotone)
;;; Code:
(defvar mnav-rev-point nil
"The rev record at 'point' of the picker. Get its id with 'mnav-rev-id'.")
(defvar mnav-rev-mark nil
"The rev record 'marked' by the picker. Get its id with 'mnav-rev-id'.")
;;
(defvar mnav-pick-min nil
"The min value allowed to pick.")
(defvar mnav-pick-cur nil
"The current selection on the pick screen.")
(defvar mnav-pick-max nil
"The max value allowed to pick.")
(defvar mnav-pick-point nil
"The point location for the cursor.")
;;
(defvar mnav-revdb nil
"A hash maping revision ids to rev structs.")
(defvar mnav-revdb-initsize 5000
"The initial size of the hashtable.")
;; debug info
(defvar mnav-run-query-rows nil)
;; many of the keys are repeats, so generate them.
(defvar mnav-pick-readkey-map
(let ((map (make-sparse-keymap))
(acts '((quit "\C-g" "q" "Q" "x" "X")
(pick "\C-M" "p" "P")
(select [right] " ")
(mark "m" "M")
(unmark "u" "U")
;;(head "h" "H")
(swap "s" "S")
(move-up [up] "-")
(move-down [down] "=" "+")
(back [left] "l" "L" "b" "B") )))
(dolist (act acts)
(dolist (key (cdr act))
(define-key map key (car act))))
(dotimes (i 10)
(define-key map (format "%s" i) i))
;; normal key defs
(define-key map "d" 'mnav-diff-revisions1)
(define-key map "D" 'mnav-diff-revisions2)
(define-key map "f" 'mnav-diff-file)
map)
"The keymap used by `mnav-pick-readkey'.
The values are either symbols for `mnav-pick' actions or
interactive functions which will be exectued in the context of the picker.
Users can use `define-key' to modifiy the mappings.")
;; (mnav-pick-readkey)
;; (read-key-sequence "Key: ")
;;;;;;;;;;
;;; the Revision structure
(defmacro mnav-rev-id (rec)
"Fetch id from REC."
`(nth 1 ,rec))
(defmacro mnav-rev-author (rec)
"Fetch the author from REC."
`(nth 2 ,rec))
(defmacro mnav-rev-date (rec)
"Fetch the date from REC."
`(nth 3 ,rec))
(defmacro mnav-rev-parents (rec)
"Fetch the list of parent revisions from REC."
`(nth 4 ,rec))
(defmacro mnav-rev-children (rec)
"Fetch the list of child revisions from REC."
`(nth 5 ,rec))
(defmacro mnav-rev-changelog (rec)
"Fetch the changelog from REC."
`(nth 6 ,rec))
(defmacro mnav-rev-branch (rec)
"Fetch the name of the branch from REC."
`(nth 7 ,rec))
(defmacro mnav-rev-tag (rec)
"Fetch the tags from REC."
`(nth 8 ,rec))
(defmacro mnav-rev-pick-back (rec) ;; the picker stores the "back link" here
"Fetch the prior record viewed from REC.
This is not from the DB but used by mnav-pick."
`(nth 9 ,rec))
(defmacro mnav-rev-pick-cur (rec) ;; the picker stores mnav-pick-cur here.
"Fetch the current link selected from REC.
This is not from the DB but used by mnav-pick."
`(nth 10 ,rec))
(defun mnav-rev-make (id)
"Create a mnav-rev structure. ID is required."
(let ((rec (make-list 11 nil)))
(setf (car rec) 'rev)
(setf (mnav-rev-id rec) id)
rec))
(defun mnav-rev-p (rec)
"Is this an mnav-rec?"
(and (listp rec) (equal (car rec) 'rev)))
;; (mapcar #'mnav-rev-p (list nil (mnav-rev-make "aaa")))
(defun mnav-rev-string (rec)
"Cast the revison record REC to a string.
This is used for debugging."
(format
"#<rev %s p=%d c=%d %s %s>"
(or (mnav-rev-id rec) (make-string 40 63))
(length (mnav-rev-parents rec))
(length (mnav-rev-children rec))
(or (mnav-rev-date rec) "???")
(or (mnav-rev-author rec) "???")))
;; (mnav-rev-string nil)
(defun mnav-rev-nth-link (n rev)
"Return link N from the revision REV.
Links are numbered in order starting with the parent."
(let ((plen (length (mnav-rev-parents rev)))
(clen (length (mnav-rev-children rev))))
(assert (< n (+ plen clen)) t "N is out of bounds: %s" n)
(if (< n plen)
(nth n (mnav-rev-parents rev))
(nth (- n plen) (mnav-rev-children rev)))))
;; (mnav-rev-nth-link 0 '(rev 1 2 3 (4 a b c) (5 d e f) 6 7 8))
;;;;;;;;;;
;;; The index to revision entries
(defun mnav-revdb-clear ()
"Clear the REVDB by creating a new hash table."
(setq mnav-rev-point nil
mnav-rev-mark nil)
(setq mnav-revdb (make-hash-table :test #'equal :size mnav-revdb-initsize)))
;; (mnav-revdb-clear)
(defun mnav-revdb-find (id &optional create)
"Find the ID in the revdb. CREATE if t."
;; init?
(when (null mnav-revdb)
(mnav-revdb-clear))
(when (not (stringp id))
(if (mnav-rev-p id)
(setq id (mnav-rev-id id))
(error "ID is not a string or REV record.")))
;;
(let ((rev (gethash id mnav-revdb)))
(when (and (not rev) create)
(setq rev (mnav-rev-make id))
(puthash id rev mnav-revdb))
rev))
(defun mnav-revdb-print ()
"Dump the contents of revdb to a buffer for debugging."
(when (not mnav-revdb)
(mnav-revdb-clear))
(let ((buf (get-buffer-create "*monotone revdb*")))
(set-buffer buf)
(erase-buffer)
(maphash (function (lambda (k v) (insert (mnav-rev-string v) "\n"))) mnav-revdb)
(goto-char (point-min))
(switch-to-buffer-other-window buf)))
;; (mnav-revdb-print)
(defun mnav-revdb-add-ancestry (parentid childid)
"Add links from PARENTID to CHILDID."
(let ((p-rec (mnav-revdb-find parentid t))
(c-rec (mnav-revdb-find childid t)))
(push c-rec (mnav-rev-children p-rec))
(push p-rec (mnav-rev-parents c-rec))
nil))
;; (mnav-revdb-print)
(defun mnav-query-run (sqlquery row-func)
(let ((buf (get-buffer monotone-buffer))
read-mark row)
(let ((monotone-cmd-show nil)) ;; dont show the output
(monotone-cmd (list "db" "execute" sqlquery))
;; skip to data
(goto-char (point-min))
(search-forward-regexp "^$" (point-max) t)
(setq read-mark (point-marker))
;;
(setq mnav-query-rows nil) ;; debug
(while (setq row (condition-case nil (read read-mark) (error nil)))
(funcall row-func row)
(setq mnav-query-rows (cons row mnav-query-rows)) ;; debug
nil))))
(defun mnav-revdb-query-ancestry ()
"Query the revision_ancestry table for ancestry info."
;; ("parentid" "childid")
(mnav-query-run "
select '(\"'||coalesce(parent,'')||'\" \"'||coalesce(child,'')||'\")'
from revision_ancestry"
(function (lambda (row) (mnav-revdb-add-ancestry (car row) (cadr row))))))
(defun mnav-revdb-query-metaname (name setfunc)
"Query for metadata NAME and apply SETFUNC to each row.
SETFUNC is called with the revision rec and *decoded* value."
(let ((sql (format "
select '(\"'||id||'\" \"'||value||'\")'
from revision_certs
where name = '%s'" name)))
(mnav-query-run
sql
(function
(lambda (row)
(let ((rec (mnav-revdb-find (car row) t))
(val (base64-decode-string (cadr row))))
(funcall setfunc rec val)))))))
;; the revision info we care about.
(defun mnav-revdb-query-meta-author ()
(mnav-revdb-query-metaname
"author"
(function (lambda (rec val) (setf (mnav-rev-author rec) val)))))
(defun mnav-revdb-query-meta-date ()
(mnav-revdb-query-metaname
"date"
(function (lambda (rec val) (setf (mnav-rev-date rec) val)))))
(defun mnav-revdb-query-meta-changelog ()
(mnav-revdb-query-metaname
"changelog"
(function (lambda (rec val) (setf (mnav-rev-changelog rec) val)))))
(defun mnav-revdb-query-meta-branch ()
(mnav-revdb-query-metaname
"branch"
(function (lambda (rec val) (setf (mnav-rev-branch rec) val)))))
(defun mnav-revdb-query-meta-tag ()
(mnav-revdb-query-metaname
"tag"
(function (lambda (rec val) (setf (mnav-rev-tag rec) val)))))
(defun mnav-revdb-reload ()
(mnav-revdb-clear)
(message "Loading ancestry...")
(mnav-revdb-query-ancestry)
(message "Loading authors...")
(mnav-revdb-query-meta-author)
(message "Loading dates...")
(mnav-revdb-query-meta-date)
(message "Loading changelogs...")
(mnav-revdb-query-meta-changelog)
(message "Loading branches...")
(mnav-revdb-query-meta-branch)
(message "Loading tags...")
(mnav-revdb-query-meta-tag)
nil)
;; (mnav-revdb-reload)
;;;;;;;;;;
;;; PICK
(defun mnav-pick-clamp ()
"Clamp mnav-pick-cur between min and max."
(when (or (not (numberp mnav-pick-cur)) (< mnav-pick-cur mnav-pick-min))
(setq mnav-pick-cur mnav-pick-min))
(when (not (< mnav-pick-cur mnav-pick-max))
(setq mnav-pick-cur (1- mnav-pick-max))))
;; (progn (setq mnav-pick-max 5 mnav-pick-cur 10) (mnav-pick-clamp) mnav-pick-cur)
;;; PAINT
(defun mnav-pick-paint-revlink (rev)
"Render a link to REV into the buffer.
This function should insert a single line of text.
The pointer '=>' and newline are supplied by the caller."
(if rev
(insert
(or (mnav-rev-id rev) "???") " "
(or (mnav-rev-date rev) "???") " "
(or (mnav-rev-author rev) "???"))
(insert "-none-")))
(defun mnav-pick-paint-revlink-short (rev)
"An example of a function to paint short links."
(if rev
(insert
(or (mnav-rev-id rev) "???") " "
(or (mnav-rev-date rev) "???") " "
(or (mnav-rev-author rev) "???"))
(insert "-none-")))
(defun mnav-pick-paint-revlst (label lst min)
"Paint the buffer with a numbered list links to revisions."
(insert (format "--- %-10s --------------------\n" label))
(let ((c 0))
(dolist (p lst)
(if (= mnav-pick-cnt mnav-pick-cur)
(progn
(setq mnav-pick-point (point))
(insert "=>"))
(insert " "))
(insert (format "%2d: " mnav-pick-cnt))
(mnav-pick-paint-revlink p) ;; the data
(insert "\n")
(incf mnav-pick-cnt)
(incf c))
;; pad lines to min
(do ((c c (1+ c))) ((>= c min)) (insert "\n")))
(insert "\n"))
(defun mnav-pick-paint-selected (rev)
"Paint the buffer with the selected REV.
This function can be replaced by the user."
(when (not (mnav-rev-p rev))
(error "invalid rev to display."))
(insert "Revision: " (or (mnav-rev-id rev) "???") "\n"
"Date: " (or (mnav-rev-date rev) "???") "\n"
"Author: " (or (mnav-rev-author rev) "???") "\n"
"Branch: " (or (mnav-rev-branch rev) "???") "\n"
"Tag: " (or (mnav-rev-tag rev) "???") "\n"
"\n"
(or (mnav-rev-changelog rev) "#<none>")))
(defun mnav-pick-paint-buffer (rev)
"Paint an empty buffer with the selected REV."
(mnav-pick-paint-revlst "Parents" (mnav-rev-parents rev) 3)
(mnav-pick-paint-revlst "Children" (mnav-rev-children rev) 4)
(let ((m mnav-rev-mark))
(if m
(insert "=== Mark ==========\n "
(mnav-rev-id m) " "
(mnav-rev-date m) " "
(mnav-rev-author m) "\n\n")))
(insert "=== Current Selection ==========\n")
(mnav-pick-paint-selected rev))
;; (mnav-pick-paint-buffer mnav-rev-point)
(defun mnav-pick-readkey ()
"Read until a action is found."
(let (action key)
(while (not action)
(setq key (read-key-sequence (format "Pick: ")))
(setq action (lookup-key mnav-pick-readkey-map key)))
action))
;; (mnav-pick-readkey)
(defun mnav-pick-select (nextrev)
"Select NEXTREV as the next revision."
;; rev = current
(setf (mnav-rev-pick-cur rev) mnav-pick-cur
(mnav-rev-pick-back nextrev) rev
mnav-pick-cur (mnav-rev-pick-cur nextrev)
rev nextrev))
(defun mnav-pick (&optional revid)
"Display browser to pick a monotone revision."
(interactive)
(when (not mnav-revdb) ; DB loaded?
(mnav-revdb-reload))
;; cast revid to a rec
(when (not revid) ; default revid
(setq revid (or mnav-rev-point (monotone-MT-revision))))
(when (stringp revid) ; cast to a revrec
(setq revid (mnav-revdb-find revid)))
(when (not (mnav-rev-p revid))
(error "revid is not a rev"))
(setq mnav-rev-point revid)
;;
(let ((buf (get-buffer-create "*monotone rev pick*"))
(start-buf (current-buffer))
(rev revid)
mnav-pick-min mnav-pick-cur mnav-pick-max
mnav-pick-cnt mnav-pick-point)
(switch-to-buffer buf)
;;
(catch 'done
(while t
;; clamp
(setq mnav-pick-cnt 0
mnav-pick-min 0
mnav-pick-max (+ (length (mnav-rev-parents rev))
(length (mnav-rev-children rev)))
mnav-rev-point rev)
(mnav-pick-clamp)
;; paint
(erase-buffer)
(mnav-pick-paint-buffer rev)
(goto-char mnav-pick-point)
;; prompt & decode
(setq action (mnav-pick-readkey))
(cond
;; exiting actions
((equal action 'quit)
(setq rev nil)
(throw 'done nil))
((equal action 'pick)
(throw 'done nil))
;;
((commandp action)
(call-interactively action)
(setq start-buf nil) ;; done switch back
(throw 'done nil))
;; selecting actions
((equal action 'back)
(let ((back (mnav-rev-pick-back rev)))
(if back
(mnav-pick-select back)
(message "cant go back!"))))
((and (numberp action) (<= mnav-pick-min action) (< action mnav-pick-max))
(mnav-pick-select (mnav-rev-nth-link action rev)))
((equal action 'select)
(mnav-pick-select (mnav-rev-nth-link mnav-pick-cur rev)))
;; moving actions
((and (equal action 'move-up) (< mnav-pick-min mnav-pick-cur))
(incf mnav-pick-cur -1))
((and (equal action 'move-down) (< mnav-pick-cur mnav-pick-max))
(incf mnav-pick-cur +1))
;; mark
((equal action 'swap)
(if mnav-rev-mark
(let ((p rev)
(m mnav-rev-mark))
(setq mnav-rev-mark p
rev m))))
((equal action 'mark)
(setq mnav-rev-mark rev))
((equal action 'unmark)
(setq mnav-rev-mark nil))
;; motion
;;((null action) nil)
(t
(message "bad action %s" action)
(sit-for 1)) )
;; while & catch
nil))
;; done
(when start-buf
(switch-to-buffer start-buf))
(kill-buffer buf)
;; dont print a huge sexp
(if (interactive-p) nil rev)))
;;;;;;;;;;
(defun mnav-diff-revisions1 ()
"Run a diff between the checked out and point revisions."
(interactive)
(when (not (and mnav-rev-point))
(error "You need to choose a revision."))
(let ((pid (mnav-rev-id mnav-rev-point)))
(monotone-cmd (list "diff" "--revision" pid))))
;; (mnav-diff-revisions1)
(defun mnav-diff-revisions2 ()
"Run a diff between the point and mark revisions."
(interactive)
(when (not (and mnav-rev-point mnav-rev-mark))
(error "You need to choose a point and mark with 'mnav-pick'"))
(let ((pid (mnav-rev-id mnav-rev-point))
(mid (mnav-rev-id mnav-rev-mark )) )
(monotone-cmd (list "diff" "--revision" mid "--revision" pid))))
;; (mnav-diff-revisions2)
(defun mnav-diff-file (file)
"Run a diff between the point and mark revisions."
(interactive "sEnter monotone file: ")
(when (not mnav-rev-point)
(error "You need to choose a point with 'mnav-pick'"))
(let ((pid (mnav-rev-id mnav-rev-point)))
(monotone-cmd (list "diff" "--revision" pid file))))
;; (mnav-diff-file "contrib/monotone.el")
;; TESTING:
;; (progn (eval-buffer) (mnav-revdb-reload))
;; (progn (eval-buffer) (message "mnav-pick: %s" (mnav-rev-id (mnav-pick))))
;; (message "mnav-pick: %s" (mnav-rev-id (mnav-pick (monotone-MT-revision))))
(provide 'monotone-nav)
;;; monotone-nav.el ends here
