monotone

monotone Mtn Source Tree

Root/contrib/monotone-nav.el

1;;; monotone-nav.el --- A navigator of monotone revision histories.
2;;
3;; ~/share/emacs/pkg/monotone/monotone-db.el ---
4;;
5;; $Id: monotone-nav.el,v 1.18 2005/04/26 07:42:22 harley Exp $
6;;
7
8;;; Commentary:
9;; "monotone-nav" is a database browser for monotone databases.
10;; Using the sql option of monotone it extacts the data into
11;; emacs which you may browse using the arrow keys.
12;; You can also mark revisons to run diffs or do other work.
13
14;;; EXAMPLE USAGE:
15;; (mnav-revdb-reload)
16;; (message "mnav-pick: %s" (mnav-rev-id (mnav-pick)))
17
18(require 'base64)
19(require 'cl)
20(require 'monotone)
21
22;;; Code:
23(defvar mnav-rev-point nil
24 "The rev record at 'point' of the picker. Get its id with 'mnav-rev-id'.")
25(defvar mnav-rev-mark nil
26 "The rev record 'marked' by the picker. Get its id with 'mnav-rev-id'.")
27
28;;
29(defvar mnav-pick-min nil
30 "The min value allowed to pick.")
31(defvar mnav-pick-cur nil
32 "The current selection on the pick screen.")
33(defvar mnav-pick-max nil
34 "The max value allowed to pick.")
35(defvar mnav-pick-point nil
36 "The point location for the cursor.")
37
38;;
39(defvar mnav-revdb nil
40 "A hash maping revision ids to rev structs.")
41(defvar mnav-revdb-initsize 5000
42 "The initial size of the hashtable.")
43
44;; debug info
45(defvar mnav-run-query-rows nil)
46
47;; many of the keys are repeats, so generate them.
48(defvar mnav-pick-readkey-map
49 (let ((map (make-sparse-keymap))
50 (acts '((quit "\C-g" "q" "Q" "x" "X")
51 (pick "\C-M" "p" "P")
52 (select [right] " ")
53 (mark "m" "M")
54 (unmark "u" "U")
55 ;;(head "h" "H")
56 (swap "s" "S")
57 (move-up [up] "-")
58 (move-down [down] "=" "+")
59 (back [left] "l" "L" "b" "B") )))
60 (dolist (act acts)
61 (dolist (key (cdr act))
62 (define-key map key (car act))))
63 (dotimes (i 10)
64 (define-key map (format "%s" i) i))
65 ;; normal key defs
66 (define-key map "d" 'mnav-diff-revisions1)
67 (define-key map "D" 'mnav-diff-revisions2)
68 (define-key map "f" 'mnav-diff-file)
69 map)
70 "The keymap used by `mnav-pick-readkey'.
71The values are either symbols for `mnav-pick' actions or
72interactive functions which will be exectued in the context of the picker.
73Users can use `define-key' to modifiy the mappings.")
74
75;; (mnav-pick-readkey)
76;; (read-key-sequence "Key: ")
77
78;;;;;;;;;;
79
80;;; the Revision structure
81(defmacro mnav-rev-id (rec)
82 "Fetch id from REC."
83 `(nth 1 ,rec))
84(defmacro mnav-rev-author (rec)
85 "Fetch the author from REC."
86 `(nth 2 ,rec))
87(defmacro mnav-rev-date (rec)
88 "Fetch the date from REC."
89 `(nth 3 ,rec))
90(defmacro mnav-rev-parents (rec)
91 "Fetch the list of parent revisions from REC."
92 `(nth 4 ,rec))
93(defmacro mnav-rev-children (rec)
94 "Fetch the list of child revisions from REC."
95 `(nth 5 ,rec))
96(defmacro mnav-rev-changelog (rec)
97 "Fetch the changelog from REC."
98 `(nth 6 ,rec))
99(defmacro mnav-rev-branch (rec)
100 "Fetch the name of the branch from REC."
101 `(nth 7 ,rec))
102(defmacro mnav-rev-tag (rec)
103 "Fetch the tags from REC."
104 `(nth 8 ,rec))
105(defmacro mnav-rev-pick-back (rec) ;; the picker stores the "back link" here
106 "Fetch the prior record viewed from REC.
107This is not from the DB but used by mnav-pick."
108 `(nth 9 ,rec))
109(defmacro mnav-rev-pick-cur (rec) ;; the picker stores mnav-pick-cur here.
110 "Fetch the current link selected from REC.
111This is not from the DB but used by mnav-pick."
112 `(nth 10 ,rec))
113(defun mnav-rev-make (id)
114 "Create a mnav-rev structure. ID is required."
115 (let ((rec (make-list 11 nil)))
116 (setf (car rec) 'rev)
117 (setf (mnav-rev-id rec) id)
118 rec))
119(defun mnav-rev-p (rec)
120 "Is this an mnav-rec?"
121 (and (listp rec) (equal (car rec) 'rev)))
122;; (mapcar #'mnav-rev-p (list nil (mnav-rev-make "aaa")))
123
124(defun mnav-rev-string (rec)
125 "Cast the revison record REC to a string.
126This is used for debugging."
127 (format
128 "#<rev %s p=%d c=%d %s %s>"
129 (or (mnav-rev-id rec) (make-string 40 63))
130 (length (mnav-rev-parents rec))
131 (length (mnav-rev-children rec))
132 (or (mnav-rev-date rec) "???")
133 (or (mnav-rev-author rec) "???")))
134;; (mnav-rev-string nil)
135
136(defun mnav-rev-nth-link (n rev)
137 "Return link N from the revision REV.
138Links are numbered in order starting with the parent."
139 (let ((plen (length (mnav-rev-parents rev)))
140 (clen (length (mnav-rev-children rev))))
141 (assert (< n (+ plen clen)) t "N is out of bounds: %s" n)
142 (if (< n plen)
143 (nth n (mnav-rev-parents rev))
144 (nth (- n plen) (mnav-rev-children rev)))))
145;; (mnav-rev-nth-link 0 '(rev 1 2 3 (4 a b c) (5 d e f) 6 7 8))
146
147;;;;;;;;;;
148
149;;; The index to revision entries
150
151(defun mnav-revdb-clear ()
152 "Clear the REVDB by creating a new hash table."
153 (setq mnav-rev-point nil
154 mnav-rev-mark nil)
155 (setq mnav-revdb (make-hash-table :test #'equal :size mnav-revdb-initsize)))
156;; (mnav-revdb-clear)
157
158(defun mnav-revdb-find (id &optional create)
159 "Find the ID in the revdb. CREATE if t."
160 ;; init?
161 (when (null mnav-revdb)
162 (mnav-revdb-clear))
163 (when (not (stringp id))
164 (if (mnav-rev-p id)
165 (setq id (mnav-rev-id id))
166 (error "ID is not a string or REV record.")))
167 ;;
168 (let ((rev (gethash id mnav-revdb)))
169 (when (and (not rev) create)
170 (setq rev (mnav-rev-make id))
171 (puthash id rev mnav-revdb))
172 rev))
173
174(defun mnav-revdb-print ()
175 "Dump the contents of revdb to a buffer for debugging."
176 (when (not mnav-revdb)
177 (mnav-revdb-clear))
178 (let ((buf (get-buffer-create "*monotone revdb*")))
179 (set-buffer buf)
180 (erase-buffer)
181 (maphash (function (lambda (k v) (insert (mnav-rev-string v) "\n"))) mnav-revdb)
182 (goto-char (point-min))
183 (switch-to-buffer-other-window buf)))
184;; (mnav-revdb-print)
185
186(defun mnav-revdb-add-ancestry (parentid childid)
187 "Add links from PARENTID to CHILDID."
188 (let ((p-rec (mnav-revdb-find parentid t))
189 (c-rec (mnav-revdb-find childid t)))
190 (push c-rec (mnav-rev-children p-rec))
191 (push p-rec (mnav-rev-parents c-rec))
192 nil))
193
194;; (mnav-revdb-print)
195
196(defun mnav-query-run (sqlquery row-func)
197 (let ((buf (get-buffer monotone-buffer))
198 read-mark row)
199 (let ((monotone-cmd-show nil)) ;; dont show the output
200 (monotone-cmd (list "db" "execute" sqlquery))
201 ;; skip to data
202 (goto-char (point-min))
203 (search-forward-regexp "^$" (point-max) t)
204 (setq read-mark (point-marker))
205 ;;
206 (setq mnav-query-rows nil) ;; debug
207 (while (setq row (condition-case nil (read read-mark) (error nil)))
208 (funcall row-func row)
209 (setq mnav-query-rows (cons row mnav-query-rows)) ;; debug
210 nil))))
211
212(defun mnav-revdb-query-ancestry ()
213 "Query the revision_ancestry table for ancestry info."
214 ;; ("parentid" "childid")
215 (mnav-query-run "
216select '(\"'||coalesce(parent,'')||'\" \"'||coalesce(child,'')||'\")'
217from revision_ancestry"
218 (function (lambda (row) (mnav-revdb-add-ancestry (car row) (cadr row))))))
219
220(defun mnav-revdb-query-metaname (name setfunc)
221 "Query for metadata NAME and apply SETFUNC to each row.
222SETFUNC is called with the revision rec and *decoded* value."
223 (let ((sql (format "
224select '(\"'||id||'\" \"'||value||'\")'
225from revision_certs
226where name = '%s'" name)))
227 (mnav-query-run
228 sql
229 (function
230 (lambda (row)
231 (let ((rec (mnav-revdb-find (car row) t))
232 (val (base64-decode-string (cadr row))))
233 (funcall setfunc rec val)))))))
234
235;; the revision info we care about.
236(defun mnav-revdb-query-meta-author ()
237 (mnav-revdb-query-metaname
238 "author"
239 (function (lambda (rec val) (setf (mnav-rev-author rec) val)))))
240(defun mnav-revdb-query-meta-date ()
241 (mnav-revdb-query-metaname
242 "date"
243 (function (lambda (rec val) (setf (mnav-rev-date rec) val)))))
244(defun mnav-revdb-query-meta-changelog ()
245 (mnav-revdb-query-metaname
246 "changelog"
247 (function (lambda (rec val) (setf (mnav-rev-changelog rec) val)))))
248(defun mnav-revdb-query-meta-branch ()
249 (mnav-revdb-query-metaname
250 "branch"
251 (function (lambda (rec val) (setf (mnav-rev-branch rec) val)))))
252(defun mnav-revdb-query-meta-tag ()
253 (mnav-revdb-query-metaname
254 "tag"
255 (function (lambda (rec val) (setf (mnav-rev-tag rec) val)))))
256
257(defun mnav-revdb-reload ()
258 (mnav-revdb-clear)
259 (message "Loading ancestry...")
260 (mnav-revdb-query-ancestry)
261 (message "Loading authors...")
262 (mnav-revdb-query-meta-author)
263 (message "Loading dates...")
264 (mnav-revdb-query-meta-date)
265 (message "Loading changelogs...")
266 (mnav-revdb-query-meta-changelog)
267 (message "Loading branches...")
268 (mnav-revdb-query-meta-branch)
269 (message "Loading tags...")
270 (mnav-revdb-query-meta-tag)
271 nil)
272;; (mnav-revdb-reload)
273
274
275;;;;;;;;;;
276
277;;; PICK
278
279(defun mnav-pick-clamp ()
280 "Clamp mnav-pick-cur between min and max."
281 (when (or (not (numberp mnav-pick-cur)) (< mnav-pick-cur mnav-pick-min))
282 (setq mnav-pick-cur mnav-pick-min))
283 (when (not (< mnav-pick-cur mnav-pick-max))
284 (setq mnav-pick-cur (1- mnav-pick-max))))
285;; (progn (setq mnav-pick-max 5 mnav-pick-cur 10) (mnav-pick-clamp) mnav-pick-cur)
286
287;;; PAINT
288
289(defun mnav-pick-paint-revlink (rev)
290 "Render a link to REV into the buffer.
291This function should insert a single line of text.
292The pointer '=>' and newline are supplied by the caller."
293 (if rev
294 (insert
295 (or (mnav-rev-id rev) "???") " "
296 (or (mnav-rev-date rev) "???") " "
297 (or (mnav-rev-author rev) "???"))
298 (insert "-none-")))
299
300(defun mnav-pick-paint-revlink-short (rev)
301 "An example of a function to paint short links."
302 (if rev
303 (insert
304 (or (mnav-rev-id rev) "???") " "
305 (or (mnav-rev-date rev) "???") " "
306 (or (mnav-rev-author rev) "???"))
307 (insert "-none-")))
308
309
310(defun mnav-pick-paint-revlst (label lst min)
311 "Paint the buffer with a numbered list links to revisions."
312 (insert (format "--- %-10s --------------------\n" label))
313 (let ((c 0))
314 (dolist (p lst)
315 (if (= mnav-pick-cnt mnav-pick-cur)
316 (progn
317 (setq mnav-pick-point (point))
318 (insert "=>"))
319 (insert " "))
320 (insert (format "%2d: " mnav-pick-cnt))
321 (mnav-pick-paint-revlink p) ;; the data
322 (insert "\n")
323 (incf mnav-pick-cnt)
324 (incf c))
325 ;; pad lines to min
326 (do ((c c (1+ c))) ((>= c min)) (insert "\n")))
327 (insert "\n"))
328
329(defun mnav-pick-paint-selected (rev)
330 "Paint the buffer with the selected REV.
331This function can be replaced by the user."
332 (when (not (mnav-rev-p rev))
333 (error "invalid rev to display."))
334 (insert "Revision: " (or (mnav-rev-id rev) "???") "\n"
335 "Date: " (or (mnav-rev-date rev) "???") "\n"
336 "Author: " (or (mnav-rev-author rev) "???") "\n"
337 "Branch: " (or (mnav-rev-branch rev) "???") "\n"
338 "Tag: " (or (mnav-rev-tag rev) "???") "\n"
339 "\n"
340 (or (mnav-rev-changelog rev) "#<none>")))
341
342(defun mnav-pick-paint-buffer (rev)
343 "Paint an empty buffer with the selected REV."
344 (mnav-pick-paint-revlst "Parents" (mnav-rev-parents rev) 3)
345 (mnav-pick-paint-revlst "Children" (mnav-rev-children rev) 4)
346 (let ((m mnav-rev-mark))
347 (if m
348 (insert "=== Mark ==========\n "
349 (mnav-rev-id m) " "
350 (mnav-rev-date m) " "
351 (mnav-rev-author m) "\n\n")))
352 (insert "=== Current Selection ==========\n")
353 (mnav-pick-paint-selected rev))
354;; (mnav-pick-paint-buffer mnav-rev-point)
355
356 (defun mnav-pick-readkey ()
357 "Read until a action is found."
358 (let (action key)
359 (while (not action)
360 (setq key (read-key-sequence (format "Pick: ")))
361 (setq action (lookup-key mnav-pick-readkey-map key)))
362 action))
363;; (mnav-pick-readkey)
364
365(defun mnav-pick-select (nextrev)
366 "Select NEXTREV as the next revision."
367 ;; rev = current
368 (setf (mnav-rev-pick-cur rev) mnav-pick-cur
369 (mnav-rev-pick-back nextrev) rev
370 mnav-pick-cur (mnav-rev-pick-cur nextrev)
371 rev nextrev))
372
373(defun mnav-pick (&optional revid)
374 "Display browser to pick a monotone revision."
375 (interactive)
376 (when (not mnav-revdb) ; DB loaded?
377 (mnav-revdb-reload))
378 ;; cast revid to a rec
379 (when (not revid) ; default revid
380 (setq revid (or mnav-rev-point (monotone-MT-revision))))
381 (when (stringp revid) ; cast to a revrec
382 (setq revid (mnav-revdb-find revid)))
383 (when (not (mnav-rev-p revid))
384 (error "revid is not a rev"))
385 (setq mnav-rev-point revid)
386 ;;
387 (let ((buf (get-buffer-create "*monotone rev pick*"))
388 (start-buf (current-buffer))
389 (rev revid)
390 mnav-pick-min mnav-pick-cur mnav-pick-max
391 mnav-pick-cnt mnav-pick-point)
392 (switch-to-buffer buf)
393 ;;
394 (catch 'done
395 (while t
396 ;; clamp
397 (setq mnav-pick-cnt 0
398 mnav-pick-min 0
399 mnav-pick-max (+ (length (mnav-rev-parents rev))
400 (length (mnav-rev-children rev)))
401 mnav-rev-point rev)
402 (mnav-pick-clamp)
403 ;; paint
404 (erase-buffer)
405 (mnav-pick-paint-buffer rev)
406 (goto-char mnav-pick-point)
407 ;; prompt & decode
408 (setq action (mnav-pick-readkey))
409 (cond
410 ;; exiting actions
411 ((equal action 'quit)
412 (setq rev nil)
413 (throw 'done nil))
414 ((equal action 'pick)
415 (throw 'done nil))
416 ;;
417 ((commandp action)
418 (call-interactively action)
419 (setq start-buf nil) ;; done switch back
420 (throw 'done nil))
421 ;; selecting actions
422 ((equal action 'back)
423 (let ((back (mnav-rev-pick-back rev)))
424 (if back
425 (mnav-pick-select back)
426 (message "cant go back!"))))
427 ((and (numberp action) (<= mnav-pick-min action) (< action mnav-pick-max))
428 (mnav-pick-select (mnav-rev-nth-link action rev)))
429 ((equal action 'select)
430 (mnav-pick-select (mnav-rev-nth-link mnav-pick-cur rev)))
431 ;; moving actions
432 ((and (equal action 'move-up) (< mnav-pick-min mnav-pick-cur))
433 (incf mnav-pick-cur -1))
434 ((and (equal action 'move-down) (< mnav-pick-cur mnav-pick-max))
435 (incf mnav-pick-cur +1))
436 ;; mark
437 ((equal action 'swap)
438 (if mnav-rev-mark
439 (let ((p rev)
440 (m mnav-rev-mark))
441 (setq mnav-rev-mark p
442 rev m))))
443 ((equal action 'mark)
444 (setq mnav-rev-mark rev))
445 ((equal action 'unmark)
446 (setq mnav-rev-mark nil))
447 ;; motion
448 ;;((null action) nil)
449 (t
450 (message "bad action %s" action)
451 (sit-for 1)) )
452 ;; while & catch
453 nil))
454 ;; done
455 (when start-buf
456 (switch-to-buffer start-buf))
457 (kill-buffer buf)
458 ;; dont print a huge sexp
459 (if (interactive-p) nil rev)))
460
461
462;;;;;;;;;;
463
464(defun mnav-diff-revisions1 ()
465 "Run a diff between the checked out and point revisions."
466 (interactive)
467 (when (not (and mnav-rev-point))
468 (error "You need to choose a revision."))
469 (let ((pid (mnav-rev-id mnav-rev-point)))
470 (monotone-cmd (list "diff" "--revision" pid))))
471;; (mnav-diff-revisions1)
472
473(defun mnav-diff-revisions2 ()
474 "Run a diff between the point and mark revisions."
475 (interactive)
476 (when (not (and mnav-rev-point mnav-rev-mark))
477 (error "You need to choose a point and mark with 'mnav-pick'"))
478 (let ((pid (mnav-rev-id mnav-rev-point))
479 (mid (mnav-rev-id mnav-rev-mark )) )
480 (monotone-cmd (list "diff" "--revision" mid "--revision" pid))))
481;; (mnav-diff-revisions2)
482
483(defun mnav-diff-file (file)
484 "Run a diff between the point and mark revisions."
485 (interactive "sEnter monotone file: ")
486 (when (not mnav-rev-point)
487 (error "You need to choose a point with 'mnav-pick'"))
488 (let ((pid (mnav-rev-id mnav-rev-point)))
489 (monotone-cmd (list "diff" "--revision" pid file))))
490;; (mnav-diff-file "contrib/monotone.el")
491
492;; TESTING:
493;; (progn (eval-buffer) (mnav-revdb-reload))
494;; (progn (eval-buffer) (message "mnav-pick: %s" (mnav-rev-id (mnav-pick))))
495;; (message "mnav-pick: %s" (mnav-rev-id (mnav-pick (monotone-MT-revision))))
496
497(provide 'monotone-nav)
498
499;;; monotone-nav.el ends here

Archive Download this file

Branches

Tags

Quick Links:     www.monotone.ca    -     Downloads    -     Documentation    -     Wiki    -     Code Forge    -     Build Status