(perl-mode): Don't gratuitously override the default for comment-column.
[emacs.git] / lisp / cvs-status.el
blobbed3b6185208f24ec67ab31c0a12b610c5baa47d
1 ;;; cvs-status.el --- Major mode for browsing `cvs status' output
3 ;; Copyright (C) 1999-2000 Free Software Foundation, Inc.
5 ;; Author: Stefan Monnier <monnier@cs.yale.edu>
6 ;; Keywords: pcl-cvs cvs status tree
7 ;; Version: $Name: $
8 ;; Revision: $Id: cvs-status.el,v 1.6 2000/08/16 20:46:32 monnier Exp $
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version.
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
27 ;;; Commentary:
29 ;; Todo:
31 ;; - Rename to cvs-status-mode.el
32 ;; - Somehow allow cvs-status-tree to work on-the-fly
34 ;;; Code:
36 (eval-when-compile (require 'cl))
37 (require 'pcvs-util)
39 ;;;
41 (defgroup cvs-status nil
42 "Major mode for browsing `cvs status' output."
43 :group 'pcl-cvs
44 :prefix "cvs-status-")
46 (easy-mmode-defmap cvs-status-mode-map
47 '(("n" . next-line)
48 ("p" . previous-line)
49 ("N" . cvs-status-next)
50 ("P" . cvs-status-prev)
51 ("\M-n" . cvs-status-next)
52 ("\M-p" . cvs-status-prev)
53 ("t" . cvs-status-cvstrees)
54 ("T" . cvs-status-trees))
55 "CVS-Status' keymap."
56 :group 'cvs-status
57 :inherit 'cvs-mode-map)
59 ;;(easy-menu-define cvs-status-menu cvs-status-mode-map
60 ;; "Menu for `cvs-status-mode'."
61 ;; '("CVS-Status"
62 ;; ["Show Tag Trees" cvs-status-tree t]
63 ;; ))
65 (defvar cvs-status-mode-hook nil
66 "Hook run at the end of `cvs-status-mode'.")
68 (defconst cvs-status-tags-leader-re "^ Existing Tags:$")
69 (defconst cvs-status-entry-leader-re
70 "^File:\\s-+\\(?:no file \\)?\\(.*\\S-\\)\\s-+Status: \\(.+\\)$")
71 (defconst cvs-status-dir-re "^cvs[.ex]* [a-z]+: Examining \\(.+\\)$")
72 (defconst cvs-status-rev-re "[0-9][.0-9]*\\.[.0-9]*[0-9]")
73 (defconst cvs-status-tag-re "[ \t]\\([a-zA-Z][^ \t\n.]*\\)")
75 (defconst cvs-status-font-lock-keywords
76 `((,cvs-status-entry-leader-re
77 (1 'cvs-filename-face)
78 (2 'cvs-need-action-face))
79 (,cvs-status-tags-leader-re
80 (,cvs-status-rev-re
81 (save-excursion (re-search-forward "^\n" nil 'move) (point))
82 (progn (re-search-backward cvs-status-tags-leader-re nil t)
83 (forward-line 1))
84 (0 font-lock-comment-face))
85 (,cvs-status-tag-re
86 (save-excursion (re-search-forward "^\n" nil 'move) (point))
87 (progn (re-search-backward cvs-status-tags-leader-re nil t)
88 (forward-line 1))
89 (1 font-lock-function-name-face)))))
90 (defconst cvs-status-font-lock-defaults
91 '(cvs-status-font-lock-keywords t nil nil nil))
94 (put 'cvs-status-mode 'mode-class 'special)
95 ;;;###autoload
96 (define-derived-mode cvs-status-mode fundamental-mode "CVS-Status"
97 "Mode used for cvs status output."
98 (set (make-local-variable 'font-lock-defaults) cvs-status-font-lock-defaults)
99 (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-status-minor-wrap))
101 ;; Define cvs-status-next and cvs-status-prev
102 (easy-mmode-define-navigation cvs-status cvs-status-entry-leader-re "entry")
104 (defun cvs-status-current-file ()
105 (save-excursion
106 (forward-line 1)
107 (or (re-search-backward cvs-status-entry-leader-re nil t)
108 (re-search-forward cvs-status-entry-leader-re))
109 (let* ((file (match-string 1))
110 (cvsdir (and (re-search-backward cvs-status-dir-re nil t)
111 (match-string 1)))
112 (pcldir (and (re-search-backward cvs-pcl-cvs-dirchange-re nil t)
113 (match-string 1)))
114 (dir ""))
115 (let ((default-directory ""))
116 (when pcldir (setq dir (expand-file-name pcldir dir)))
117 (when cvsdir (setq dir (expand-file-name cvsdir dir)))
118 (expand-file-name file dir)))))
120 (defun cvs-status-current-tag ()
121 (save-excursion
122 (let ((pt (point))
123 (col (current-column))
124 (start (progn (re-search-backward cvs-status-tags-leader-re nil t) (point)))
125 (end (progn (re-search-forward "^$" nil t) (point))))
126 (when (and (< start pt) (> end pt))
127 (goto-char pt)
128 (end-of-line)
129 (let ((tag nil) (dist pt) (end (point)))
130 (beginning-of-line)
131 (while (re-search-forward cvs-status-tag-re end t)
132 (let* ((cole (current-column))
133 (colb (save-excursion
134 (goto-char (match-beginning 1)) (current-column)))
135 (ndist (min (abs (- cole col)) (abs (- colb col)))))
136 (when (< ndist dist)
137 (setq dist ndist)
138 (setq tag (match-string 1)))))
139 tag)))))
141 (defun cvs-status-minor-wrap (buf f)
142 (let ((data (with-current-buffer buf
143 (cons
144 (cons (cvs-status-current-file)
145 (cvs-status-current-tag))
146 (when mark-active
147 (save-excursion
148 (goto-char (mark))
149 (cons (cvs-status-current-file)
150 (cvs-status-current-tag))))))))
151 (let ((cvs-branch-prefix (cdar data))
152 (cvs-secondary-branch-prefix (and (cdar data) (cddr data)))
153 (cvs-minor-current-files
154 (cons (caar data)
155 (when (and (cadr data) (not (equal (caar data) (cadr data))))
156 (list (cadr data)))))
157 ;; FIXME: I need to force because the fileinfos are UNKNOWN
158 (cvs-force-command "/F"))
159 (funcall f))))
162 ;; Tagelt, tag element
165 (defstruct (cvs-tag
166 (:constructor nil)
167 (:constructor cvs-tag-make
168 (vlist &optional name type))
169 (:conc-name cvs-tag->))
170 vlist
171 name
172 type)
174 (defsubst cvs-status-vl-to-str (vl) (mapconcat 'number-to-string vl "."))
176 (defun cvs-tag->string (tag)
177 (if (stringp tag) tag
178 (let ((name (cvs-tag->name tag))
179 (vl (cvs-tag->vlist tag)))
180 (if (null name) (cvs-status-vl-to-str vl)
181 (let ((rev (if vl (concat " (" (cvs-status-vl-to-str vl) ")") "")))
182 (if (consp name) (mapcar (lambda (name) (concat name rev)) name)
183 (concat name rev)))))))
185 (defun cvs-tag-compare-1 (vl1 vl2)
186 (cond
187 ((and (null vl1) (null vl2)) 'equal)
188 ((null vl1) 'more2)
189 ((null vl2) 'more1)
190 (t (let ((v1 (car vl1))
191 (v2 (car vl2)))
192 (cond
193 ((> v1 v2) 'more1)
194 ((< v1 v2) 'more2)
195 (t (cvs-tag-compare-1 (cdr vl1) (cdr vl2))))))))
197 (defsubst cvs-tag-compare (tag1 tag2)
198 (cvs-tag-compare-1 (cvs-tag->vlist tag1) (cvs-tag->vlist tag2)))
200 (defun cvs-tag-merge (tag1 tag2)
201 "Merge TAG1 and TAG2 into one."
202 (let ((type1 (cvs-tag->type tag1))
203 (type2 (cvs-tag->type tag2))
204 (name1 (cvs-tag->name tag1))
205 (name2 (cvs-tag->name tag2)))
206 (unless (equal (cvs-tag->vlist tag1) (cvs-tag->vlist tag2))
207 (setf (cvs-tag->vlist tag1) nil))
208 (if type1
209 (unless (or (not type2) (equal type1 type2))
210 (setf (cvs-tag->type tag1) nil))
211 (setf (cvs-tag->type tag1) type2))
212 (if name1
213 (setf (cvs-tag->name tag1) (cvs-append name1 name2))
214 (setf (cvs-tag->name tag1) name2))
215 tag1))
217 (defun cvs-tree-print (tags printer column)
218 "Print the tree of TAGS where each tag's string is given by PRINTER.
219 PRINTER should accept both a tag (in which case it should return a string)
220 or a string (in which case it should simply return its argument).
221 A tag cannot be a CONS. The return value can also be a list of strings,
222 if several nodes where merged into one.
223 The tree will be printed no closer than column COLUMN."
225 (let* ((eol (save-excursion (end-of-line) (current-column)))
226 (column (max (+ eol 2) column)))
227 (if (null tags) column
228 ;;(move-to-column-force column)
229 (let* ((rev (cvs-car tags))
230 (name (funcall printer (cvs-car rev)))
231 (rest (append (cvs-cdr name) (cvs-cdr tags)))
232 (prefix
233 (save-excursion
234 (or (= (forward-line 1) 0) (insert "\n"))
235 (cvs-tree-print rest printer column))))
236 (assert (>= prefix column))
237 (move-to-column prefix t)
238 (assert (eolp))
239 (insert (cvs-car name))
240 (dolist (br (cvs-cdr rev))
241 (let* ((column (current-column))
242 (brrev (funcall printer (cvs-car br)))
243 (brlength (length (cvs-car brrev)))
244 (brfill (concat (make-string (/ brlength 2) ? ) "|"))
245 (prefix
246 (save-excursion
247 (insert " -- ")
248 (cvs-tree-print (cvs-append brrev brfill (cvs-cdr br))
249 printer (current-column)))))
250 (delete-region (save-excursion (move-to-column prefix) (point))
251 (point))
252 (insert " " (make-string (- prefix column 2) ?-) " ")
253 (end-of-line)))
254 prefix))))
256 (defun cvs-tree-merge (tree1 tree2)
257 "Merge tags trees TREE1 and TREE2 into one.
258 BEWARE: because of stability issues, this is not a symetric operation."
259 (assert (and (listp tree1) (listp tree2)))
260 (cond
261 ((null tree1) tree2)
262 ((null tree2) tree1)
264 (let* ((rev1 (car tree1))
265 (tag1 (cvs-car rev1))
266 (vl1 (cvs-tag->vlist tag1))
267 (l1 (length vl1))
268 (rev2 (car tree2))
269 (tag2 (cvs-car rev2))
270 (vl2 (cvs-tag->vlist tag2))
271 (l2 (length vl2)))
272 (cond
273 ((= l1 l2)
274 (case (cvs-tag-compare tag1 tag2)
275 (more1 (list* rev2 (cvs-tree-merge tree1 (cdr tree2))))
276 (more2 (list* rev1 (cvs-tree-merge (cdr tree1) tree2)))
277 (equal
278 (cons (cons (cvs-tag-merge tag1 tag2)
279 (cvs-tree-merge (cvs-cdr rev1) (cvs-cdr rev2)))
280 (cvs-tree-merge (cdr tree1) (cdr tree2))))))
281 ((> l1 l2)
282 (cvs-tree-merge (list (cons (cvs-tag-make (butlast vl1)) tree1)) tree2))
283 ((< l1 l2)
284 (cvs-tree-merge 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 (lambda (tag)
294 (let ((tag (cvs-tag-make-tag tag)))
295 (list (if (not (eq (cvs-tag->type tag) 'branch)) tag
296 (list (cvs-tag-make (butlast (cvs-tag->vlist tag)))
297 tag)))))
298 tags)))
299 (while (cdr tags)
300 (let (tl)
301 (while tags
302 (push (cvs-tree-merge (pop tags) (pop tags)) tl))
303 (setq tags (nreverse tl))))
304 (car tags)))
306 (defun cvs-status-get-tags ()
307 "Look for a list of tags, read them in and delete them.
308 Returns NIL if there was an empty list of tags and T if there wasn't
309 even a list. Else, return the list of tags where each element of
310 the list is a three-string list TAG, KIND, REV."
311 (let ((tags nil))
312 (if (not (re-search-forward cvs-status-tags-leader-re nil t)) t
313 (forward-char 1)
314 (let ((pt (point))
315 (lastrev nil)
316 (case-fold-search t))
318 (looking-at "\\s-+no\\s-+tags")
320 (progn ; normal listing
321 (while (looking-at "^[ \t]+\\([^ \t\n]+\\)[ \t]+(\\([a-z]+\\): \\(.+\\))$")
322 (push (list (match-string 1) (match-string 2) (match-string 3)) tags)
323 (forward-line 1))
324 (unless (looking-at "^$") (setq tags nil) (goto-char pt))
325 tags)
327 (progn ; cvstree-style listing
328 (while (or (looking-at "^ .+\\(.\\) \\([0-9.]+\\): \\([^\n\t .0-9][^\n\t ]*\\)?$")
329 (and lastrev
330 (looking-at "^ .+\\(\\) \\(8\\)? \\([^\n\t .0-9][^\n\t ]*\\)$")))
331 (setq lastrev (or (match-string 2) lastrev))
332 (push (list (match-string 3)
333 (if (equal (match-string 1) " ") "branch" "revision")
334 lastrev) tags)
335 (forward-line 1))
336 (unless (looking-at "^$") (setq tags nil) (goto-char pt))
337 (setq tags (nreverse tags)))
339 (progn ; new tree style listing
340 (let* ((re-lead "[ \t]*\\(-+\\)?\\(|\n?[ \t]+\\)?")
341 (re3 (concat re-lead "\\(\\.\\)?\\(" cvs-status-rev-re "\\)"))
342 (re2 (concat re-lead cvs-status-tag-re "\\(\\)"))
343 (re1 (concat re-lead cvs-status-tag-re
344 " (\\(" cvs-status-rev-re "\\))")))
345 (while (or (looking-at re1) (looking-at re2) (looking-at re3))
346 (push (list (match-string 3)
347 (if (match-string 1) "branch" "revision")
348 (match-string 4)) tags)
349 (goto-char (match-end 0))
350 (when (eolp) (forward-char 1))))
351 (unless (looking-at "^$") (setq tags nil) (goto-char pt))
352 (setq tags (nreverse tags))))
354 (delete-region pt (point)))
355 tags)))
357 (defvar font-lock-mode)
358 (defun cvs-refontify (beg end)
359 (when (and (boundp 'font-lock-mode)
360 font-lock-mode
361 (fboundp 'font-lock-fontify-region))
362 (font-lock-fontify-region (1- beg) (1+ end))))
364 (defun cvs-status-trees ()
365 "Look for a lists of tags, and replace them with trees."
366 (interactive)
367 (save-excursion
368 (goto-char (point-min))
369 (let ((inhibit-read-only t)
370 (tags nil))
371 (while (listp (setq tags (cvs-status-get-tags)))
372 ;;(let ((pt (save-excursion (forward-line -1) (point))))
373 (save-restriction
374 (narrow-to-region (point) (point))
375 ;;(newline)
376 (cvs-tree-print (cvs-tags->tree tags) 'cvs-tag->string 3))
377 ;;(cvs-refontify pt (point))
378 (sit-for 0)
380 ))))
382 ;;;;
383 ;;;; CVSTree-style trees
384 ;;;;
386 ;; chars sets. Ripped from cvstree
387 (defvar cvs-tree-dstr-2byte-ready
388 (when (featurep 'mule)
389 (if (boundp 'current-language-environment)
390 (string= current-language-environment "Japanese")
391 t)) ; mule/emacs-19
392 "*Variable that specifies characters set used in cvstree tree graph.
393 If non-nil, 2byte (Japanese?) characters set is used.
394 If nil, 1byte characters set is used.
395 2byte characters might be available with Mule or Emacs with Mule extension.")
397 (defconst cvs-tree-dstr-char-space
398 (if cvs-tree-dstr-2byte-ready "\e$B!!\e(B" " "))
399 (defconst cvs-tree-dstr-char-hbar
400 (if cvs-tree-dstr-2byte-ready "\e$B(,\e(B" "--"))
401 (defconst cvs-tree-dstr-char-vbar
402 (if cvs-tree-dstr-2byte-ready "\e$B(-\e(B" "| "))
403 (defconst cvs-tree-dstr-char-branch
404 (if cvs-tree-dstr-2byte-ready "\e$B(2\e(B" "+-"))
405 (defconst cvs-tree-dstr-char-eob ;end of branch
406 (if cvs-tree-dstr-2byte-ready "\e$B(1\e(B" "`-"))
407 (defconst cvs-tree-dstr-char-bob ;beginning of branch
408 (if cvs-tree-dstr-2byte-ready "\e$B(3\e(B" "+-"))
410 (defun cvs-tag-lessp (tag1 tag2)
411 (eq (cvs-tag-compare tag1 tag2) 'more2))
413 (defvar cvs-tree-nomerge nil)
415 (defun cvs-status-cvstrees (&optional arg)
416 "Look for a list of tags, and replace it with a tree.
417 Optional prefix ARG chooses between two representations."
418 (interactive "P")
419 (save-excursion
420 (goto-char (point-min))
421 (let ((inhibit-read-only t)
422 (tags nil)
423 (cvs-tree-nomerge (if arg (not cvs-tree-nomerge) cvs-tree-nomerge)))
424 (while (listp (setq tags (cvs-status-get-tags)))
425 (let ((tags (mapcar 'cvs-tag-make-tag tags))
426 ;;(pt (save-excursion (forward-line -1) (point)))
428 (setq tags (sort tags 'cvs-tag-lessp))
429 (let* ((first (car tags))
430 (prev (if (cvs-tag-p first)
431 (list (car (cvs-tag->vlist first))) nil)))
432 (cvs-tree-tags-insert tags prev)
433 ;;(cvs-refontify pt (point))
434 (sit-for 0)))))))
436 (defun cvs-tree-tags-insert (tags prev)
437 (when tags
438 (let* ((tag (car tags))
439 (vlist (cvs-tag->vlist tag))
440 (nprev ;"next prev"
441 (let* ((next (cvs-car (cadr tags)))
442 (nprev (if (and cvs-tree-nomerge next
443 (equal vlist (cvs-tag->vlist next)))
444 prev vlist)))
445 (cvs-map (lambda (v p) v) nprev prev)))
446 (after (save-excursion
447 (newline)
448 (cvs-tree-tags-insert (cdr tags) nprev)))
449 (pe t) ;"prev equal"
450 (nas nil)) ;"next afters" to be returned
451 (insert " ")
452 (do* ((vs vlist (cdr vs))
453 (ps prev (cdr ps))
454 (as after (cdr as)))
455 ((and (null as) (null vs) (null ps))
456 (let ((revname (cvs-status-vl-to-str vlist)))
457 (if (cvs-every 'identity (cvs-map 'equal prev vlist))
458 (insert (make-string (+ 4 (length revname)) ? )
459 (or (cvs-tag->name tag) ""))
460 (insert " " revname ": " (or (cvs-tag->name tag) "")))))
461 (let* ((eq (and pe (equal (car ps) (car vs))))
462 (next-eq (equal (cadr ps) (cadr vs))))
463 (let* ((na+char
464 (if (car as)
465 (if eq
466 (if next-eq (cons t cvs-tree-dstr-char-vbar)
467 (cons t cvs-tree-dstr-char-branch))
468 (cons nil cvs-tree-dstr-char-bob))
469 (if eq
470 (if next-eq (cons nil cvs-tree-dstr-char-space)
471 (cons t cvs-tree-dstr-char-eob))
472 (cons nil (if (and (eq (cvs-tag->type tag) 'branch)
473 (cvs-every 'null as))
474 cvs-tree-dstr-char-space
475 cvs-tree-dstr-char-hbar))))))
476 (insert (cdr na+char))
477 (push (car na+char) nas))
478 (setq pe eq)))
479 (nreverse nas))))
481 ;;;;
482 ;;;; Merged trees from different files
483 ;;;;
485 (defun cvs-tree-fuzzy-merge-1 (trees tree prev)
488 (defun cvs-tree-fuzzy-merge (trees tree)
489 "Do the impossible: merge TREE into TREES."
492 (defun cvs-tree ()
493 "Get tags from the status output and merge tham all into a big tree."
494 (save-excursion
495 (goto-char (point-min))
496 (let ((inhibit-read-only t)
497 (trees (make-vector 31 0)) tree)
498 (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags))))
499 (cvs-tree-fuzzy-merge trees tree))
500 (erase-buffer)
501 (let ((cvs-tag-print-rev nil))
502 (cvs-tree-print tree 'cvs-tag->string 3)))))
505 (provide 'cvs-status)
507 ;;; Change Log:
508 ;; $Log: cvs-status.el,v $
509 ;; Revision 1.6 2000/08/16 20:46:32 monnier
510 ;; *** empty log message ***
512 ;; Revision 1.5 2000/08/06 09:18:02 gerd
513 ;; Use `nth' instead of `first', `second', and `third'.
515 ;; Revision 1.4 2000/05/10 22:08:28 monnier
516 ;; (cvs-status-minor-wrap): Use mark-active.
518 ;; Revision 1.3 2000/03/22 01:08:08 monnier
519 ;; (cvs-status-mode): Use define-derived-mode.
521 ;; Revision 1.2 2000/03/22 01:01:36 monnier
522 ;; (cvs-status-(prev|next)): Rename from
523 ;; cvs-status-(prev|next)-entry and use easy-mmode-define-navigation.
524 ;; (cvs-tree-dstr-*): Rename from cvstree-dstr-* and use two ascii chars
525 ;; to let the output "breathe" a little more (more readable).
528 ;;; cvs-status.el ends here