[bpt/emacs.git] / lisp / cvs-status.el

;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8 -*-

;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
;;   2005, 2006 Free Software Foundation, Inc.

;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: pcl-cvs cvs status tree tools

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; Todo:

;; - Somehow allow cvs-status-tree to work on-the-fly

;;; Code:

(eval-when-compile (require 'cl))
(require 'pcvs-util)
(eval-when-compile (require 'pcvs))

;;;

(defgroup cvs-status nil
  "Major mode for browsing `cvs status' output."
  :group 'pcl-cvs
  :prefix "cvs-status-")

(easy-mmode-defmap cvs-status-mode-map
  '(("n"	. next-line)
    ("p"	. previous-line)
    ("N"	. cvs-status-next)
    ("P"	. cvs-status-prev)
    ("\M-n"	. cvs-status-next)
    ("\M-p"	. cvs-status-prev)
    ("t"	. cvs-status-cvstrees)
    ("T"	. cvs-status-trees)
    (">"        . cvs-mode-checkout))
  "CVS-Status' keymap."
  :group 'cvs-status
  :inherit 'cvs-mode-map)

;;(easy-menu-define cvs-status-menu cvs-status-mode-map
;;  "Menu for `cvs-status-mode'."
;;  '("CVS-Status"
;;    ["Show Tag Trees"	cvs-status-tree	t]
;;    ))

(defvar cvs-status-mode-hook nil
  "Hook run at the end of `cvs-status-mode'.")

(defconst cvs-status-tags-leader-re "^   Existing Tags:$")
(defconst cvs-status-entry-leader-re
  "^File:\\s-+\\(?:no file \\)?\\(.*\\S-\\)\\s-+Status: \\(.+\\)$")
(defconst cvs-status-dir-re "^cvs[.ex]* [a-z]+: Examining \\(.+\\)$")
(defconst cvs-status-rev-re "[0-9][.0-9]*\\.[.0-9]*[0-9]")
(defconst cvs-status-tag-re "[ \t]\\([a-zA-Z][^ \t\n.]*\\)")

(defconst cvs-status-font-lock-keywords
  `((,cvs-status-entry-leader-re
     (1 'cvs-filename)
     (2 'cvs-need-action))
    (,cvs-status-tags-leader-re
     (,cvs-status-rev-re
      (save-excursion (re-search-forward "^\n" nil 'move) (point))
      (progn (re-search-backward cvs-status-tags-leader-re nil t)
	     (forward-line 1))
      (0 font-lock-comment-face))
     (,cvs-status-tag-re
      (save-excursion (re-search-forward "^\n" nil 'move) (point))
      (progn (re-search-backward cvs-status-tags-leader-re nil t)
	     (forward-line 1))
      (1 font-lock-function-name-face)))))
(defconst cvs-status-font-lock-defaults
  '(cvs-status-font-lock-keywords t nil nil nil (font-lock-multiline . t)))

(defvar cvs-minor-wrap-function)
(put 'cvs-status-mode 'mode-class 'special)
;;;###autoload
(define-derived-mode cvs-status-mode fundamental-mode "CVS-Status"
  "Mode used for cvs status output."
  (set (make-local-variable 'font-lock-defaults) cvs-status-font-lock-defaults)
  (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-status-minor-wrap))

;; Define cvs-status-next and cvs-status-prev
(easy-mmode-define-navigation cvs-status cvs-status-entry-leader-re "entry")

(defun cvs-status-current-file ()
  (save-excursion
    (forward-line 1)
    (or (re-search-backward cvs-status-entry-leader-re nil t)
	(re-search-forward cvs-status-entry-leader-re))
    (let* ((file (match-string 1))
	   (cvsdir (and (re-search-backward cvs-status-dir-re nil t)
			(match-string 1)))
	   (pcldir (and (if (boundp 'cvs-pcl-cvs-dirchange-re)
			    (re-search-backward cvs-pcl-cvs-dirchange-re nil t))
			(match-string 1)))
	   (dir ""))
      (let ((default-directory ""))
	(when pcldir (setq dir (expand-file-name pcldir dir)))
	(when cvsdir (setq dir (expand-file-name cvsdir dir)))
	(expand-file-name file dir)))))

(defun cvs-status-current-tag ()
  (save-excursion
    (let ((pt (point))
	  (col (current-column))
	  (start (progn (re-search-backward cvs-status-tags-leader-re nil t) (point)))
	  (end (progn (re-search-forward "^$" nil t) (point))))
      (when (and (< start pt) (> end pt))
	(goto-char pt)
	(end-of-line)
	(let ((tag nil) (dist pt) (end (point)))
	  (beginning-of-line)
	  (while (re-search-forward cvs-status-tag-re end t)
	    (let* ((cole (current-column))
		   (colb (save-excursion
			   (goto-char (match-beginning 1)) (current-column)))
		   (ndist (min (abs (- cole col)) (abs (- colb col)))))
	      (when (< ndist dist)
		(setq dist ndist)
		(setq tag (match-string 1)))))
	  tag)))))

(defun cvs-status-minor-wrap (buf f)
  (let ((data (with-current-buffer buf
		(cons
		 (cons (cvs-status-current-file)
		       (cvs-status-current-tag))
		 (when mark-active
		   (save-excursion
		     (goto-char (mark))
		     (cons (cvs-status-current-file)
			   (cvs-status-current-tag))))))))
    (let ((cvs-branch-prefix (cdar data))
	  (cvs-secondary-branch-prefix (and (cdar data) (cddr data)))
	  (cvs-minor-current-files
	   (cons (caar data)
		 (when (and (cadr data) (not (equal (caar data) (cadr data))))
		   (list (cadr data)))))
	  ;; FIXME:  I need to force because the fileinfos are UNKNOWN
	  (cvs-force-command "/F"))
      (funcall f))))

;;
;; Tagelt, tag element
;;

(defstruct (cvs-tag
	    (:constructor nil)
	    (:constructor cvs-tag-make
			  (vlist &optional name type))
	    (:conc-name cvs-tag->))
  vlist
  name
  type)

(defsubst cvs-status-vl-to-str (vl) (mapconcat 'number-to-string vl "."))

(defun cvs-tag->string (tag)
  (if (stringp tag) tag
    (let ((name (cvs-tag->name tag))
	   (vl (cvs-tag->vlist tag)))
      (if (null name) (cvs-status-vl-to-str vl)
	(let ((rev (if vl (concat " (" (cvs-status-vl-to-str vl) ")") "")))
	  (if (consp name) (mapcar (lambda (name) (concat name rev)) name)
	    (concat name rev)))))))

(defun cvs-tag-compare-1 (vl1 vl2)
  (cond
   ((and (null vl1) (null vl2)) 'equal)
   ((null vl1) 'more2)
   ((null vl2) 'more1)
   (t (let ((v1 (car vl1))
	    (v2 (car vl2)))
	(cond
	 ((> v1 v2) 'more1)
	 ((< v1 v2) 'more2)
	 (t (cvs-tag-compare-1 (cdr vl1) (cdr vl2))))))))

(defsubst cvs-tag-compare (tag1 tag2)
  (cvs-tag-compare-1 (cvs-tag->vlist tag1) (cvs-tag->vlist tag2)))

(defun cvs-tag-merge (tag1 tag2)
  "Merge TAG1 and TAG2 into one."
  (let ((type1 (cvs-tag->type tag1))
	(type2 (cvs-tag->type tag2))
	(name1 (cvs-tag->name tag1))
	(name2 (cvs-tag->name tag2)))
    (unless (equal (cvs-tag->vlist tag1) (cvs-tag->vlist tag2))
      (setf (cvs-tag->vlist tag1) nil))
    (if type1
	(unless (or (not type2) (equal type1 type2))
	  (setf (cvs-tag->type tag1) nil))
      (setf (cvs-tag->type tag1) type2))
    (if name1
	(setf (cvs-tag->name tag1) (cvs-append name1 name2))
      (setf (cvs-tag->name tag1) name2))
    tag1))

(defun cvs-tree-print (tags printer column)
  "Print the tree of TAGS where each tag's string is given by PRINTER.
PRINTER should accept both a tag (in which case it should return a string)
or a string (in which case it should simply return its argument).
A tag cannot be a CONS.  The return value can also be a list of strings,
if several nodes where merged into one.
The tree will be printed no closer than column COLUMN."

  (let* ((eol (save-excursion (end-of-line) (current-column)))
	 (column (max (+ eol 2) column)))
    (if (null tags) column
      ;;(move-to-column-force column)
      (let* ((rev (cvs-car tags))
	     (name (funcall printer (cvs-car rev)))
	     (rest (append (cvs-cdr name) (cvs-cdr tags)))
	     (prefix
	      (save-excursion
		(or (= (forward-line 1) 0) (insert "\n"))
		(cvs-tree-print rest printer column))))
	(assert (>= prefix column))
	(move-to-column prefix t)
	(assert (eolp))
	(insert (cvs-car name))
	(dolist (br (cvs-cdr rev))
	  (let* ((column (current-column))
		 (brrev (funcall printer (cvs-car br)))
		 (brlength (length (cvs-car brrev)))
		 (brfill (concat (make-string (/ brlength 2) ? ) "|"))
		 (prefix
		  (save-excursion
		    (insert " -- ")
		    (cvs-tree-print (cvs-append brrev brfill (cvs-cdr br))
				    printer (current-column)))))
	    (delete-region (save-excursion (move-to-column prefix) (point))
			   (point))
	    (insert " " (make-string (- prefix column 2) ?-) " ")
	    (end-of-line)))
	prefix))))

(defun cvs-tree-merge (tree1 tree2)
  "Merge tags trees TREE1 and TREE2 into one.
BEWARE:  because of stability issues, this is not a symetric operation."
  (assert (and (listp tree1) (listp tree2)))
  (cond
   ((null tree1) tree2)
   ((null tree2) tree1)
   (t
    (let* ((rev1 (car tree1))
	   (tag1 (cvs-car rev1))
	   (vl1 (cvs-tag->vlist tag1))
	   (l1 (length vl1))
	   (rev2 (car tree2))
	   (tag2 (cvs-car rev2))
	   (vl2 (cvs-tag->vlist tag2))
	   (l2 (length vl2)))
    (cond
     ((= l1 l2)
      (case (cvs-tag-compare tag1 tag2)
	(more1 (list* rev2 (cvs-tree-merge tree1 (cdr tree2))))
	(more2 (list* rev1 (cvs-tree-merge (cdr tree1) tree2)))
	(equal
	 (cons (cons (cvs-tag-merge tag1 tag2)
		     (cvs-tree-merge (cvs-cdr rev1) (cvs-cdr rev2)))
	       (cvs-tree-merge (cdr tree1) (cdr tree2))))))
     ((> l1 l2)
      (cvs-tree-merge
       (list (cons (cvs-tag-make (butlast vl1)) tree1)) tree2))
     ((< l1 l2)
      (cvs-tree-merge
       tree1 (list (cons (cvs-tag-make (butlast vl2)) tree2)))))))))

(defun cvs-tag-make-tag (tag)
  (let ((vl (mapcar 'string-to-number (split-string (nth 2 tag) "\\."))))
    (cvs-tag-make vl (nth 0 tag) (intern (nth 1 tag)))))

(defun cvs-tags->tree (tags)
  "Make a tree out of a list of TAGS."
  (let ((tags
	 (mapcar
	  (lambda (tag)
	    (let ((tag (cvs-tag-make-tag tag)))
	      (list (if (not (eq (cvs-tag->type tag) 'branch)) tag
		      (list (cvs-tag-make (butlast (cvs-tag->vlist tag)))
			    tag)))))
	  tags)))
    (while (cdr tags)
      (let (tl)
	(while tags
	  (push (cvs-tree-merge (pop tags) (pop tags)) tl))
	(setq tags (nreverse tl))))
    (car tags)))

(defun cvs-status-get-tags ()
  "Look for a list of tags, read them in and delete them.
Return nil if there was an empty list of tags and t if there wasn't
even a list.  Else, return the list of tags where each element of
the list is a three-string list TAG, KIND, REV."
  (let ((tags nil))
    (if (not (re-search-forward cvs-status-tags-leader-re nil t)) t
      (forward-char 1)
      (let ((pt (point))
	    (lastrev nil)
	    (case-fold-search t))
	(or
	 (looking-at "\\s-+no\\s-+tags")

	 (progn				; normal listing
	   (while (looking-at "^[ \t]+\\([^ \t\n]+\\)[ \t]+(\\([a-z]+\\): \\(.+\\))$")
	     (push (list (match-string 1) (match-string 2) (match-string 3)) tags)
	     (forward-line 1))
	   (unless (looking-at "^$") (setq tags nil) (goto-char pt))
	   tags)

	 (progn				; cvstree-style listing
	   (while (or (looking-at "^   .+\\(.\\)  \\([0-9.]+\\): \\([^\n\t .0-9][^\n\t ]*\\)?$")
		      (and lastrev
			   (looking-at "^   .+\\(\\)  \\(8\\)?  \\([^\n\t .0-9][^\n\t ]*\\)$")))
	     (setq lastrev (or (match-string 2) lastrev))
	     (push (list (match-string 3)
			 (if (equal (match-string 1) " ") "branch" "revision")
			 lastrev) tags)
	     (forward-line 1))
	   (unless (looking-at "^$") (setq tags nil) (goto-char pt))
	   (setq tags (nreverse tags)))

	 (progn				; new tree style listing
	   (let* ((re-lead "[ \t]*\\(-+\\)?\\(|\n?[ \t]+\\)*")
		  (re3 (concat re-lead "\\(\\.\\)?\\(" cvs-status-rev-re "\\)"))
		  (re2 (concat re-lead cvs-status-tag-re "\\(\\)"))
		  (re1 (concat re-lead cvs-status-tag-re
			       " (\\(" cvs-status-rev-re "\\))")))
	     (while (or (looking-at re1) (looking-at re2) (looking-at re3))
	       (push (list (match-string 3)
			   (if (match-string 1) "branch" "revision")
			   (match-string 4)) tags)
	       (goto-char (match-end 0))
	       (when (eolp) (forward-char 1))))
	   (unless (looking-at "^$") (setq tags nil) (goto-char pt))
	   (setq tags (nreverse tags))))

	(delete-region pt (point)))
      tags)))

(defvar font-lock-mode)
(defun cvs-refontify (beg end)
  (when (and (boundp 'font-lock-mode)
	     font-lock-mode
	     (fboundp 'font-lock-fontify-region))
    (font-lock-fontify-region (1- beg) (1+ end))))

(defun cvs-status-trees ()
  "Look for a lists of tags, and replace them with trees."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (let ((inhibit-read-only t)
	  (tags nil))
      (while (listp (setq tags (cvs-status-get-tags)))
	;;(let ((pt (save-excursion (forward-line -1) (point))))
	  (save-restriction
	    (narrow-to-region (point) (point))
	    ;;(newline)
	    (combine-after-change-calls
	      (cvs-tree-print (cvs-tags->tree tags) 'cvs-tag->string 3)))
	  ;;(cvs-refontify pt (point))
	  ;;(sit-for 0)
	  ;;)
	  ))))

;;;;
;;;; CVSTree-style trees
;;;;

(defvar cvs-tree-use-jisx0208 nil)	;Old compat var.
(defvar cvs-tree-use-charset
  (cond
   (cvs-tree-use-jisx0208 'jisx0208)
   ((char-displayable-p ?━) 'unicode)
   ((char-displayable-p (make-char 'japanese-jisx0208 40 44)) 'jisx0208))
  "*Non-nil if we should use the graphical glyphs from `japanese-jisx0208'.
Otherwise, default to ASCII chars like +, - and |.")

(defconst cvs-tree-char-space
  (case cvs-tree-use-charset
    (jisx0208 (make-char 'japanese-jisx0208 33 33))
    (unicode " ")
    (t "  ")))
(defconst cvs-tree-char-hbar
  (case cvs-tree-use-charset
    (jisx0208 (make-char 'japanese-jisx0208 40 44))
    (unicode "━")
    (t "--")))
(defconst cvs-tree-char-vbar
  (case cvs-tree-use-charset
    (jisx0208 (make-char 'japanese-jisx0208 40 45))
    (unicode "┃")
    (t "| ")))
(defconst cvs-tree-char-branch
  (case cvs-tree-use-charset
    (jisx0208 (make-char 'japanese-jisx0208 40 50))
    (unicode "┣")
    (t "+-")))
(defconst cvs-tree-char-eob		;end of branch
  (case cvs-tree-use-charset
    (jisx0208 (make-char 'japanese-jisx0208 40 49))
    (unicode "┗")
    (t "`-")))
(defconst cvs-tree-char-bob		;beginning of branch
  (case cvs-tree-use-charset
    (jisx0208 (make-char 'japanese-jisx0208 40 51))
    (unicode "┳")
    (t "+-")))

(defun cvs-tag-lessp (tag1 tag2)
  (eq (cvs-tag-compare tag1 tag2) 'more2))

(defvar cvs-tree-nomerge nil)

(defun cvs-status-cvstrees (&optional arg)
  "Look for a list of tags, and replace it with a tree.
Optional prefix ARG chooses between two representations."
  (interactive "P")
  (when (and cvs-tree-use-charset
	     (not enable-multibyte-characters))
    ;; We need to convert the buffer from unibyte to multibyte
    ;; since we'll use multibyte chars for the tree.
    (let ((modified (buffer-modified-p))
	  (inhibit-read-only t)
	  (inhibit-modification-hooks t))
      (unwind-protect
	  (progn
	    (decode-coding-region (point-min) (point-max) 'undecided)
	    (set-buffer-multibyte t))
	(restore-buffer-modified-p modified))))
  (save-excursion
    (goto-char (point-min))
    (let ((inhibit-read-only t)
	  (tags nil)
	  (cvs-tree-nomerge (if arg (not cvs-tree-nomerge) cvs-tree-nomerge)))
      (while (listp (setq tags (cvs-status-get-tags)))
	(let ((tags (mapcar 'cvs-tag-make-tag tags))
	      ;;(pt (save-excursion (forward-line -1) (point)))
	      )
	  (setq tags (sort tags 'cvs-tag-lessp))
	  (let* ((first (car tags))
		 (prev (if (cvs-tag-p first)
			   (list (car (cvs-tag->vlist first))) nil)))
	    (combine-after-change-calls
	      (cvs-tree-tags-insert tags prev))
	    ;;(cvs-refontify pt (point))
	    ;;(sit-for 0)
	    ))))))

(defun cvs-tree-tags-insert (tags prev)
  (when tags
    (let* ((tag (car tags))
	   (vlist (cvs-tag->vlist tag))
	   (nprev ;"next prev"
	    (let* ((next (cvs-car (cadr tags)))
		   (nprev (if (and cvs-tree-nomerge next
				   (equal vlist (cvs-tag->vlist next)))
			      prev vlist)))
	      (cvs-map (lambda (v p) v) nprev prev)))
	   (after (save-excursion
		   (newline)
		   (cvs-tree-tags-insert (cdr tags) nprev)))
	   (pe t)			;"prev equal"
	   (nas nil))			;"next afters" to be returned
      (insert "   ")
      (do* ((vs vlist (cdr vs))
	    (ps prev (cdr ps))
	    (as after (cdr as)))
	  ((and (null as) (null vs) (null ps))
	   (let ((revname (cvs-status-vl-to-str vlist)))
	     (if (cvs-every 'identity (cvs-map 'equal prev vlist))
		 (insert (make-string (+ 4 (length revname)) ? )
			 (or (cvs-tag->name tag) ""))
	       (insert "  " revname ": " (or (cvs-tag->name tag) "")))))
	(let* ((eq (and pe (equal (car ps) (car vs))))
	       (next-eq (equal (cadr ps) (cadr vs))))
	  (let* ((na+char
		  (if (car as)
		      (if eq
			  (if next-eq (cons t cvs-tree-char-vbar)
			    (cons t cvs-tree-char-branch))
			(cons nil cvs-tree-char-bob))
		    (if eq
			(if next-eq (cons nil cvs-tree-char-space)
			  (cons t cvs-tree-char-eob))
		      (cons nil (if (and (eq (cvs-tag->type tag) 'branch)
					 (cvs-every 'null as))
				    cvs-tree-char-space
				  cvs-tree-char-hbar))))))
	    (insert (cdr na+char))
	    (push (car na+char) nas))
	  (setq pe eq)))
      (nreverse nas))))

;;;;
;;;; Merged trees from different files
;;;;

(defun cvs-tree-fuzzy-merge-1 (trees tree prev)
  )

(defun cvs-tree-fuzzy-merge (trees tree)
  "Do the impossible:  merge TREE into TREES."
  ())

(defun cvs-tree ()
  "Get tags from the status output and merge tham all into a big tree."
  (save-excursion
    (goto-char (point-min))
    (let ((inhibit-read-only t)
	  (trees (make-vector 31 0)) tree)
      (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags))))
	(cvs-tree-fuzzy-merge trees tree))
      (erase-buffer)
      (let ((cvs-tag-print-rev nil))
	(cvs-tree-print tree 'cvs-tag->string 3)))))


(provide 'cvs-status)

;; arch-tag: db8b5094-d02a-473e-a476-544e89ff5ad0
;;; cvs-status.el ends here
Commit	Line	Data
5ebfa0ab	1	;;; cvs-status.el --- major mode for browsing `cvs status' output -- coding: utf-8 --
5b467bf4	2
0d30b337	3	;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
aaef169d	4	;; 2005, 2006 Free Software Foundation, Inc.
5b467bf4	5
cc1eecfd	6	;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
337bfec7	7	;; Keywords: pcl-cvs cvs status tree tools
5b467bf4 SM	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
086add15 LK	23	;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
086add15 LK	24	;; Boston, MA 02110-1301, USA.
5b467bf4 SM	25
	26	;;; Commentary:
	27
	28	;; Todo:
	29
5b467bf4 SM	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)
d6a13317	36	(eval-when-compile (require 'pcvs))
5b467bf4 SM	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)
5b467bf4	47	("p" . previous-line)
184c5091 SM	48	("N" . cvs-status-next)
	49	("P" . cvs-status-prev)
	50	("\M-n" . cvs-status-next)
	51	("\M-p" . cvs-status-prev)
5b467bf4	52	("t" . cvs-status-cvstrees)
44feddcf	53	("T" . cvs-status-trees)
d6a13317	54	(">" . cvs-mode-checkout))
5b467bf4 SM	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:$")
ad710d9f SM	69	(defconst cvs-status-entry-leader-re
ad710d9f SM	70	"^File:\\s-+\\(?:no file \\)?\\(.*\\S-\\)\\s-+Status: \\(.+\\)$")
5b467bf4 SM	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
94d5c876 MB	77	(1 'cvs-filename)
94d5c876 MB	78	(2 'cvs-need-action))
5b467bf4 SM	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
c68088c2	91	'(cvs-status-font-lock-keywords t nil nil nil (font-lock-multiline . t)))
71296446	92
d6a13317	93	(defvar cvs-minor-wrap-function)
5b467bf4 SM	94	(put 'cvs-status-mode 'mode-class 'special)
5b467bf4 SM	95	;;;###autoload
43e56cba	96	(define-derived-mode cvs-status-mode fundamental-mode "CVS-Status"
5b467bf4 SM	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
184c5091 SM	101	;; Define cvs-status-next and cvs-status-prev
184c5091 SM	102	(easy-mmode-define-navigation cvs-status cvs-status-entry-leader-re "entry")
5b467bf4 SM	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)))
d6a13317 SM	112	(pcldir (and (if (boundp 'cvs-pcl-cvs-dirchange-re)
d6a13317 SM	113	(re-search-backward cvs-pcl-cvs-dirchange-re nil t))
5b467bf4 SM	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))
befe763f	147	(when mark-active
5b467bf4 SM	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."
71296446	225
5b467bf4 SM	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)
c68088c2	283	(cvs-tree-merge
1703d649	284	(list (cons (cvs-tag-make (butlast vl1)) tree1)) tree2))
5b467bf4	285	((< l1 l2)
c68088c2	286	(cvs-tree-merge
1703d649	287	tree1 (list (cons (cvs-tag-make (butlast vl2)) tree2)))))))))
5b467bf4 SM	288
5b467bf4 SM	289	(defun cvs-tag-make-tag (tag)
dedffa6a GM	290	(let ((vl (mapcar 'string-to-number (split-string (nth 2 tag) "\\."))))
dedffa6a GM	291	(cvs-tag-make vl (nth 0 tag) (intern (nth 1 tag)))))
5b467bf4 SM	292
	293	(defun cvs-tags->tree (tags)
	294	"Make a tree out of a list of TAGS."
	295	(let ((tags
c68088c2 SM	296	(mapcar
	297	(lambda (tag)
	298	(let ((tag (cvs-tag-make-tag tag)))
	299	(list (if (not (eq (cvs-tag->type tag) 'branch)) tag
1703d649	300	(list (cvs-tag-make (butlast (cvs-tag->vlist tag)))
c68088c2 SM	301	tag)))))
c68088c2 SM	302	tags)))
5b467bf4 SM	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.
f0529b5b	312	Return nil if there was an empty list of tags and t if there wasn't
5b467bf4 SM	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
c68088c2	344	(let* ((re-lead "[ \t]\\(-+\\)?\\(\|\n?[ \t]+\\)")
5b467bf4 SM	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)
c68088c2 SM	380	(combine-after-change-calls
c68088c2 SM	381	(cvs-tree-print (cvs-tags->tree tags) 'cvs-tag->string 3)))
5b467bf4	382	;;(cvs-refontify pt (point))
c68088c2	383	;;(sit-for 0)
5b467bf4 SM	384	;;)
	385	))))
	386
c68088c2	387	;;;;
5b467bf4	388	;;;; CVSTree-style trees
c68088c2 SM	389	;;;;
c68088c2 SM	390
5ebfa0ab SM	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))
c68088c2 SM	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
5ebfa0ab SM	401	(case cvs-tree-use-charset
	402	(jisx0208 (make-char 'japanese-jisx0208 33 33))
	403	(unicode " ")
	404	(t " ")))
c68088c2	405	(defconst cvs-tree-char-hbar
5ebfa0ab SM	406	(case cvs-tree-use-charset
	407	(jisx0208 (make-char 'japanese-jisx0208 40 44))
	408	(unicode "━")
	409	(t "--")))
c68088c2	410	(defconst cvs-tree-char-vbar
5ebfa0ab SM	411	(case cvs-tree-use-charset
	412	(jisx0208 (make-char 'japanese-jisx0208 40 45))
	413	(unicode "┃")
	414	(t "\| ")))
c68088c2	415	(defconst cvs-tree-char-branch
5ebfa0ab SM	416	(case cvs-tree-use-charset
	417	(jisx0208 (make-char 'japanese-jisx0208 40 50))
	418	(unicode "┣")
	419	(t "+-")))
c68088c2	420	(defconst cvs-tree-char-eob ;end of branch
5ebfa0ab SM	421	(case cvs-tree-use-charset
	422	(jisx0208 (make-char 'japanese-jisx0208 40 49))
	423	(unicode "┗")
	424	(t "`-")))
c68088c2	425	(defconst cvs-tree-char-bob ;beginning of branch
5ebfa0ab SM	426	(case cvs-tree-use-charset
	427	(jisx0208 (make-char 'japanese-jisx0208 40 51))
	428	(unicode "┳")
	429	(t "+-")))
5b467bf4 SM	430
	431	(defun cvs-tag-lessp (tag1 tag2)
	432	(eq (cvs-tag-compare tag1 tag2) 'more2))
	433
184c5091	434	(defvar cvs-tree-nomerge nil)
5b467bf4 SM	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")
5ebfa0ab	440	(when (and cvs-tree-use-charset
c68088c2 SM	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))))
5b467bf4 SM	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))
7382bcae	462	(let* ((first (car tags))
5b467bf4	463	(prev (if (cvs-tag-p first)
7382bcae	464	(list (car (cvs-tag->vlist first))) nil)))
c68088c2 SM	465	(combine-after-change-calls
c68088c2 SM	466	(cvs-tree-tags-insert tags prev))
5b467bf4	467	;;(cvs-refontify pt (point))
c68088c2 SM	468	;;(sit-for 0)
c68088c2 SM	469	))))))
5b467bf4 SM	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
c68088c2 SM	501	(if next-eq (cons t cvs-tree-char-vbar)
	502	(cons t cvs-tree-char-branch))
	503	(cons nil cvs-tree-char-bob))
5b467bf4	504	(if eq
c68088c2 SM	505	(if next-eq (cons nil cvs-tree-char-space)
c68088c2 SM	506	(cons t cvs-tree-char-eob))
5b467bf4 SM	507	(cons nil (if (and (eq (cvs-tag->type tag) 'branch)
5b467bf4 SM	508	(cvs-every 'null as))
c68088c2 SM	509	cvs-tree-char-space
c68088c2 SM	510	cvs-tree-char-hbar))))))
5b467bf4 SM	511	(insert (cdr na+char))
	512	(push (car na+char) nas))
	513	(setq pe eq)))
	514	(nreverse nas))))
	515
71296446	516	;;;;
5b467bf4	517	;;;; Merged trees from different files
71296446	518	;;;;
5b467bf4 SM	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)))))
71296446	538
5b467bf4 SM	539
	540	(provide 'cvs-status)
	541
d6a13317	542	;; arch-tag: db8b5094-d02a-473e-a476-544e89ff5ad0
5b467bf4	543	;;; cvs-status.el ends here