← Back to branch summary

~mathrick/dvc/trunk

« back to all changes in this revision

Viewing changes to lisp/xmtn-revlist.el

  • Committer: Stefan Reichoer
  • Date: 2009-11-11 21:29:58 UTC
  • Revision ID: stefan@xsteve.at-20091111212958-kq3uuk87ymkfmcre
Patch from Thierry Volpiatto: xhg.el:Improve xhg-convert, with prefix arg prompt for revision number.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lisp/xmtn-revlist.el
1
1
;;; xmtn-revlist.el --- Interactive display of revision histories for monotone
2
2
 
3
 
;; Copyright (C) 2008 Stephen Leake
 
3
;; Copyright (C) 2008, 2009 Stephen Leake
4
4
;; Copyright (C) 2006, 2007 Christian M. Ohler
5
5
 
6
6
;; Author: Christian M. Ohler
334
334
         ,(format "Base   %s" base-revision-hash-id)
335
335
         ,(case (length heads)
336
336
            (1 "branch is merged")
337
 
            (t "branch is not merged"))
 
337
            (t (dvc-face-add (format "branch has %s heads; need merge" (length heads)) 'dvc-conflict)))
338
338
         nil
339
339
         ,(case (length difference)
340
340
            (0 "No revisions that are not in base revision")
345
345
       '()
346
346
       difference))))
347
347
 
 
348
(defun xmtn-revlist-show-conflicts ()
 
349
  "If point is on a revision that has two parents, show conflicts
 
350
from the merge."
 
351
  ;; IMPROVEME: We just use the xmtn conflicts machinery for now. It
 
352
  ;; would be better if we had a read-only version of it.
 
353
  (interactive)
 
354
  (let ((changelog (car (xmtn--revlist-entry-changelogs (dvc-revlist-entry-patch-struct (dvc-revlist-current-patch)))))
 
355
        start end left-branch left-rev right-branch right-rev)
 
356
    ;; string-match does _not_ set up match-strings properly, so we do this instead
 
357
    (cond
 
358
     ((string= (substring changelog 0 9) "propagate")
 
359
      (setq start (+ 1 (string-match "'" changelog)))
 
360
      (setq end (string-match "'" changelog start))
 
361
      (setq left-branch (substring changelog start end))
 
362
 
 
363
      (setq start (+ 6 (string-match "(head" changelog end)))
 
364
      (setq end (string-match ")" changelog start))
 
365
      (setq left-rev (substring changelog start end))
 
366
 
 
367
      (setq start (+ 1 (string-match "'" changelog end)))
 
368
      (setq end (string-match "'" changelog start))
 
369
      (setq right-branch (substring changelog start end))
 
370
 
 
371
      (setq start (+ 6 (string-match "(head .*)" changelog end)))
 
372
      (setq end (string-match ")" changelog start))
 
373
      (setq right-rev (substring changelog start end)))
 
374
 
 
375
 
 
376
     ((string= (substring changelog 0 5) "merge")
 
377
      (setq start (+ 4 (string-match "of" changelog)))
 
378
      (setq end (string-match "'" changelog start))
 
379
      (setq left-rev (substring changelog start (1- end)))
 
380
 
 
381
      (setq start (+ 5 (string-match "and" changelog start)))
 
382
      (setq end (string-match "'" changelog start))
 
383
      (setq right-rev (substring changelog start (1- end))))
 
384
 
 
385
     (t
 
386
      (error "not on a two parent revision")))
 
387
 
 
388
    (xmtn-conflicts-save-opts
 
389
     (read-file-name "left work: ")
 
390
     (read-file-name "right work: ")
 
391
     left-branch
 
392
     right-branch)
 
393
 
 
394
    (dvc-run-dvc-async
 
395
     'xmtn
 
396
     (list "conflicts" "store" left-rev right-rev)
 
397
     :finished (lambda (output error status arguments)
 
398
                 (let ((conflicts-buffer (dvc-get-buffer-create 'xmtn 'conflicts default-directory)))
 
399
                   (pop-to-buffer conflicts-buffer)
 
400
                   (xmtn-conflicts-load-opts)
 
401
                   (set (make-local-variable 'after-insert-file-functions) '(xmtn-conflicts-after-insert-file))
 
402
                   (insert-file-contents "_MTN/conflicts" t)))
 
403
 
 
404
     :error (lambda (output error status arguments)
 
405
              (pop-to-buffer error)))))
 
406
 
348
407
;;;###autoload
349
408
(defvar xmtn-revlist-mode-map
350
409
  (let ((map (make-sparse-keymap)))
354
413
    (define-key map "CC" 'xmtn-conflicts-clean)
355
414
    (define-key map "MH" 'xmtn-view-heads-revlist)
356
415
    (define-key map "MP" 'xmtn-propagate-from)
 
416
    (define-key map "MC" 'xmtn-revlist-show-conflicts)
357
417
    map))
358
418
 
359
419
;; items added here should probably also be added to xmtn-diff-mode-menu, -map in xmtn-dvc.el
361
421
  "Mtn specific revlist menu."
362
422
  `("DVC-Mtn"
363
423
    ["View Heads"       xmtn-view-heads-revlist t]
364
 
    ["Show merge conflicts" xmtn-conflicts-merge t]
 
424
    ["Show merge conflicts before merge" xmtn-conflicts-merge t]
 
425
    ["Show merge conflicts after merge" xmtn-revlist-show-conflicts t]
365
426
    ["Show propagate conflicts" xmtn-conflicts-propagate t]
366
427
    ["Review conflicts" xmtn-conflicts-review t]
367
428
    ["Propagate branch" xmtn-propagate-from t]
380
441
    (xmtn--setup-revlist
381
442
     root
382
443
     'xmtn--revlist--missing-get-info
383
 
     ;; Passing nil as first-line-only-p, last-n is arbitrary here.
384
 
     nil nil))
 
444
     ;; Passing nil as first-line-only-p is arbitrary here.
 
445
     ;;
 
446
     ;; When the missing revs are due to a propagate, there can be a
 
447
     ;; lot of them, but we only really need to see the revs since the
 
448
     ;; propagate. So dvc-log-last-n is appropriate. We use
 
449
     ;; dvc-log-last-n, not dvc-revlist-last-n, because -log is user
 
450
     ;; customizable.
 
451
     nil dvc-log-last-n))
385
452
  nil)
386
453
 
387
454
;;;###autoload
549
616
  (let* ((root (dvc-tree-root))
550
617
         (entry (dvc-revlist-current-patch-struct))
551
618
         (target-hash-id (xmtn--revlist-entry-revision-hash-id entry)))
552
 
    (xmtn--update-after-confirmation root target-hash-id)))
 
619
    (xmtn--update root target-hash-id nil nil)))
553
620
 
554
621
;; Being able to conveniently disapprove whole batches of revisions
555
622
;; is going to be a lot of fun.