monotone

monotone Mtn Source Tree

Root/contrib/monotone.el

1;;; monotone.el --- Run monotone from within Emacs.
2;;
3;; Copyright 2005 by Olivier Andrieu <oandrieu@nerim.net>
4;; Version 0.2 2005-04-13
5;;
6;; Licence: GPL v2 (same as monotone)
7;; Keymaps and other stuff added by harley@panix.com
8;;
9
10;;; Commentary:
11;;
12;; To use monotone from within Emacs, all you should need to
13;; do is require the package. There are many options but
14;; then only one you should have to set is the prefix key for
15;; the keybindings. Something like the following should work:
16;;
17;; (require 'monotone)
18;; (monotone-set-vc-prefix-key [f5]) ;; or "\C-xv"
19;; (setq monotone-passwd-remember t)
20;;
21;; You may want to put "monotone-grab-id" on a handy function key.
22;;
23;; Monotone prefers to work with the global working set.
24;; "monotone.el" has its defaults set to match.
25;; Commands run without a prefix work on the global working set.
26;; One C-u is the subtree (".") and C-u C-u is the current file.
27;; (There are exceptions)
28;;
29;; Some of the function names follow Emacs "vc-" names,
30;; others follow monotone names. I havent decided which I
31;; like better.
32;;
33;; This mode was written and tested with GNU Emacs 21.3.50.1
34
35;; FIXME: handle aborts better and kill monotone.
36;; FIXME: given an id, suck out the file with "mtn cat"
37;; FIXME: handle diff --revision XXX path/to/file
38;; -- Prefix arg on diff should probably prompt for parent
39;; -- Have a version that diffs against branch-point
40
41;;; User vars:
42;; These vars are likley to be changed by the user.
43
44(defvar monotone-program "mtn"
45 "*The path to the monotone program.")
46
47(defvar monotone-passwd-remember nil
48 "*Should Emacs remember your monotone passwords?
49This is a security risk as it could be extracted from memory or core dumps.")
50
51(defvar monotone-passwd-alist nil
52 "*The password to be used when monotone asks for one.
53List of of (pubkey_id . password ).
54If `monotone-passwd-remember' is t it will be remembered here.")
55
56;; This is set to [f5] for testing.
57;; Should be nil for general release, as we dont want to
58;; remove keys without the users consent.
59(defvar monotone-vc-prefix-key nil ;; [f5] "\C-xv" nil
60 "The prefix key to use for the monotone vc key map.
61You may wish to change this before loading monotone.el.
62Habitual monotone users can set it to '\C-xv'.")
63
64(defvar monotone-menu-name "Monotone"
65 "The name of the monotone menu.")
66
67
68;;; System Vars:
69;; It is unlikely for users to need to change these.
70
71(defvar monotone-cmd-show t
72 "Show the outout of the monotone command?
73This is normally rebound when the output should not be shown.")
74
75(defvar monotone-program-args-always '("--ticker=dot")
76 "Args which will always be passed to monotone.
77The arg '--ticker=dot' should be here to avoid lots of output.")
78
79(defvar monotone-last-id nil
80 "The last id which was worked with or grabbed.
81This could be a file, manifest or revision.
82It is also stuffed into the kill ring.
83This is used for defaults.")
84(defvar monotone-last-fileid nil
85 "The last file id.")
86(defvar monotone-last-manifestid nil
87 "The last manifest id.")
88(defvar monotone-last-revisionid nil
89 "The last revision id.")
90
91(defvar monotone-buffer "*monotone*"
92 "The buffer used for running monotone commands.")
93
94(defvar monotone-commit-buffer "*monotone commit*"
95 "The name of the buffer for the commit message.")
96(defvar monotone-commit-edit-status nil
97 "The sentinel for completion of editing the log.")
98(make-variable-buffer-local 'monotone-commit-edit-status)
99(defvar monotone-commit-args nil
100 "The args for the commit.")
101(make-variable-buffer-local 'monotone-commit-args)
102
103(defvar monotone-cmd-last-args nil
104 "The args for the last command.")
105;;(make-variable-buffer-local 'monotone-cmd-args)
106
107
108(defvar monotone-commit-dir nil)
109
110(defvar monotone-wait-time 5
111 "Time to wait for monotone to produce output.")
112
113(defvar monotone-_MTN-top nil
114 "The directory which contains the _MTN directory.
115This is used to pass state -- best be left nil.")
116
117(defvar monotone-log-depth 100
118 "The depth to limit output of 'monotone log' entries.
119Zero is unlimited.")
120
121(defvar monotone-_MTN-revision nil
122 "")
123
124;;; monotone-commit-mode is used when editing the commit message.
125(defvar monotone-commit-mode nil)
126(make-variable-buffer-local 'monotone-commit-mode)
127
128(defvar monotone-commit-mode-map
129 (let ((map (make-sparse-keymap)))
130 (define-key map "\C-c\C-c" 'monotone-commit-complete)
131 map))
132
133;; hook it in
134(add-to-list 'minor-mode-alist '(monotone-commit-mode " Monotone Commit"))
135(add-to-list 'minor-mode-map-alist (cons 'monotone-commit-mode monotone-commit-mode-map))
136
137(defvar monotone-msg nil
138 "When non-nil log stuff to *Messages*.")
139
140(defmacro monotone-msg (&rest args)
141 "Print ARGS to *Messages* when variable `monotone-msg' is non-nil."
142 `(when monotone-msg
143 (message ,@args)))
144;; (monotone-msg "%s" '("foo" 1 2 3))
145
146(defvar monotone-output-mode-hook nil
147 "*The hook for monotone output.")
148
149(defvar monotone-commit-instructions
150 "--------------------------------------------------
151Enter Log. Lines beginning with 'MTN:' are removed automatically.
152Type C-c C-c to commit, kill the buffer to abort.
153--------------------------------------------------"
154 "Instructional text to insert into the commit buffer.
155'MTN: ' is added when inserted.")
156
157(defvar monotone-commit-mode-hook nil
158 "*The hook for function `monotone-commit-mode'.")
159
160
161(defvar monotone-server nil
162 "The default server for pulls and pushes.")
163(defvar monotone-collection nil
164 "The default collection for pulls and pushes.")
165(defvar monotone-server-hist nil
166 "A history of servers.")
167(defvar monotone-collection-hist nil
168 "A history of collections.")
169
170;;; Key maps
171(defvar monotone-vc-prefix-map
172 (let ((map (make-sparse-keymap)))
173 ; keys for compatibility with vc-mode (and anyone who has those binding
174 ; burned into their fingers)
175 (define-key map "=" 'monotone-vc-diff)
176 (define-key map "\C-q" 'monotone-vc-commit)
177 (define-key map "i" 'monotone-vc-register)
178 (define-key map "l" 'monotone-vc-print-log)
179 ; new keys, perhaps more sensible
180 (define-key map "d" 'monotone-vc-diff)
181 (define-key map "c" 'monotone-vc-commit)
182 (define-key map "a" 'monotone-vc-register)
183 (define-key map "6" 'monotone-grab-id)
184 (define-key map "P" 'monotone-push)
185 (define-key map "p" 'monotone-pull)
186 (define-key map "q" 'monotone-vc-commit) ;; i am a lazy typist
187 (define-key map "s" 'monotone-vc-status)
188 (define-key map "x" 'monotone)
189 map))
190(fset 'monotone-vc-prefix-map monotone-vc-prefix-map)
191
192;;; Code:
193
194(defun monotone-set-vc-prefix-key (key)
195 "Set KEY to be the prefix for monotone in the global keymap."
196 (setq monotone-vc-prefix-key key)
197 (define-key global-map monotone-vc-prefix-key 'monotone-vc-prefix-map))
198
199;; install it if set.
200(when monotone-vc-prefix-key
201 (monotone-set-vc-prefix-key monotone-vc-prefix-key))
202
203
204(defun monotone-toggle-vc-prefix-map (&optional arg)
205 "Toggle between the default and monotone vc-maps, ARG set map.
206With arg 0 use the default variable `vc-prefix-map'.
207With t use `monotone-vc-prefix-map'.
208This permits quick switches between the classic vc and monotone keymaps."
209 (interactive "P")
210 (define-key ctl-x-map "v"
211 (let ((current (lookup-key ctl-x-map "v")))
212 (if (and (not (eq arg 0))
213 (or arg (not (eq current monotone-vc-prefix-map))))
214 monotone-vc-prefix-map
215 vc-prefix-map))))
216;; (monotone-toggle-vc-prefix-map t)
217
218;; Utility functions
219(defun monotone-file-parent-directory (file)
220 "Return the parent directory of FILE."
221 (file-name-directory (directory-file-name file)))
222
223(defun monotone-_MTN-revision ()
224 "The current revision as read from '_MTN/revision'."
225 (let ((dir (monotone-find-_MTN-top)))
226 (when (not dir)
227 (error "No _MTN top directory."))
228 (let ((file (concat dir "/_MTN/revision")))
229 (with-temp-buffer
230 (insert-file-contents-literally file nil)
231 (setq monotone-_MTN-revision (buffer-substring 1 41)))
232 monotone-_MTN-revision)))
233;; (monotone-_MTN-revision)
234
235
236(defun monotone-find-_MTN-top (&optional path)
237 "Find the directory which contains the '_MTN' directory.
238Optional argument PATH ."
239 (setq path (or path buffer-file-name default-directory))
240 (when (null path)
241 (error "Cant find top for %s" path))
242 ;; work with full path names
243 (setq path (expand-file-name path))
244 (catch 'found
245 (let ((prev-path nil))
246 (while (not (equal path prev-path))
247 (let ((mtn-dir (concat path "_MTN")))
248 ;;(message "Search: %s" mtn-dir)
249 (when (file-directory-p mtn-dir)
250 (throw 'found path))
251 (setq prev-path path
252 path (monotone-file-parent-directory path)))))))
253;;(monotone-find-_MTN-top "/disk/amelie1/harley/monotone-dev/contrib/monotone.el")
254
255(defun monotone-extract-_MTN-path (path &optional mtn-top)
256 "Get the PATH minus the _MTN-TOP."
257 ;; cast and check
258 (when (bufferp path)
259 (setq path (buffer-file-name path)))
260 (when (not (stringp path))
261 (error "path is not a string."))
262 (let ((mtn-top (or mtn-top monotone-_MTN-top (monotone-find-_MTN-top path))))
263 ;; work with full names
264 (setq path (expand-file-name path)
265 mtn-top (expand-file-name mtn-top))
266 (if (not mtn-top)
267 nil
268 (substring path (length mtn-top)))))
269
270;; (monotone-extract-_MTN-path "/disk/amelie1/harley/monotone-dev/contrib/monotone.el")
271;; (monotone-find-_MTN-dir "/disk/amelie1/harley")
272;; (monotone-extract-_MTN-path (current-buffer))
273
274(defun monotone-output-mode ()
275 "In the future this will provide some fontification.
276Nothing for now."
277 (interactive)
278 (fundamental-mode) ;;(text-mode)
279 (run-hooks monotone-output-mode-hook))
280
281;;(define-derived-mode monotone-shell-mode comint-mode "Monotone")
282
283(defun monotone-string-chomp (str)
284 "Remove the last char if it is a newline."
285 (when (char-equal 10 (elt str (1- (length str))))
286 (setq str (substring str 0 (1- (length str)))))
287 str)
288;; (monotone-string-chomp "aaa")
289
290(defun monotone-process-sentinel (process event)
291 "This sentinel suppresses the text from PROCESS on EVENT."
292 (when monotone-cmd-show
293 (message "monotone: process %s received %s" process
294 (monotone-string-chomp event))
295 nil))
296
297;; Run a monotone command
298(defun monotone-cmd (args)
299 "Execute the monotone command with ARGS in the monotone top directory."
300 (monotone-msg "%s" args)
301 ;; coerce args to what we expect
302 (when (stringp args)
303 (setq args (split-string args nil)))
304 (when (not (listp args))
305 (setq args (list args)))
306 ;;
307 (let ((mtn-top (or monotone-_MTN-top (monotone-find-_MTN-top)))
308 (mtn-buf (get-buffer-create monotone-buffer))
309 ;;(mtn-pgm "ls") ;; easy debugging
310 (mtn-pgm monotone-program)
311 monotone-_MTN-top
312 mtn-cmd mtn-status)
313 ;; where to run
314 (when (or (not (stringp mtn-top)) (not (file-directory-p mtn-top)))
315 (setq mtn-top (monotone-find-_MTN-top))
316 (when (or (not (stringp mtn-top)) (not (file-directory-p mtn-top)))
317 (error "Unable to find the _MTN top directory")))
318 (setq monotone-_MTN-top mtn-top)
319 ;; show buffer in a window
320 (when monotone-cmd-show
321 (pop-to-buffer mtn-buf)
322 (sit-for 0))
323 (set-buffer mtn-buf)
324 ;; still going?
325 (when (get-buffer-process mtn-buf)
326 (error "Monotone is currently running"))
327 ;; prep the buffer for output
328 (setq buffer-read-only nil)
329 (erase-buffer)
330 ;;(buffer-disable-undo (current-buffer))
331 (setq default-directory mtn-top)
332 ;; remeber the args
333 (setq monotone-cmd-last-args args)
334 ;;
335 (when monotone-program-args-always
336 (setq args (append monotone-program-args-always args)))
337 ;; run
338 (let ((p (apply #'start-process monotone-buffer mtn-buf mtn-pgm args)))
339 ;; dont dirty the output
340 (set-process-sentinel p #'monotone-process-sentinel)
341 (while (eq (process-status p) 'run)
342 ;; FIXME: rather than printing messages, abort after too long a wait.
343 (when (not (accept-process-output p monotone-wait-time))
344 ;;(message "waiting for monotone..."))
345 (when monotone-cmd-show ;; update the screen
346 (goto-char (point-max))
347 (sit-for 0))
348 ;; look for passwd prompt
349 (beginning-of-line)
350 (when (looking-at "^enter passphrase for key ID \\[\\(.*\\)\\]")
351 (let ((pass (monotone-passwd-prompt (match-string 1))))
352 ;;(end-of-line)
353 ;;(insert "********\n") ;; filler text
354 (process-send-string p pass)
355 (process-send-string p "\n"))))
356 (setq mtn-status (process-exit-status p)))
357 ;; make the buffer nice.
358 (goto-char (point-min))
359 (view-mode)
360 (set-buffer-modified-p nil)
361 ;; did we part on good terms?
362 (when (and mtn-status (not (zerop mtn-status)))
363 (message "%s: exited with status %s" mtn-pgm mtn-status)
364 (beep)
365 (sit-for 3))
366 ;; this seems to be needed for the sentinel to catch up.
367 (sit-for 1)
368 mtn-status)))
369
370;; (monotone-cmd '("list" "branches"))
371;; (monotone-cmd '("list" "keys"))
372;; (monotone-cmd "pubkey harley@panix.com")
373;; (monotone-cmd '("status error"))
374
375(defun monotone-cmd-hide (args)
376 "Run monotone with ARGS without showing the output."
377 (save-window-excursion
378 (monotone-cmd args)))
379
380;; run
381(defun monotone (string)
382 "Prompt for a STRING and run monotone with the split string."
383 (interactive "smonotone ")
384 (monotone-cmd string))
385
386(defun monotone-rerun ()
387 "Rerun the last monotone command."
388 (interactive)
389 (let ((args monotone-cmd-last-args))
390 (when (or (null args) (not (listp args)))
391 (error "No last args to rerun"))
392 (monotone-cmd args)))
393;; (monotone-cmd "list known")
394
395(defun monotone-cmd-is-running ()
396 "Return if monotone is running."
397 (save-window-excursion
398 (let ((buf (get-buffer-create monotone-buffer)))
399 (get-buffer-process buf))))
400;; (monotone-cmd-is-running)
401
402
403;;;;;;;;;;
404(defun monotone-passwd-remember (keypairid password)
405 "Remember the PASSWORD for KEYPAIRID."
406 (let ((rec (assoc keypairid monotone-passwd-alist)))
407 (if rec
408 (setcdr rec password)
409 (progn
410 (setq rec (cons keypairid password))
411 (setq monotone-passwd-alist (cons rec monotone-passwd-alist))))
412 rec))
413;; (monotone-passwd-remember "foo" "bar")
414;; (setq monotone-passwd-alist nil)
415
416(defun monotone-passwd-find (keypairid)
417 "Return the password for KEYPAIRID or nil."
418 (cdr (assoc keypairid monotone-passwd-alist)))
419;; (monotone-passwd-find "foo")
420
421(defun monotone-passwd-prompt (keypairid)
422 "Read the password for KEYPAIRID."
423 (let ((passwd (monotone-passwd-find keypairid))
424 prompt)
425 (setq prompt (format "Password for '%s'%s: " keypairid
426 (if passwd " [return for default]" "")))
427 (setq passwd (read-passwd prompt nil passwd))
428 (when monotone-passwd-remember
429 (monotone-passwd-remember keypairid passwd))
430 passwd))
431;; (monotone-passwd-prompt "foo@bar.com")
432;; (setq monotone-passwd-remember t)
433
434;;
435(defun monotone-list-branches ()
436 "List the monotone branches known."
437 (interactive)
438 (monotone-cmd '("list" "branches")))
439
440;;;;;;;;;;
441
442(defun monotone-db-prompt ()
443 "Prompt for the server and collection, defaulting to the prior values."
444 ;; read-string docs say not to use initial-input but "compile" does.
445 (setq monotone-server
446 (read-string "Monotone server [host:port]: " monotone-server
447 'monotone-server-hist))
448 (setq monotone-collection
449 (read-string "Monotone collection: " monotone-collection
450 'monotone-collection-hist)))
451
452(defun monotone-db-action (prefix action)
453 "Preform the db ACTION requested. With PREFIX prompt for info."
454 (when (equal prefix 0)
455 (setq monotone-server nil
456 monotone-collection nil))
457 (when prefix
458 (monotone-db-prompt))
459 ;;
460 (let ((cmd (list (format "%s" action)))
461 (svr (or monotone-server ""))
462 (col (or monotone-collection "")))
463 ;; given address?
464 (when (and (stringp svr) (not (string= svr "")))
465 (setq cmd (append cmd (list svr)))
466 ;; given collection?
467 (when (and (stringp col) (not (string= col "")))
468 (setq cmd (append cmd (list col)))))
469 ;;
470 (monotone-cmd cmd)))
471
472(defun monotone-pull (arg)
473 "Pull updates from a remote server. ARG prompts.
474With ARG prompt for server and collection.
475With ARG of 0, clear default server and collection."
476 (interactive "P")
477 (monotone-db-action arg "pull"))
478
479(defun monotone-push (arg)
480 "Push the DB contents to a remote server. ARG prompts."
481 (interactive "P")
482 (monotone-db-action arg "push"))
483
484(defun monotone-sync (arg)
485 "Sync the DB with a remote server. ARG prompts."
486 (interactive "P")
487 (monotone-db-action arg "sync"))
488
489;;;;;;;;;;
490
491;;; Start if the commit process...
492;; FIXME: the default should be a global commit.
493(defun monotone-vc-commit (args)
494 "Do a commit."
495 (interactive "p")
496 (setq args (monotone-arg-decode args))
497 (when (eq args 'file)
498 (when (not (setq args buffer-file-name))
499 (error "Cant commit a buffer without a filename")))
500 ;; dont run two processes
501 (when (monotone-cmd-is-running)
502 (switch-to-buffer (get-buffer-create monotone-buffer))
503 (error "You have a monotone process running"))
504 ;; flush buffers
505 (save-some-buffers)
506 ;;
507 (let ((buf (get-buffer-create monotone-commit-buffer))
508 (monotone-_MTN-top (monotone-find-_MTN-top)))
509 ;; found _MTN?
510 (when (not monotone-_MTN-top)
511 (error "Cant find _MTN directory"))
512 ;; show it
513 (when (not (equal (current-buffer) buf))
514 (switch-to-buffer-other-window buf))
515 (set-buffer buf)
516 (setq buffer-read-only nil)
517 ;; Have the contents been commited?
518 (when (eq monotone-commit-edit-status 'started)
519 (message "Continuing commit message already started."))
520 (when (or (null monotone-commit-edit-status) (eq monotone-commit-edit-status 'done))
521 (erase-buffer)
522 (setq default-directory monotone-_MTN-top)
523 (let ((mtn-log-path (concat monotone-_MTN-top "_MTN/log")))
524 (when (file-readable-p mtn-log-path)
525 (insert-file mtn-log-path)))
526 ;; blank line for user to type
527 (goto-char (point-min))
528 (insert "\n")
529 (goto-char (point-min))
530 (monotone-commit-mode))
531 ;; update the "MTN:" lines by replacing them.
532 (monotone-remove-MTN-lines)
533 (end-of-buffer)
534 (when (not (looking-at "^"))
535 (insert "\n"))
536 (let ((eo-message (point)))
537 ;; what is being commited?
538 ;;(mapc (function (lambda (a) (insert "args: " (format "%s" a) "\n"))) args)
539 (insert (format "%s\n" args))
540 ;;(insert (format "Commit arg = %s" arg) "\n")
541 ;; instructional text
542 (when (stringp monotone-commit-instructions)
543 (insert monotone-commit-instructions)
544 (when (not (looking-at "^"))
545 (insert "\n")))
546 ;; what is being committed?
547 ;; FIXME: handle args -- this is doing a global status
548 (monotone-cmd-hide "status")
549 (insert-buffer-substring monotone-buffer)
550 ;; insert "MTN: " prefix
551 (goto-char eo-message)
552 (while (search-forward-regexp "^" (point-max) t)
553 (insert "MTN: ")))
554 ;; ready for edit -- put this last avoid being cleared on mode switch.
555 (goto-char (point-min))
556 (setq monotone-commit-edit-status 'started
557 monotone-commit-args args)))
558
559(defun monotone-commit-mode (&optional arg)
560 "Mode for editing a monotone commit message. ARG turns on."
561 (interactive "p")
562 (fundamental-mode) ;; (text-mode)
563 (run-hooks monotone-commit-mode-hook)
564 ;; must be last to avoid being cleared.
565 (setq monotone-commit-mode t))
566;; (if (null arg)
567;; (not monotone-commit-mode)
568;; (> (prefix-numeric-value arg) 0)))
569;; (when monotone-commit-mode
570;; turn on the minor mode for keybindings and run hooks.
571
572
573(defun monotone-commit-complete ()
574 "Complete the message and commit the work."
575 (interactive)
576 (when (not (eq monotone-commit-edit-status 'started))
577 (error "The commit in this buffer is '%s'" monotone-commit-edit-status))
578 (monotone-remove-MTN-lines)
579 (let ((buf (current-buffer))
580 (message (buffer-substring-no-properties (point-min) (point-max)))
581 (mca monotone-commit-args) ;; copy of buffer-local-var
582 (args (list "commit")))
583 (switch-to-buffer (get-buffer-create monotone-buffer))
584 ;; assemble and run the command
585 (setq args (append args (list "--message" message)))
586 ;; FIXME: global subtree file list...
587 (cond
588 ((equal mca 'global)
589 (monotone-cmd args)) ;; no spec
590 ((equal mca 'tree)
591 (error "Monotone tree scope sucks for commit!"))
592 ((stringp mca) ;; file
593 (setq args (append args (list (monotone-extract-_MTN-path mca))))
594 (monotone-cmd args))
595 (t
596 (error "unknown monotone-commit-args")))
597 ;; mark it done
598 (set-buffer buf)
599 (setq monotone-commit-edit-status 'done)))
600
601(defun monotone-remove-MTN-lines ()
602 "Remove lines starting with 'MTN:' from the buffer."
603 ;; doesnt need to be (interactive)
604 (goto-char (point-min))
605 (while (search-forward-regexp "^MTN:.*$" (point-max) t)
606 (beginning-of-line)
607 (kill-line 1)))
608
609;;;;;;;;;;
610
611(defun monotone-arg-decode (arg)
612 "Decode the ARG into the scope monotone should work on."
613 (interactive "p")
614 (monotone-msg "%s" arg)
615 (cond
616 ((member arg '(global tree file)) arg) ;; identity
617 ((= arg 1) 'global)
618 ((= arg 4) 'tree)
619 ((= arg 16) 'file)
620 (t (error "Prefix should be in (1,4,16) or (global tree file)"))))
621;; (monotone-arg-decode 4)
622;; (monotone-arg-decode 'file)
623
624;;(defun monotone-arg-scope (scope filename)
625;; "Turn the SCOPE and FILENAME into and arg for monotone."
626;; (when (numberp scope)
627;; (setq scope (monotone-arg-decode scope)))
628;; (when (bufferp filename)
629;; (setq filename (buffer-file-name filename)))
630;; (cond
631;; ((eq scope 'global) nil)
632;; ((eq scope 'tree) ".")
633;; ((eq scope 'file)
634;; (if filename
635;; (monotone-extract-_MTN-path filename
636;; (t (error "Bad scope: %s" scope))))
637;;;; (monotone-arg-scope 'file (current-buffer))
638
639;; check for common errors and args.
640(defun monotone-cmd-buf (prefix cmds &optional buf)
641 "Run a simple monotone command for this buffer.
642PREFIX selects the scope. CMDS is the command to execute. BUF is
643the buffer if not global."
644 (setq prefix (monotone-arg-decode prefix)) ;; what is the scope?
645 (setq buf (or buf (current-buffer))) ;; default
646 (cond
647 ;; no args
648 ((eq prefix 'global)
649 (monotone-cmd cmds))
650 ;; path/.
651 ((eq prefix 'tree)
652 (let ((path (monotone-extract-_MTN-path
653 (with-current-buffer buf default-directory))))
654 (unless path
655 (error "No directory"))
656 (monotone-cmd (append cmds (list path)))))
657 ;; path/file
658 ((eq prefix 'file)
659 (let ((name (buffer-file-name buf)))
660 (unless name
661 (error "This buffer is not a file"))
662 (setq name (monotone-extract-_MTN-path name))
663 (monotone-cmd (append cmds (list name)))))
664 (t
665 (error "Bad prefix"))))
666
667(defmacro replace-buffer (name)
668 `(let ((buf (get-buffer ,name)))
669 (when buf (kill-buffer buf))
670 (rename-buffer ,name)))
671
672;; runs the command without the buffer.
673;; (let ((bfn (buffer-file-name)))
674;; (when (not bfn)
675;; (error "No file-name for buffer"))
676;; (let* ((monotone-_MTN-top (monotone-find-_MTN-top bfn))
677;; (bmn (monotone-extract-_MTN-path bfn)))
678;;
679
680;; NOTE: The command names are modeled after the vc command names.
681
682(defun monotone-set-log-depth (arg)
683 "Set the max number of entries displayed in log output to ARG."
684 (interactive "NEnter max depth of log entries to report (0=all): ")
685 (setq monotone-log-depth arg))
686;; (monotone-set-log-depth 10)
687
688(defun monotone-vc-print-log (&optional arg)
689 "Print the log for this buffer. With prefix ARG the global log."
690 (interactive "p")
691 ;; MONOTONE BUG: when using "log ." the command must be run in that dir.
692 ;; monotone.el runs its commands in the top dir so
693 ;; just report it for now
694 (when (eq 'tree (monotone-arg-decode arg))
695 (error "monotone subtree log is busted"))
696 ;;
697 (let ((cmds (list "log" "--no-merges"))
698 (depth monotone-log-depth))
699 (when (and (numberp depth) (< 0 depth))
700 (setq cmds (append cmds (list (format "--last=%d" depth)))))
701 (monotone-cmd-buf arg cmds)
702 (replace-buffer "*monotone log*")))
703;; (monotone-vc-print-log)
704
705(defun monotone-vc-diff (&optional arg)
706 "Print the diffs for this buffer. With prefix ARG, the global diffs."
707 (interactive "p")
708 (save-some-buffers)
709 (let* ((what (monotone-arg-decode arg))
710 (target-buffer-name
711 (format "*monotone diff %s*"
712 (cond
713 ((eq what 'file)
714 (monotone-extract-_MTN-path buffer-file-name))
715 (t what)))))
716 (monotone-cmd-buf what '("diff"))
717 (diff-mode)
718 ;; dont duplicate the buffers
719 (replace-buffer target-buffer-name)))
720
721(defun monotone-vc-register ()
722 "Register this file with monotone for the next commit."
723 (interactive)
724 (if buffer-file-name
725 (monotone-cmd-buf 'file '("add") (current-buffer))
726 (error "This buffer does not have a file name")))
727
728(defun monotone-vc-status (&optional arg)
729 "Print the status of the current branch."
730 (interactive "p")
731 (save-some-buffers)
732 (monotone-cmd-buf arg '("status")))
733
734(defun monotone-vc-update-change-log ()
735 "Edit the monotone change log."
736 (interactive)
737 (let ((mtn-top (monotone-find-_MTN-top)))
738 (when (not mtn-top)
739 (error "Unable to find _MTN directory"))
740 (find-file-other-window (concat mtn-top "_MTN/log"))))
741
742;; (monotone-vc-update-change-log)
743
744(defun monotone-cat-revision ()
745 "Display the current revision."
746 (interactive)
747 (monotone-cmd '("cat" "revision")))
748
749;;;;;;;;;;
750
751(defvar monotone-id-regexp "\\([0-9A-Fa-f]\\{40\\}\\)"
752 "A regexp matching a monotone id.")
753
754(defun monotone-id-at-point ()
755 "Return the ID under the point."
756 (save-excursion
757 (skip-chars-backward "0-9A-Fa-f" (- (point) 40))
758 (if (looking-at monotone-id-regexp)
759 (match-string 1)
760 nil)))
761
762(defun monotone-grab-id ()
763 "Grab the id under point and put it in the kill buffer for later use.
764Grab the ids you want from the buffer and then yank back when needed."
765 (interactive)
766 (let ((id (monotone-id-at-point)))
767 (when (not id)
768 (error "Point is not on a monotone id"))
769 (setq monotone-last-id id)
770 (kill-new id)))
771
772(defun monotone-id-at-point-prompt (what defaultid)
773 "Get the id at point. Prompt for WHAT not found, defaulting to DEFAULTID."
774 (let ((id (monotone-id-at-point)))
775 (when (not id)
776 (let ((prompt (capitalize (format "%s: " what))))
777 (setq id (read-string prompt (or defaultid monotone-last-id)))))
778 id))
779;; (monotone-id-at-point-prompt 'file)
780
781(defun monotone-cat-id (what id)
782 "Display the item WHAT which has ID."
783 (when id
784 (let ((what (format "%s" what))
785 (name (format "*monotone %s %s*" what id)))
786 (monotone-cmd (list "cat" what id))
787 ;; remember it
788 (setq monotone-last-id id)
789 ;; dont duplicate the buffers
790 (replace-buffer name))))
791
792(defun monotone-cat-id-pd (what id default)
793 "A helper function."
794 (monotone-cat-id what (or id (monotone-id-at-point-prompt what default))))
795
796(defun monotone-cat-fileid (&optional id)
797 "Display the file with ID."
798 (interactive)
799 (monotone-cat-id-pd 'file id monotone-last-fileid)
800 (setq monotone-last-fileid monotone-last-id))
801
802(defun monotone-cat-manifestid (&optional id)
803 "Display the manifest with ID."
804 (interactive)
805 (monotone-cat-id-pd 'manifest id monotone-last-manifestid)
806 (setq monotone-last-revisionid monotone-last-id))
807
808(defun monotone-cat-revisionid (&optional id)
809 "Display the revision with ID."
810 (interactive)
811 (monotone-cat-id-pd 'revision id monotone-last-revisionid)
812 (setq monotone-last-revisionid monotone-last-id))
813
814;;;;;;;;;;
815
816(defvar monotone-menu
817 (let ((map (make-sparse-keymap "Monotone")))
818 ;; These need to be in reverse order
819 (define-key map [monotone-sync]
820 '(menu-item "DB Sync" monotone-sync))
821 (define-key map [monotone-push]
822 '(menu-item "DB Push" monotone-push))
823 (define-key map [monotone-pull]
824 '(menu-item "DB Pull" monotone-pull))
825 (define-key map [monotone-separator] '("--"))
826 ;;
827 (define-key map [monotone-vc-commit]
828 '(menu-item "Commit" monotone-vc-commit))
829 (define-key map [monotone-separator2] '("--"))
830 ;;
831 (define-key map [monotone-cat-rid]
832 '(menu-item "Cat this revision id" monotone-cat-revisionid))
833 (define-key map [monotone-cat-mid]
834 '(menu-item "Cat this manifest id" monotone-cat-manifestid))
835 (define-key map [monotone-cat-fid]
836 '(menu-item "Cat this file id" monotone-cat-fileid))
837 (define-key map [monotone-separator3] '("--"))
838 ;;
839 (define-key map [monotone-grab-id]
840 '(menu-item "Grab ID" monotone-grab-id))
841 (define-key map [monotone-vc-status]
842 '(menu-item "Status" monotone-vc-status))
843 (define-key map [monotone-vc-diff]
844 '(menu-item "Diff" monotone-vc-diff))
845 (define-key map [monotone-vc-log]
846 '(menu-item "Log" monotone-vc-log))
847 ;;
848 map))
849
850;; People have reported problems with the menu.
851;; dont report an error for now.
852(let ((ok nil))
853 (condition-case nil
854 (progn
855 (when monotone-menu-name
856 (define-key-after
857 (lookup-key global-map [menu-bar])
858 [monotone] (cons monotone-menu-name monotone-menu)))
859 (setq ok t))
860 (error nil))
861 (when (not ok)
862 (message "Menu bar failed to load.")))
863
864(provide 'monotone)
865;;; monotone.el ends here

Archive Download this file

Branches

Tags

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