# 
# add_file "contrib/monotone-nav.el"
# 
# patch "contrib/monotone-nav.el"
#  from []
#    to [6712c56de443fbcc25a988234323dbe50f97268f]
# 
--- contrib/monotone-nav.el
+++ contrib/monotone-nav.el
@@ -0,0 +1,499 @@
+;;; 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
+(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))
+(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-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