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