Backport Bug#6765 fix from trunk.
[emacs.git] / lisp / cvs-status.el
blob1cc9ca9d7135f7c6c2ef050b6c844ec242a611bb
1 ;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8 -*-
3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
7 ;; Keywords: pcl-cvs cvs status tree tools
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 ;;; Commentary:
26 ;; Todo:
28 ;; - Somehow allow cvs-status-tree to work on-the-fly
30 ;;; Code:
32 (eval-when-compile (require 'cl))
33 (require 'pcvs-util)
35 ;;;
37 (defgroup cvs-status nil
38 "Major mode for browsing `cvs status' output."
39 :group 'pcl-cvs
40 :prefix "cvs-status-")
42 (easy-mmode-defmap cvs-status-mode-map
43 '(("n" . next-line)
44 ("p" . previous-line)
45 ("N" . cvs-status-next)
46 ("P" . cvs-status-prev)
47 ("\M-n" . cvs-status-next)
48 ("\M-p" . cvs-status-prev)
49 ("t" . cvs-status-cvstrees)
50 ("T" . cvs-status-trees)
51 (">" . cvs-mode-checkout))
52 "CVS-Status' keymap."
53 :group 'cvs-status
54 :inherit 'cvs-mode-map)
56 ;;(easy-menu-define cvs-status-menu cvs-status-mode-map
57 ;; "Menu for `cvs-status-mode'."
58 ;; '("CVS-Status"
59 ;; ["Show Tag Trees" cvs-status-tree t]
60 ;; ))
62 (defvar cvs-status-mode-hook nil
63 "Hook run at the end of `cvs-status-mode'.")
65 (defconst cvs-status-tags-leader-re "^ Existing Tags:$")
66 (defconst cvs-status-entry-leader-re
67 "^File:\\s-+\\(?:no file \\)?\\(.*\\S-\\)\\s-+Status: \\(.+\\)$")
68 (defconst cvs-status-dir-re "^cvs[.ex]* [a-z]+: Examining \\(.+\\)$")
69 (defconst cvs-status-rev-re "[0-9][.0-9]*\\.[.0-9]*[0-9]")
70 (defconst cvs-status-tag-re "[ \t]\\([a-zA-Z][^ \t\n.]*\\)")
72 (defconst cvs-status-font-lock-keywords
73 `((,cvs-status-entry-leader-re
74 (1 'cvs-filename)
75 (2 'cvs-need-action))
76 (,cvs-status-tags-leader-re
77 (,cvs-status-rev-re
78 (save-excursion (re-search-forward "^\n" nil 'move) (point))
79 (progn (re-search-backward cvs-status-tags-leader-re nil t)
80 (forward-line 1))
81 (0 font-lock-comment-face))
82 (,cvs-status-tag-re
83 (save-excursion (re-search-forward "^\n" nil 'move) (point))
84 (progn (re-search-backward cvs-status-tags-leader-re nil t)
85 (forward-line 1))
86 (1 font-lock-function-name-face)))))
87 (defconst cvs-status-font-lock-defaults
88 '(cvs-status-font-lock-keywords t nil nil nil (font-lock-multiline . t)))
90 (defvar cvs-minor-wrap-function)
91 (put 'cvs-status-mode 'mode-class 'special)
92 ;;;###autoload
93 (define-derived-mode cvs-status-mode fundamental-mode "CVS-Status"
94 "Mode used for cvs status output."
95 (set (make-local-variable 'font-lock-defaults) cvs-status-font-lock-defaults)
96 (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-status-minor-wrap))
98 ;; Define cvs-status-next and cvs-status-prev
99 (easy-mmode-define-navigation cvs-status cvs-status-entry-leader-re "entry")
101 (defun cvs-status-current-file ()
102 (save-excursion
103 (forward-line 1)
104 (or (re-search-backward cvs-status-entry-leader-re nil t)
105 (re-search-forward cvs-status-entry-leader-re))
106 (let* ((file (match-string 1))
107 (cvsdir (and (re-search-backward cvs-status-dir-re nil t)
108 (match-string 1)))
109 (pcldir (and (if (boundp 'cvs-pcl-cvs-dirchange-re)
110 (re-search-backward cvs-pcl-cvs-dirchange-re nil t))
111 (match-string 1)))
112 (dir ""))
113 (let ((default-directory ""))
114 (when pcldir (setq dir (expand-file-name pcldir dir)))
115 (when cvsdir (setq dir (expand-file-name cvsdir dir)))
116 (expand-file-name file dir)))))
118 (defun cvs-status-current-tag ()
119 (save-excursion
120 (let ((pt (point))
121 (col (current-column))
122 (start (progn (re-search-backward cvs-status-tags-leader-re nil t) (point)))
123 (end (progn (re-search-forward "^$" nil t) (point))))
124 (when (and (< start pt) (> end pt))
125 (goto-char pt)
126 (end-of-line)
127 (let ((tag nil) (dist pt) (end (point)))
128 (beginning-of-line)
129 (while (re-search-forward cvs-status-tag-re end t)
130 (let* ((cole (current-column))
131 (colb (save-excursion
132 (goto-char (match-beginning 1)) (current-column)))
133 (ndist (min (abs (- cole col)) (abs (- colb col)))))
134 (when (< ndist dist)
135 (setq dist ndist)
136 (setq tag (match-string 1)))))
137 tag)))))
139 (defun cvs-status-minor-wrap (buf f)
140 (let ((data (with-current-buffer buf
141 (cons
142 (cons (cvs-status-current-file)
143 (cvs-status-current-tag))
144 (when mark-active
145 (save-excursion
146 (goto-char (mark))
147 (cons (cvs-status-current-file)
148 (cvs-status-current-tag))))))))
149 (let ((cvs-branch-prefix (cdar data))
150 (cvs-secondary-branch-prefix (and (cdar data) (cddr data)))
151 (cvs-minor-current-files
152 (cons (caar data)
153 (when (and (cadr data) (not (equal (caar data) (cadr data))))
154 (list (cadr data)))))
155 ;; FIXME: I need to force because the fileinfos are UNKNOWN
156 (cvs-force-command "/F"))
157 (funcall f))))
160 ;; Tagelt, tag element
163 (defstruct (cvs-tag
164 (:constructor nil)
165 (:constructor cvs-tag-make
166 (vlist &optional name type))
167 (:conc-name cvs-tag->))
168 vlist
169 name
170 type)
172 (defsubst cvs-status-vl-to-str (vl) (mapconcat 'number-to-string vl "."))
174 (defun cvs-tag->string (tag)
175 (if (stringp tag) tag
176 (let ((name (cvs-tag->name tag))
177 (vl (cvs-tag->vlist tag)))
178 (if (null name) (cvs-status-vl-to-str vl)
179 (let ((rev (if vl (concat " (" (cvs-status-vl-to-str vl) ")") "")))
180 (if (consp name) (mapcar (lambda (name) (concat name rev)) name)
181 (concat name rev)))))))
183 (defun cvs-tag-compare-1 (vl1 vl2)
184 (cond
185 ((and (null vl1) (null vl2)) 'equal)
186 ((null vl1) 'more2)
187 ((null vl2) 'more1)
188 (t (let ((v1 (car vl1))
189 (v2 (car vl2)))
190 (cond
191 ((> v1 v2) 'more1)
192 ((< v1 v2) 'more2)
193 (t (cvs-tag-compare-1 (cdr vl1) (cdr vl2))))))))
195 (defsubst cvs-tag-compare (tag1 tag2)
196 (cvs-tag-compare-1 (cvs-tag->vlist tag1) (cvs-tag->vlist tag2)))
198 (defun cvs-tag-merge (tag1 tag2)
199 "Merge TAG1 and TAG2 into one."
200 (let ((type1 (cvs-tag->type tag1))
201 (type2 (cvs-tag->type tag2))
202 (name1 (cvs-tag->name tag1))
203 (name2 (cvs-tag->name tag2)))
204 (unless (equal (cvs-tag->vlist tag1) (cvs-tag->vlist tag2))
205 (setf (cvs-tag->vlist tag1) nil))
206 (if type1
207 (unless (or (not type2) (equal type1 type2))
208 (setf (cvs-tag->type tag1) nil))
209 (setf (cvs-tag->type tag1) type2))
210 (if name1
211 (setf (cvs-tag->name tag1) (cvs-append name1 name2))
212 (setf (cvs-tag->name tag1) name2))
213 tag1))
215 (defun cvs-tree-print (tags printer column)
216 "Print the tree of TAGS where each tag's string is given by PRINTER.
217 PRINTER should accept both a tag (in which case it should return a string)
218 or a string (in which case it should simply return its argument).
219 A tag cannot be a CONS. The return value can also be a list of strings,
220 if several nodes where merged into one.
221 The tree will be printed no closer than column COLUMN."
223 (let* ((eol (save-excursion (end-of-line) (current-column)))
224 (column (max (+ eol 2) column)))
225 (if (null tags) column
226 ;;(move-to-column-force column)
227 (let* ((rev (cvs-car tags))
228 (name (funcall printer (cvs-car rev)))
229 (rest (append (cvs-cdr name) (cvs-cdr tags)))
230 (prefix
231 (save-excursion
232 (or (= (forward-line 1) 0) (insert "\n"))
233 (cvs-tree-print rest printer column))))
234 (assert (>= prefix column))
235 (move-to-column prefix t)
236 (assert (eolp))
237 (insert (cvs-car name))
238 (dolist (br (cvs-cdr rev))
239 (let* ((column (current-column))
240 (brrev (funcall printer (cvs-car br)))
241 (brlength (length (cvs-car brrev)))
242 (brfill (concat (make-string (/ brlength 2) ? ) "|"))
243 (prefix
244 (save-excursion
245 (insert " -- ")
246 (cvs-tree-print (cvs-append brrev brfill (cvs-cdr br))
247 printer (current-column)))))
248 (delete-region (save-excursion (move-to-column prefix) (point))
249 (point))
250 (insert " " (make-string (- prefix column 2) ?-) " ")
251 (end-of-line)))
252 prefix))))
254 (defun cvs-tree-merge (tree1 tree2)
255 "Merge tags trees TREE1 and TREE2 into one.
256 BEWARE: because of stability issues, this is not a symetric operation."
257 (assert (and (listp tree1) (listp tree2)))
258 (cond
259 ((null tree1) tree2)
260 ((null tree2) tree1)
262 (let* ((rev1 (car tree1))
263 (tag1 (cvs-car rev1))
264 (vl1 (cvs-tag->vlist tag1))
265 (l1 (length vl1))
266 (rev2 (car tree2))
267 (tag2 (cvs-car rev2))
268 (vl2 (cvs-tag->vlist tag2))
269 (l2 (length vl2)))
270 (cond
271 ((= l1 l2)
272 (case (cvs-tag-compare tag1 tag2)
273 (more1 (list* rev2 (cvs-tree-merge tree1 (cdr tree2))))
274 (more2 (list* rev1 (cvs-tree-merge (cdr tree1) tree2)))
275 (equal
276 (cons (cons (cvs-tag-merge tag1 tag2)
277 (cvs-tree-merge (cvs-cdr rev1) (cvs-cdr rev2)))
278 (cvs-tree-merge (cdr tree1) (cdr tree2))))))
279 ((> l1 l2)
280 (cvs-tree-merge
281 (list (cons (cvs-tag-make (butlast vl1)) tree1)) tree2))
282 ((< l1 l2)
283 (cvs-tree-merge
284 tree1 (list (cons (cvs-tag-make (butlast vl2)) tree2)))))))))
286 (defun cvs-tag-make-tag (tag)
287 (let ((vl (mapcar 'string-to-number (split-string (nth 2 tag) "\\."))))
288 (cvs-tag-make vl (nth 0 tag) (intern (nth 1 tag)))))
290 (defun cvs-tags->tree (tags)
291 "Make a tree out of a list of TAGS."
292 (let ((tags
293 (mapcar
294 (lambda (tag)
295 (let ((tag (cvs-tag-make-tag tag)))
296 (list (if (not (eq (cvs-tag->type tag) 'branch)) tag
297 (list (cvs-tag-make (butlast (cvs-tag->vlist tag)))
298 tag)))))
299 tags)))
300 (while (cdr tags)
301 (let (tl)
302 (while tags
303 (push (cvs-tree-merge (pop tags) (pop tags)) tl))
304 (setq tags (nreverse tl))))
305 (car tags)))
307 (defun cvs-status-get-tags ()
308 "Look for a list of tags, read them in and delete them.
309 Return nil if there was an empty list of tags and t if there wasn't
310 even a list. Else, return the list of tags where each element of
311 the list is a three-string list TAG, KIND, REV."
312 (let ((tags nil))
313 (if (not (re-search-forward cvs-status-tags-leader-re nil t)) t
314 (forward-char 1)
315 (let ((pt (point))
316 (lastrev nil)
317 (case-fold-search t))
319 (looking-at "\\s-+no\\s-+tags")
321 (progn ; normal listing
322 (while (looking-at "^[ \t]+\\([^ \t\n]+\\)[ \t]+(\\([a-z]+\\): \\(.+\\))$")
323 (push (list (match-string 1) (match-string 2) (match-string 3)) tags)
324 (forward-line 1))
325 (unless (looking-at "^$") (setq tags nil) (goto-char pt))
326 tags)
328 (progn ; cvstree-style listing
329 (while (or (looking-at "^ .+\\(.\\) \\([0-9.]+\\): \\([^\n\t .0-9][^\n\t ]*\\)?$")
330 (and lastrev
331 (looking-at "^ .+\\(\\) \\(8\\)? \\([^\n\t .0-9][^\n\t ]*\\)$")))
332 (setq lastrev (or (match-string 2) lastrev))
333 (push (list (match-string 3)
334 (if (equal (match-string 1) " ") "branch" "revision")
335 lastrev) tags)
336 (forward-line 1))
337 (unless (looking-at "^$") (setq tags nil) (goto-char pt))
338 (setq tags (nreverse tags)))
340 (progn ; new tree style listing
341 (let* ((re-lead "[ \t]*\\(-+\\)?\\(|\n?[ \t]+\\)*")
342 (re3 (concat re-lead "\\(\\.\\)?\\(" cvs-status-rev-re "\\)"))
343 (re2 (concat re-lead cvs-status-tag-re "\\(\\)"))
344 (re1 (concat re-lead cvs-status-tag-re
345 " (\\(" cvs-status-rev-re "\\))")))
346 (while (or (looking-at re1) (looking-at re2) (looking-at re3))
347 (push (list (match-string 3)
348 (if (match-string 1) "branch" "revision")
349 (match-string 4)) tags)
350 (goto-char (match-end 0))
351 (when (eolp) (forward-char 1))))
352 (unless (looking-at "^$") (setq tags nil) (goto-char pt))
353 (setq tags (nreverse tags))))
355 (delete-region pt (point)))
356 tags)))
358 (defvar font-lock-mode)
359 (defun cvs-refontify (beg end)
360 (when (and (boundp 'font-lock-mode)
361 font-lock-mode
362 (fboundp 'font-lock-fontify-region))
363 (font-lock-fontify-region (1- beg) (1+ end))))
365 (defun cvs-status-trees ()
366 "Look for a lists of tags, and replace them with trees."
367 (interactive)
368 (save-excursion
369 (goto-char (point-min))
370 (let ((inhibit-read-only t)
371 (tags nil))
372 (while (listp (setq tags (cvs-status-get-tags)))
373 ;;(let ((pt (save-excursion (forward-line -1) (point))))
374 (save-restriction
375 (narrow-to-region (point) (point))
376 ;;(newline)
377 (combine-after-change-calls
378 (cvs-tree-print (cvs-tags->tree tags) 'cvs-tag->string 3)))
379 ;;(cvs-refontify pt (point))
380 ;;(sit-for 0)
382 ))))
384 ;;;;
385 ;;;; CVSTree-style trees
386 ;;;;
388 (defvar cvs-tree-use-jisx0208 nil) ;Old compat var.
389 (defvar cvs-tree-use-charset
390 (cond
391 (cvs-tree-use-jisx0208 'jisx0208)
392 ((char-displayable-p ?━) 'unicode)
393 ((char-displayable-p (make-char 'japanese-jisx0208 40 44)) 'jisx0208))
394 "*Non-nil if we should use the graphical glyphs from `japanese-jisx0208'.
395 Otherwise, default to ASCII chars like +, - and |.")
397 (defconst cvs-tree-char-space
398 (case cvs-tree-use-charset
399 (jisx0208 (make-char 'japanese-jisx0208 33 33))
400 (unicode " ")
401 (t " ")))
402 (defconst cvs-tree-char-hbar
403 (case cvs-tree-use-charset
404 (jisx0208 (make-char 'japanese-jisx0208 40 44))
405 (unicode "━")
406 (t "--")))
407 (defconst cvs-tree-char-vbar
408 (case cvs-tree-use-charset
409 (jisx0208 (make-char 'japanese-jisx0208 40 45))
410 (unicode "┃")
411 (t "| ")))
412 (defconst cvs-tree-char-branch
413 (case cvs-tree-use-charset
414 (jisx0208 (make-char 'japanese-jisx0208 40 50))
415 (unicode "┣")
416 (t "+-")))
417 (defconst cvs-tree-char-eob ;end of branch
418 (case cvs-tree-use-charset
419 (jisx0208 (make-char 'japanese-jisx0208 40 49))
420 (unicode "┗")
421 (t "`-")))
422 (defconst cvs-tree-char-bob ;beginning of branch
423 (case cvs-tree-use-charset
424 (jisx0208 (make-char 'japanese-jisx0208 40 51))
425 (unicode "┳")
426 (t "+-")))
428 (defun cvs-tag-lessp (tag1 tag2)
429 (eq (cvs-tag-compare tag1 tag2) 'more2))
431 (defvar cvs-tree-nomerge nil)
433 (defun cvs-status-cvstrees (&optional arg)
434 "Look for a list of tags, and replace it with a tree.
435 Optional prefix ARG chooses between two representations."
436 (interactive "P")
437 (when (and cvs-tree-use-charset
438 (not enable-multibyte-characters))
439 ;; We need to convert the buffer from unibyte to multibyte
440 ;; since we'll use multibyte chars for the tree.
441 (let ((modified (buffer-modified-p))
442 (inhibit-read-only t)
443 (inhibit-modification-hooks t))
444 (unwind-protect
445 (progn
446 (decode-coding-region (point-min) (point-max) 'undecided)
447 (set-buffer-multibyte t))
448 (restore-buffer-modified-p modified))))
449 (save-excursion
450 (goto-char (point-min))
451 (let ((inhibit-read-only t)
452 (tags nil)
453 (cvs-tree-nomerge (if arg (not cvs-tree-nomerge) cvs-tree-nomerge)))
454 (while (listp (setq tags (cvs-status-get-tags)))
455 (let ((tags (mapcar 'cvs-tag-make-tag tags))
456 ;;(pt (save-excursion (forward-line -1) (point)))
458 (setq tags (sort tags 'cvs-tag-lessp))
459 (let* ((first (car tags))
460 (prev (if (cvs-tag-p first)
461 (list (car (cvs-tag->vlist first))) nil)))
462 (combine-after-change-calls
463 (cvs-tree-tags-insert tags prev))
464 ;;(cvs-refontify pt (point))
465 ;;(sit-for 0)
466 ))))))
468 (defun cvs-tree-tags-insert (tags prev)
469 (when tags
470 (let* ((tag (car tags))
471 (vlist (cvs-tag->vlist tag))
472 (nprev ;"next prev"
473 (let* ((next (cvs-car (cadr tags)))
474 (nprev (if (and cvs-tree-nomerge next
475 (equal vlist (cvs-tag->vlist next)))
476 prev vlist)))
477 (cvs-map (lambda (v p) v) nprev prev)))
478 (after (save-excursion
479 (newline)
480 (cvs-tree-tags-insert (cdr tags) nprev)))
481 (pe t) ;"prev equal"
482 (nas nil)) ;"next afters" to be returned
483 (insert " ")
484 (do* ((vs vlist (cdr vs))
485 (ps prev (cdr ps))
486 (as after (cdr as)))
487 ((and (null as) (null vs) (null ps))
488 (let ((revname (cvs-status-vl-to-str vlist)))
489 (if (cvs-every 'identity (cvs-map 'equal prev vlist))
490 (insert (make-string (+ 4 (length revname)) ? )
491 (or (cvs-tag->name tag) ""))
492 (insert " " revname ": " (or (cvs-tag->name tag) "")))))
493 (let* ((eq (and pe (equal (car ps) (car vs))))
494 (next-eq (equal (cadr ps) (cadr vs))))
495 (let* ((na+char
496 (if (car as)
497 (if eq
498 (if next-eq (cons t cvs-tree-char-vbar)
499 (cons t cvs-tree-char-branch))
500 (cons nil cvs-tree-char-bob))
501 (if eq
502 (if next-eq (cons nil cvs-tree-char-space)
503 (cons t cvs-tree-char-eob))
504 (cons nil (if (and (eq (cvs-tag->type tag) 'branch)
505 (cvs-every 'null as))
506 cvs-tree-char-space
507 cvs-tree-char-hbar))))))
508 (insert (cdr na+char))
509 (push (car na+char) nas))
510 (setq pe eq)))
511 (nreverse nas))))
513 ;;;;
514 ;;;; Merged trees from different files
515 ;;;;
517 (defun cvs-tree-fuzzy-merge-1 (trees tree prev)
520 (defun cvs-tree-fuzzy-merge (trees tree)
521 "Do the impossible: merge TREE into TREES."
524 (defun cvs-tree ()
525 "Get tags from the status output and merge tham all into a big tree."
526 (save-excursion
527 (goto-char (point-min))
528 (let ((inhibit-read-only t)
529 (trees (make-vector 31 0)) tree)
530 (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags))))
531 (cvs-tree-fuzzy-merge trees tree))
532 (erase-buffer)
533 (let ((cvs-tag-print-rev nil))
534 (cvs-tree-print tree 'cvs-tag->string 3)))))
537 (provide 'cvs-status)
539 ;; arch-tag: db8b5094-d02a-473e-a476-544e89ff5ad0
540 ;;; cvs-status.el ends here