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