lisp/cvs-status.el

   1 ;;; cvs-status.el --- major mode for browsing `cvs status' output
   2
   3 ;; Copyright (C) 1999, 2000  Free Software Foundation, Inc.
   4
   5 ;; Author: Stefan Monnier <monnier@cs.yale.edu>
   6 ;; Keywords: pcl-cvs cvs status tree tools
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Todo:
  28
  29 ;; - Somehow allow cvs-status-tree to work on-the-fly
  30
  31 ;;; Code:
  32
  33 (eval-when-compile (require 'cl))
  34 (require 'pcvs-util)
  35
  36 ;;;
  37
  38 (defgroup cvs-status nil
  39   "Major mode for browsing `cvs status' output."
  40   :group 'pcl-cvs
  41   :prefix "cvs-status-")
  42
  43 (easy-mmode-defmap cvs-status-mode-map
  44   '(("n"        . next-line)
  45     ("p"        . previous-line)
  46     ("N"        . cvs-status-next)
  47     ("P"        . cvs-status-prev)
  48     ("\M-n"     . cvs-status-next)
  49     ("\M-p"     . cvs-status-prev)
  50     ("t"        . cvs-status-cvstrees)
  51     ("T"        . cvs-status-trees))
  52   "CVS-Status' keymap."
  53   :group 'cvs-status
  54   :inherit 'cvs-mode-map)
  55
  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 ;;    ))
  61
  62 (defvar cvs-status-mode-hook nil
  63   "Hook run at the end of `cvs-status-mode'.")
  64
  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.]*\\)")
  71
  72 (defconst cvs-status-font-lock-keywords
  73   `((,cvs-status-entry-leader-re
  74      (1 'cvs-filename-face)
  75      (2 'cvs-need-action-face))
  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)))
  89
  90
  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))
  97
  98 ;; Define cvs-status-next and cvs-status-prev
  99 (easy-mmode-define-navigation cvs-status cvs-status-entry-leader-re "entry")
 100
 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 (re-search-backward cvs-pcl-cvs-dirchange-re nil t)
 110                         (match-string 1)))
 111            (dir ""))
 112       (let ((default-directory ""))
 113         (when pcldir (setq dir (expand-file-name pcldir dir)))
 114         (when cvsdir (setq dir (expand-file-name cvsdir dir)))
 115         (expand-file-name file dir)))))
 116
 117 (defun cvs-status-current-tag ()
 118   (save-excursion
 119     (let ((pt (point))
 120           (col (current-column))
 121           (start (progn (re-search-backward cvs-status-tags-leader-re nil t) (point)))
 122           (end (progn (re-search-forward "^$" nil t) (point))))
 123       (when (and (< start pt) (> end pt))
 124         (goto-char pt)
 125         (end-of-line)
 126         (let ((tag nil) (dist pt) (end (point)))
 127           (beginning-of-line)
 128           (while (re-search-forward cvs-status-tag-re end t)
 129             (let* ((cole (current-column))
 130                    (colb (save-excursion
 131                            (goto-char (match-beginning 1)) (current-column)))
 132                    (ndist (min (abs (- cole col)) (abs (- colb col)))))
 133               (when (< ndist dist)
 134                 (setq dist ndist)
 135                 (setq tag (match-string 1)))))
 136           tag)))))
 137
 138 (defun cvs-status-minor-wrap (buf f)
 139   (let ((data (with-current-buffer buf
 140                 (cons
 141                  (cons (cvs-status-current-file)
 142                        (cvs-status-current-tag))
 143                  (when mark-active
 144                    (save-excursion
 145                      (goto-char (mark))
 146                      (cons (cvs-status-current-file)
 147                            (cvs-status-current-tag))))))))
 148     (let ((cvs-branch-prefix (cdar data))
 149           (cvs-secondary-branch-prefix (and (cdar data) (cddr data)))
 150           (cvs-minor-current-files
 151            (cons (caar data)
 152                  (when (and (cadr data) (not (equal (caar data) (cadr data))))
 153                    (list (cadr data)))))
 154           ;; FIXME:  I need to force because the fileinfos are UNKNOWN
 155           (cvs-force-command "/F"))
 156       (funcall f))))
 157
 158 ;;
 159 ;; Tagelt, tag element
 160 ;;
 161
 162 (defstruct (cvs-tag
 163             (:constructor nil)
 164             (:constructor cvs-tag-make
 165                           (vlist &optional name type))
 166             (:conc-name cvs-tag->))
 167   vlist
 168   name
 169   type)
 170
 171 (defsubst cvs-status-vl-to-str (vl) (mapconcat 'number-to-string vl "."))
 172
 173 (defun cvs-tag->string (tag)
 174   (if (stringp tag) tag
 175     (let ((name (cvs-tag->name tag))
 176            (vl (cvs-tag->vlist tag)))
 177       (if (null name) (cvs-status-vl-to-str vl)
 178         (let ((rev (if vl (concat " (" (cvs-status-vl-to-str vl) ")") "")))
 179           (if (consp name) (mapcar (lambda (name) (concat name rev)) name)
 180             (concat name rev)))))))
 181
 182 (defun cvs-tag-compare-1 (vl1 vl2)
 183   (cond
 184    ((and (null vl1) (null vl2)) 'equal)
 185    ((null vl1) 'more2)
 186    ((null vl2) 'more1)
 187    (t (let ((v1 (car vl1))
 188             (v2 (car vl2)))
 189         (cond
 190          ((> v1 v2) 'more1)
 191          ((< v1 v2) 'more2)
 192          (t (cvs-tag-compare-1 (cdr vl1) (cdr vl2))))))))
 193
 194 (defsubst cvs-tag-compare (tag1 tag2)
 195   (cvs-tag-compare-1 (cvs-tag->vlist tag1) (cvs-tag->vlist tag2)))
 196
 197 (defun cvs-tag-merge (tag1 tag2)
 198   "Merge TAG1 and TAG2 into one."
 199   (let ((type1 (cvs-tag->type tag1))
 200         (type2 (cvs-tag->type tag2))
 201         (name1 (cvs-tag->name tag1))
 202         (name2 (cvs-tag->name tag2)))
 203     (unless (equal (cvs-tag->vlist tag1) (cvs-tag->vlist tag2))
 204       (setf (cvs-tag->vlist tag1) nil))
 205     (if type1
 206         (unless (or (not type2) (equal type1 type2))
 207           (setf (cvs-tag->type tag1) nil))
 208       (setf (cvs-tag->type tag1) type2))
 209     (if name1
 210         (setf (cvs-tag->name tag1) (cvs-append name1 name2))
 211       (setf (cvs-tag->name tag1) name2))
 212     tag1))
 213
 214 (defun cvs-tree-print (tags printer column)
 215   "Print the tree of TAGS where each tag's string is given by PRINTER.
 216 PRINTER should accept both a tag (in which case it should return a string)
 217 or a string (in which case it should simply return its argument).
 218 A tag cannot be a CONS.  The return value can also be a list of strings,
 219 if several nodes where merged into one.
 220 The tree will be printed no closer than column COLUMN."
 221
 222   (let* ((eol (save-excursion (end-of-line) (current-column)))
 223          (column (max (+ eol 2) column)))
 224     (if (null tags) column
 225       ;;(move-to-column-force column)
 226       (let* ((rev (cvs-car tags))
 227              (name (funcall printer (cvs-car rev)))
 228              (rest (append (cvs-cdr name) (cvs-cdr tags)))
 229              (prefix
 230               (save-excursion
 231                 (or (= (forward-line 1) 0) (insert "\n"))
 232                 (cvs-tree-print rest printer column))))
 233         (assert (>= prefix column))
 234         (move-to-column prefix t)
 235         (assert (eolp))
 236         (insert (cvs-car name))
 237         (dolist (br (cvs-cdr rev))
 238           (let* ((column (current-column))
 239                  (brrev (funcall printer (cvs-car br)))
 240                  (brlength (length (cvs-car brrev)))
 241                  (brfill (concat (make-string (/ brlength 2) ? ) "|"))
 242                  (prefix
 243                   (save-excursion
 244                     (insert " -- ")
 245                     (cvs-tree-print (cvs-append brrev brfill (cvs-cdr br))
 246                                     printer (current-column)))))
 247             (delete-region (save-excursion (move-to-column prefix) (point))
 248                            (point))
 249             (insert " " (make-string (- prefix column 2) ?-) " ")
 250             (end-of-line)))
 251         prefix))))
 252
 253 (defun cvs-tree-merge (tree1 tree2)
 254   "Merge tags trees TREE1 and TREE2 into one.
 255 BEWARE:  because of stability issues, this is not a symetric operation."
 256   (assert (and (listp tree1) (listp tree2)))
 257   (cond
 258    ((null tree1) tree2)
 259    ((null tree2) tree1)
 260    (t
 261     (let* ((rev1 (car tree1))
 262            (tag1 (cvs-car rev1))
 263            (vl1 (cvs-tag->vlist tag1))
 264            (l1 (length vl1))
 265            (rev2 (car tree2))
 266            (tag2 (cvs-car rev2))
 267            (vl2 (cvs-tag->vlist tag2))
 268            (l2 (length vl2)))
 269     (cond
 270      ((= l1 l2)
 271       (case (cvs-tag-compare tag1 tag2)
 272         (more1 (list* rev2 (cvs-tree-merge tree1 (cdr tree2))))
 273         (more2 (list* rev1 (cvs-tree-merge (cdr tree1) tree2)))
 274         (equal
 275          (cons (cons (cvs-tag-merge tag1 tag2)
 276                      (cvs-tree-merge (cvs-cdr rev1) (cvs-cdr rev2)))
 277                (cvs-tree-merge (cdr tree1) (cdr tree2))))))
 278      ((> l1 l2)
 279       (cvs-tree-merge
 280        (list (cons (cvs-tag-make (cvs-butlast vl1)) tree1)) tree2))
 281      ((< l1 l2)
 282       (cvs-tree-merge
 283        tree1 (list (cons (cvs-tag-make (cvs-butlast vl2)) tree2)))))))))
 284
 285 (defun cvs-tag-make-tag (tag)
 286   (let ((vl (mapcar 'string-to-number (split-string (nth 2 tag) "\\."))))
 287     (cvs-tag-make vl (nth 0 tag) (intern (nth 1 tag)))))
 288
 289 (defun cvs-tags->tree (tags)
 290   "Make a tree out of a list of TAGS."
 291   (let ((tags
 292          (mapcar
 293           (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 (cvs-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)))
 305
 306 (defun cvs-status-get-tags ()
 307   "Look for a list of tags, read them in and delete them.
 308 Return 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))
 317         (or
 318          (looking-at "\\s-+no\\s-+tags")
 319
 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)
 326
 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)))
 338
 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))))
 353
 354         (delete-region pt (point)))
 355       tags)))
 356
 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))))
 363
 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             (combine-after-change-calls
 377               (cvs-tree-print (cvs-tags->tree tags) 'cvs-tag->string 3)))
 378           ;;(cvs-refontify pt (point))
 379           ;;(sit-for 0)
 380           ;;)
 381           ))))
 382
 383 ;;;;
 384 ;;;; CVSTree-style trees
 385 ;;;;
 386
 387 (defvar cvs-tree-use-jisx0208
 388   nil ;; (and (char-display-font 'japanese-jisx0208) t)
 389   "*Non-nil if we should use the graphical glyphs from `japanese-jisx0208'.
 390 Otherwise, default to ASCII chars like +, - and |.")
 391
 392 (defconst cvs-tree-char-space
 393   (if cvs-tree-use-jisx0208 (make-char 'japanese-jisx0208 33 33) "  "))
 394 (defconst cvs-tree-char-hbar
 395   (if cvs-tree-use-jisx0208 (make-char 'japanese-jisx0208 40 44) "--"))
 396 (defconst cvs-tree-char-vbar
 397   (if cvs-tree-use-jisx0208 (make-char 'japanese-jisx0208 40 45) "| "))
 398 (defconst cvs-tree-char-branch
 399   (if cvs-tree-use-jisx0208 (make-char 'japanese-jisx0208 40 50) "+-"))
 400 (defconst cvs-tree-char-eob             ;end of branch
 401   (if cvs-tree-use-jisx0208 (make-char 'japanese-jisx0208 40 49) "`-"))
 402 (defconst cvs-tree-char-bob             ;beginning of branch
 403   (if cvs-tree-use-jisx0208 (make-char 'japanese-jisx0208 40 51) "+-"))
 404
 405 (defun cvs-tag-lessp (tag1 tag2)
 406   (eq (cvs-tag-compare tag1 tag2) 'more2))
 407
 408 (defvar cvs-tree-nomerge nil)
 409
 410 (defun cvs-status-cvstrees (&optional arg)
 411   "Look for a list of tags, and replace it with a tree.
 412 Optional prefix ARG chooses between two representations."
 413   (interactive "P")
 414   (when (and cvs-tree-use-jisx0208
 415              (not enable-multibyte-characters))
 416     ;; We need to convert the buffer from unibyte to multibyte
 417     ;; since we'll use multibyte chars for the tree.
 418     (let ((modified (buffer-modified-p))
 419           (inhibit-read-only t)
 420           (inhibit-modification-hooks t))
 421       (unwind-protect
 422           (progn
 423             (decode-coding-region (point-min) (point-max) 'undecided)
 424             (set-buffer-multibyte t))
 425         (restore-buffer-modified-p modified))))
 426   (save-excursion
 427     (goto-char (point-min))
 428     (let ((inhibit-read-only t)
 429           (tags nil)
 430           (cvs-tree-nomerge (if arg (not cvs-tree-nomerge) cvs-tree-nomerge)))
 431       (while (listp (setq tags (cvs-status-get-tags)))
 432         (let ((tags (mapcar 'cvs-tag-make-tag tags))
 433               ;;(pt (save-excursion (forward-line -1) (point)))
 434               )
 435           (setq tags (sort tags 'cvs-tag-lessp))
 436           (let* ((first (car tags))
 437                  (prev (if (cvs-tag-p first)
 438                            (list (car (cvs-tag->vlist first))) nil)))
 439             (combine-after-change-calls
 440               (cvs-tree-tags-insert tags prev))
 441             ;;(cvs-refontify pt (point))
 442             ;;(sit-for 0)
 443             ))))))
 444
 445 (defun cvs-tree-tags-insert (tags prev)
 446   (when tags
 447     (let* ((tag (car tags))
 448            (vlist (cvs-tag->vlist tag))
 449            (nprev ;"next prev"
 450             (let* ((next (cvs-car (cadr tags)))
 451                    (nprev (if (and cvs-tree-nomerge next
 452                                    (equal vlist (cvs-tag->vlist next)))
 453                               prev vlist)))
 454               (cvs-map (lambda (v p) v) nprev prev)))
 455            (after (save-excursion
 456                    (newline)
 457                    (cvs-tree-tags-insert (cdr tags) nprev)))
 458            (pe t)                       ;"prev equal"
 459            (nas nil))                   ;"next afters" to be returned
 460       (insert "   ")
 461       (do* ((vs vlist (cdr vs))
 462             (ps prev (cdr ps))
 463             (as after (cdr as)))
 464           ((and (null as) (null vs) (null ps))
 465            (let ((revname (cvs-status-vl-to-str vlist)))
 466              (if (cvs-every 'identity (cvs-map 'equal prev vlist))
 467                  (insert (make-string (+ 4 (length revname)) ? )
 468                          (or (cvs-tag->name tag) ""))
 469                (insert "  " revname ": " (or (cvs-tag->name tag) "")))))
 470         (let* ((eq (and pe (equal (car ps) (car vs))))
 471                (next-eq (equal (cadr ps) (cadr vs))))
 472           (let* ((na+char
 473                   (if (car as)
 474                       (if eq
 475                           (if next-eq (cons t cvs-tree-char-vbar)
 476                             (cons t cvs-tree-char-branch))
 477                         (cons nil cvs-tree-char-bob))
 478                     (if eq
 479                         (if next-eq (cons nil cvs-tree-char-space)
 480                           (cons t cvs-tree-char-eob))
 481                       (cons nil (if (and (eq (cvs-tag->type tag) 'branch)
 482                                          (cvs-every 'null as))
 483                                     cvs-tree-char-space
 484                                   cvs-tree-char-hbar))))))
 485             (insert (cdr na+char))
 486             (push (car na+char) nas))
 487           (setq pe eq)))
 488       (nreverse nas))))
 489
 490 ;;;;
 491 ;;;; Merged trees from different files
 492 ;;;;
 493
 494 (defun cvs-tree-fuzzy-merge-1 (trees tree prev)
 495   )
 496
 497 (defun cvs-tree-fuzzy-merge (trees tree)
 498   "Do the impossible:  merge TREE into TREES."
 499   ())
 500
 501 (defun cvs-tree ()
 502   "Get tags from the status output and merge tham all into a big tree."
 503   (save-excursion
 504     (goto-char (point-min))
 505     (let ((inhibit-read-only t)
 506           (trees (make-vector 31 0)) tree)
 507       (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags))))
 508         (cvs-tree-fuzzy-merge trees tree))
 509       (erase-buffer)
 510       (let ((cvs-tag-print-rev nil))
 511         (cvs-tree-print tree 'cvs-tag->string 3)))))
 512
 513
 514 (provide 'cvs-status)
 515
 516 ;;; arch-tag: db8b5094-d02a-473e-a476-544e89ff5ad0
 517 ;;; cvs-status.el ends here