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

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

;; Copyright (C) 1999-2014 Free Software Foundation, Inc.

;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: pcl-cvs cvs status tree vc 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 3 of the License, 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.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Todo:

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

;;; Code:

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

;;;

(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)
(defvar cvs-force-command)
(defvar cvs-minor-current-files)
(defvar cvs-secondary-branch-prefix)
(defvar cvs-branch-prefix)
(defvar cvs-tag-print-rev)

(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
;;

(cl-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
      (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))))
	(cl-assert (>= prefix column))
	(move-to-column prefix t)
	(cl-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 symmetric operation."
  (cl-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)
      (pcase (cvs-tag-compare tag1 tag2)
	(`more1 (cons rev2 (cvs-tree-merge tree1 (cdr tree2))))
	(`more2 (cons 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
  (pcase cvs-tree-use-charset
    (`jisx0208 (make-char 'japanese-jisx0208 33 33))
    (`unicode " ")
    (_ "  ")))
(defconst cvs-tree-char-hbar
  (pcase cvs-tree-use-charset
    (`jisx0208 (make-char 'japanese-jisx0208 40 44))
    (`unicode "━")
    (_ "--")))
(defconst cvs-tree-char-vbar
  (pcase cvs-tree-use-charset
    (`jisx0208 (make-char 'japanese-jisx0208 40 45))
    (`unicode "┃")
    (_ "| ")))
(defconst cvs-tree-char-branch
  (pcase cvs-tree-use-charset
    (`jisx0208 (make-char 'japanese-jisx0208 40 50))
    (`unicode "┣")
    (_ "+-")))
(defconst cvs-tree-char-eob		;end of branch
  (pcase cvs-tree-use-charset
    (`jisx0208 (make-char 'japanese-jisx0208 40 49))
    (`unicode "┗")
    (_ "`-")))
(defconst cvs-tree-char-bob		;beginning of branch
  (pcase cvs-tree-use-charset
    (`jisx0208 (make-char 'japanese-jisx0208 40 51))
    (`unicode "┳")
    (_ "+-")))

(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 "   ")
      (cl-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 them 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)

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