Mercurial > emacs
changeset 28088:b442dfc3cef0
*** empty log message ***
| author | Stefan Monnier <monnier@iro.umontreal.ca> |
|---|---|
| date | Sat, 11 Mar 2000 03:51:31 +0000 |
| parents | 9ca294cf76c7 |
| children | 1899d4c422fc |
| files | lisp/ChangeLog lisp/cvs-status.el lisp/emacs-lisp/ewoc.el lisp/log-edit.el lisp/log-view.el lisp/pcvs-defs.el lisp/pcvs-info.el lisp/pcvs-parse.el lisp/pcvs-util.el lisp/pcvs.el |
| diffstat | 10 files changed, 5730 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Sat Mar 11 03:50:50 2000 +0000 +++ b/lisp/ChangeLog Sat Mar 11 03:51:31 2000 +0000 @@ -1,3 +1,16 @@ +2000-03-10 Stefan Monnier <monnier@cs.yale.edu> + + * cvs-status, log-edit.el, log-view.el, pcvs-defs.el, pcvs-info.el, + pcvs-parse.el, pcvs-util.el, pcvs.el: New files. + + * emacs-lisp/ewoc.el: New file. This is a merge of elib-node.el, dll.el + and cookie.el (from Elib) with heavy renaming and other massaging. + + * emacs-lisp/easy-mmode.el (easy-mmode-defmap, easy-mmode-defsyntax): + Autoload the functions used. + (easy-mmode-define-syntax): Fix CL typo. + (easy-mmode-define-derived-mode): Improve the docstring generation. + 2000-03-10 Gerd Moellmann <gerd@gnu.org> * textmodes/texinfo.el (texinfo-version): Variable and function
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cvs-status.el Sat Mar 11 03:51:31 2000 +0000 @@ -0,0 +1,523 @@ +;;; cvs-status.el --- Major mode for browsing `cvs status' output + +;; Copyright (C) 1999-2000 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@cs.yale.edu> +;; Keywords: pcl-cvs cvs status tree +;; Version: $Name: $ +;; Revision: $Id: cvs-status.el,v 1.14 2000/03/05 21:32:21 monnier Exp $ + +;; 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Todo: + +;; - Rename to cvs-status-mode.el +;; - Somehow allow cvs-status-tree to work on-the-fly + +;;; Code: + +(eval-when-compile (require 'cl)) +(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) + ("N" . cvs-status-next-entry) + ("\M-n" . cvs-status-next-entry) + ("p" . previous-line) + ("P" . cvs-status-prev-entry) + ("\M-p" . cvs-status-prev-entry) + ("t" . cvs-status-cvstrees) + ("T" . cvs-status-trees)) + "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-+\\)\\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-face) + (2 'cvs-need-action-face)) + (,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)) + + +(put 'cvs-status-mode 'mode-class 'special) +;;;###autoload +(autoload 'cvs-status-mode "cvs-status" "Mode used for cvs status output." t) +(eval-when-compile (autoload 'easy-mmode-define-derived-mode "easy-mmode")) +(easy-mmode-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)) + + +(defun cvs-status-next-entry (n) + "Go to the N'th next cvs status entry." + (interactive "p") + (if (< n 0) (cvs-status-prev-entry (- n)) + (forward-line 1) + (re-search-forward cvs-status-entry-leader-re nil t n) + (beginning-of-line))) + +(defun cvs-status-prev-entry (n) + "Go to the N'th previous cvs status entry." + (interactive "p") + (if (< n 0) (cvs-status-next-entry (- n)) + (forward-line -1) + (re-search-backward cvs-status-entry-leader-re nil t n) + (beginning-of-line))) + +(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 (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 (ignore-errors (mark)) + ;; `mark-active' is not provided by XEmacs :-( + (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 (third tag) "\\.")))) + (cvs-tag-make vl (first tag) (intern (second 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. +Returns 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) + (cvs-tree-print (cvs-tags->tree tags) 'cvs-tag->string 3)) + ;;(cvs-refontify pt (point)) + (sit-for 0) + ;;) + )))) + +;;;; +;;;; CVSTree-style trees +;;;; + +;; chars sets. Ripped from cvstree +(defvar cvstree-dstr-2byte-ready + (when (featurep 'mule) + (if (boundp 'current-language-environment) + (string= current-language-environment "Japanese") + t)) ; mule/emacs-19 + "*Variable that specifies characters set used in cvstree tree graph. +If non-nil, 2byte (Japanese?) characters set is used. +If nil, 1byte characters set is used. +2byte characters might be available with Mule or Emacs with Mule extension.") + +(defconst cvstree-dstr-char-space + (if cvstree-dstr-2byte-ready "$B!!(B" " ")) +(defconst cvstree-dstr-char-hbar + (if cvstree-dstr-2byte-ready "$B(,(B" "-")) +(defconst cvstree-dstr-char-vbar + (if cvstree-dstr-2byte-ready "$B(-(B" "|")) +(defconst cvstree-dstr-char-branch + (if cvstree-dstr-2byte-ready "$B(2(B" "+")) +(defconst cvstree-dstr-char-eob ;end of branch + (if cvstree-dstr-2byte-ready "$B(1(B" "`")) +(defconst cvstree-dstr-char-bob ;beginning of branch + (if cvstree-dstr-2byte-ready "$B(3(B" "+")) + +(defun cvs-tag-lessp (tag1 tag2) + (eq (cvs-tag-compare tag1 tag2) 'more2)) + +(defvar cvs-tree-nomerge t) + +(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") + (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 (first tags)) + (prev (if (cvs-tag-p first) + (list (first (cvs-tag->vlist first))) nil))) + (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 cvstree-dstr-char-vbar) + (cons t cvstree-dstr-char-branch)) + (cons nil cvstree-dstr-char-bob)) + (if eq + (if next-eq (cons nil cvstree-dstr-char-space) + (cons t cvstree-dstr-char-eob)) + (cons nil (if (and (eq (cvs-tag->type tag) 'branch) + (cvs-every 'null as)) + cvstree-dstr-char-space + cvstree-dstr-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) + +;;; cvs-status.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/ewoc.el Sat Mar 11 03:51:31 2000 +0000 @@ -0,0 +1,620 @@ +;;; ewoc.el -- Utility to maintain a view of a list of objects in a buffer + +;; Copyright (C) 1991-2000 Free Software Foundation + +;; Author: Per Cederqvist <ceder@lysator.liu.se> +;; Inge Wallin <inge@lysator.liu.se> +;; Maintainer: monnier@gnu.org +;; Created: 3 Aug 1992 +;; Keywords: extensions, lisp + +;; 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Ewoc Was Once Cookie +;; But now it's Emacs' Widget for Object Collections + +;; As the name implies this derives from the `cookie' package (part +;; of Elib). The changes are mostly superficial: + +;; - uses CL (and its `defstruct' +;; - separate from Elib. +;; - uses its own version of a doubly-linked list which allows us +;; to merge the elib-wrapper and the elib-node structures into ewoc-node +;; - dropping functions not used by PCL-CVS (the only client of ewoc at the +;; time of writing) +;; - removing unused arguments +;; - renaming: +;; elib-node ==> ewoc--node +;; collection ==> ewoc +;; tin ==> ewoc--node +;; cookie ==> data or element or elem + +;; Introduction +;; ============ +;; +;; Ewoc is a package that implements a connection between an +;; dll (a doubly linked list) and the contents of a buffer. +;; Possible uses are dired (have all files in a list, and show them), +;; buffer-list, kom-prioritize (in the LysKOM elisp client) and +;; others. pcl-cvs.el uses ewoc.el. +;; +;; Ewoc can be considered as the `view' part of a model-view-controller. +;; +;; A `element' can be any lisp object. When you use the ewoc +;; package you specify a pretty-printer, a function that inserts +;; a printable representation of the element in the buffer. (The +;; pretty-printer should use "insert" and not +;; "insert-before-markers"). +;; +;; A `ewoc' consists of a doubly linked list of elements, a +;; header, a footer and a pretty-printer. It is displayed at a +;; certain point in a certain buffer. (The buffer and point are +;; fixed when the ewoc is created). The header and the footer +;; are constant strings. They appear before and after the elements. +;; (Currently, once set, they can not be changed). +;; +;; Ewoc does not affect the mode of the buffer in any way. It +;; merely makes it easy to connect an underlying data representation +;; to the buffer contents. +;; +;; A `ewoc--node' is an object that contains one element. There are +;; functions in this package that given an ewoc--node extracts the data, or +;; gives the next or previous ewoc--node. (All ewoc--nodes are linked together +;; in a doubly linked list. The 'previous' ewoc--node is the one that appears +;; before the other in the buffer.) You should not do anything with +;; an ewoc--node except pass it to the functions in this package. +;; +;; An ewoc is a very dynamic thing. You can easily add or delete elements. +;; You can apply a function to all elements in an ewoc, etc, etc. +;; +;; Remember that an element can be anything. Your imagination is the +;; limit! It is even possible to have another ewoc as an +;; element. In that way some kind of tree hierarchy can be created. +;; +;; Full documentation will, God willing, soon be available in a +;; Texinfo manual. + +;; In the mean time `grep '^(.*ewoc-[^-]' emacs-lisp/ewoc.el' can help +;; you find all the exported functions: +;; +;; (defun ewoc-create (buffer pretty-printer &optional header footer pos) +;; (defalias 'ewoc-data 'ewoc--node-data) +;; (defun ewoc-enter-first (ewoc data) +;; (defun ewoc-enter-last (ewoc data) +;; (defun ewoc-enter-after (ewoc node data) +;; (defun ewoc-enter-before (ewoc node data) +;; (defun ewoc-next (ewoc node) +;; (defun ewoc-prev (ewoc node) +;; (defun ewoc-nth (ewoc n) +;; (defun ewoc-map (map-function ewoc &rest args) +;; (defun ewoc-filter (ewoc predicate &rest args) +;; (defun ewoc-locate (ewoc pos &optional guess) +;; (defun ewoc-invalidate (ewoc &rest nodes) +;; (defun ewoc-goto-prev (ewoc pos arg) +;; (defun ewoc-goto-next (ewoc pos arg) +;; (defun ewoc-goto-node (ewoc node) +;; (defun ewoc-refresh (ewoc) +;; (defun ewoc-collect (ewoc predicate &rest args) +;; (defun ewoc-buffer (ewoc) + + +;; Coding conventions +;; ================== +;; +;; All functions of course start with `ewoc'. Functions and macros +;; starting with the prefix `ewoc--' are meant for internal use, +;; while those starting with `ewoc-' are exported for public use. +;; There are currently no global or buffer-local variables used. + + +;;; Code: + +(eval-when-compile (require 'cl)) ;because of CL compiler macros + +;; The doubly linked list is implemented as a circular list +;; with a dummy node first and last. The dummy node is used as +;; "the dll" (or rather is the dll handle passed around). + +(defstruct (ewoc--node + (:type vector) ;required for ewoc--node-branch hack + (:constructor ewoc--node-create (start-marker data))) + left right data start-marker) + +(defalias 'ewoc--node-branch 'aref) + +(defun ewoc--dll-create () + "Create an empty doubly linked list." + (let ((dummy-node (ewoc--node-create 'DL-LIST 'DL-LIST))) + (setf (ewoc--node-right dummy-node) dummy-node) + (setf (ewoc--node-left dummy-node) dummy-node) + dummy-node)) + +(defun ewoc--node-enter-before (node elemnode) + "Insert ELEMNODE before NODE in a DLL." + (assert (and (null (ewoc--node-left elemnode)) (null (ewoc--node-right elemnode)))) + (setf (ewoc--node-left elemnode) (ewoc--node-left node)) + (setf (ewoc--node-right elemnode) node) + (setf (ewoc--node-right (ewoc--node-left node)) elemnode) + (setf (ewoc--node-left node) elemnode)) + +(defun ewoc--node-enter-first (dll node) + "Add a free floating NODE first in DLL." + (ewoc--node-enter-before (ewoc--node-right dll) node)) + +(defun ewoc--node-enter-last (dll node) + "Add a free floating NODE last in DLL." + (ewoc--node-enter-before dll node)) + +(defun ewoc--node-next (dll node) + "Return the node after NODE, or nil if NODE is the last node." + (unless (eq (ewoc--node-right node) dll) (ewoc--node-right node))) + +(defun ewoc--node-prev (dll node) + "Return the node before NODE, or nil if NODE is the first node." + (unless (eq (ewoc--node-left node) dll) (ewoc--node-left node))) + +(defun ewoc--node-delete (node) + "Unbind NODE from its doubly linked list and return it." + ;; This is a no-op when applied to the dummy node. This will return + ;; nil if applied to the dummy node since it always contains nil. + (setf (ewoc--node-right (ewoc--node-left node)) (ewoc--node-right node)) + (setf (ewoc--node-left (ewoc--node-right node)) (ewoc--node-left node)) + (setf (ewoc--node-left node) nil) + (setf (ewoc--node-right node) nil) + node) + +(defun ewoc--node-nth (dll n) + "Return the Nth node from the doubly linked list DLL. +N counts from zero. If DLL is not that long, nil is returned. +If N is negative, return the -(N+1)th last element. +Thus, (ewoc--node-nth dll 0) returns the first node, +and (ewoc--node-nth dll -1) returns the last node." + ;; Branch 0 ("follow left pointer") is used when n is negative. + ;; Branch 1 ("follow right pointer") is used otherwise. + (let* ((branch (if (< n 0) 0 1)) + (node (ewoc--node-branch dll branch))) + (if (< n 0) (setq n (- -1 n))) + (while (and (not (eq dll node)) (> n 0)) + (setq node (ewoc--node-branch node branch)) + (setq n (1- n))) + (unless (eq dll node) node))) + + +;;; The ewoc data type + +(defstruct (ewoc + (:constructor nil) + (:constructor ewoc--create + (buffer pretty-printer header footer dll)) + (:conc-name ewoc--)) + buffer pretty-printer header footer dll last-node) + +(defmacro ewoc--set-buffer-bind-dll-let* (ewoc varlist &rest forms) + "Execute FORMS with ewoc--buffer selected as current buffer, +dll bound to ewoc--dll, and VARLIST bound as in a let*. +dll will be bound when VARLIST is initialized, but the current +buffer will *not* have been changed. +Return value of last form in FORMS." + (let ((old-buffer (make-symbol "old-buffer")) + (hnd (make-symbol "ewoc"))) + (` (let* (((, old-buffer) (current-buffer)) + ((, hnd) (, ewoc)) + (dll (ewoc--dll (, hnd))) + (,@ varlist)) + (set-buffer (ewoc--buffer (, hnd))) + (unwind-protect + (progn (,@ forms)) + (set-buffer (, old-buffer))))))) + +(defmacro ewoc--set-buffer-bind-dll (ewoc &rest forms) + `(ewoc--set-buffer-bind-dll-let* ,ewoc nil ,@forms)) + +(defsubst ewoc--filter-hf-nodes (ewoc node) + "Evaluate NODE once and return it. +BUT if it is the header or the footer in EWOC return nil instead." + (unless (or (eq node (ewoc--header ewoc)) + (eq node (ewoc--footer ewoc))) + node)) + + +(defun ewoc--create-special-node (data string pos) + "Insert STRING at POS in current buffer. Remember the start +position. Create a wrapper containing that start position and the +element DATA." + (save-excursion + ;; Remember the position as a number so that it doesn't move + ;; when we insert the string. + (when (markerp pos) (setq pos (marker-position pos))) + (goto-char pos) + (let ((inhibit-read-only t)) + ;; Use insert-before-markers so that the marker for the + ;; next element is updated. + (insert-before-markers string) + ;; Always insert a newline. You want invisible elements? You + ;; lose. (At least in this version). FIXME-someday. (It is + ;; harder to fix than it might seem. All markers have to point + ;; to the right place all the time...) + (insert-before-markers ?\n) + (ewoc--node-create (copy-marker pos) data)))) + + +(defun ewoc--create-node (data pretty-printer pos) + "Call PRETTY-PRINTER with point set at POS in current buffer. +Remember the start position. Create a wrapper containing that +start position and the element DATA." + (save-excursion + ;; Remember the position as a number so that it doesn't move + ;; when we insert the string. + (when (markerp pos) (setq pos (marker-position pos))) + (goto-char pos) + (let ((inhibit-read-only t)) + ;; Insert the trailing newline using insert-before-markers + ;; so that the start position for the next element is updated. + (insert-before-markers ?\n) + ;; Move back, and call the pretty-printer. + (backward-char 1) + (funcall pretty-printer data) + (ewoc--node-create (copy-marker pos) data)))) + + +(defun ewoc--delete-node-internal (ewoc node) + "Delete a data string from EWOC. +Can not be used on the footer. Returns the wrapper that is deleted. +The start-marker in the wrapper is set to nil, so that it doesn't +consume any more resources." + (let ((dll (ewoc--dll ewoc)) + (inhibit-read-only t)) + ;; If we are about to delete the node pointed at by last-node, + ;; set last-node to nil. + (if (eq (ewoc--last-node ewoc) node) + (setf (ewoc--last-node ewoc) nil)) + + (delete-region (ewoc--node-start-marker node) + (ewoc--node-start-marker (ewoc--node-next dll node))) + (set-marker (ewoc--node-start-marker node) nil) + ;; Delete the node, and return the wrapper. + (ewoc--node-delete node))) + + +(defvar dll) ;passed by dynamic binding + +(defun ewoc--refresh-node (ewoc node) + "Redisplay the element represented by NODE. +Can not be used on the footer. dll *must* be bound to +\(ewoc--dll ewoc)." + (let ((inhibit-read-only t)) + (save-excursion + ;; First, remove the string from the buffer: + (delete-region (ewoc--node-start-marker node) + (1- (marker-position + (ewoc--node-start-marker (ewoc--node-next dll node))))) + ;; Calculate and insert the string. + (goto-char (ewoc--node-start-marker node)) + (funcall (ewoc--pretty-printer ewoc) + (ewoc--node-data node))))) + +;;; =========================================================================== +;;; Public members of the Ewoc package + + +(defun ewoc-create (buffer pretty-printer &optional header footer pos) + "Create an empty ewoc. + +The ewoc will be inserted in BUFFER. BUFFER may be a +buffer or a buffer name. It is created if it does not exist. + +PRETTY-PRINTER should be a function that takes one argument, an +element, and inserts a string representing it in the buffer (at +point). The string PRETTY-PRINTER inserts may be empty or span +several linse. A trailing newline will always be inserted +automatically. The PRETTY-PRINTER should use insert, and not +insert-before-markers. + +Optional third argument HEADER is a string that will always be +present at the top of the ewoc. HEADER should end with a +newline. Optionaly fourth argument FOOTER is similar, and will +always be inserted at the bottom of the ewoc. + +Optional fifth argument POS is a buffer position, specifying +where the ewoc will be inserted. It defaults to the +beginning of the buffer." + (let ((new-ewoc + (ewoc--create (get-buffer-create buffer) + pretty-printer nil nil (ewoc--dll-create)))) + (ewoc--set-buffer-bind-dll new-ewoc + ;; Set default values + (unless header (setq header "")) + (unless footer (setq footer "")) + (unless pos (setq pos (point-min))) + ;; Force header to be above footer. + (if (markerp pos) (setq pos (marker-position pos))) + (let ((foot (ewoc--create-special-node footer footer pos)) + (head (ewoc--create-special-node header header pos))) + (ewoc--node-enter-first dll head) + (ewoc--node-enter-last dll foot) + (setf (ewoc--header new-ewoc) (ewoc--node-nth dll 0)) + (setf (ewoc--footer new-ewoc) (ewoc--node-nth dll -1)))) + ;; Return the ewoc + new-ewoc)) + +(defalias 'ewoc-data 'ewoc--node-data) + +(defun ewoc-enter-first (ewoc data) + "Enter DATA first in EWOC." + (ewoc--set-buffer-bind-dll ewoc + (ewoc-enter-after ewoc (ewoc--node-nth dll 0) data))) + +(defun ewoc-enter-last (ewoc data) + "Enter DATA last in EWOC." + (ewoc--set-buffer-bind-dll ewoc + (ewoc-enter-before ewoc (ewoc--node-nth dll -1) data))) + + +(defun ewoc-enter-after (ewoc node data) + "Enter a new element DATA after NODE in EWOC." + (ewoc--set-buffer-bind-dll ewoc + (ewoc-enter-before ewoc (ewoc--node-next dll node) data))) + +(defun ewoc-enter-before (ewoc node data) + "Enter a new element DATA before NODE in EWOC." + (ewoc--set-buffer-bind-dll ewoc + (ewoc--node-enter-before + node + (ewoc--create-node + data + (ewoc--pretty-printer ewoc) + (ewoc--node-start-marker node))))) + +(defun ewoc-next (ewoc node) + "Get the next node. +Returns nil if NODE is nil or the last element." + (when node + (ewoc--filter-hf-nodes + ewoc (ewoc--node-next (ewoc--dll ewoc) node)))) + +(defun ewoc-prev (ewoc node) + "Get the previous node. +Returns nil if NODE is nil or the first element." + (when node + (ewoc--filter-hf-nodes + ewoc + (ewoc--node-prev (ewoc--dll ewoc) node)))) + + +(defun ewoc-nth (ewoc n) + "Return the Nth node. +N counts from zero. Nil is returned if there is less than N elements. +If N is negative, return the -(N+1)th last element. +Thus, (ewoc-nth dll 0) returns the first node, +and (ewoc-nth dll -1) returns the last node. +Use `ewoc--node-data' to extract the data from the node." + ;; Skip the header (or footer, if n is negative). + (setq n (if (< n 0) (1- n) (1+ n))) + (ewoc--filter-hf-nodes ewoc + (ewoc--node-nth (ewoc--dll ewoc) n))) + +(defun ewoc-map (map-function ewoc &rest args) + "Apply MAP-FUNCTION to all elements in EWOC. +MAP-FUNCTION is applied to the first element first. +If MAP-FUNCTION returns non-nil the element will be refreshed (its +pretty-printer will be called once again). + +Note that the buffer for EWOC will be current buffer when MAP-FUNCTION +is called. MAP-FUNCTION must restore the current buffer to BUFFER before +it returns, if it changes it. + +If more than two arguments are given, the remaining +arguments will be passed to MAP-FUNCTION." + (ewoc--set-buffer-bind-dll-let* ewoc + ((footer (ewoc--footer ewoc)) + (node (ewoc--node-nth dll 1))) + (while (not (eq node footer)) + (if (apply map-function (ewoc--node-data node) args) + (ewoc--refresh-node ewoc node)) + (setq node (ewoc--node-next dll node))))) + +(defun ewoc-filter (ewoc predicate &rest args) + "Remove all elements in EWOC for which PREDICATE returns nil. +Note that the buffer for EWOC will be current-buffer when PREDICATE +is called. PREDICATE must restore the current buffer before it returns +if it changes it. +The PREDICATE is called with the element as its first argument. If any +ARGS are given they will be passed to the PREDICATE." + (ewoc--set-buffer-bind-dll-let* ewoc + ((node (ewoc--node-nth dll 1)) + (footer (ewoc--footer ewoc)) + (next nil)) + (while (not (eq node footer)) + (setq next (ewoc--node-next dll node)) + (unless (apply predicate (ewoc--node-data node) args) + (ewoc--delete-node-internal ewoc node)) + (setq node next)))) + +(defun ewoc-locate (ewoc pos &optional guess) + "Return the node that POS (a buffer position) is within. +POS may be a marker or an integer. +GUESS should be a node that it is likely that POS is near. + +If POS points before the first element, the first node is returned. +If POS points after the last element, the last node is returned. +If the EWOC is empty, nil is returned." + (ewoc--set-buffer-bind-dll-let* ewoc + ((footer (ewoc--footer ewoc))) + + (cond + ;; Nothing present? + ((eq (ewoc--node-nth dll 1) (ewoc--node-nth dll -1)) + nil) + + ;; Before second elem? + ((< pos (ewoc--node-start-marker (ewoc--node-nth dll 2))) + (ewoc--node-nth dll 1)) + + ;; After one-before-last elem? + ((>= pos (ewoc--node-start-marker (ewoc--node-nth dll -2))) + (ewoc--node-nth dll -2)) + + ;; We now know that pos is within a elem. + (t + ;; Make an educated guess about which of the three known + ;; node'es (the first, the last, or GUESS) is nearest. + (let* ((best-guess (ewoc--node-nth dll 1)) + (distance (abs (- pos (ewoc--node-start-marker best-guess))))) + (when guess + (let ((d (abs (- pos (ewoc--node-start-marker guess))))) + (when (< d distance) + (setq distance d) + (setq best-guess guess)))) + + (let* ((g (ewoc--node-nth dll -1)) ;Check the last elem + (d (abs (- pos (ewoc--node-start-marker g))))) + (when (< d distance) + (setq distance d) + (setq best-guess g))) + + (when (ewoc--last-node ewoc) ;Check "previous". + (let* ((g (ewoc--last-node ewoc)) + (d (abs (- pos (ewoc--node-start-marker g))))) + (when (< d distance) + (setq distance d) + (setq best-guess g)))) + + ;; best-guess is now a "best guess". + ;; Find the correct node. First determine in which direction + ;; it lies, and then move in that direction until it is found. + + (cond + ;; Is pos after the guess? + ((>= pos + (ewoc--node-start-marker best-guess)) + ;; Loop until we are exactly one node too far down... + (while (>= pos (ewoc--node-start-marker best-guess)) + (setq best-guess (ewoc--node-next dll best-guess))) + ;; ...and return the previous node. + (ewoc--node-prev dll best-guess)) + + ;; Pos is before best-guess + (t + (while (< pos (ewoc--node-start-marker best-guess)) + (setq best-guess (ewoc--node-prev dll best-guess))) + best-guess))))))) + +(defun ewoc-invalidate (ewoc &rest nodes) + "Refresh some elements. +The pretty-printer that for EWOC will be called for all NODES." + (ewoc--set-buffer-bind-dll ewoc + (dolist (node nodes) + (ewoc--refresh-node ewoc node)))) + +(defun ewoc-goto-prev (ewoc pos arg) + "Move point to the ARGth previous element. +Don't move if we are at the first element, or if EWOC is empty. +Returns the node we moved to." + (ewoc--set-buffer-bind-dll-let* ewoc + ((node (ewoc-locate ewoc pos (ewoc--last-node ewoc)))) + (when node + (while (and node (> arg 0)) + (setq arg (1- arg)) + (setq node (ewoc--node-prev dll node))) + ;; Never step above the first element. + (unless (ewoc--filter-hf-nodes ewoc node) + (setq node (ewoc--node-nth dll 1))) + (ewoc-goto-node ewoc node)))) + +(defun ewoc-goto-next (ewoc pos arg) + "Move point to the ARGth next element. +Don't move if we are at the last element. +Returns the node." + (ewoc--set-buffer-bind-dll-let* ewoc + ((node (ewoc-locate ewoc pos (ewoc--last-node ewoc)))) + (while (and node (> arg 0)) + (setq arg (1- arg)) + (setq node (ewoc--node-next dll node))) + ;; Never step below the first element. + (unless (ewoc--filter-hf-nodes ewoc node) + (setq node (ewoc--node-nth dll -2))) + (ewoc-goto-node ewoc node))) + +(defun ewoc-goto-node (ewoc node) + "Move point to NODE." + (ewoc--set-buffer-bind-dll ewoc + (goto-char (ewoc--node-start-marker node)) + (if goal-column (move-to-column goal-column)) + (setf (ewoc--last-node ewoc) node))) + +(defun ewoc-refresh (ewoc) + "Refresh all data in EWOC. +The pretty-printer that was specified when the EWOC was created +will be called for all elements in EWOC. +Note that `ewoc-invalidate' is more efficient if only a small +number of elements needs to be refreshed." + (ewoc--set-buffer-bind-dll-let* ewoc + ((header (ewoc--header ewoc)) + (footer (ewoc--footer ewoc))) + (let ((inhibit-read-only t)) + (delete-region (ewoc--node-start-marker (ewoc--node-nth dll 1)) + (ewoc--node-start-marker footer)) + (goto-char (ewoc--node-start-marker footer)) + (let ((node (ewoc--node-nth dll 1))) + (while (not (eq node footer)) + (set-marker (ewoc--node-start-marker node) (point)) + (funcall (ewoc--pretty-printer ewoc) + (ewoc--node-data node)) + (insert "\n") + (setq node (ewoc--node-next dll node))))) + (set-marker (ewoc--node-start-marker footer) (point)))) + +(defun ewoc-collect (ewoc predicate &rest args) + "Select elements from EWOC using PREDICATE. +Return a list of all selected data elements. +PREDICATE is a function that takes a data element as its first argument. +The elements on the returned list will appear in the same order as in +the buffer. You should not rely on in which order PREDICATE is +called. +Note that the buffer the EWOC is displayed in is current-buffer +when PREDICATE is called. If PREDICATE must restore current-buffer if +it changes it. +If more than two arguments are given the +remaining arguments will be passed to PREDICATE." + (ewoc--set-buffer-bind-dll-let* ewoc + ((header (ewoc--header ewoc)) + (node (ewoc--node-nth dll -2)) + result) + (while (not (eq node header)) + (if (apply predicate (ewoc--node-data node) args) + (push (ewoc--node-data node) result)) + (setq node (ewoc--node-prev dll node))) + result)) + +(defun ewoc-buffer (ewoc) + "Return the buffer that is associated with EWOC. +Returns nil if the buffer has been deleted." + (let ((buf (ewoc--buffer ewoc))) + (when (buffer-name buf) buf))) + + +(provide 'ewoc) + +;;; Local Variables: +;;; eval: (put 'ewoc--set-buffer-bind-dll 'lisp-indent-hook 1) +;;; eval: (put 'ewoc--set-buffer-bind-dll-let* 'lisp-indent-hook 2) +;;; End: + +;;; ewoc.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/log-edit.el Sat Mar 11 03:51:31 2000 +0000 @@ -0,0 +1,448 @@ +;;; log-edit.el --- Major mode for editing CVS commit messages + +;; Copyright (C) 1999-2000 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@cs.yale.edu> +;; Keywords: pcl-cvs cvs commit log +;; Version: $Name: $ +;; Revision: $Id: log-edit.el,v 1.8 2000/03/05 21:32:21 monnier Exp $ + +;; 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Todo: + +;; - Remove a single leading `* <file>' in log-edit-insert-changelog +;; - Move in VC's code +;; - Add compatibility for VC's hook variables +;; - add compatibility with cvs-edit.el + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'add-log) ; for all the ChangeLog goodies +(require 'pcvs-util) +(require 'ring) +(require 'vc) + +;;;; +;;;; Global Variables +;;;; + +(defgroup log-edit nil + "Major mode for editing commit messages for PCL-CVS." + :group 'pcl-cvs + :prefix "log-edit-") + +;; compiler pacifiers +(defvar cvs-buffer) + +(easy-mmode-defmap log-edit-mode-map + `(("\C-c\C-c" . log-edit-done) + ("\C-c\C-a" . log-edit-insert-changelog) + ("\C-c\C-f" . log-edit-show-files) + ("\C-c?" . log-edit-mode-help)) + "Keymap for the `log-edit-mode' (used when editing cvs log messages)." + :group 'log-edit + :inherit (if (boundp 'vc-log-entry-mode) vc-log-entry-mode)) + +(defcustom log-edit-confirm t + "*If non-nil, `log-edit-done' will request confirmation. +If 'changed, only request confirmation if the list of files has + changed since the beginning of the log-edit session." + :group 'log-edit + :type '(choice (const changed) (const t) (const nil))) + +(defcustom log-edit-keep-buffer nil + "*If non-nil, don't hide the buffer after `log-edit-done'." + :group 'log-edit + :type 'boolean) + +(defvar cvs-commit-buffer-require-final-newline t + "Obsolete, use `log-edit-require-final-newline'.") + +(defcustom log-edit-require-final-newline + cvs-commit-buffer-require-final-newline + "*Enforce a newline at the end of commit log messages. +Enforce it silently if t, query if non-nil and don't do anything if nil." + :group 'log-edit + :type '(choice (const ask) (const t) (const nil))) + +(defcustom log-edit-setup-invert nil + "*Non-nil means `log-edit' should invert the meaning of its SETUP arg. +If SETUP is 'force, this variable has no effect." + :group 'log-edit + :type 'boolean) + +(defcustom log-edit-hook '(log-edit-insert-cvs-template + log-edit-insert-changelog) + "*Hook run at the end of `log-edit'." + :group 'log-edit + :type '(hook :options (log-edit-insert-cvs-template + log-edit-insert-changelog))) + +(defcustom log-edit-mode-hook nil + "*Hook run when entering `log-edit-mode'." + :group 'log-edit + :type 'hook) + +(defcustom log-edit-done-hook nil + "*Hook run before doing the actual commit. +This hook can be used to cleanup the message, enforce various +conventions, or to allow recording the message in some other database, +such as a bug-tracking system. The list of files about to be committed +can be obtained from `log-edit-files'." + :group 'log-edit + :type '(hook :options (log-edit-delete-common-indentation + log-edit-add-to-changelog))) + +(defvar cvs-changelog-full-paragraphs t + "*If non-nil, include full ChangeLog paragraphs in the CVS log. +This may be set in the ``local variables'' section of a ChangeLog, to +indicate the policy for that ChangeLog. + +A ChangeLog paragraph is a bunch of log text containing no blank lines; +a paragraph usually describes a set of changes with a single purpose, +but perhaps spanning several functions in several files. Changes in +different paragraphs are unrelated. + +You could argue that the CVS log entry for a file should contain the +full ChangeLog paragraph mentioning the change to the file, even though +it may mention other files, because that gives you the full context you +need to understand the change. This is the behaviour you get when this +variable is set to t. + +On the other hand, you could argue that the CVS log entry for a change +should contain only the text for the changes which occurred in that +file, because the CVS log is per-file. This is the behaviour you get +when this variable is set to nil.") + +;;;; Internal global or buffer-local vars + +(defconst log-edit-files-buf "*log-edit-files*") +(defvar log-edit-initial-files nil) +(defvar log-edit-callback nil) +(defvar log-edit-listfun nil) + +;;;; +;;;; Actual code +;;;; + +;;;###autoload +(defun log-edit (callback &optional setup listfun &rest ignore) + "Setup a buffer to enter a log message. +The buffer will be put in `log-edit-mode'. +If SETUP is non-nil, the buffer is then erased and `log-edit-hook' is run. +Mark and point will be set around the entire contents of the +buffer so that it is easy to kill the contents of the buffer with \\[kill-region]. +Once you're done editing the message, pressing \\[log-edit-done] will call +`log-edit-done' which will end up calling CALLBACK to do the actual commit." + (when (and log-edit-setup-invert (not (eq setup 'force))) + (setq setup (not setup))) + (when setup (erase-buffer)) + (log-edit-mode) + (set (make-local-variable 'log-edit-callback) callback) + (set (make-local-variable 'log-edit-listfun) listfun) + (when setup (run-hooks 'log-edit-hook)) + (goto-char (point-min)) (push-mark (point-max)) + (set (make-local-variable 'log-edit-initial-files) (log-edit-files)) + (message (substitute-command-keys + "Press \\[log-edit-done] when you are done editing."))) + +(define-derived-mode log-edit-mode text-mode "Log-Edit" + "Major mode for entering commit messages. +This mode is intended for entering messages in a *cvs-commit* +buffer when using PCL-CVS. It provides a binding for the +\\[log-edit-done] command that should be used when done editing +to trigger the actual commit, as well as a few handy support +commands. +\\{log-edit-mode-map}") + +(defun log-edit-hide-buf (&optional buf where) + (when (setq buf (get-buffer (or buf log-edit-files-buf))) + (let ((win (get-buffer-window buf where))) + (if win (ignore-errors (delete-window win)))) + (bury-buffer buf))) + +(defun log-edit-done () + "Finish editing the log message and commit the files. +This can only be used in the *cvs-commit* buffer. +With a prefix argument, prompt for cvs commit flags. +If you want to abort the commit, simply delete the buffer." + (interactive) + (if (and (> (point-max) 1) + (/= (char-after (1- (point-max))) ?\n) + (or (eq log-edit-require-final-newline t) + (and log-edit-require-final-newline + (y-or-n-p + (format "Buffer %s does not end in newline. Add one? " + (buffer-name)))))) + (save-excursion + (goto-char (point-max)) + (insert ?\n))) + (if (boundp 'vc-comment-ring) (ring-insert vc-comment-ring (buffer-string))) + (let ((win (get-buffer-window log-edit-files-buf))) + (if (and log-edit-confirm + (not (and (eq log-edit-confirm 'changed) + (equal (log-edit-files) log-edit-initial-files))) + (progn + (log-edit-show-files) + (not (y-or-n-p "Really commit ? ")))) + (progn (when (not win) (log-edit-hide-buf)) + (message "Oh, well! Later maybe?")) + (run-hooks 'log-edit-done-hook) + (log-edit-hide-buf) + (unless log-edit-keep-buffer + (cvs-bury-buffer (current-buffer) + (when (boundp 'cvs-buffer) cvs-buffer))) + (call-interactively log-edit-callback)))) + +(defun log-edit-files () + "Return the list of files that are about to be committed." + (ignore-errors (funcall log-edit-listfun))) + + +(defun log-edit-insert-changelog () + "Insert a log message by looking at the ChangeLog. +The idea is to write your ChangeLog entries first, and then use this +command to commit your changes. + +To select default log text, we: +- find the ChangeLog entries for the files to be checked in, +- verify that the top entry in the ChangeLog is on the current date + and by the current user; if not, we don't provide any default text, +- search the ChangeLog entry for paragraphs containing the names of + the files we're checking in, and finally +- use those paragraphs as the log text." + (interactive) + (cvs-insert-changelog-entries (log-edit-files)) + (log-edit-delete-common-indentation)) + +(defun log-edit-mode-help () + "Provide help for the `log-edit-mode-map'." + (interactive) + (if (eq last-command 'log-edit-mode-help) + (describe-function major-mode) + (message + (substitute-command-keys + "Type `\\[log-edit-done]' to finish commit. Try `\\[describe-function] log-edit-done' for more help.")))) + +(defun log-edit-delete-common-indentation () + "Unindent the current buffer rigidly until at least one line is flush left." + (save-excursion + (let ((common (point-max))) + (goto-char (point-min)) + (while (< (point) (point-max)) + (if (not (looking-at "^[ \t]*$")) + (setq common (min common (current-indentation)))) + (forward-line 1)) + (indent-rigidly (point-min) (point-max) (- common))))) + +(defun log-edit-show-files () + "Show the list of files to be committed." + (interactive) + (let* ((files (log-edit-files)) + (editbuf (current-buffer)) + (buf (get-buffer-create "*log-edit-files*"))) + (with-current-buffer buf + (log-edit-hide-buf buf 'all) + (setq buffer-read-only nil) + (erase-buffer) + (insert (mapconcat 'identity files "\n")) + (setq buffer-read-only t) + (goto-char (point-min)) + (save-selected-window + (cvs-pop-to-buffer-same-frame buf) + (shrink-window-if-larger-than-buffer) + (selected-window))))) + +(defun log-edit-insert-cvs-template () + "Insert the template specified by the CVS administrator, if any." + (interactive) + (when (file-readable-p "CVS/Template") + (insert-file-contents "CVS/Template"))) + + +(defun log-edit-add-to-changelog () + "Insert this log message into the appropriate ChangeLog file." + (interactive) + ;; Yuck! + (unless (string= (buffer-string) (ring-ref vc-comment-ring 0)) + (ring-insert vc-comment-ring (buffer-string))) + (dolist (f (log-edit-files)) + (let ((buffer-file-name (expand-file-name f))) + (save-excursion + (vc-comment-to-change-log))))) + +;;;; +;;;; functions for getting commit message from ChangeLog a file... +;;;; Courtesy Jim Blandy +;;;; + +(defun cvs-narrow-changelog () + "Narrow to the top page of the current buffer, a ChangeLog file. +Actually, the narrowed region doesn't include the date line. +A \"page\" in a ChangeLog file is the area between two dates." + (or (eq major-mode 'change-log-mode) + (error "cvs-narrow-changelog: current buffer isn't a ChangeLog")) + + (goto-char (point-min)) + + ;; Skip date line and subsequent blank lines. + (forward-line 1) + (if (looking-at "[ \t\n]*\n") + (goto-char (match-end 0))) + + (let ((start (point))) + (forward-page 1) + (narrow-to-region start (point)) + (goto-char (point-min)))) + +(defun cvs-changelog-paragraph () + "Return the bounds of the ChangeLog paragraph containing point. +If we are between paragraphs, return the previous paragraph." + (save-excursion + (beginning-of-line) + (if (looking-at "^[ \t]*$") + (skip-chars-backward " \t\n" (point-min))) + (list (progn + (if (re-search-backward "^[ \t]*\n" nil 'or-to-limit) + (goto-char (match-end 0))) + (point)) + (if (re-search-forward "^[ \t\n]*$" nil t) + (match-beginning 0) + (point))))) + +(defun cvs-changelog-subparagraph () + "Return the bounds of the ChangeLog subparagraph containing point. +A subparagraph is a block of non-blank lines beginning with an asterisk. +If we are between sub-paragraphs, return the previous subparagraph." + (save-excursion + (end-of-line) + (if (search-backward "*" nil t) + (list (progn (beginning-of-line) (point)) + (progn + (forward-line 1) + (if (re-search-forward "^[ \t]*[\n*]" nil t) + (match-beginning 0) + (point-max)))) + (list (point) (point))))) + +(defun cvs-changelog-entry () + "Return the bounds of the ChangeLog entry containing point. +The variable `cvs-changelog-full-paragraphs' decides whether an +\"entry\" is a paragraph or a subparagraph; see its documentation string +for more details." + (if cvs-changelog-full-paragraphs + (cvs-changelog-paragraph) + (cvs-changelog-subparagraph))) + +(defvar user-full-name) +(defvar user-mail-address) +(defun cvs-changelog-ours-p () + "See if ChangeLog entry at point is for the current user, today. +Return non-nil iff it is." + ;; Code adapted from add-change-log-entry. + (let ((name (or (and (boundp 'add-log-full-name) add-log-full-name) + (and (fboundp 'user-full-name) (user-full-name)) + (and (boundp 'user-full-name) user-full-name))) + (mail (or (and (boundp 'add-log-mailing-address) add-log-mailing-address) + ;;(and (fboundp 'user-mail-address) (user-mail-address)) + (and (boundp 'user-mail-address) user-mail-address))) + (time (or (and (boundp 'add-log-time-format) + (functionp add-log-time-format) + (funcall add-log-time-format)) + (format-time-string "%Y-%m-%d")))) + (looking-at (regexp-quote (format "%s %s <%s>" time name mail))))) + +(defun cvs-changelog-entries (file) + "Return the ChangeLog entries for FILE, and the ChangeLog they came from. +The return value looks like this: + (LOGBUFFER (ENTRYSTART . ENTRYEND) ...) +where LOGBUFFER is the name of the ChangeLog buffer, and each +\(ENTRYSTART . ENTRYEND\) pair is a buffer region." + (save-excursion + (let ((changelog-file-name + (let ((default-directory + (file-name-directory (expand-file-name file)))) + ;; `find-change-log' uses `change-log-default-name' if set + ;; and sets it before exiting, so we need to work around + ;; that memoizing which is undesired here + (setq change-log-default-name nil) + (find-change-log)))) + (set-buffer (find-file-noselect changelog-file-name)) + (unless (eq major-mode 'change-log-mode) (change-log-mode)) + (goto-char (point-min)) + (if (looking-at "\\s-*\n") (goto-char (match-end 0))) + (if (not (cvs-changelog-ours-p)) + (list (current-buffer)) + (save-restriction + (cvs-narrow-changelog) + (goto-char (point-min)) + + ;; Search for the name of FILE relative to the ChangeLog. If that + ;; doesn't occur anywhere, they're not using full relative + ;; filenames in the ChangeLog, so just look for FILE; we'll accept + ;; some false positives. + (let ((pattern (file-relative-name + file (file-name-directory changelog-file-name)))) + (if (or (string= pattern "") + (not (save-excursion + (search-forward pattern nil t)))) + (setq pattern (file-name-nondirectory file))) + + (let (texts) + (while (search-forward pattern nil t) + (let ((entry (cvs-changelog-entry))) + (push entry texts) + (goto-char (elt entry 1)))) + + (cons (current-buffer) texts)))))))) + +(defun cvs-changelog-insert-entries (buffer regions) + "Insert those regions in BUFFER specified in REGIONS. +Sort REGIONS front-to-back first." + (let ((regions (sort regions 'car-less-than-car)) + (last)) + (dolist (region regions) + (when (and last (< last (car region))) (newline)) + (setq last (elt region 1)) + (apply 'insert-buffer-substring buffer region)))) + +(defun cvs-insert-changelog-entries (files) + "Given a list of files FILES, insert the ChangeLog entries for them." + (let ((buffer-entries nil)) + + ;; Add each buffer to buffer-entries, and associate it with the list + ;; of entries we want from that file. + (dolist (file files) + (let* ((entries (cvs-changelog-entries file)) + (pair (assq (car entries) buffer-entries))) + (if pair + (setcdr pair (cvs-union (cdr pair) (cdr entries))) + (push entries buffer-entries)))) + + ;; Now map over each buffer in buffer-entries, sort the entries for + ;; each buffer, and extract them as strings. + (dolist (buffer-entry buffer-entries) + (cvs-changelog-insert-entries (car buffer-entry) (cdr buffer-entry)) + (when (cdr buffer-entry) (newline))))) + +(provide 'log-edit) +;;; log-edit.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/log-view.el Sat Mar 11 03:51:31 2000 +0000 @@ -0,0 +1,189 @@ +;;; log-view.el --- Major mode for browsing CVS log output + +;; Copyright (C) 1999-2000 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@cs.yale.edu> +;; Keywords: pcl-cvs cvs log +;; Version: $Name: $ +;; Revision: $Id: log-view.el,v 1.2 2000/03/03 20:58:09 monnier Exp $ + +;; 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Todo: + +;; - extract version info in log-view-current-tag +;; - add support for SCCS' output format +;; - add compatibility with cvs-log.el +;; - add ability to modify a log-entry (via cvs-mode-admin ;-) + +;;; Code: + +(eval-when-compile (require 'cl)) +;;(require 'pcvs-defs) +(require 'pcvs-util) + + +(defgroup log-view nil + "Major mode for browsing log output for PCL-CVS." + :group 'pcl-cvs + :prefix "log-view-") + +(easy-mmode-defmap log-view-mode-map + '(("n" . log-view-next-message) + ("N" . log-view-next-file) + ("M-n" . log-view-next-file) + ("p" . log-view-prev-message) + ("P" . log-view-prev-file) + ("M-p" . log-view-prev-file)) + "Log-View's keymap." + :group 'log-view + :inherit 'cvs-mode-map) + +(defvar log-view-mode-hook nil + "Hook run at the end of `log-view-mode'.") + +(defface log-view-file-face + '((((class color) (background light)) + (:background "grey70" :bold t)) + (t (:bold t))) + "Face for the file header line in `log-view-mode'." + :group 'log-view) +(defvar log-view-file-face 'log-view-file-face) + +(defface log-view-message-face + '((((class color) (background light)) + (:background "grey85")) + (t (:bold t))) + "Face for the message header line in `log-view-mode'." + :group 'log-view) +(defvar log-view-message-face 'log-view-message-face) + +(defconst log-view-file-re + (concat "^\\(" + "Working file: \\(.+\\)" + "\\|SCCS/s\\.\\(.+\\):" + "\\)\n")) +(defconst log-view-message-re "^----------------------------$") + +(defconst log-view-font-lock-keywords + `((,log-view-file-re + (2 'cvs-filename-face nil t) + (3 'cvs-filename-face nil t) + (0 'log-view-file-face append)) + (,log-view-message-re . log-view-message-face))) +(defconst log-view-font-lock-defaults + '(log-view-font-lock-keywords t nil nil nil)) + +;;;; +;;;; Actual code +;;;; + +;;;###autoload +(autoload 'log-view-mode "log-view" "Major mode for browsing CVS log output." t) +(eval-when-compile (autoload 'easy-mmode-define-derived-mode "easy-mmode")) +(easy-mmode-define-derived-mode log-view-mode fundamental-mode "Log-View" + "Major mode for browsing CVS log output." + (set (make-local-variable 'font-lock-defaults) log-view-font-lock-defaults) + (set (make-local-variable 'cvs-minor-wrap-function) 'log-view-minor-wrap)) + +;;;; +;;;; Navigation +;;;; + +(defun log-view-next-message (&optional count) + "Move to next (COUNT'th) log message." + (interactive "p") + (unless count (setq count 1)) + (if (< count 0) (log-view-prev-message (- count)) + (when (looking-at log-view-message-re) (incf count)) + (re-search-forward log-view-message-re nil nil count) + (goto-char (match-beginning 0)))) + +(defun log-view-next-file (&optional count) + "Move to next (COUNT'th) file." + (interactive "p") + (unless count (setq count 1)) + (if (< count 0) (log-view-prev-file (- count)) + (when (looking-at log-view-file-re) (incf count)) + (re-search-forward log-view-file-re nil nil count) + (goto-char (match-beginning 0)))) + +(defun log-view-prev-message (&optional count) + "Move to previous (COUNT'th) log message." + (interactive "p") + (unless count (setq count 1)) + (if (< count 0) (log-view-next-message (- count)) + (re-search-backward log-view-message-re nil nil count))) + +(defun log-view-prev-file (&optional count) + "Move to previous (COUNT'th) file." + (interactive "p") + (unless count (setq count 1)) + (if (< count 0) (log-view-next-file (- count)) + (re-search-backward log-view-file-re nil nil count))) + +;;;; +;;;; Linkage to PCL-CVS (mostly copied from cvs-status.el) +;;;; + +(defconst log-view-dir-re "^cvs[.ex]* [a-z]+: Logging \\(.+\\)$") + +(defun log-view-current-file () + (save-excursion + (forward-line 1) + (or (re-search-backward log-view-file-re nil t) + (re-search-forward log-view-file-re)) + (let* ((file (or (match-string 2) (match-string 3))) + (cvsdir (and (re-search-backward log-view-dir-re nil t) + (match-string 1))) + (pcldir (and (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 log-view-current-tag () + nil);; FIXME + +(defun log-view-minor-wrap (buf f) + (let ((data (with-current-buffer buf + (cons + (cons (log-view-current-file) + (log-view-current-tag)) + (when (ignore-errors (mark)) + ;; `mark-active' is not provided by XEmacs :-( + (save-excursion + (goto-char (mark)) + (cons (log-view-current-file) + (log-view-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)))) + +(provide 'log-view) +;;; log-view.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/pcvs-defs.el Sat Mar 11 03:51:31 2000 +0000 @@ -0,0 +1,501 @@ +;;; pcvs-defs.el --- variable definitions for PCL-CVS + +;; Copyright (C) 1991-2000 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@cs.yale.edu> +;; Keywords: pcl-cvs +;; Version: $Name: $ +;; Revision: $Id: pcl-cvs-defs.el,v 1.27 2000/03/03 20:58:09 monnier Exp $ + +;; 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + + +;;; Code: + +(defconst pcl-cvs-version "$Name: $") + +(eval-when-compile (require 'cl)) +(require 'pcvs-util) + +;;;; ------------------------------------------------------- +;;;; START OF THINGS TO CHECK WHEN INSTALLING + +(defvar cvs-program "cvs" + "*Name or full path of the cvs executable.") + +(defvar cvs-version + (ignore-errors + (with-temp-buffer + (call-process "cvs" nil t nil "-v") + (goto-char (point-min)) + (when (re-search-forward "(CVS) \\([0-9]+\\)\\.\\([0-9]+\\)" nil t) + (cons (string-to-number (match-string 1)) + (string-to-number (match-string 2)))))) + "*Version of `cvs' installed on your system. +It must be in the (MAJOR . MINOR) format.") + +;; FIXME: this is only used by cvs-mode-diff-backup +(defvar cvs-diff-program (or (and (boundp 'diff-command) diff-command) "diff") + "*Name or full path of the best diff program you've got. +NOTE: there are some nasty bugs in the context diff variants of some vendor +versions, such as the one in SunOS-4.") + +;;;; END OF THINGS TO CHECK WHEN INSTALLING +;;;; -------------------------------------------------------- + +;;;; +;;;; User configuration variables: +;;;; +;;;; NOTE: these should be set in your ~/.emacs (or site-lisp/default.el) file. +;;;; + +(defgroup pcl-cvs nil + "Special support for the CVS versioning system." + :group 'tools + :prefix "cvs-") + +;; +;; cvsrc options +;; + +(defcustom cvs-cvsrc-file "~/.cvsrc" + "Path to your cvsrc file." + :group 'pcl-cvs + :type '(file)) + +(defvar cvs-shared-start 4 + "Index of the first shared flag. +If set to 4, for instance, a numeric argument smaller than 4 will +select a non-shared flag, while a numeric argument greater than 3 +will select a shared-flag.") + +(defvar cvs-shared-flags (make-list cvs-shared-start nil) + "List of flags whose settings is shared among several commands.") + +(defvar cvs-cvsroot nil + "*Specifies where the (current) cvs master repository is. +Overrides the environment variable $CVSROOT by sending \" -d dir\" to +all CVS commands. This switch is useful if you have multiple CVS +repositories. It can be set interactively with \\[cvs-change-cvsroot.] +There is no need to set this if $CVSROOT is set to a correct value.") + +(defcustom cvs-auto-remove-handled nil + "*If up-to-date files should be acknowledged automatically. +If T, they will be removed from the *cvs* buffer after every command. +If DELAYED, they will be removed from the *cvs* buffer before every command. +If STATUS, they will only be removed after a `cvs-mode-status' command. +Else, they will never be automatically removed from the *cvs* buffer." + :group 'pcl-cvs + :type '(choice (const nil) (const status) (const delayed) (const t))) + +(defcustom cvs-auto-remove-directories 'handled + "*If ALL, directory entries will never be shown. +If HANLDED, only non-handled directories will be shown. +If EMPTY, only non-empty directories will be shown." + :group 'pcl-cvs + :type '(choice (const :tag "No" nil) (const all) (const handled) (const empty))) + +(defcustom cvs-auto-revert t + "*Non-nil if changed files should automatically be reverted." + :group 'pcl-cvs + :type '(boolean)) + +(defcustom cvs-sort-ignore-file t + "*Non-nil if `cvs-mode-ignore' should sort the .cvsignore automatically." + :group 'pcl-cvs + :type '(boolean)) + +(defcustom cvs-force-dir-tag t + "*If non-nil, tagging can only be applied to directories. +Tagging should generally be applied a directory at a time, but sometimes it is +useful to be able to tag a single file. The normal way to do that is to use +`cvs-mode-force-command' so as to temporarily override the restrictions," + :group 'pcl-cvs + :type '(boolean)) + +(defcustom cvs-default-ignore-marks nil + "*Non-nil if cvs mode commands should ignore any marked files. +Normally they run on the files that are marked (with `cvs-mode-mark'), +or the file under the cursor if no files are marked. If this variable +is set to a non-nil value they will by default run on the file on the +current line. See also `cvs-ignore-marks'" + :group 'pcl-cvs + :type '(boolean)) + +(defvar cvs-diff-ignore-marks t + "Obsolete variable: use cvs-ignore-marks instead.") + +(defcustom cvs-invert-ignore-marks + (let ((l ())) + (unless (equal cvs-diff-ignore-marks cvs-default-ignore-marks) + (push "diff" l)) + (when (and cvs-force-dir-tag (not cvs-default-ignore-marks)) + (push "tag" l)) + l) + "*List of cvs commands that invert the default ignore-mark behavior. +Commands in this set will use the opposite default from the one set +in `cvs-default-ignore-marks'." + :group 'pcl-cvs + :type '(set (const "diff") + (const "tag") + (const "ignore"))) + +(defcustom cvs-confirm-removals t + "*Ask for confirmation before removing files. +Non-nil means that PCL-CVS will ask confirmation before removing files +except for files whose content can readily be recovered from the repository. +A value of LIST means that the list of files to be deleted will be +displayed when asking for confirmation." + :group 'pcl-cvs + :type '(choice (const list) + (const t) + (const nil))) + +(defcustom cvs-add-default-message nil + "*Default message to use when adding files. +If set to NIL, `cvs-mode-add' will always prompt for a message." + :group 'pcl-cvs + :type '(choice (const :tag "Prompt" nil) + (string))) + +(defvar cvs-diff-buffer-name "*cvs-diff*" + "Obsolete variable: use `cvs-buffer-name-alist' instead.") + +(defcustom cvs-find-file-and-jump t + "Jump to the modified area when finding a file. +If non-nil, `cvs-mode-file-file' will place the cursor at the beginning of +the modified area. If the file is not locally modified, this will obviously +have no effect." + :group 'pcl-cvs + :type '(boolean)) + +(defcustom cvs-buffer-name-alist + '(("diff" cvs-diff-buffer-name diff-mode) + ("status" "*cvs-info*" cvs-status-mode) + ("tree" (format "*cvs-%s*" cmd) cvs-status-mode) + ("message" "*cvs-commit*" nil log-edit) + ("log" "*cvs-info*" log-view-mode)) + "*Buffer name and mode to be used for each command. +This is a list of elements of the form + + (CMD BUFNAME MODE &optional POSTPROC) + +CMD is the name of the command. +BUFNAME is an expression that should evaluate to a string used as + a buffer name. It can use the variable CMD if it wants to. +MODE is the command to use to setup the buffer. +POSTPROC is a function that should be executed when the command terminates + +The CMD used for `cvs-mode-commit' is \"message\". For that special + case, POSTPROC is called just after MODE with special arguments." + :group 'pcl-cvs + :type '(repeat + (list (choice (const "diff") + (const "status") + (const "tree") + (const "message") + (const "log") + (string)) + (choice (const "*vc-diff*") + (const "*cvs-info*") + (const "*cvs-commit*") + (const (expand-file-name "*cvs-commit*")) + (const (format "*cvs-%s*" cmd)) + (const (expand-file-name (format "*cvs-%s*" cmd))) + (sexp :value "my-cvs-info-buffer") + (const nil)) + (choice (function-item diff-mode) + (function-item cvs-edit-mode) + (function-item cvs-status-mode) + function + (const nil)) + (set :inline t + (choice (function-item cvs-status-cvstrees) + (function-item cvs-status-trees) + function))))) + +(defvar cvs-buffer-name '(expand-file-name "*cvs*" dir) ;; "*cvs*" + "Name of the cvs buffer. +This expression will be evaluated in an environment where DIR is set to +the directory name of the cvs buffer.") + +(defvar cvs-temp-buffer-name '(expand-file-name " *cvs-tmp*" dir) + "*Name of the cvs temporary buffer. +Output from cvs is placed here for asynchronous commands.") + +(defcustom cvs-idiff-imerge-handlers + (if (fboundp 'ediff) + '(cvs-ediff-diff . cvs-ediff-merge) + '(cvs-emerge-diff . cvs-emerge-merge)) + "*Pair of functions to be used for resp. diff'ing and merg'ing interactively." + :group 'pcl-cvs + :type '(choice (const :tag "Ediff" (cvs-ediff-diff . cvs-ediff-merge)) + (const :tag "Emerge" (cvs-emerge-diff . cvs-emerge-merge)))) + +(defvar pcl-cvs-load-hook nil + "Run after loading pcl-cvs.") + +(defvar cvs-mode-hook nil + "Run after `cvs-mode' was setup.") + + +;;;; +;;;; Internal variables, used in the process buffer. +;;;; + +(defvar cvs-postprocess nil + "(Buffer local) what to do once the process exits.") + +;;;; +;;;; Internal variables for the *cvs* buffer. +;;;; + +(defcustom cvs-reuse-cvs-buffer 'subdir + "When to reuse an existing cvs buffer. +Alternatives are: + CURRENT: just reuse the current buffer if it is a cvs buffer + SAMEDIR: reuse any cvs buffer displaying the same directory + SUBDIR: or reuse any cvs buffer displaying any sub- or super- directory + ALWAYS: reuse any cvs buffer." + :group 'pcl-cvs + :type '(choice (const always) (const subdir) (const samedir) (const current))) + +(defvar cvs-temp-buffer nil + "(Buffer local) The temporary buffer associated with this *cvs* buffer.") + +(defvar cvs-lock-file nil + "Full path to a lock file that CVS is waiting for (or was waiting for). +This variable is buffer local and only used in the *cvs* buffer.") + +(defvar cvs-lock-file-regexp "^#cvs\\.\\([trw]fl\\.[-.a-z0-9]+\\|lock\\)\\'" + "Regexp matching the possible names of locks in the CVS repository.") + +(defconst cvs-cursor-column 22 + "Column to position cursor in in `cvs-mode'.") + +;;;; +;;;; Global internal variables +;;;; + +(defconst cvs-startup-message + (concat "PCL-CVS release " pcl-cvs-version) + "*Startup message for CVS.") + +(defconst cvs-vendor-branch "1.1.1" + "The default branch used by CVS for vendor code.") + +(defvar cvs-menu + '("CVS" + ["Open File.." cvs-mode-find-file t] + [" ..Other Window" cvs-mode-find-file-other-window t] + ["Interactive Merge" cvs-mode-imerge t] + ["Interactive Diff" cvs-mode-idiff t] + ["View Diff" cvs-mode-diff (cvs-enabledp 'diff)] + ["Diff with Vendor" cvs-mode-diff-vendor t] + ["Diff with Backup" cvs-mode-diff-backup t] + ["View Log" cvs-mode-log t] + ["View Status" cvs-mode-status t] + "----" + ["Update" cvs-mode-update (cvs-enabledp 'update)] + ["Re-Examine" cvs-mode-examine t] + ["Commit" cvs-mode-commit-setup (cvs-enabledp 'commit)] + ["Undo Changes" cvs-mode-undo (cvs-enabledp 'undo)] + ["Add" cvs-mode-add (cvs-enabledp 'add)] + ["Remove" cvs-mode-remove (cvs-enabledp 'remove)] + ["Ignore" cvs-mode-ignore (cvs-enabledp 'ignore)] + ["Add ChangeLog" cvs-mode-add-change-log-entry-other-window t] + "----" + ["Mark All" cvs-mode-mark-all-files t] + ["Unmark All" cvs-mode-unmark-all-files t] + ["Hide Handled" cvs-mode-remove-handled t] + "----" + ;; ["Update Directory" cvs-update t] + ;; ["Examine Directory" cvs-examine t] + ;; ["Status Directory" cvs-status t] + ;; ["Checkout Module" cvs-checkout t] + ;; "----" + ["Quit" cvs-mode-quit t] + )) + +(easy-mmode-defmap cvs-mode-diff-map + '(("=" . cvs-mode-diff) + ("b" . cvs-mode-diff-backup) + ("2" . cvs-mode-idiff-other) + ("h" . cvs-mode-diff-head) + ("v" . cvs-mode-diff-vendor) + ("?" . cvs-mode-diff-help) + ("e" . cvs-mode-idiff) + ("E" . cvs-mode-imerge)) + "Keymap for diff-related operations in `cvs-mode'.") + +(easy-mmode-defmap cvs-mode-map + ;;(define-prefix-command 'cvs-mode-map-diff-prefix) + ;;(define-prefix-command 'cvs-mode-map-control-c-prefix) + `(;; simulate `suppress-keymap' + (self-insert-command . undefined) + (("0" "1" "2" "3" "4" "5" "6" "7" "8" "9") . digit-argument) + ("-" . negative-argument) + ;; various + (undo . cvs-mode-undo) + ("?" . cvs-help) + ("h" . cvs-help) + ("q" . cvs-bury-buffer) + ;;("Q" . kill-buffer) + ("F" . cvs-mode-set-flags) + ("\M-f" . cvs-mode-force-command) + ("\C-c\C-c" . cvs-mode-kill-process) + ;; marking + ("m" . cvs-mode-mark) + ("M" . cvs-mode-mark-all-files) + ("u" . cvs-mode-unmark) + ("\C-?". cvs-mode-unmark-up) + ("%" . cvs-mode-mark-matching-files) + ("T" . cvs-mode-toggle-marks) + ("\M-\C-?" . cvs-mode-unmark-all-files) + ;; navigation keys + (" " . cvs-mode-next-line) + ("n" . cvs-mode-next-line) + ("p" . cvs-mode-previous-line) + ;; M- keys are usually those that operate on modules + ;;("\M-C". cvs-mode-rcs2log) ; i.e. "Create a ChangeLog" + ;;("\M-t". cvs-rtag) + ;;("\M-l". cvs-rlog) + ("\M-c". cvs-checkout) + ("\M-e". cvs-examine) + ("g" . cvs-mode-revert-buffer) + ("\M-u". cvs-update) + ("\M-s". cvs-status) + ;; diff commands + ("=" . cvs-mode-diff) + ("d" . ,cvs-mode-diff-map) + ;; keys that operate on individual files + ("\C-k". cvs-mode-acknowledge) + ("A" . cvs-mode-add-change-log-entry-other-window) + ;;("B" . cvs-mode-byte-compile-files) + ("C" . cvs-mode-commit-setup) + ("O" . cvs-mode-update) + ("U" . cvs-mode-undo) + ("I" . cvs-mode-insert) + ("a" . cvs-mode-add) + ("b" . cvs-set-branch-prefix) + ("B" . cvs-set-secondary-branch-prefix) + ("c" . cvs-mode-commit) + ("e" . cvs-mode-examine) + ("f" . cvs-mode-find-file) + ("i" . cvs-mode-ignore) + ("l" . cvs-mode-log) + ("o" . cvs-mode-find-file-other-window) + ("r" . cvs-mode-remove) + ("s" . cvs-mode-status) + ("t" . cvs-mode-tag) + ;;("v" . cvs-mode-diff-vendor) + ("x" . cvs-mode-remove-handled) + ;; cvstree bindings + ("+" . cvs-mode-tree) + ;; mouse bindings + ([(down-mouse-3)] . cvs-menu) + ;; Emacs-21 toolbar + ;;([tool-bar item1] . (menu-item "Examine" cvs-examine :image (image :file "/usr/share/icons/xpaint.xpm" :type xpm))) + ;;([tool-bar item2] . (menu-item "Update" cvs-update :image (image :file "/usr/share/icons/mail1.xpm" :type xpm))) + ) + "Keymap for `cvs-mode'." + :dense t) + +(fset 'cvs-mode-map cvs-mode-map) + +;; add the cvs-menu to the map so it's added whenever we are in cvs-mode +(when (ignore-errors (require 'easymenu)) + (easy-menu-define cvs-menu-map + cvs-mode-map + "Menu used in cvs-mode." + cvs-menu)) + +;;;; +;;;; CVS-Minor mode +;;;; + +(defcustom cvs-minor-mode-prefix "\C-xc" + "Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'." + :group 'pcl-cvs) + +(easy-mmode-defmap cvs-minor-mode-map + `((,cvs-minor-mode-prefix . cvs-mode-map)) + "Keymap for `cvs-minor-mode', used in buffers related to pcl-cvs.") + +(defvar cvs-buffer nil + "(Buffer local) The *cvs* buffer associated with this buffer.") +(put 'cvs-buffer 'permanent-local t) +;;(make-variable-buffer-local 'cvs-buffer) + +(defvar cvs-minor-wrap-function nil + "Function to call when switching to the *cvs* buffer. +Takes two arguments: +- a *cvs* buffer. +- a zero-arg function which is guaranteed not to switch buffer. +It is expected to call the function.") +;;(make-variable-buffer-local 'cvs-minor-wrap-function) + +(defvar cvs-minor-current-files) +;;"Current files in a `cvs-minor-mode' buffer." +;; This should stay `void' because we want to be able to tell the difference +;; between an empty list and no list at all. + +(defconst cvs-pcl-cvs-dirchange-re "^pcl-cvs: descending directory \\(.*\\)$") + +;;;; +;;;; +;;;; + +;;;###autoload +(if (progn (condition-case () (require 'easymenu) (error nil)) + (fboundp 'easy-menu-add-item)) + (easy-menu-add-item nil '("tools") + '("PCL CVS" + ["Update Directory" cvs-update t] + ["Examine Directory" cvs-examine t] + ["Status Directory" cvs-status t] + ["Checkout Module" cvs-checkout t]) "vc")) + + +;; cvs-1.10 and above can take file arguments in other directories +;; while others need to be executed once per directory +(defvar cvs-execute-single-dir + (if (and (consp cvs-version) + (or (>= (cdr cvs-version) 10) (> (car cvs-version) 1))) + '("status") + t) + "Whether cvs commands should be executed a directory at a time. +If a list, specifies for which commands the single-dir mode should be used. +If T, single-dir mode should be used for all operations. + +CVS versions before 1.10 did not allow passing them arguments in different +directories, so pcl-cvs checks what version you're using to determine +whether to use the new feature or not. +Sadly, even with a new cvs executable, if you connect to an older cvs server +\(typically a cvs-1.9 on the server), the old restriction applies. In such +a case the sanity check made by pcl-cvs fails and you will have to manually +set this variable to T (until the cvs server is upgraded). +When the above problem occurs, pcl-cvs should (hopefully) catch cvs' error +message and replace it with a message tell you to change this variable.") + +;; +(provide 'pcvs-defs) + +;;; pcl-cvs-defs.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/pcvs-info.el Sat Mar 11 03:51:31 2000 +0000 @@ -0,0 +1,455 @@ +;;; pcvs-info.el --- Internal representation of a fileinfo entry + +;; Copyright (C) 1991-2000 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@cs.yale.edu> +;; Keywords: pcl-cvs +;; Version: $Name: $ +;; Revision: $Id: pcl-cvs-info.el,v 1.28 2000/03/05 21:32:21 monnier Exp $ + +;; 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; The cvs-fileinfo data structure: +;; +;; When the `cvs update' is ready we parse the output. Every file +;; that is affected in some way is added to the cookie collection as +;; a "fileinfo" (as defined below in cvs-create-fileinfo). + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'pcvs-util) +;;(require 'pcvs-defs) + +;;;; +;;;; config variables +;;;; + +(defcustom cvs-display-full-path t + "*Specifies how the filenames should look like in the listing. +If t, their full path name will be displayed, else only the filename." + :group 'pcl-cvs + :type '(boolean)) + +(defvar global-font-lock-mode) +(defvar font-lock-auto-fontify) +(defcustom cvs-highlight + (or (and (boundp 'font-lock-auto-fontify) font-lock-auto-fontify) + (and (boundp 'global-font-lock-mode) global-font-lock-mode)) + "*Whether to use text highlighting (à la font-lock) or not." + :group 'pcl-cvs + :type '(boolean)) + +(defcustom cvs-allow-dir-commit nil + "*Allow `cvs-mode-commit' on directories. +If you commit without any marked file and with the cursor positioned +on a directory entry, cvs would commit the whole directory. This seems +to confuse some users sometimes." + :group 'pcl-cvs + :type '(boolean)) + + +;;;; +;;;; Faces for fontification +;;;; + +(defface cvs-header-face + '((((class color) (background dark)) + (:foreground "lightyellow" :bold t)) + (((class color) (background light)) + (:foreground "blue4" :bold t)) + (t (:bold t))) + "PCL-CVS face used to highlight directory changes." + :group 'pcl-cvs) + +(defface cvs-filename-face + '((((class color) (background dark)) + (:foreground "lightblue")) + (((class color) (background light)) + (:foreground "blue4")) + (t ())) + "PCL-CVS face used to highlight file names." + :group 'pcl-cvs) + +(defface cvs-unknown-face + '((((class color) (background dark)) + (:foreground "red")) + (((class color) (background light)) + (:foreground "red")) + (t (:italic t))) + "PCL-CVS face used to highlight unknown file status." + :group 'pcl-cvs) + +(defface cvs-handled-face + '((((class color) (background dark)) + (:foreground "pink")) + (((class color) (background light)) + (:foreground "pink")) + (t ())) + "PCL-CVS face used to highlight handled file status." + :group 'pcl-cvs) + +(defface cvs-need-action-face + '((((class color) (background dark)) + (:foreground "orange")) + (((class color) (background light)) + (:foreground "orange")) + (t (:italic t))) + "PCL-CVS face used to highlight status of files needing action." + :group 'pcl-cvs) + +(defface cvs-marked-face + '((((class color) (background dark)) + (:foreground "green" :bold t)) + (((class color) (background light)) + (:foreground "green3" :bold t)) + (t (:bold t))) + "PCL-CVS face used to highlight marked file indicator." + :group 'pcl-cvs) + +(defface cvs-msg-face + '((t (:italic t))) + "PCL-CVS face used to highlight CVS messages." + :group 'pcl-cvs) + + +;; There is normally no need to alter the following variable, but if +;; your site has installed CVS in a non-standard way you might have +;; to change it. + +(defvar cvs-bakprefix ".#" + "The prefix that CVS prepends to files when rcsmerge'ing.") + +(easy-mmode-defmap cvs-filename-map + '(([(mouse-2)] . cvs-mode-find-file)) + "Local keymap for text properties of file names" + :inherit 'cvs-mode-map) + +(easy-mmode-defmap cvs-status-map + '(([(mouse-2)] . cvs-mouse-toggle-mark)) + "Local keymap for text properties of status" + :inherit 'cvs-mode-map) + +(easy-mmode-defmap cvs-dirname-map + '(([(mouse-2)] . cvs-mode-find-file)) + "Local keymap for text properties of directory names" + :inherit 'cvs-mode-map) + +;; Constructor: + +(defstruct (cvs-fileinfo + (:constructor nil) + (:copier nil) + (:constructor -cvs-create-fileinfo (type dir file full-log + &key marked subtype + merge + base-rev + head-rev)) + (:conc-name cvs-fileinfo->)) + marked ;; t/nil. + type ;; See below + subtype ;; See below + dir ;; Relative directory the file resides in. + ;; (concat dir file) should give a valid path. + file ;; The file name sans the directory. + base-rev ;; During status: This is the revision that the + ;; working file is based on. + head-rev ;; During status: This is the highest revision in + ;; the repository. + merge ;; A cons cell containing the (ancestor . head) revisions + ;; of the merge that resulted in the current file. + ;;removed ;; t if the file no longer exists. + full-log ;; The output from cvs, unparsed. + ;;mod-time ;; Not used. + + ;; In addition to the above, the following values can be extracted: + + ;; handled ;; t if this file doesn't require further action. + ;; full-path ;; The complete relative filename. + ;; pp-name ;; The printed file name + ;; backup-file;; For MERGED and CONFLICT files after a \"cvs update\", + ;; this is a full path to the backup file where the + ;; untouched version resides. + + ;; The meaning of the type field: + + ;; Value ---Used by--- Explanation + ;; update status + ;; NEED-UPDATE x file needs update + ;; MODIFIED x x modified by you, unchanged in repository + ;; MERGED x x successful merge + ;; ADDED x x added by you, not yet committed + ;; MISSING x rm'd, but not yet `cvs remove'd + ;; REMOVED x x removed by you, not yet committed + ;; NEED-MERGE x need merge + ;; CONFLICT x conflict when merging + ;; ;;MOD-CONFLICT x removed locally, changed in repository. + ;; DIRCHANGE x x A change of directory. + ;; UNKNOWN x An unknown file. + ;; UP-TO-DATE x The file is up-to-date. + ;; UPDATED x x file copied from repository + ;; PATCHED x x diff applied from repository + ;; COMMITTED x x cvs commit'd + ;; DEAD An entry that should be removed + ;; MESSAGE x x This is a special fileinfo that is used + ;; to display a text that should be in + ;; full-log." + ;; TEMP A temporary message that should be removed + ;; HEADER A message that should stick at the top of the display + ;; FOOTER A message that should stick at the bottom of the display + ) +(defun cvs-create-fileinfo (type dir file msg &rest keys) + (cvs-check-fileinfo (apply #'-cvs-create-fileinfo type dir file msg keys))) + +;; Fake selectors: + +(defun cvs-fileinfo->full-path (fileinfo) + "Return the full path for the file that is described in FILEINFO." + (let ((dir (cvs-fileinfo->dir fileinfo))) + (if (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE) + (if (string= dir "") "." (directory-file-name dir)) + ;; Here, I use `concat' rather than `expand-file-name' because I want + ;; the resulting path to stay relative if `dir' is relative. + ;; I could also use `expand-file-name' with `default-directory = ""' + (concat dir (cvs-fileinfo->file fileinfo))))) + +(defun cvs-fileinfo->pp-name (fi) + "Return the filename of FI as it should be displayed." + (if cvs-display-full-path + (cvs-fileinfo->full-path fi) + (cvs-fileinfo->file fi))) + +(defun cvs-fileinfo->backup-file (fileinfo) + "Construct the file name of the backup file for FILEINFO." + (let* ((dir (cvs-fileinfo->dir fileinfo)) + (file (cvs-fileinfo->file fileinfo)) + (default-directory (file-name-as-directory (expand-file-name dir))) + (files (directory-files "." nil + (concat "^" (regexp-quote cvs-bakprefix) + (regexp-quote file) "\\."))) + bf) + (dolist (f files bf) + (when (and (file-readable-p f) + (or (null bf) (file-newer-than-file-p f bf))) + (setq bf (concat dir f)))))) + +;; (defun cvs-fileinfo->handled (fileinfo) +;; "Tell if this requires further action" +;; (memq (cvs-fileinfo->type fileinfo) '(UP-TO-DATE DEAD))) + + +;; Predicate: + +(defun boolp (x) (or (eq t x) (null x))) +(defun cvs-check-fileinfo (fi) + "Check FI's conformance to some conventions." + (let ((check 'none) + (type (cvs-fileinfo->type fi)) + (subtype (cvs-fileinfo->subtype fi)) + (marked (cvs-fileinfo->marked fi)) + (dir (cvs-fileinfo->dir fi)) + (file (cvs-fileinfo->file fi)) + (base-rev (cvs-fileinfo->base-rev fi)) + (head-rev (cvs-fileinfo->head-rev fi)) + (full-log (cvs-fileinfo->full-log fi))) + (if (and (setq check 'marked) (boolp marked) + (setq check 'base-rev) (or (null base-rev) (stringp base-rev)) + (setq check 'head-rev) (or (null head-rev) (stringp head-rev)) + (setq check 'full-log) (stringp full-log) + (setq check 'dir) + (and (stringp dir) + (not (file-name-absolute-p dir)) + (or (string= dir "") + (string= dir (file-name-as-directory dir)))) + (setq check 'file) + (and (stringp file) + (string= file (file-name-nondirectory file))) + (setq check 'type) (symbolp type) + (setq check 'consistency) + (case type + (DIRCHANGE (and (null subtype) (string= "." file))) + ((NEED-UPDATE ADDED MISSING DEAD MODIFIED MESSAGE UP-TO-DATE + REMOVED NEED-MERGE CONFLICT UNKNOWN MESSAGE) + t))) + fi + (error "Invalid :%s in cvs-fileinfo %s" check fi)))) + + +;;;; +;;;; State table to indicate what you can do when. +;;;; + +(defconst cvs-states + `((NEED-UPDATE update diff) + (UP-TO-DATE update nil remove diff safe-rm revert) + (MODIFIED update commit undo remove diff merge diff-base) + (ADDED update commit remove) + (MISSING remove undo update safe-rm revert) + (REMOVED commit add undo safe-rm) + (NEED-MERGE update undo diff diff-base) + (CONFLICT merge remove undo commit diff diff-base) + (DIRCHANGE remove update diff ,(if cvs-allow-dir-commit 'commit) tag) + (UNKNOWN ignore add remove) + (DEAD ) + (MESSAGE)) + "Fileinfo state descriptions for pcl-cvs. +This is an assoc list. Each element consists of (STATE . FUNS) +- STATE (described in `cvs-create-fileinfo') is the key +- FUNS is the list of applicable operations. + The first one (if any) should be the \"default\" action. +Most of the actions have the obvious meaning. +`safe-rm' indicates that the file can be removed without losing + any information.") + +;;;; +;;;; Utility functions +;;;; + +;;---------- +(defun cvs-applicable-p (fi-or-type func) + "Check if FUNC is applicable to FI-OR-TYPE. +If FUNC is nil, always return t. +FI-OR-TYPE can either be a symbol (a fileinfo-type) or a fileinfo." + (let ((type (if (symbolp fi-or-type) fi-or-type + (cvs-fileinfo->type fi-or-type)))) + (and (not (eq type 'MESSAGE)) + (eq (car (memq func (cdr (assq type cvs-states)))) func)))) + +;; (defun cvs-default-action (fileinfo) +;; "Return some kind of \"default\" action to be performed." +;; (second (assq (cvs-fileinfo->type fileinfo) cvs-states))) + +;; fileinfo pretty-printers: + +(defun cvs-add-face (str face &optional keymap) + (when cvs-highlight + (add-text-properties 0 (length str) + (list* 'face face + (when keymap + (list 'mouse-face 'highlight + 'local-map keymap))) + str)) + str) + +;;---------- +(defun cvs-fileinfo-pp (fileinfo) + "Pretty print FILEINFO. Insert a printed representation in current buffer. +For use by the cookie package." + (cvs-check-fileinfo fileinfo) + (let ((type (cvs-fileinfo->type fileinfo)) + (subtype (cvs-fileinfo->subtype fileinfo))) + (insert + (case type + (DIRCHANGE (concat "In directory " + (cvs-add-face (cvs-fileinfo->full-path fileinfo) + 'cvs-header-face cvs-dirname-map) + ":")) + (MESSAGE + (if (memq (cvs-fileinfo->subtype fileinfo) '(FOOTER HEADER)) + (cvs-fileinfo->full-log fileinfo) + (cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo)) + 'cvs-msg-face))) + (t + (let* ((status (if (cvs-fileinfo->marked fileinfo) + (cvs-add-face "*" 'cvs-marked-face) + " ")) + (file (cvs-add-face (cvs-fileinfo->pp-name fileinfo) + 'cvs-filename-face cvs-filename-map)) + (base (or (cvs-fileinfo->base-rev fileinfo) "")) + (head (cvs-fileinfo->head-rev fileinfo)) + (type + (let ((str (case type + ;;(MOD-CONFLICT "Not Removed") + (DEAD "") + (t (capitalize (symbol-name type))))) + (face (case type + (UP-TO-DATE 'cvs-handled-face) + (UNKNOWN 'cvs-unknown-face) + (t 'cvs-need-action-face)))) + (cvs-add-face str face cvs-status-map))) + (side (or + ;; maybe a subtype + (when subtype (downcase (symbol-name subtype))) + ;; or the head-rev + (when (and head (not (string= head base))) head) + ;; or nothing + "")) + ;; (action (cvs-add-face (case (cvs-default-action fileinfo) + ;; (commit "com") + ;; (update "upd") + ;; (undo "udo") + ;; (t " ")) + ;; 'cvs-action-face + ;; cvs-action-map)) + ) + (concat (cvs-string-fill side 11) " " + status " " + (cvs-string-fill type 11) " " + ;; action " " + (cvs-string-fill base 11) " " + file))))))) +;; it seems that `format' removes text-properties. Too bad! +;; (format "%-11s %s %-11s %-11s %s" +;; side status type base file))))))) + + +(defun cvs-fileinfo-update (fi fi-new) + "Update FI with the information provided in FI-NEW." + (let ((type (cvs-fileinfo->type fi-new)) + (merge (cvs-fileinfo->merge fi-new))) + (setf (cvs-fileinfo->type fi) type) + (setf (cvs-fileinfo->subtype fi) (cvs-fileinfo->subtype fi-new)) + (setf (cvs-fileinfo->full-log fi) (cvs-fileinfo->full-log fi-new)) + (setf (cvs-fileinfo->base-rev fi) (cvs-fileinfo->base-rev fi-new)) + (setf (cvs-fileinfo->head-rev fi) (cvs-fileinfo->head-rev fi-new)) + (cond + (merge (setf (cvs-fileinfo->merge fi) merge)) + ((memq type '(UP-TO-DATE NEED-UPDATE)) + (setf (cvs-fileinfo->merge fi) nil))))) + +;;---------- +(defun cvs-fileinfo< (a b) + "Compare fileinfo A with fileinfo B and return t if A is `less'. +The ordering defined by this function is such that directories are +sorted alphabetically, and inside every directory the DIRCHANGE +fileinfo will appear first, followed by all files (alphabetically)." + (let ((subtypea (cvs-fileinfo->subtype a)) + (subtypeb (cvs-fileinfo->subtype b))) + (cond + ;; keep header and footer where they belong. Note: the order is important + ((eq subtypeb 'HEADER) nil) + ((eq subtypea 'HEADER) t) + ((eq subtypea 'FOOTER) nil) + ((eq subtypeb 'FOOTER) t) + + ;; Sort according to directories. + ((string< (cvs-fileinfo->dir a) (cvs-fileinfo->dir b)) t) + ((not (string= (cvs-fileinfo->dir a) (cvs-fileinfo->dir b))) nil) + + ;; The DIRCHANGE entry is always first within the directory. + ((eq (cvs-fileinfo->type b) 'DIRCHANGE) nil) + ((eq (cvs-fileinfo->type a) 'DIRCHANGE) t) + + ;; All files are sorted by file name. + ((string< (cvs-fileinfo->file a) (cvs-fileinfo->file b)))))) + +(provide 'pcvs-info) + +;;; pcl-cvs-info.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/pcvs-parse.el Sat Mar 11 03:51:31 2000 +0000 @@ -0,0 +1,478 @@ +;;; pcvs-parse.el --- The CVS output parser + +;; Copyright (C) 1991-2000 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@cs.yale.edu> +;; Keywords: pcl-cvs +;; Version: $Name: $ +;; Revision: $Id: pcl-cvs-parse.el,v 1.41 2000/03/05 21:32:21 monnier Exp $ + +;; 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'pcvs-util) +(require 'pcvs-info) + +;; imported from pcvs.el +(defvar cvs-execute-single-dir) + +;; parse vars + +(defcustom cvs-update-prog-output-skip-regexp "$" + "*A regexp that matches the end of the output from all cvs update programs. +That is, output from any programs that are run by CVS (by the flag -u +in the `modules' file - see cvs(5)) when `cvs update' is performed should +terminate with a line that this regexp matches. It is enough that +some part of the line is matched. + +The default (a single $) fits programs without output." + :group 'pcl-cvs + :type '(regexp :value "$")) + +(defcustom cvs-parse-ignored-messages + '("Executing ssh-askpass to query the password.*$" + ".*Remote host denied X11 forwarding.*$") + "*A list of regexps matching messages that should be ignored by the parser. +Each regexp should match a whole set of lines and should hence be terminated +by `$'." + :group 'pcl-cvs + :type '(repeat regexp)) + +;; a few more defvars just to shut up the compiler +(defvar cvs-start) +(defvar cvs-current-dir) +(defvar cvs-current-subdir) +(defvar dont-change-disc) + +;;;; The parser + +(defconst cvs-parse-known-commands + '("status" "add" "commit" "update" "remove" "checkout" "ci") + "List of CVS commands whose output is understood by the parser.") + +(defun cvs-parse-buffer (parse-spec dont-change-disc &optional subdir) + "Parse current buffer according to PARSE-SPEC. +PARSE-SPEC is a function of no argument advancing the point and returning + either a fileinfo or t (if the matched text should be ignored) or + nil if it didn't match anything. +DONT-CHANGE-DISC just indicates whether the command was changing the disc + or not (useful to tell the difference btween `cvs-examine' and `cvs-update' + ouytput. +The path names should be interpreted as relative to SUBDIR (defaults + to the `default-directory'). +Return a list of collected entries, or t if an error occured." + (goto-char (point-min)) + (let ((fileinfos ()) + (cvs-current-dir "") + (case-fold-search nil) + (cvs-current-subdir (or subdir ""))) + (while (not (or (eobp) (eq fileinfos t))) + (let ((ret (cvs-parse-run-table parse-spec))) + (cond + ;; it matched a known information message + ((cvs-fileinfo-p ret) (push ret fileinfos)) + ;; it didn't match anything at all (impossible) + ((and (consp ret) (cvs-fileinfo-p (car ret))) + (setq fileinfos (append ret fileinfos))) + ((null ret) (setq fileinfos t)) + ;; it matched something that should be ignored + (t nil)))) + (nreverse fileinfos))) + + +;; All those parsing macros/functions should return a success indicator +(defsubst cvs-parse-msg () (buffer-substring cvs-start (1- (point)))) + +;;(defsubst COLLECT (exp) (push exp *result*)) +;;(defsubst PROG (e) t) +;;(defmacro SEQ (&rest seqs) (cons 'and seqs)) + +(defmacro cvs-match (re &rest matches) + "Try to match RE and extract submatches. +If RE matches, advance the point until the line after the match and +then assign the variables as specified in MATCHES (via `setq')." + (cons 'cvs-do-match + (cons re (mapcar (lambda (match) + `(cons ',(first match) ,(second match))) + matches)))) + +(defun cvs-do-match (re &rest matches) + "Internal function for the `cvs-match' macro. +Match RE and if successful, execute MATCHES." + ;; Is it a match? + (when (looking-at re) + (goto-char (match-end 0)) + ;; Skip the newline (unless we already are at the end of the buffer). + (when (and (eolp) (< (point) (point-max))) (forward-char)) + ;; assign the matches + (dolist (match matches t) + (let ((val (cdr match))) + (set (car match) (if (integerp val) (match-string val) val)))))) + +(defmacro cvs-or (&rest alts) + "Try each one of the ALTS alternatives until one matches." + `(let ((-cvs-parse-point (point))) + ,(cons 'or + (mapcar (lambda (es) + `(or ,es (ignore (goto-char -cvs-parse-point)))) + alts)))) +(def-edebug-spec cvs-or t) + +;; This is how parser tables should be executed +(defun cvs-parse-run-table (parse-spec) + "Run PARSE-SPEC and provide sensible default behavior." + (unless (bolp) (forward-line 1)) ;this should never be needed + (let ((cvs-start (point))) + (cvs-or + (funcall parse-spec) + + (dolist (re cvs-parse-ignored-messages) + (when (cvs-match re) (return t))) + + ;; This is a parse error. Create a message-type fileinfo. + (and + (cvs-match ".*$") + (cvs-create-fileinfo 'MESSAGE cvs-current-dir " " + (concat " Parser Error: '" (cvs-parse-msg) "'") + :subtype 'ERROR))))) + + +(defun cvs-parsed-fileinfo (type path &optional directory &rest keys) + "Create a fileinfo. +TYPE can either be a type symbol or a cons of the form (TYPE . SUBTYPE). +PATH is the filename. +DIRECTORY influences the way PATH is interpreted: +- if it's a string, it denotes the directory in which PATH (which should then be + a plain file name with no directory component) resides. +- if it's nil, the PATH should not be trusted: if it has a directory + component, use it, else, assume it is relative to the current directory. +- else, the PATH should be trusted to be relative to the root + directory (i.e. if there is no directory component, it means the file + is inside the main directory). +The remaining KEYS are passed directly to `cvs-create-fileinfo'." + (let ((dir directory) + (file path)) + ;; only trust the directory if it's a string + (unless (stringp directory) + ;; else, if the directory is true, the path should be trusted + (setq dir (or (file-name-directory path) (if directory ""))) + (setq file (file-name-nondirectory path))) + + (let ((type (if (consp type) (car type) type)) + (subtype (if (consp type) (cdr type)))) + (when dir (setq cvs-current-dir dir)) + (apply 'cvs-create-fileinfo type + (concat cvs-current-subdir (or dir cvs-current-dir)) + file (cvs-parse-msg) :subtype subtype keys)))) + + +;;;; CVS Process Parser Tables: +;;;; +;;;; The table for status and update could actually be merged since they +;;;; don't conflict. But they don't overlap much either. + +(defun cvs-parse-table () + "Table of message objects for `cvs-parse-process'." + (let (c file dir path type base-rev subtype) + (cvs-or + + (cvs-parse-status) + (cvs-parse-merge) + (cvs-parse-commit) + + ;; this is not necessary because the fileinfo merging will remove + ;; such duplicate info and luckily the second info is the one we want. + ;; (and (cvs-match "M \\(.*\\)$" (path 1)) + ;; (cvs-parse-merge path)) + + ;; Normal file state indicator. + (and + (cvs-match "\\([MARCUPNJ?]\\) \\(.*\\)$" (c 1) (path 2)) + ;; M: The file is modified by the user, and untouched in the repository. + ;; A: The file is "cvs add"ed, but not "cvs ci"ed. + ;; R: The file is "cvs remove"ed, but not "cvs ci"ed. + ;; C: Conflict + ;; U: The file is copied from the repository. + ;; P: The file was patched from the repository. + ;; ?: Unknown file. + (let ((code (aref c 0))) + (cvs-parsed-fileinfo (case code + (?M 'MODIFIED) + (?A 'ADDED) + (?R 'REMOVED) + (?? 'UNKNOWN) + (?C 'CONFLICT) ;(if dont-change-disc 'NEED-MERGE + (?J 'NEED-MERGE) ;not supported by standard CVS + ((?U ?P) + (if dont-change-disc + 'NEED-UPDATE + (cons 'UP-TO-DATE + (if (eq code ?U) 'UPDATED 'PATCHED))))) + path 'trust))) + + (and + (cvs-match "pcl-cvs: descending directory \\(.*\\)$" (dir 1)) + (setq cvs-current-subdir dir)) + + ;; A special cvs message + (and + (cvs-match "cvs[.ex]* [a-z]+: ") + (cvs-or + + ;; CVS is descending a subdirectory + ;; (status says `examining' while update says `updating') + (and + (cvs-match "\\(Examining\\|Updating\\) \\(.*\\)$" (dir 2)) + (let ((dir (if (string= "." dir) "" (file-name-as-directory dir)))) + (cvs-parsed-fileinfo 'DIRCHANGE "." dir))) + + ;; [-n update] A new (or pruned) directory appeared but isn't traversed + (and + (cvs-match "New directory `\\(.*\\)' -- ignored$" (dir 1)) + (cvs-parsed-fileinfo 'MESSAGE " " (file-name-as-directory dir))) + + ;; File removed, since it is removed (by third party) in repository. + (and + (cvs-or + (cvs-match "warning: \\(.*\\) is not (any longer) pertinent$" (file 1)) + (cvs-match "\\(.*\\) is no longer in the repository$" (file 1))) + (cvs-parsed-fileinfo 'DEAD file)) + + ;; [add] + (and + (cvs-or + (cvs-match "scheduling file `\\(.*\\)' for addition.*$" (path 1)) + (cvs-match "re-adding file \\(.*\\) (in place of .*)$" (path 1))) + (cvs-parsed-fileinfo 'ADDED path)) + + ;; [add] this will also show up as a `U <file>' + (and + (cvs-match "\\(.*\\), version \\(.*\\), resurrected$" + (path 1) (base-rev 2)) + (cvs-parsed-fileinfo '(UP-TO-DATE . RESURRECTED) path nil + :base-rev base-rev)) + + ;; [remove] + (and + (cvs-match "removed `\\(.*\\)'$" (path 1)) + (cvs-parsed-fileinfo 'DEAD path)) + + ;; [remove,merge] + (and + (cvs-match "scheduling `\\(.*\\)' for removal$" (file 1)) + (cvs-parsed-fileinfo 'REMOVED file)) + + ;; [update] File removed by you, but not cvs rm'd + (and + (cvs-match "warning: \\(.*\\) was lost$" (path 1)) + (cvs-match (concat "U " (regexp-quote path) "$")) + (cvs-parsed-fileinfo (if dont-change-disc + 'MISSING + '(UP-TO-DATE . UPDATED)) + path)) + + ;; Mode conflicts (rather than contents) + (and + (cvs-match "conflict: ") + (cvs-or + (cvs-match "removed \\(.*\\) was modified by second party$" + (path 1) (subtype 'REMOVED)) + (cvs-match "\\(.*\\) created independently by second party$" + (path 1) (subtype 'ADDED)) + (cvs-match "\\(.*\\) is modified but no longer in the repository$" + (path 1) (subtype 'MODIFIED))) + (cvs-match (concat "C " (regexp-quote path))) + (cvs-parsed-fileinfo (cons 'CONFLICT subtype) path)) + + ;; Messages that should be shown to the user + (and + (cvs-or + (cvs-match "move away \\(.*\\); it is in the way$" (file 1)) + (cvs-match "warning: new-born \\(.*\\) has disappeared$" (file 1)) + (cvs-match "sticky tag .* for file `\\(.*\\)' is not a branch$" + (file 1))) + (cvs-parsed-fileinfo 'MESSAGE file)) + + ;; File unknown. + (and (cvs-match "use `.+ add' to create an entry for \\(.*\\)$" (path 1)) + (cvs-parsed-fileinfo 'UNKNOWN path)) + + ;; We use cvs-execute-multi-dir but cvs can't handle it + ;; Probably because the cvs-client can but the cvs-server can't + (and (cvs-match ".* files with '?/'? in their name.*$") + (not cvs-execute-single-dir) + (setq cvs-execute-single-dir t) + (cvs-create-fileinfo + 'MESSAGE "" " " + "*** Add (setq cvs-execute-single-dir t) to your .emacs *** + See the FAQ file or the variable's documentation for more info.")) + + ;; Cvs waits for a lock. Ignored: already handled by the process filter + (cvs-match "\\[..:..:..\\] \\(waiting for\\|obtained\\) .*lock in .*$") + ;; File you removed still exists. Ignore (will be noted as removed). + (cvs-match ".* should be removed and is still there$") + ;; just a note + (cvs-match "use '.+ commit' to \\sw+ th\\sw+ files? permanently$") + ;; [add,status] followed by a more complete status description anyway + (cvs-match "nothing known about .*$") + ;; [update] problem with patch + (cvs-match "checksum failure after patch to .*; will refetch$") + (cvs-match "refetching unpatchable files$") + ;; [commit] + (cvs-match "Rebuilding administrative file database$") + + ;; CVS is running a *info program. + (and + (cvs-match "Executing.*$") + ;; Skip by any output the program may generate to stdout. + ;; Note that pcl-cvs will get seriously confused if the + ;; program prints anything to stderr. + (re-search-forward cvs-update-prog-output-skip-regexp)))) + + (and + (cvs-match "cvs[.ex]* \\[[a-z]+ aborted\\]:.*$") + (cvs-parsed-fileinfo 'MESSAGE "")) + + ;; sadly you can't do much with these since the path is in the repository + (cvs-match "Directory .* added to the repository$") + ))) + + +(defun cvs-parse-merge () + (let (path base-rev head-rev handled type) + ;; A merge (maybe with a conflict). + (and + (cvs-match "RCS file: .*$") + ;; Squirrel away info about the files that were retrieved for merging + (cvs-match "retrieving revision \\([0-9.]+\\)$" (base-rev 1)) + (cvs-match "retrieving revision \\([0-9.]+\\)$" (head-rev 1)) + (cvs-match "Merging differences between [0-9.]+ and [0-9.]+ into \\(.*\\)$" + (path 1)) + + ;; eat up potential conflict warnings + (cvs-or (cvs-match "\\(rcs\\)?merge:?\\( warning\\)?: \\(overlaps\\|conflicts\\) \\(or other problems \\)?during merge$" (type 'CONFLICT)) t) + (cvs-or + (and + (cvs-match "cvs[.ex]* [a-z]+: ") + (cvs-or + (cvs-match "conflicts found in \\(.*\\)$" (path 1) (type 'CONFLICT)) + (cvs-match "could not merge .*$") + (cvs-match "restoring \\(.*\\) from backup file .*$" (path 1)))) + t) + + ;; Is it a succesful merge? + ;; Figure out result of merging (ie, was there a conflict?) + (let ((qfile (regexp-quote path))) + (cvs-or + ;; Conflict + (and + (cvs-match (concat "C \\(.*" qfile "\\)$") (path 1) (type 'CONFLICT)) + ;; C might be followed by a "suprious" U for non-mergeable files + (cvs-or (cvs-match (concat "U \\(.*" qfile "\\)$")) t)) + ;; Successful merge + (cvs-match (concat "M \\(.*" qfile "\\)$") (path 1)) + ;; The file already contained the modifications + (cvs-match (concat "^\\(.*" qfile + "\\) already contains the differences between .*$") + (path 1) (type '(UP-TO-DATE . MERGED))) + t) + (cvs-parsed-fileinfo (if dont-change-disc 'NEED-MERGE + (or type '(MODIFIED . MERGED))) path nil + :merge (cons base-rev head-rev)))))) + +(defun cvs-parse-status () + (let (nofile path base-rev head-rev type) + (and + (cvs-match + "===================================================================$") + (cvs-match "File: \\(no file \\)?\\(.*[^ \t]\\)[ \t]+Status: " + (nofile 1) (path 2)) + (cvs-or + (cvs-match "Needs \\(Checkout\\|Patch\\)$" + (type (if nofile 'MISSING 'NEED-UPDATE))) + (cvs-match "Up-to-date$" + (type (if nofile '(UP-TO-DATE . REMOVED) 'UP-TO-DATE))) + (cvs-match ".*[Cc]onflict.*$" (type 'CONFLICT)) + (cvs-match "Locally Added$" (type 'ADDED)) + (cvs-match "Locally Removed$" (type 'REMOVED)) + (cvs-match "Locally Modified$" (type 'MODIFIED)) + (cvs-match "Needs Merge$" (type 'NEED-MERGE)) + (cvs-match "Unknown$" (type 'UNKNOWN))) + (cvs-match "$") + (cvs-or + (cvs-match " *Version:[ \t]*\\([0-9.]+\\).*$" (base-rev 1)) + ;; NOTE: there's no date on the end of the following for server mode... + (cvs-match " *Working revision:[ \t]*-?\\([0-9.]+\\).*$" (base-rev 1)) + ;; Let's not get all worked up if the format changes a bit + (cvs-match " *Working revision:.*$")) + (cvs-or + (cvs-match " *RCS Version:[ \t]*\\([0-9.]+\\)[ \t]*.*$" (head-rev 1)) + (cvs-match " *Repository revision:[ \t]*\\([0-9.]+\\)[ \t]*\\(.*\\)$" + (head-rev 1)) + (cvs-match " *Repository revision:.*")) + (cvs-or + (and;;sometimes those fields are missing + (cvs-match " *Sticky Tag:[ \t]*\\(.*\\)$") ; FIXME: use it + (cvs-match " *Sticky Date:[ \t]*\\(.*\\)$") ; FIXME: use it + (cvs-match " *Sticky Options:[ \t]*\\(.*\\)$")) ; FIXME: use it + t) + (cvs-match "$") + ;; ignore the tags-listing in the case of `status -v' + (cvs-or (cvs-match " *Existing Tags:\n\\(\t.*\n\\)*$") t) + (cvs-parsed-fileinfo type path nil + :base-rev base-rev + :head-rev head-rev)))) + +(defun cvs-parse-commit () + (let (path base-rev subtype) + (cvs-or + + (and + (cvs-match "\\(Checking in\\|Removing\\) \\(.*\\);$" (path 2)) + (cvs-match ".*,v <-- .*$") + (cvs-or + ;; deletion + (cvs-match "new revision: delete; previous revision: \\([0-9.]*\\)$" + (subtype 'REMOVED) (base-rev 1)) + ;; addition + (cvs-match "initial revision: \\([0-9.]*\\)$" + (subtype 'ADDED) (base-rev 1)) + ;; update + (cvs-match "new revision: \\([0-9.]*\\); previous revision: .*$" + (subtype 'COMMITTED) (base-rev 1))) + (cvs-match "done$") + ;; it's important here not to rely on the default directory management + ;; because `cvs commit' might begin by a series of Examining messages + ;; so the processing of the actual checkin messages might begin with + ;; a `current-dir' set to something different from "" + (cvs-parsed-fileinfo (cons 'UP-TO-DATE subtype) path 'trust + :base-rev base-rev)) + + ;; useless message added before the actual addition: ignored + (cvs-match "RCS file: .*\ndone$")))) + + +(provide 'pcvs-parse) + +;;; pcl-cvs-parse.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/pcvs-util.el Sat Mar 11 03:51:31 2000 +0000 @@ -0,0 +1,381 @@ +;;; pcvs-util.el --- Utitlity functions for pcl-cvs + +;; Copyright (C) 1998-2000 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@cs.yale.edu> +;; Keywords: pcl-cvs +;; Version: $Name: $ +;; Revision: $Id: pcl-cvs-util.el,v 1.26 2000/03/05 21:32:21 monnier Exp $ + +;; 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + + +;;; Code: + +(eval-when-compile (require 'cl)) + +;;;; +;;;; list processing +;;;l + +(defsubst cvs-car (x) (if (consp x) (car x) x)) +(defalias 'cvs-cdr 'cdr-safe) +(defsubst cvs-append (&rest xs) + (apply 'append (mapcar (lambda (x) (if (listp x) x (list x))) xs))) + +(defsubst cvs-every (-cvs-every-f -cvs-every-l) + (while (consp -cvs-every-l) + (unless (funcall -cvs-every-f (pop -cvs-every-l)) + (setq -cvs-every-l t))) + (not -cvs-every-l)) + +(defun cvs-union (xs ys) + (let ((zs ys)) + (dolist (x xs zs) + (unless (member x ys) (push x zs))))) + + +(defun cvs-map (-cvs-map-f &rest -cvs-map-ls) + (unless (cvs-every 'null -cvs-map-ls) + (cons (apply -cvs-map-f (mapcar 'car -cvs-map-ls)) + (apply 'cvs-map -cvs-map-f (mapcar 'cdr -cvs-map-ls))))) + +(defun cvs-first (l &optional n) + (if (null n) (car l) + (when l + (let* ((nl (list (pop l))) + (ret nl)) + (while (and l (> n 1)) + (setcdr nl (list (pop l))) + (setq nl (cdr nl)) + (decf n)) + ret)))) + +(defun cvs-partition (p l) + "Partition a list L into two lists based on predicate P. +The function returns a `cons' cell where the `car' contains +elements of L for which P is true while the `cdr' contains +the other elements. The ordering among elements is maintained." + (let (car cdr) + (dolist (x l) + (if (funcall p x) (push x car) (push x cdr))) + (cons (nreverse car) (nreverse cdr)))) + +;;;; +;;;; frame, window, buffer handling +;;;; + +(defun cvs-pop-to-buffer-same-frame (buf) + "Pop to BUF like `pop-to-buffer' but staying on the same frame. +If `pop-to-buffer' would have opened a new frame, this function would +try to split the a new window instead." + (let ((pop-up-windows (or pop-up-windows pop-up-frames)) + (pop-up-frames nil)) + (or (let ((buf (get-buffer-window buf))) (and buf (select-window buf))) + (and pop-up-windows + (ignore-errors (select-window (split-window-vertically))) + (switch-to-buffer buf)) + (pop-to-buffer (current-buffer))))) + +(defun cvs-bury-buffer (buf &optional mainbuf) + "Hide the buffer BUF that was temporarily popped up. +BUF is assumed to be a temporary buffer used from the buffer MAINBUF." + (interactive (list (current-buffer))) + (save-current-buffer + (let ((win (if (eq buf (window-buffer (selected-window))) (selected-window) + (get-buffer-window buf t)))) + (when win + (if (window-dedicated-p win) + (condition-case () + (delete-window win) + (error (iconify-frame (window-frame win)))) + (if (and mainbuf (get-buffer-window mainbuf)) + (delete-window win))))) + (with-current-buffer buf + (bury-buffer (unless (and (eq buf (window-buffer (selected-window))) + (not (window-dedicated-p (selected-window)))) + buf))) + (when mainbuf + (let ((mainwin (or (get-buffer-window mainbuf) + (get-buffer-window mainbuf 'visible)))) + (when mainwin (select-window mainwin)))))) + +(defun cvs-get-buffer-create (name &optional noreuse) + "Create a buffer NAME unless such a buffer already exists. +If the NAME looks like an absolute file name, the buffer will be created +with `create-file-buffer' and will probably get another name than NAME. +In such a case, the search for another buffer with the same name doesn't +use the buffer name but the buffer's `list-buffers-directory' variable. +If NOREUSE is non-nil, always return a new buffer." + (or (and (not (file-name-absolute-p name)) (get-buffer-create name)) + (unless noreuse + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (equal name list-buffers-directory) + (return buf))))) + (with-current-buffer (create-file-buffer name) + (set (make-local-variable 'list-buffers-directory) name) + (current-buffer)))) + +;;;; +;;;; string processing +;;;; + +(defun cvs-file-to-string (file &optional oneline args) + "Read the content of FILE and return it as a string. +If ONELINE is t, only the first line (no \\n) will be returned. +If ARGS is non-nil, the file will be executed with ARGS as its +arguments. If ARGS is not a list, no argument will be passed." + (with-temp-buffer + (condition-case nil + (progn + (if args + (apply 'call-process + file nil t nil (when (listp args) args)) + (insert-file-contents file)) + (buffer-substring (point-min) + (if oneline + (progn (goto-char (point-min)) (end-of-line) (point)) + (point-max)))) + (file-error nil)))) + +(defun cvs-string-prefix-p (str1 str2) + "Tell whether STR1 is a prefix of STR2." + (let ((length1 (length str1))) + (and (>= (length str2) length1) + (string= str1 (substring str2 0 length1))))) + +;; (string->strings (strings->string X)) == X +(defun cvs-strings->string (strings &optional separator) + "Concatenate the STRINGS, adding the SEPARATOR (default \" \"). +This tries to quote the strings to avoid ambiguity such that + (cvs-string->strings (cvs-strings->string strs)) == strs +Only some SEPARATOR will work properly." + (let ((sep (or separator " "))) + (mapconcat + (lambda (str) + (if (string-match "[\\\"]" str) + (concat "\"" (replace-regexps-in-string "[\\\"]" "\\\\\\&" str) "\"") + str)) + strings sep))) + +;; (string->strings (strings->string X)) == X +(defun cvs-string->strings (string &optional separator) + "Split the STRING into a list of strings. +It understands elisp style quoting within STRING such that + (cvs-string->strings (cvs-strings->string strs)) == strs +The SEPARATOR regexp defaults to \"\\s-+\"." + (let ((sep (or separator "\\s-+")) + (i (string-match "[\"]" string))) + (if (null i) (split-string string sep) ; no quoting: easy + (append (unless (eq i 0) (split-string (substring string 0 i) sep)) + (let ((rfs (read-from-string string i))) + (cons (car rfs) + (cvs-string->strings (substring string (cdr rfs)) sep))))))) + + +(defun cvs-string-fill (str n &optional filling truncate) + "Add FILLING (defaults to the space char) to STR to reach size N. +If STR is longer than N, truncate if TRUNCATE is set, else don't do anything." + (let ((l (length str))) + (if (> l n) + (if truncate (substring str 0 n) str) + (concat str (make-string (- n l) (or filling ? )))))) + +;;;; +;;;; file names +;;;; + +(defsubst cvs-expand-dir-name (d) + (file-name-as-directory (expand-file-name d))) + +;;;; +;;;; (interactive <foo>) support function +;;;; + +(defstruct (cvs-qtypedesc + (:constructor nil) (:copier nil) + (:constructor cvs-qtypedesc-create + (str2obj obj2str &optional complete hist-sym require))) + str2obj + obj2str + hist-sym + complete + require) + + +(defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t)) +(defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity)) +(defconst cvs-qtypedesc-strings + (cvs-qtypedesc-create 'cvs-string->strings 'cvs-strings->string nil)) + +(defun cvs-query-read (default prompt qtypedesc &optional hist-sym) + (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings)) + (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc))) + (complete (cvs-qtypedesc-complete qtypedesc)) + (completions (and (functionp complete) (funcall complete))) + (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default))) + (funcall (cvs-qtypedesc-str2obj qtypedesc) + (cond + ((null complete) (read-string prompt initval hist-sym)) + ((functionp complete) + (completing-read prompt completions + nil (cvs-qtypedesc-require qtypedesc) + initval hist-sym)) + (t initval))))) + +;;;; +;;;; Flags handling +;;;; + +(defstruct (cvs-flags + (:constructor nil) + (:constructor -cvs-flags-make + (desc defaults &optional qtypedesc hist-sym))) + defaults persist desc qtypedesc hist-sym) + +(defmacro cvs-flags-define (sym defaults + &optional desc qtypedesc hist-sym docstring) + `(defconst ,sym + (let ((bound (boundp ',sym))) + (if (and bound (cvs-flags-p ,sym)) ,sym + (let ((defaults ,defaults)) + (-cvs-flags-make ,desc + (if bound (cons ,sym (cdr defaults)) defaults) + ,qtypedesc ,hist-sym)))) + ,docstring)) + +(defun cvs-flags-query (sym &optional desc arg) + "Query flags based on SYM. +Optional argument DESC will be used for the prompt +If ARG (or a prefix argument) is nil, just use the 0th default. +If it is a non-negative integer, use the corresponding default. +If it is a negative integer query for a new value of the corresponding + default and return that new value. +If it is \\[universal-argument], just query and return a value without + altering the defaults. +If it is \\[universal-argument] \\[universal-argument], behave just + as if a negative zero was provided." + (let* ((flags (symbol-value sym)) + (desc (or desc (cvs-flags-desc flags))) + (qtypedesc (cvs-flags-qtypedesc flags)) + (hist-sym (cvs-flags-hist-sym flags)) + (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0))) + (numarg (prefix-numeric-value arg)) + (defaults (cvs-flags-defaults flags)) + (permstr (if (< numarg 0) (format " (%sth default)" (- numarg))))) + ;; special case for universal-argument + (when (consp arg) + (setq permstr (if (> numarg 4) " (permanent)" "")) + (setq numarg 0)) + + ;; sanity check + (unless (< (abs numarg) (length defaults)) + (error "There is no %sth default." (abs numarg))) + + (if permstr + (let* ((prompt (format "%s%s: " desc permstr)) + (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags)) + prompt qtypedesc hist-sym))) + (when (not (equal permstr "")) + (setf (nth (- numarg) (cvs-flags-defaults flags)) fs)) + fs) + (nth numarg defaults)))) + +(defsubst cvs-flags-set (sym index value) + "Set SYM's INDEX'th setting to VALUE." + (setf (nth index (cvs-flags-defaults (symbol-value sym))) value)) + +;;;; +;;;; Prefix keys +;;;; + +(defconst cvs-prefix-number 10) + +(defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps"))) + +(defmacro cvs-prefix-define (sym docstring desc defaults + &optional qtypedesc hist-sym) + (let ((cps (cvs-prefix-sym sym))) + `(progn + (defvar ,sym nil ,(cons (or docstring "") " +See `cvs-prefix-set' for further description of the behavior.")) + (defconst ,cps + (let ((defaults ,defaults)) + ;; sanity ensurance + (unless (>= (length defaults) cvs-prefix-number) + (setq defaults (append defaults + (make-list (1- cvs-prefix-number) + (first defaults))))) + (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym)))))) + +(defun cvs-prefix-make-local (sym) + (let ((cps (cvs-prefix-sym sym))) + (make-local-variable sym) + (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps))))) + +(defun cvs-prefix-set (sym arg) + ;; we could distinguish between numeric and non-numeric prefix args instead of + ;; relying on that magic `4'. + "Set the cvs-prefix contained in SYM. +If ARG is between 0 and 9, it selects the corresponding default. +If ARG is negative (or \\[universal-argument] which corresponds to negative 0), + it queries the user and sets the -ARG'th default. +If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]), + the (ARG mod 10)'th prefix is made persistent. +If ARG is NIL toggle the PREFIX's value between its 0th default and NIL + and reset the persistence." + (let* ((prefix (symbol-value (cvs-prefix-sym sym))) + (numarg (if (integerp arg) arg 0)) + (defs (cvs-flags-defaults prefix))) + + ;; set persistence if requested + (when (> (prefix-numeric-value arg) 9) + (setf (cvs-flags-persist prefix) t) + (setq numarg (mod numarg 10))) + + ;; set the value + (set sym + (cond + ((null arg) + (setf (cvs-flags-persist prefix) nil) + (unless (symbol-value sym) (first (cvs-flags-defaults prefix)))) + + ((or (consp arg) (< numarg 0)) + (setf (nth (- numarg) (cvs-flags-defaults prefix)) + (cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix)) + (format "%s: " (cvs-flags-desc prefix)) + (cvs-flags-qtypedesc prefix) + (cvs-flags-hist-sym prefix)))) + (t (nth numarg (cvs-flags-defaults prefix))))) + (force-mode-line-update))) + +(defun cvs-prefix-get (sym &optional read-only) + "Return the current value of the prefix SYM. +and reset it unless READ-ONLY is non-nil." + (prog1 (symbol-value sym) + (unless (or read-only + (cvs-flags-persist (symbol-value (cvs-prefix-sym sym)))) + (set sym nil) + (force-mode-line-update)))) + +(provide 'pcvs-util) + +;;; pcl-cvs-util.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/pcvs.el Sat Mar 11 03:51:31 2000 +0000 @@ -0,0 +1,2122 @@ +;;; pcvs.el -- A Front-end to CVS. + +;; Copyright (C) 1991-2000 Free Software Foundation, Inc. + +;; Author: (The PCL-CVS Trust) pcl-cvs@cyclic.com +;; (Per Cederqvist) ceder@lysator.liu.se +;; (Greg A. Woods) woods@weird.com +;; (Jim Blandy) jimb@cyclic.com +;; (Karl Fogel) kfogel@floss.red-bean.com +;; (Jim Kingdon) kingdon@cyclic.com +;; (Stefan Monnier) monnier@cs.yale.edu +;; (Greg Klanderman) greg@alphatech.com +;; (Jari Aalto+mail.emacs) jari.aalto@poboxes.com +;; Maintainer: (Stefan Monnier) monnier+lists/cvs/pcl@flint.cs.yale.edu +;; Keywords: CVS, version control, release management +;; Version: $Name: $ +;; Revision: $Id: pcl-cvs.el,v 1.75 2000/03/05 21:32:21 monnier Exp $ + +;; 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Todo: + +;; * FIX THE DOCUMENTATION +;; +;; * Emacs-21 adaptation +;; ** use the new arg of save-some-buffers +;; ** add toolbar entries +;; ** use `format' now that it keeps properties +;; ** use propertize +;; ** add compatibility with older name's variables. +;; +;; * New Features +;; +;; ** marking +;; *** marking directories should jump to just after the dir. +;; *** allow (un)marking directories at a time with the mouse. +;; *** marking with the mouse should not move point. +;; +;; ** liveness indicator +;; +;; ** indicate in docstring if the cmd understands the `b' prefix(es). +;; +;; ** call smerge-mode when opening CONFLICT files. +;; +;; ** after-parse-hook (to eliminate *.elc from Emacs' CVS repository :-) +;; +;; ** have vc-checkin delegate to cvs-mode-commit when applicable +;; +;; ** higher-level CVS operations +;; +;; *** cvs-mode-rename +;; *** cvs-mode-branch +;; +;; ** module-level commands +;; +;; *** add support for parsing 'modules' file ("cvs co -c") +;; +;; *** cvs-mode-rcs2log +;; *** cvs-rdiff +;; *** cvs-release +;; *** cvs-import +;; *** C-u M-x cvs-checkout should ask for a cvsroot +;; +;; *** cvs-mode-handle-new-vendor-version +;; - checks out module, or alternately does update join +;; - does "cvs -n tag LAST_VENDOR" to find old files into *cvs* +;; +;; *** cvs-export +;; (with completion on tag names and hooks to +;; help generate full releases) +;; +;; ** allow cvs-cmd-do to either clear the marks or not. +;; +;; ** allow more concurrency: if the output buffer is busy, pick a new one. +;; +;; ** configurable layout/format of *cvs*. +;; +;; ** display stickiness information. And current CVS/Tag as well. +;; +;; ** cvs-log-mode should know how to extract version info +;; cvs-log-current-tag is a nop right now :-( +;; +;; ** write 'cvs-mode-admin' to do arbitrary 'cvs admin' commands +;; +;; ** cvs-mode-incorporate +;; It would merge in the status from one ``*cvs*'' buffer into another. +;; This would be used to populate such a buffer that had been created with +;; a `cvs {update,status,checkout} -l'. +;; +;; ** cvs-mode-(i)diff-other-{file,buffer,cvs-buffer} +;; +;; ** offer the choice to kill the process when the user kills the cvs buffer. +;; right now, it's killed without further ado. +;; +;; ** make `cvs-mode-ignore' allow manually entering a pattern. +;; to which dir should it apply ? +;; +;; ** cvs-mode-ignore should try to remove duplicate entries. +;; +;; * Old misfeatures +;; +;; ** cvs-mode-<foo> commands tend to require saving too many buffers +;; they should only require saving the files concerned by the command +;; +;; * Secondary issues +;; +;; ** maybe poll/check CVS/Entries files to react to external `cvs' commands ? +;; +;; ** some kind of `cvs annotate' support ? +;; but vc-annotate can be used instead. +;; +;; * probably not worth the trouble +;; +;; ** dynamic `g' mapping +;; Make 'g', and perhaps other commands, use either cvs-update or +;; cvs-examine depending on the read-only status of the cvs buffer, for +;; instance. +;; +;; ** add message-levels so that we can hide some levels of messages + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'ewoc) ;Ewoc was once cookie +(require 'pcvs-defs) +(require 'pcvs-util) +(require 'pcvs-parse) +(require 'pcvs-info) + + +;;;; +;;;; global vars +;;;; + +(defvar cvs-cookies) ;;nil + ;;"Handle for the cookie structure that is displayed in the *cvs* buffer.") +;;(make-variable-buffer-local 'cvs-cookies) + +;;;; +;;;; Dynamically scoped variables +;;;; + +(defvar cvs-from-vc nil "Bound to t inside VC advice.") + +;;;; +;;;; flags variables +;;;; + +(defun cvs-defaults (&rest defs) + (let ((defs (cvs-first defs cvs-shared-start))) + (append defs + (make-list (- cvs-shared-start (length defs)) (first defs)) + cvs-shared-flags))) + +;; For cvs flags, we need to add "-f" to override the cvsrc settings +;; we also want to evict the annoying -q and -Q options that hide useful +;; information from pcl-cvs. +(cvs-flags-define cvs-cvs-flags '(("-f"))) + +(cvs-flags-define cvs-checkout-flags (cvs-defaults '("-P"))) +(cvs-flags-define cvs-status-flags (cvs-defaults '("-v") nil)) +(cvs-flags-define cvs-log-flags (cvs-defaults nil)) +(cvs-flags-define cvs-diff-flags (cvs-defaults '("-u" "-N") '("-c" "-N"))) +(cvs-flags-define cvs-tag-flags (cvs-defaults nil)) +(cvs-flags-define cvs-add-flags (cvs-defaults nil)) +(cvs-flags-define cvs-commit-flags (cvs-defaults nil)) +(cvs-flags-define cvs-remove-flags (cvs-defaults nil)) +;;(cvs-flags-define cvs-undo-flags (cvs-defaults nil)) +(cvs-flags-define cvs-update-flags (cvs-defaults '("-d" "-P"))) + +(defun cvs-reread-cvsrc () + "Reset the default arguments to those in the `cvs-cvsrc-file'." + (interactive) + (let ((cvsrc (cvs-file-to-string cvs-cvsrc-file))) + (when (stringp cvsrc) + ;; fetch the values + (dolist (cmd '("cvs" "checkout" "status" "log" "diff" "tag" + "add" "commit" "remove" "update")) + (let* ((sym (intern (concat "cvs-" cmd "-flags"))) + (val (when (string-match (concat "^" cmd "\\s-\\(.*\\)$") cvsrc) + (cvs-string->strings (match-string 1 cvsrc))))) + (cvs-flags-set sym 0 val))) + ;; ensure that cvs doesn't have -q or -Q + (cvs-flags-set 'cvs-cvs-flags 0 + (cons "-f" + (cdr (cvs-partition + (lambda (x) (member x '("-q" "-Q"))) + (cvs-flags-query 'cvs-cvs-flags + nil 'noquery)))))))) + +;; initialize to cvsrc's default values +(cvs-reread-cvsrc) + + +;;;; +;;;; Mouse bindings and mode motion +;;;; + +(defun cvs-menu (e) + "Popup the CVS menu." + (interactive "e") + (mouse-set-point e) + (x-popup-menu e cvs-menu-map)) + +(defvar cvs-mode-line-process nil + "Mode-line control for displaying info on cvs process status.") + + +;;;; +;;;; Query-Type-Descriptor for Tags +;;;; + +(autoload 'cvs-status-get-tags "cvs-status") +(defun cvs-tags-list () + "Return a list of acceptable tags, ready for completions." + (assert (cvs-buffer-p)) + (let ((marked (cvs-get-marked))) + (list* '("BASE") '("HEAD") + (when marked + (with-temp-buffer + (call-process cvs-program + nil ;no input + t ;output to current-buffer + nil ;don't update display while running + "status" + "-v" + (cvs-fileinfo->full-path (car marked))) + (goto-char (point-min)) + (let ((tags (cvs-status-get-tags))) + (when (listp tags) tags))))))) + +(defvar cvs-tag-history nil) +(defconst cvs-qtypedesc-tag + (cvs-qtypedesc-create 'identity 'identity 'cvs-tags-list 'cvs-tag-history)) + +;;;; + +(defun cvs-mode! (&optional -cvs-mode!-fun -cvs-mode!-noerror) + "Switch to the *cvs* buffer. +If -CVS-MODE!-FUN is provided, it is executed *cvs* being the current buffer + and with its window selected. Else, the *cvs* buffer is simply selected. +If -CVS-MODE!-NOERROR is non-nil, then failure to find a *cvs* buffer does + not generate an error and the current buffer is kept selected. +-CVS-MODE!-FUN is called interactively if applicable and else with no argument." + (let* ((-cvs-mode!-buf (current-buffer)) + (cvsbuf (cond ((cvs-buffer-p) (current-buffer)) + ((and cvs-buffer (cvs-buffer-p cvs-buffer)) cvs-buffer) + (-cvs-mode!-noerror (current-buffer)) + (t (error "can't find the *cvs* buffer.")))) + (-cvs-mode!-wrapper cvs-minor-wrap-function) + (-cvs-mode!-cont (lambda () + (save-current-buffer + (if (commandp -cvs-mode!-fun) + (call-interactively -cvs-mode!-fun) + (funcall -cvs-mode!-fun)))))) + (if (not -cvs-mode!-fun) (set-buffer cvsbuf) + (let ((cvs-mode!-buf (current-buffer)) + (cvs-mode!-owin (selected-window)) + (cvs-mode!-nwin (get-buffer-window cvsbuf 'visible))) + (unwind-protect + (progn + (set-buffer cvsbuf) + (when cvs-mode!-nwin (select-window cvs-mode!-nwin)) + (if -cvs-mode!-wrapper + (funcall -cvs-mode!-wrapper -cvs-mode!-buf -cvs-mode!-cont) + (funcall -cvs-mode!-cont))) + (set-buffer cvs-mode!-buf) + (when (and cvs-mode!-nwin (eq cvs-mode!-nwin (selected-window))) + ;; the selected window has not been changed by FUN + (select-window cvs-mode!-owin))))))) + +;;;; +;;;; Prefixes +;;;; + +(defvar cvs-branches (list cvs-vendor-branch "HEAD" "HEAD")) +(cvs-prefix-define cvs-branch-prefix + "Current selected branch." + "version" + (cons cvs-vendor-branch cvs-branches) + cvs-qtypedesc-tag) + +(defun cvs-set-branch-prefix (arg) + "Set the branch prefix to take action at the next command. +See `cvs-prefix-set' for a further the description of the behavior. +\\[universal-argument] 1 selects the vendor branch +and \\[universal-argument] 2 selects the HEAD." + (interactive "P") + (cvs-mode!) + (cvs-prefix-set 'cvs-branch-prefix arg)) + +(defun cvs-add-branch-prefix (flags &optional arg) + "Add branch selection argument if the branch prefix was set. +The argument is added (or not) to the list of FLAGS and is constructed +by appending the branch to ARG which defaults to \"-r\"." + (let ((branch (cvs-prefix-get 'cvs-branch-prefix))) + ;; deactivate the secondary prefix, even if not used. + (cvs-prefix-get 'cvs-secondary-branch-prefix) + (if branch (cons (concat (or arg "-r") branch) flags) flags))) + +(cvs-prefix-define cvs-secondary-branch-prefix + "Current secondary selected branch." + "version" + (cons cvs-vendor-branch cvs-branches) + cvs-qtypedesc-tag) + +(defun cvs-set-secondary-branch-prefix (arg) + "Set the branch prefix to take action at the next command. +See `cvs-prefix-set' for a further the description of the behavior. +\\[universal-argument] 1 selects the vendor branch +and \\[universal-argument] 2 selects the HEAD." + (interactive "P") + (cvs-mode!) + (cvs-prefix-set 'cvs-secondary-branch-prefix arg)) + +(defun cvs-add-secondary-branch-prefix (flags &optional arg) + "Add branch selection argument if the secondary branch prefix was set. +The argument is added (or not) to the list of FLAGS and is constructed +by appending the branch to ARG which defaults to \"-r\". +Since the `cvs-secondary-branch-prefix' is only active if the primary +prefix is active, it is important to read the secondary prefix before +the primay since reading the primary can deactivate it." + (let ((branch (and (cvs-prefix-get 'cvs-branch-prefix 'read-only) + (cvs-prefix-get 'cvs-secondary-branch-prefix)))) + (if branch (cons (concat (or arg "-r") branch) flags) flags))) + +;;;; + +(define-minor-mode + cvs-minor-mode + " +This mode is used for buffers related to a main *cvs* buffer. +All the `cvs-mode' buffer operations are simply rebound under +the \\[cvs-mode-map] prefix. +" + nil " CVS") +(put 'cvs-minor-mode 'permanent-local t) + + +(defvar cvs-temp-buffers nil) +(defun cvs-temp-buffer (&optional cmd normal nosetup) + "Create a temporary buffer to run CMD in. +If CMD is a string, use it to lookup `cvs-buffer-name-alist' to find +the buffer name to be used and its `major-mode'. + +The selected window will not be changed. The new buffer will not maintain undo +information and will be read-only unless NORMAL is non-nil. It will be emptied +\(unless NOSETUP is non-nil\) and its `default-directory' will be inherited +from the current buffer." + (let* ((cvs-buf (current-buffer)) + (info (cdr (assoc cmd cvs-buffer-name-alist))) + (name (eval (first info))) + (mode (second info)) + (dir default-directory) + (buf (cond + (name (cvs-get-buffer-create name)) + ((and (bufferp cvs-temp-buffer) (buffer-name cvs-temp-buffer)) + cvs-temp-buffer) + (t + (set (make-local-variable 'cvs-temp-buffer) + (cvs-get-buffer-create + (eval cvs-temp-buffer-name) 'noreuse)))))) + + ;; handle the potential pre-existing process + (let ((proc (get-buffer-process buf))) + (when (and (not normal) (processp proc) + (memq (process-status proc) '(run stop))) + (error "Can not run two cvs processes simultaneously"))) + + (if (not name) (kill-local-variable 'other-window-scroll-buffer) + ;; Strangely, if no window is created, `display-buffer' ends up + ;; doing a `switch-to-buffer' which does a `set-buffer', hence + ;; the need for `save-excursion'. + (unless nosetup (save-excursion (display-buffer buf))) + ;; FIXME: this doesn't do the right thing if the user later on + ;; does a `find-file-other-window' and `scroll-other-window' + (set (make-local-variable 'other-window-scroll-buffer) buf)) + + (add-to-list 'cvs-temp-buffers buf) + + (with-current-buffer buf + (setq buffer-read-only nil) + (setq default-directory dir) + (unless nosetup (erase-buffer)) + (set (make-local-variable 'cvs-buffer) cvs-buf) + ;;(cvs-minor-mode 1) + (let ((lbd list-buffers-directory)) + (if (fboundp mode) (funcall mode) (fundamental-mode)) + (when lbd (set (make-local-variable 'list-buffers-directory) lbd))) + (cvs-minor-mode 1) + ;;(set (make-local-variable 'cvs-buffer) cvs-buf) + (unless normal + (setq buffer-read-only t) + (buffer-disable-undo)) + buf))) + +(defun cvs-mode-kill-buffers () + "Kill all the \"temporary\" buffers created by the *cvs* buffer." + (interactive) + (dolist (buf cvs-temp-buffers) (ignore-errors (kill-buffer buf)))) + +(defun cvs-make-cvs-buffer (dir &optional new) + "Create the *cvs* buffer for directory DIR. +If non-nil, NEW means to create a new buffer no matter what." + ;; the real cvs-buffer creation + (setq dir (cvs-expand-dir-name dir)) + (let* ((buffer-name (eval cvs-buffer-name)) + (buffer + (or (and (not new) + (eq cvs-reuse-cvs-buffer 'current) + (cvs-buffer-p) ;reuse the current buffer if possible + (current-buffer)) + ;; look for another cvs buffer visiting the same directory + (save-excursion + (unless new + (dolist (buffer (cons (current-buffer) (buffer-list))) + (set-buffer buffer) + (and (cvs-buffer-p) + (case cvs-reuse-cvs-buffer + (always t) + (subdir + (or (cvs-string-prefix-p default-directory dir) + (cvs-string-prefix-p dir default-directory))) + (samedir (string= default-directory dir))) + (return buffer))))) + ;; we really have to create a new buffer: + ;; we temporarily bind cwd to "" to prevent + ;; create-file-buffer from using directory info + ;; unless it is explicitly in the cvs-buffer-name. + (cvs-get-buffer-create buffer-name new)))) + (with-current-buffer buffer + (or + (and (string= dir default-directory) (cvs-buffer-p) + ;; just a refresh + (ignore-errors + (cvs-cleanup-collection cvs-cookies nil nil t) + (current-buffer))) + ;; setup from scratch + (progn + (setq default-directory dir) + (setq buffer-read-only nil) + (erase-buffer) + (setq buffer-read-only t) + (cvs-mode) + (set (make-local-variable 'list-buffers-directory) buffer-name) + ;;(set (make-local-variable 'cvs-temp-buffer) (cvs-temp-buffer)) + (let ((cookies + (ewoc-create + buffer 'cvs-fileinfo-pp + (format "%s\n\nRepository : %s\nWorking directory: %s\n" + cvs-startup-message + (directory-file-name (cvs-get-cvsroot)) + dir)))) + (set (make-local-variable 'cvs-cookies) cookies) + (ewoc-enter-first + cookies + (cvs-create-fileinfo 'MESSAGE "" " " "\n" :subtype 'HEADER)) + (ewoc-enter-last + cookies + (cvs-create-fileinfo 'MESSAGE "" " " "\n" :subtype 'FOOTER)) + (make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook + (lambda () + (ignore-errors (kill-buffer cvs-temp-buffer))) + nil t) + ;;(set-buffer buf) + buffer)))))) + +(defun* cvs-cmd-do (cmd dir flags fis new + &key cvsargs noexist dont-change-disc noshow) + (let* ((dir (file-name-as-directory + (abbreviate-file-name (expand-file-name dir)))) + (cvsbuf (cvs-make-cvs-buffer dir new))) + ;; Check that dir is under CVS control. + (unless (file-directory-p dir) + (error "%s is not a directory." dir)) + (unless (or noexist (file-directory-p (expand-file-name "CVS" dir))) + (error "%s does not contain CVS controlled files." dir)) + + (set-buffer cvsbuf) + (cvs-mode-run cmd flags fis + :cvsargs cvsargs :dont-change-disc dont-change-disc) + + (if noshow cvsbuf + (let ((pop-up-windows nil)) (pop-to-buffer cvsbuf))))) +;; (funcall (if (and (boundp 'pop-up-frames) pop-up-frames) +;; 'pop-to-buffer 'switch-to-buffer) +;; cvsbuf)))) + +;;---------- +(defun cvs-run-process (args fis postprocess &optional single-dir) + (assert (cvs-buffer-p cvs-buffer)) + (save-current-buffer + (let ((procbuf (current-buffer)) + (cvsbuf cvs-buffer) + (single-dir (or single-dir (eq cvs-execute-single-dir t)))) + + (set-buffer procbuf) + (goto-char (point-max)) + (unless (bolp) (let ((inhibit-read-only t)) (insert "\n"))) + ;; find the set of files we'll process in this round + (let* ((dir+files+rest + (if (or (null fis) (not single-dir)) + ;; not single-dir mode: just process the whole thing + (list "" (mapcar 'cvs-fileinfo->full-path fis) nil) + ;; single-dir mode: extract the same-dir-elements + (let ((dir (cvs-fileinfo->dir (car fis)))) + ;; output the concerned dir so the parser can translate paths + (let ((inhibit-read-only t)) + (insert "pcl-cvs: descending directory " dir "\n")) + ;; loop to find the same-dir-elems + (do* ((files () (cons (cvs-fileinfo->file fi) files)) + (fis fis (cdr fis)) + (fi (car fis) (car fis))) + ((not (and fis (string= dir (cvs-fileinfo->dir fi)))) + (list dir files fis)))))) + (dir (first dir+files+rest)) + (files (second dir+files+rest)) + (rest (third dir+files+rest))) + + ;; setup the (current) process buffer + (set (make-local-variable 'cvs-postprocess) + (if (null rest) + ;; this is the last invocation + postprocess + ;; else, we have to register ourselves to be rerun on the rest + `(cvs-run-process ',args ',rest ',postprocess ',single-dir))) + (make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook + (lambda () + (let ((proc (get-buffer-process (current-buffer)))) + (when (processp proc) + (set-process-filter proc nil) + (set-process-sentinel proc nil) + (delete-process proc)))) + nil t) + + ;; create the new process and setup the procbuffer correspondingly + (let* ((args (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery) + (if cvs-cvsroot (list "-d" cvs-cvsroot)) + args + files)) + (process-connection-type nil) ; Use a pipe, not a pty. + (process + ;; the process will be run in the selected dir + (let ((default-directory (cvs-expand-dir-name dir))) + (apply 'start-process "cvs" procbuf cvs-program args)))) + (set-process-sentinel process 'cvs-sentinel) + (set-process-filter process 'cvs-update-filter) + (set-marker (process-mark process) (point-max)) + (ignore-errors (process-send-eof process)) ;close its stdin to avoid hangs + + ;; now finish setting up the cvs-buffer + (set-buffer cvsbuf) + (setq cvs-mode-line-process (symbol-name (process-status process))) + (force-mode-line-update))))) + + ;; The following line is said to improve display updates on some + ;; emacsen. It shouldn't be needed, but it does no harm. + (sit-for 0)) + +(defun cvs-update-header (args fis) ; inline + (let* ((lastarg nil) + ;; filter out the largish commit message + (args (mapcar (lambda (arg) + (cond + ((and (eq lastarg nil) (string= arg "commit")) + (setq lastarg 'commit) arg) + ((and (eq lastarg 'commit) (string= arg "-m")) + (setq lastarg '-m) arg) + ((eq lastarg '-m) + (setq lastarg 'done) "<log message>") + (t arg))) + args)) + ;; turn them into a string + (arg (cvs-strings->string + (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery) + (if cvs-cvsroot (list "-d" cvs-cvsroot)) + args + (mapcar 'cvs-fileinfo->full-path fis)))) + (str (if args (concat "-- Running " cvs-program " " arg " ...\n") + "\n"))) + (if nil (insert str) ;inline + ;;(with-current-buffer cvs-buffer + (let* ((tin0 (ewoc-nth cvs-cookies 0)) + (tin-1 (ewoc-nth cvs-cookies -1)) + (header (ewoc-data tin0)) + (footer (ewoc-data tin-1)) + (prev-msg (cvs-fileinfo->full-log header)) + (tin tin0)) + (assert (and (eq 'HEADER (cvs-fileinfo->subtype header)) + (eq 'FOOTER (cvs-fileinfo->subtype footer)))) + ;; look for the first *real* fileinfo (to determine emptyness) + (while + (and tin + (memq (cvs-fileinfo->type (ewoc-data tin)) + '(MESSAGE DIRCHANGE))) + (setq tin (ewoc-next cvs-cookies tin))) + ;; cleanup the prev-msg + (when (string-match "Running \\(.*\\) ...\n" prev-msg) + (setq prev-msg + (concat + "-- last cmd: " + (match-string 1 prev-msg) + " --"))) + ;; set the new header and footer + (setf (cvs-fileinfo->full-log header) str) + (setf (cvs-fileinfo->full-log footer) + (concat "\n--------------------- " + (if tin "End" "Empty") + " ---------------------\n" + prev-msg)) + (ewoc-invalidate cvs-cookies tin0 tin-1)))));;) + + +;;---------- +(defun cvs-sentinel (proc msg) + "Sentinel for the cvs update process. +This is responsible for parsing the output from the cvs update when +it is finished." + (when (memq (process-status proc) '(signal exit)) + (if (null (buffer-name (process-buffer proc))) + ;;(set-process-buffer proc nil) + (error "cvs' process buffer was killed") + (let* ((obuf (current-buffer)) + (procbuffer (process-buffer proc))) + (set-buffer (with-current-buffer procbuffer cvs-buffer)) + (setq cvs-mode-line-process (symbol-name (process-status proc))) + (force-mode-line-update) + (set-buffer procbuffer) + (let ((cvs-postproc cvs-postprocess)) + ;; Since the buffer and mode line will show that the + ;; process is dead, we can delete it now. Otherwise it + ;; will stay around until M-x list-processes. + (delete-process proc) + (setq cvs-postprocess nil) + ;; do the postprocessing like parsing and such + (save-excursion (eval cvs-postproc)) + ;; check whether something is left + (unless cvs-postprocess + (buffer-enable-undo) + (with-current-buffer cvs-buffer + (cvs-update-header nil nil) ;FIXME: might need to be inline + (message "CVS process has completed")))) + ;; This might not even be necessary + (set-buffer obuf))))) + +;;---------- +(defun cvs-parse-process (dcd &optional subdir) + "FIXME: bad name, no doc" + (let* ((from-buf (current-buffer)) + (fileinfos (cvs-parse-buffer 'cvs-parse-table dcd subdir)) + (_ (set-buffer cvs-buffer)) + last + (from-pt (point))) + ;; add the new fileinfos + (dolist (fi fileinfos) + (setq last (cvs-addto-collection cvs-cookies fi last))) + (cvs-cleanup-collection cvs-cookies + (eq cvs-auto-remove-handled t) + cvs-auto-remove-directories + nil) + ;; update the display (might be unnecessary) + (ewoc-refresh cvs-cookies) + ;; revert buffers if necessary + (when (and cvs-auto-revert (not dcd) (not cvs-from-vc)) + (cvs-revert-if-needed fileinfos)) + ;; get back to where we were. `save-excursion' doesn't seem to + ;; work in this case, probably because the buffer is reconstructed + ;; by the cookie code. + (goto-char from-pt) + (set-buffer from-buf))) + +(defmacro defun-cvs-mode (fun args docstring interact &rest body) + "Define a function to be used in a *cvs* buffer. +This will look for a *cvs* buffer and execute BODY in it. +Since the interactive arguments might need to be queried after +switching to the *cvs* buffer, the generic code is rather ugly, +but luckily we can often use simpler alternatives. + +FUN can be either a symbol (i.e. STYLE is nil) or a cons (FUN . STYLE). +ARGS and DOCSTRING are the normal argument list. +INTERACT is the interactive specification or nil for non-commands. + +STYLE can be either SIMPLE, NOARGS or DOUBLE. It's an error for it +to have any other value, unless other details of the function make it +clear what alternative to use. +- SIMPLE will get all the interactive arguments from the original buffer. +- NOARGS will get all the arguments from the *cvs* buffer and will + always behave as if called interactively. +- DOUBLE is the generic case." + (let ((style (cvs-cdr fun)) + (fun (cvs-car fun))) + (cond + ;; a trivial interaction, no need to move it + ((or (eq style 'SIMPLE) + (null (second interact)) + (stringp (second interact))) + `(defun ,fun ,args ,docstring ,interact + (cvs-mode! (lambda () ,@body)))) + + ;; fun is only called interactively: move all the args to the inner fun + ((eq style 'NOARGS) + `(defun ,fun () ,docstring (interactive) + (cvs-mode! (lambda ,args ,interact ,@body)))) + + ;; bad case + ((eq style 'DOUBLE) + (string-match ".*" docstring) + (let ((line1 (match-string 0 docstring)) + (restdoc (substring docstring (match-end 0))) + (fun-1 (intern (concat (symbol-name fun) "-1")))) + `(progn + (defun ,fun-1 ,args + ,(concat docstring "\nThis function only works within a *cvs* buffer. +For interactive use, use `" (symbol-name fun) "' instead.") + ,interact + ,@body) + (defun ,fun () + ,(concat line1 "\nWrapper function that switches to a *cvs* buffer +before calling the real function `" (symbol-name fun-1) "'.\n") + (interactive) + (cvs-mode! ',fun-1))))) + + (t (error "unknown style %s in `defun-cvs-mode'" style))))) +(def-edebug-spec defun-cvs-mode (&define sexp lambda-list stringp ("interactive" interactive) def-body)) + +(defun-cvs-mode cvs-mode-kill-process () + "Kill the temporary buffer and associated process." + (interactive) + (when (and (bufferp cvs-temp-buffer) (buffer-name cvs-temp-buffer)) + (let ((proc (get-buffer-process cvs-temp-buffer))) + (when proc (delete-process proc))))) + +;;; +;;; Maintaining the collection in the face of updates +;;; + +(defun cvs-addto-collection (c fi &optional tin) + "Add FI to C and return a tin. +FI is inserted in its proper place or maybe even merged with a preexisting + fileinfo if applicable. +TIN specifies an optional starting point." + (unless tin (setq tin (ewoc-nth c 0))) + (while (and tin (cvs-fileinfo< fi (ewoc-data tin))) + (setq tin (ewoc-prev c tin))) + (if (null tin) (progn (ewoc-enter-first c fi) nil) ;empty collection + (assert (not (cvs-fileinfo< fi (ewoc-data tin)))) + (let ((next-tin (ewoc-next c tin))) + (while (not (or (null next-tin) + (cvs-fileinfo< fi (ewoc-data next-tin)))) + (setq tin next-tin next-tin (ewoc-next c next-tin))) + (if (cvs-fileinfo< (ewoc-data tin) fi) + ;; tin < fi < next-tin + (ewoc-enter-after c tin fi) + ;; fi == tin + (cvs-fileinfo-update (ewoc-data tin) fi) + (ewoc-invalidate c tin)) + tin))) + +;; called at the following times: +;; - postparse ((eq cvs-auto-remove-handled t) cvs-auto-remove-directories nil) +;; - pre-run ((eq cvs-auto-remove-handled 'delayed) nil t) +;; - remove-handled (t (or cvs-auto-remove-directories 'handled) t) +;; - cvs-cmd-do (nil nil t) +;; - post-ignore (nil nil nil) +;; - acknowledge (nil nil nil) +;; - remove (nil nil nil) +(defun cvs-cleanup-collection (c rm-handled rm-dirs rm-msgs) + "Remove undesired entries. +C is the collection +RM-HANDLED if non-nil means remove handled entries. +RM-DIRS behaves like `cvs-auto-remove-directories'. +RM-MSGS if non-nil means remove messages." + (let (last-fi first-dir (rerun t)) + (while rerun + (setq rerun nil) + (setq first-dir t) + (setq last-fi (cvs-create-fileinfo 'DEAD "../" "" "")) ;place-holder + (ewoc-filter + c (lambda (fi) + (let* ((type (cvs-fileinfo->type fi)) + (subtype (cvs-fileinfo->subtype fi)) + (keep + (case type + ;; remove temp messages and keep the others + (MESSAGE + (or (memq subtype '(HEADER FOOTER)) + (not (or rm-msgs (eq subtype 'TEMP))))) + ;; remove entries + (DEAD nil) + ;; handled also? + (UP-TO-DATE (not rm-handled)) + ;; keep the rest + (t t)))) + + ;; mark dirs for removal + (when (and keep rm-dirs + (eq (cvs-fileinfo->type last-fi) 'DIRCHANGE) + (not (when first-dir (setq first-dir nil) t)) + (or (eq rm-dirs 'all) + (not (cvs-string-prefix-p + (cvs-fileinfo->dir last-fi) + (cvs-fileinfo->dir fi))) + (and (eq type 'DIRCHANGE) (eq rm-dirs 'empty)) + (eq subtype 'FOOTER))) + (setf (cvs-fileinfo->type last-fi) 'DEAD) + (setq rerun t)) + (when keep (setq last-fi fi)))))))) + +(defun cvs-get-cvsroot () + "Gets the CVSROOT for DIR." + (let ((cvs-cvsroot-file (expand-file-name "Root" "CVS"))) + (or (cvs-file-to-string cvs-cvsroot-file t) + cvs-cvsroot + (getenv "CVSROOT") + "?????"))) + +(defun cvs-get-module () + "Return the current CVS module. +This usually doesn't really work but is a handy initval in a prompt." + (let* ((repfile (expand-file-name "Repository" "CVS")) + (rep (cvs-file-to-string repfile t))) + (cond + ((null rep) "") + ((not (file-name-absolute-p rep)) rep) + (t + (let* ((root (cvs-get-cvsroot)) + (str (concat (file-name-as-directory (or root "/")) " || " rep))) + (if (and root (string-match "\\(.*\\) || \\1\\(.*\\)\\'" str)) + (match-string 2 str) + (file-name-nondirectory rep))))))) + + + +;;;; +;;;; running a "cvs checkout". +;;;; + +;;;###autoload +(defun cvs-checkout (modules dir flags) + "Run a 'cvs checkout MODULES' in DIR. +Feed the output to a *cvs* buffer, display it in the current window, +and run `cvs-mode' on it. + +With a prefix argument, prompt for cvs FLAGS to use." + (interactive + (list (cvs-string->strings (read-string "Module(s): " (cvs-get-module))) + (read-file-name "CVS Checkout Directory: " + nil default-directory nil) + (cvs-add-branch-prefix + (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags")))) + (when (eq flags t) + (setf flags (cvs-flags-query 'cvs-checkout-flags nil 'noquery))) + (cvs-cmd-do "checkout" (or dir default-directory) + (append flags modules) nil 'new + :noexist t)) + + +;;;; +;;;; The code for running a "cvs update" and friends in various ways. +;;;; + +(defun-cvs-mode (cvs-mode-revert-buffer . SIMPLE) + (&optional ignore-auto noconfirm) + "Rerun cvs-examine on the current directory with the defauls flags." + (interactive) + (cvs-examine default-directory t)) + +(defun cvs-query-directory (msg) + ;; last-command-char = ?\r hints that the command was run via M-x + (if (and (cvs-buffer-p) + (not current-prefix-arg) + (not (eq last-command-char ?\r))) + default-directory + (read-file-name msg nil default-directory nil))) + + +;;;###autoload +(defun cvs-examine (directory flags &optional noshow) + "Run a `cvs -n update' in the specified DIRECTORY. +That is, check what needs to be done, but don't change the disc. +Feed the output to a *cvs* buffer and run `cvs-mode' on it. +With a prefix argument, prompt for a directory and cvs FLAGS to use. +A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), + prevents reuse of an existing *cvs* buffer. +Optional argument NOSHOW if non-nil means not to display the buffer." + (interactive (list (cvs-query-directory "CVS Examine (directory): ") + (cvs-flags-query 'cvs-update-flags "cvs -n update flags"))) + (when (eq flags t) + (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery))) + (cvs-cmd-do "update" directory flags nil + (> (prefix-numeric-value current-prefix-arg) 8) + :cvsargs '("-n") + :noshow noshow + :dont-change-disc t)) + + +;;;###autoload +(defun cvs-update (directory flags) + "Run a `cvs update' in the current working DIRECTORY. +Feed the output to a *cvs* buffer and run `cvs-mode' on it. +With a prefix argument, prompt for a directory and cvs FLAGS to use. +A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), + prevents reuse of an existing *cvs* buffer." + (interactive (list (cvs-query-directory "CVS Update (directory): ") + (cvs-flags-query 'cvs-update-flags "cvs update flags"))) + (when (eq flags t) + (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery))) + (cvs-cmd-do "update" directory flags nil + (> (prefix-numeric-value current-prefix-arg) 8))) + + +;;;###autoload +(defun cvs-status (directory flags &optional noshow) + "Run a `cvs status' in the current working DIRECTORY. +Feed the output to a *cvs* buffer and run `cvs-mode' on it. +With a prefix argument, prompt for a directory and cvs FLAGS to use. +A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), + prevents reuse of an existing *cvs* buffer. +Optional argument NOSHOW if non-nil means not to display the buffer." + (interactive (list (cvs-query-directory "CVS Status (directory): ") + (cvs-flags-query 'cvs-status-flags "cvs status flags"))) + (when (eq flags t) + (setf flags (cvs-flags-query 'cvs-status-flags nil 'noquery))) + (cvs-cmd-do "status" directory flags nil + (> (prefix-numeric-value current-prefix-arg) 8) + :noshow noshow :dont-change-disc t)) + +;;---------- +(defun cvs-update-filter (proc string) + "Filter function for pcl-cvs. +This function gets the output that CVS sends to stdout. It inserts +the STRING into (process-buffer PROC) but it also checks if CVS is waiting +for a lock file. If so, it inserts a message cookie in the *cvs* buffer." + (save-match-data + (with-current-buffer (process-buffer proc) + (let ((inhibit-read-only t)) + (save-excursion + ;; Insert the text, moving the process-marker. + (goto-char (process-mark proc)) + (insert string) + (set-marker (process-mark proc) (point)) + ;; FIXME: Delete any old lock message + ;;(if (tin-nth cookies 1) + ;; (tin-delete cookies + ;; (tin-nth cookies 1))) + ;; Check if CVS is waiting for a lock. + (beginning-of-line 0) ;Move to beginning of last complete line. + (when (looking-at "^[ a-z]+: \\(.*waiting for .*lock in \\(.*\\)\\)$") + (let ((msg (match-string 1)) + (lock (match-string 2))) + (with-current-buffer cvs-buffer + (set (make-local-variable 'cvs-lock-file) lock) + ;; display the lock situation in the *cvs* buffer: + (ewoc-enter-last + cvs-cookies + (cvs-create-fileinfo + 'MESSAGE "" " " + (concat msg + (substitute-command-keys + "\n\t(type \\[cvs-mode-delete-lock] to delete it)")) + :subtype 'TEMP)) + (pop-to-buffer (current-buffer)) + (goto-char (point-max)) + (beep))))))))) + + +;;;; +;;;; The cvs-mode and its associated commands. +;;;; + +(cvs-prefix-define cvs-force-command "" "" '("/F") cvs-qtypedesc-string1) +(defun-cvs-mode cvs-mode-force-command (arg) + "Force the next cvs command to operate on all the selected files. +By default, cvs commands only operate on files on which the command +\"makes sense\". This overrides the safety feature on the next cvs command. +It actually behaves as a toggle. If prefixed by \\[universal-argument] \\[universal-argument], +the override will persist until the next toggle." + (interactive "P") + (cvs-prefix-set 'cvs-force-command arg)) + +;;---------- +(put 'cvs-mode 'mode-class 'special) +(easy-mmode-define-derived-mode cvs-mode fundamental-mode "CVS" + "Mode used for PCL-CVS, a frontend to CVS. +Full documentation is in the Texinfo file. +Pcl-cvs runs `pcl-cvs-load-hook' after being loaded." + (setq mode-line-process + '("" cvs-force-command cvs-ignore-marks-modif + ":" (cvs-branch-prefix + ("" cvs-branch-prefix (cvs-secondary-branch-prefix + ("->" cvs-secondary-branch-prefix)))) + " " cvs-mode-line-process)) + (buffer-disable-undo (current-buffer)) + ;;(set (make-local-variable 'goal-column) cvs-cursor-column) + (set (make-local-variable 'revert-buffer-function) 'cvs-mode-revert-buffer) + (cvs-prefix-make-local 'cvs-branch-prefix) + (cvs-prefix-make-local 'cvs-secondary-branch-prefix) + (cvs-prefix-make-local 'cvs-force-command) + (cvs-prefix-make-local 'cvs-ignore-marks-modif) + (make-local-variable 'cvs-mode-line-process) + (make-local-variable 'cvs-temp-buffers)) + + +(defun cvs-buffer-p (&optional buffer) + "Return whether the (by default current) BUFFER is a `cvs-mode' buffer." + (save-excursion + (if buffer (set-buffer buffer)) + (and (eq major-mode 'cvs-mode)))) + +(defun cvs-buffer-check () + "Check that the current buffer follows cvs-buffer's conventions." + (let ((buf (current-buffer)) + (check 'none)) + (or (and (setq check 'collection) + (eq (ewoc-buffer cvs-cookies) buf) + (setq check 'cvs-temp-buffer) + (or (null cvs-temp-buffer) + (null (buffer-name cvs-temp-buffer)) + (and (eq (with-current-buffer cvs-temp-buffer cvs-buffer) buf) + (equal (with-current-buffer cvs-temp-buffer + default-directory) + default-directory))) + t) + (error "Inconsistent %s in buffer %s" check (buffer-name buf))))) + + +(defun-cvs-mode cvs-mode-quit () + "Quit PCL-CVS, killing the *cvs* buffer." + (interactive) + (and (y-or-n-p "Quit pcl-cvs? ") (kill-buffer (current-buffer)))) + +;; Give help.... + +(defun cvs-help () + "Display help for various PCL-CVS commands." + (interactive) + (if (eq last-command 'cvs-help) + (describe-function 'cvs-mode) ; would need to use minor-mode for cvs-edit-mode + (message + (substitute-command-keys + "`\\[cvs-help]':help `\\[cvs-mode-add]':add `\\[cvs-mode-commit]':commit \ +`\\[cvs-mode-diff-map]':diff* `\\[cvs-mode-log]':log \ +`\\[cvs-mode-remove]':remove `\\[cvs-mode-status]':status \ +`\\[cvs-mode-undo]':undo")))) + +(defun cvs-mode-diff-help () + "Display help for various PCL-CVS diff commands." + (interactive) + (if (eq last-command 'cvs-mode-diff-help) + (describe-function 'cvs-mode) ; no better docs for diff stuff? + (message + (substitute-command-keys + "`\\[cvs-mode-diff]':diff `\\[cvs-mode-idiff]':idiff \ +`\\[cvs-mode-diff-head]':head `\\[cvs-mode-diff-vendor]':vendor \ +`\\[cvs-mode-diff-backup]':backup `\\[cvs-mode-idiff-other]':other \ +`\\[cvs-mode-imerge]':imerge")))) + +;; Move around in the buffer + +(defun-cvs-mode cvs-mode-previous-line (arg) + "Go to the previous line. +If a prefix argument is given, move by that many lines." + (interactive "p") + (ewoc-goto-prev cvs-cookies (point) arg)) + +(defun-cvs-mode cvs-mode-next-line (arg) + "Go to the next line. +If a prefix argument is given, move by that many lines." + (interactive "p") + (ewoc-goto-next cvs-cookies (point) arg)) + +;;;; +;;;; Mark handling +;;;; + +(defun-cvs-mode cvs-mode-mark (&optional arg) + "Mark the fileinfo on the current line. +If the fileinfo is a directory, all the contents of that directory are +marked instead. A directory can never be marked." + (interactive) + (let* ((tin (ewoc-locate cvs-cookies (point))) + (fi (ewoc-data tin))) + (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE) + ;; it's a directory: let's mark all files inside + (ewoc-map + (lambda (f dir) + (when (cvs-dir-member-p f dir) + (setf (cvs-fileinfo->marked f) + (not (if (eq arg 'toggle) (cvs-fileinfo->marked f) arg))) + t)) ;Tell cookie to redisplay this cookie. + cvs-cookies + (cvs-fileinfo->dir fi)) + ;; not a directory: just do the obvious + (setf (cvs-fileinfo->marked fi) + (not (if (eq arg 'toggle) (cvs-fileinfo->marked fi) arg))) + (ewoc-invalidate cvs-cookies tin) + (cvs-mode-next-line 1)))) + +(defun cvs-mouse-toggle-mark (e) + "Toggle the mark of the entry under the mouse." + (interactive "e") + (mouse-set-point e) + (cvs-mode-mark 'toggle)) + +(defun-cvs-mode cvs-mode-unmark () + "Unmark the fileinfo on the current line." + (interactive) + (cvs-mode-mark t)) + +(defun-cvs-mode cvs-mode-mark-all-files () + "Mark all files." + (interactive) + (ewoc-map (lambda (cookie) + (unless (eq (cvs-fileinfo->type cookie) 'DIRCHANGE) + (setf (cvs-fileinfo->marked cookie) t))) + cvs-cookies)) + +(defun-cvs-mode cvs-mode-mark-matching-files (regex) + "Mark all files matching REGEX." + (interactive "sMark files matching: ") + (ewoc-map (lambda (cookie) + (when (and (not (eq (cvs-fileinfo->type cookie) 'DIRCHANGE)) + (string-match regex (cvs-fileinfo->file cookie))) + (setf (cvs-fileinfo->marked cookie) t))) + cvs-cookies)) + +(defun-cvs-mode cvs-mode-unmark-all-files () + "Unmark all files. +Directories are also unmarked, but that doesn't matter, since +they should always be unmarked." + (interactive) + (ewoc-map (lambda (cookie) + (setf (cvs-fileinfo->marked cookie) nil) + t) + cvs-cookies)) + +(defun-cvs-mode cvs-mode-unmark-up () + "Unmark the file on the previous line." + (interactive) + (let ((tin (ewoc-goto-prev cvs-cookies (point) 1))) + (when tin + (setf (cvs-fileinfo->marked (ewoc-data tin)) nil) + (ewoc-invalidate cvs-cookies tin)))) + +(defconst cvs-ignore-marks-alternatives + '(("toggle-marks" . "/TM") + ("force-marks" . "/FM") + ("ignore-marks" . "/IM"))) + +(cvs-prefix-define cvs-ignore-marks-modif + "Prefix to decide whether to ignore marks or not." + "active" + (mapcar 'cdr cvs-ignore-marks-alternatives) + (cvs-qtypedesc-create + (lambda (str) (cdr (assoc str cvs-ignore-marks-alternatives))) + (lambda (obj) (caar (member* obj cvs-ignore-marks-alternatives :key 'cdr))) + (lambda () cvs-ignore-marks-alternatives) + nil t)) + +(defun-cvs-mode cvs-mode-toggle-marks (arg) + "Toggle whether the next CVS command uses marks. +See `cvs-prefix-set' for further description of the behavior. +\\[universal-argument] 1 selects `force-marks', +\\[universal-argument] 2 selects `ignore-marks', +\\[universal-argument] 3 selects `toggle-marks'." + (interactive "P") + (cvs-prefix-set 'cvs-ignore-marks-modif arg)) + +(defun cvs-ignore-marks-p (cmd &optional read-only) + (let ((default (if (member cmd cvs-invert-ignore-marks) + (not cvs-default-ignore-marks) + cvs-default-ignore-marks)) + (modif (cvs-prefix-get 'cvs-ignore-marks-modif read-only))) + (cond + ((equal modif "/IM") t) + ((equal modif "/TM") (not default)) + ((equal modif "/FM") nil) + (t default)))) + +(defun cvs-mode-mark-get-modif (cmd) + (if (cvs-ignore-marks-p cmd 'read-only) "/IM" "/FM")) + +(defvar cvs-minor-current-files) +(defun cvs-get-marked (&optional ignore-marks ignore-contents) + "Return a list of all selected fileinfos. +If there are any marked tins, and IGNORE-MARKS is nil, return them. +Otherwise, if the cursor selects a directory, and IGNORE-CONTENTS is +nil, return all files in it, else return just the directory. +Otherwise return (a list containing) the file the cursor points to, or +an empty list if it doesn't point to a file at all. + +Args: &optional IGNORE-MARKS IGNORE-CONTENTS." + + (let ((fis nil)) + (dolist (fi (if (boundp 'cvs-minor-current-files) + (mapcar + (lambda (f) + (let ((f (file-relative-name f))) + (if (file-directory-p f) + (cvs-create-fileinfo + 'DIRCHANGE (file-name-as-directory f) "." "") + (let ((dir (file-name-directory f)) + (file (file-name-nondirectory f))) + (cvs-create-fileinfo + 'UNKNOWN (or dir "") file ""))))) + cvs-minor-current-files) + (or (and (not ignore-marks) + (ewoc-collect cvs-cookies + 'cvs-fileinfo->marked)) + (list (ewoc-data (ewoc-locate cvs-cookies (point))))))) + + (if (or ignore-contents (not (eq (cvs-fileinfo->type fi) 'DIRCHANGE))) + (push fi fis) + ;; If a directory is selected, return members, if any. + (setq fis + (append (ewoc-collect cvs-cookies + 'cvs-dir-member-p + (cvs-fileinfo->dir fi)) + fis)))) + (nreverse fis))) + +(defun* cvs-mode-marked (filter &optional (cmd (symbol-name filter)) + &key read-only one file) + "Get the list of marked FIS. +CMD is used to determine whether to use the marks or not. +Only files for which FILTER is applicable are returned. +If READ-ONLY is non-nil, the current toggling is left intact. +If ONE is non-nil, marks are ignored and a single FI is returned. +If FILE is non-nil, directory entries won't be selected." + (let* ((fis (cvs-get-marked (or one (cvs-ignore-marks-p cmd read-only)) + (and (not file) + (cvs-applicable-p 'DIRCHANGE filter)))) + (force (cvs-prefix-get 'cvs-force-command)) + (fis (car (cvs-partition + (lambda (fi) (cvs-applicable-p fi (and (not force) filter))) + fis)))) + (cond + ((null fis) + (error "`%s' is not applicable to any of the selected files." filter)) + ((and one (cdr fis)) + (error "`%s' is only applicable to a single file." cmd)) + (one (car fis)) + (t fis)))) + +(defun cvs-enabledp (filter) + "Determine whether FILTER applies to at least one of the selected files." + (ignore-errors (cvs-mode-marked filter nil :read-only t))) + +(defun cvs-mode-files (&rest -cvs-mode-files-args) + (cvs-mode! + (lambda () + (mapcar 'cvs-fileinfo->full-path + (apply 'cvs-mode-marked -cvs-mode-files-args))))) + +;;; +;;; Interface between CVS-Edit and PCL-CVS +;;; + +(defun cvs-mode-commit-setup () + "Run `cvs-mode-commit' with setup." + (interactive) + (cvs-mode-commit 'force)) + +(defun cvs-mode-commit (setup) + "Check in all marked files, or the current file. +The user will be asked for a log message in a buffer. +The buffer's mode and name is determined by the \"message\" setting + of `cvs-buffer-name-alist'. +The POSTPROC specified there (typically `cvs-edit') is then called, + passing it the SETUP argument." + (interactive "P") + ;; It seems that the save-excursion that happens if I use the better + ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which + ;; end up being rather annoying (like cvs-edit-mode's message being + ;; displayed in the wrong minibuffer). + (cvs-mode!) + (pop-to-buffer (cvs-temp-buffer "message" 'normal 'nosetup)) + (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-commit-minor-wrap) + (let ((lbd list-buffers-directory) + (setupfun (or (third (cdr (assoc "message" cvs-buffer-name-alist))) + 'cvs-edit))) + (funcall setupfun 'cvs-do-commit setup 'cvs-commit-filelist) + (set (make-local-variable 'list-buffers-directory) lbd))) + +(defun cvs-commit-minor-wrap (buf f) + (let ((cvs-ignore-marks-modif (cvs-mode-mark-get-modif "commit"))) + (funcall f))) + +(defun cvs-commit-filelist () (cvs-mode-files 'commit nil :read-only t :file t)) + +(defun cvs-do-commit (flags) + "Do the actual commit, using the current buffer as the log message." + (interactive (list (cvs-flags-query 'cvs-commit-flags "cvs commit flags"))) + (let ((msg (buffer-string))) + (cvs-mode!) + ;;(pop-to-buffer cvs-buffer) + (cvs-mode-do "commit" (list* "-m" msg flags) 'commit))) + + +;;;; +;;;; CVS Mode commands +;;;; + +(defun-cvs-mode (cvs-mode-insert . NOARGS) (file) + "Insert an entry for a specific file." + (interactive + (list (read-file-name "File to insert: " nil nil nil + (ignore-errors + (cvs-fileinfo->dir + (car (cvs-mode-marked nil nil :read-only t))))))) + (let ((file (file-relative-name (directory-file-name file)))) + (if (file-directory-p file) + (let ((fi (cvs-create-fileinfo 'DIRCHANGE + (file-name-as-directory file) + "." + "cvs-mode-insert"))) + (cvs-addto-collection cvs-cookies fi)) + (let ((fi (cvs-create-fileinfo 'UNKNOWN + (or (file-name-directory file) "") + (file-name-nondirectory file) + "cvs-mode-insert"))) + (cvs-mode-run "status" (cvs-flags-query 'cvs-status-flags nil 'noquery) + (list fi) :dont-change-disc t))))) + +(defun-cvs-mode (cvs-mode-add . SIMPLE) (flags) + "Add marked files to the cvs repository. +With prefix argument, prompt for cvs flags." + (interactive (list (cvs-flags-query 'cvs-add-flags "cvs add flags"))) + (let ((fis (cvs-mode-marked 'add)) + (needdesc nil) (dirs nil)) + ;; find directories and look for fis needing a description + (dolist (fi fis) + (cond + ((file-directory-p (cvs-fileinfo->full-path fi)) (push fi dirs)) + ((eq (cvs-fileinfo->type fi) 'UNKNOWN) (setq needdesc t)))) + ;; prompt for description if necessary + (let* ((msg (if (and needdesc + (or current-prefix-arg (not cvs-add-default-message))) + (read-from-minibuffer "Enter description: ") + (or cvs-add-default-message ""))) + (flags (list* "-m" msg flags)) + (postproc + ;; setup postprocessing for the directory entries + (when dirs + `((cvs-run-process (list "-n" "update") + ',dirs + '(cvs-parse-process t)) + (dolist (fi ',dirs) (setf (cvs-fileinfo->type fi) 'DEAD)))))) + (cvs-mode-run "add" flags fis :postproc postproc)))) + +;;---------- +(defun-cvs-mode (cvs-mode-diff . DOUBLE) (flags) + "Diff the selected files against the repository. +This command compares the files in your working area against the +revision which they are based upon." + (interactive + (list (cvs-add-branch-prefix + (cvs-add-secondary-branch-prefix + (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))))) + (cvs-mode-do "diff" flags 'diff + :show t)) ;; :ignore-exit t + +;;---------- +(defun-cvs-mode (cvs-mode-diff-head . SIMPLE) (flags) + "Diff the selected files against the head of the current branch. +See ``cvs-mode-diff'' for more info." + (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) + (cvs-mode-diff-1 (cons "-rHEAD" flags))) + +;;---------- +(defun-cvs-mode (cvs-mode-diff-vendor . SIMPLE) (flags) + "Diff the selected files against the head of the vendor branch. +See ``cvs-mode-diff'' for more info." + (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) + (cvs-mode-diff-1 (cons (concat "-r" cvs-vendor-branch) flags))) + +;;---------- +;; sadly, this is not provided by cvs, so we have to roll our own +(defun-cvs-mode (cvs-mode-diff-backup . SIMPLE) (flags) + "Diff the files against the backup file. +This command can be used on files that are marked with \"Merged\" +or \"Conflict\" in the *cvs* buffer." + (interactive (list (cvs-flags-query 'cvs-diff-flags "diff flags"))) + (unless (listp flags) (error "flags should be a list of strings.")) + (save-some-buffers) + (let* ((filter 'diff) + (marked (cvs-get-marked (cvs-ignore-marks-p "diff"))) + ;;(tins (cvs-filter-applicable filter marked)) + (fis (delete-if-not 'cvs-fileinfo->backup-file marked))) + (unless (consp fis) + (error "No files with a backup file selected!")) + ;; let's extract some info into the environment for `buffer-name' + (let* ((dir (cvs-fileinfo->dir (car fis))) + (file (cvs-fileinfo->file (car fis)))) + (set-buffer (cvs-temp-buffer "diff"))) + (message "cvs diff backup...") + (cvs-execute-single-file-list fis 'cvs-diff-backup-extractor + cvs-diff-program flags)) + (message "cvs diff backup... Done.")) + +;;---------- +;; (defun cvs-backup-diffable-p (fi) +;; "Check if the TIN is backup-diffable. +;; It must have a backup file to be diffable." +;; (cvs-fileinfo->backup-file fi)) + +;;---------- +(defun cvs-diff-backup-extractor (fileinfo) + "Return the filename and the name of the backup file as a list. +Signal an error if there is no backup file." + (let ((backup-file (cvs-fileinfo->backup-file fileinfo))) + (unless backup-file + (error "%s has no backup file." (cvs-fileinfo->full-path fileinfo))) + (list backup-file (cvs-fileinfo->file fileinfo)))) + +;; +;; Emerge support +;; +(defun cvs-emerge-diff (b1 b2) (emerge-buffers b1 b2 b1)) +(defun cvs-emerge-merge (b1 b2 base out) + (emerge-buffers-with-ancestor b1 b2 base (find-file-noselect out))) + +;; +;; Ediff support +;; + +(defvar ediff-after-quit-destination-buffer) +(defvar cvs-transient-buffers) +(defun cvs-ediff-startup-hook () + (add-hook 'ediff-after-quit-hook-internal + `(lambda () + (cvs-ediff-exit-hook + ',ediff-after-quit-destination-buffer ',cvs-transient-buffers)) + nil 'local)) + +(defun cvs-ediff-exit-hook (cvs-buf tmp-bufs) + ;; kill the temp buffers (and their associated windows) + (dolist (tb tmp-bufs) + (when (and tb (buffer-live-p tb) (not (buffer-modified-p tb))) + (let ((win (get-buffer-window tb t))) + (when win (delete-window win)) + (kill-buffer tb)))) + ;; switch back to the *cvs* buffer + (when (and cvs-buf (buffer-live-p cvs-buf) + (not (get-buffer-window cvs-buf t))) + (ignore-errors (switch-to-buffer cvs-buf)))) + +(defun cvs-ediff-diff (b1 b2) + (let ((ediff-after-quit-destination-buffer (current-buffer)) + (startup-hook '(cvs-ediff-startup-hook))) + (ediff-buffers b1 b2 startup-hook 'ediff-revisions))) + +(defun cvs-ediff-merge (b1 b2 base out) + (let ((ediff-after-quit-destination-buffer (current-buffer)) + (startup-hook '(cvs-ediff-startup-hook))) + (ediff-merge-buffers-with-ancestor + b1 b2 base startup-hook + 'ediff-merge-revisions-with-ancestor + out))) + +;; +;; Interactive merge/diff support. +;; + +(defun cvs-retrieve-revision (fileinfo rev) + "Retrieve the given REVision of the file in FILEINFO into a new buffer." + (save-excursion + (let* ((file (cvs-fileinfo->full-path fileinfo)) + (buf (create-file-buffer (concat file "." rev)))) + (set-buffer buf) + (message "Retrieving revision %s..." rev) + (let ((res (call-process cvs-program nil t nil + "-q" "update" "-p" "-r" rev file))) + (when (and res (not (and (equal 0 res)))) + (error "Something went wrong retrieving revision %s: %s" rev res)) + (set-buffer-modified-p nil) + (let ((buffer-file-name (expand-file-name file))) + (after-find-file)) + (toggle-read-only 1) + (message "Retrieving revision %s... Done" rev) + buf)))) + +(eval-and-compile (autoload 'vc-resolve-conflicts "vc")) + +(defun-cvs-mode cvs-mode-imerge () + "Merge interactively appropriate revisions of the selected file." + (interactive) + (let ((fi (cvs-mode-marked 'merge nil :one t :file t))) + (let ((merge (cvs-fileinfo->merge fi)) + (file (cvs-fileinfo->full-path fi)) + (backup-file (cvs-fileinfo->backup-file fi))) + (if (not (and merge backup-file)) + (let ((buf (find-file-noselect file))) + (message "Missing merge info or backup file, using VC.") + (save-excursion + (set-buffer buf) + (vc-resolve-conflicts))) + (let* ((ancestor-buf (cvs-retrieve-revision fi (car merge))) + (head-buf (cvs-retrieve-revision fi (cdr merge))) + (backup-buf (let ((auto-mode-alist nil)) + (find-file-noselect backup-file))) + ;; this binding is used by cvs-ediff-startup-hook + (cvs-transient-buffers (list ancestor-buf backup-buf head-buf))) + (with-current-buffer backup-buf + (let ((buffer-file-name (expand-file-name file))) + (after-find-file))) + (funcall (cdr cvs-idiff-imerge-handlers) + backup-buf head-buf ancestor-buf file)))))) + +(cvs-flags-define cvs-idiff-version + (list "BASE" cvs-vendor-branch cvs-vendor-branch "BASE" "BASE") + "version: " cvs-qtypedesc-tag) + +(defun-cvs-mode (cvs-mode-idiff . NOARGS) (&optional rev1 rev2) + "Diff interactively current file to revisions." + (interactive + (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix)) + (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix)))) + (list (or rev1 (cvs-flags-query 'cvs-idiff-version)) + rev2))) + (let ((fi (cvs-mode-marked 'diff "idiff" :one t :file t))) + (let* ((file (cvs-fileinfo->full-path fi)) + (rev1-buf (cvs-retrieve-revision fi (or rev1 "BASE"))) + (rev2-buf (if rev2 (cvs-retrieve-revision fi rev2))) + ;; this binding is used by cvs-ediff-startup-hook + (cvs-transient-buffers (list rev1-buf rev2-buf))) + (funcall (car cvs-idiff-imerge-handlers) + rev1-buf (or rev2-buf (find-file-noselect file)))))) + +(defun-cvs-mode (cvs-mode-idiff-other . NOARGS) () + "Diff interactively current file to revisions." + (interactive) + (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix)) + (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix))) + (fis (cvs-mode-marked 'diff "idiff" :file t))) + (when (> (length fis) 2) + (error "idiff-other cannot be applied to more than 2 files at a time.")) + (let* ((fi1 (first fis)) + (rev1-buf (if rev1 (cvs-retrieve-revision fi1 rev1) + (find-file-noselect (cvs-fileinfo->full-path fi1)))) + rev2-buf) + (if (cdr fis) + (let ((fi2 (second fis))) + (setq rev2-buf + (if rev2 (cvs-retrieve-revision fi2 rev2) + (find-file-noselect (cvs-fileinfo->full-path fi2))))) + (error "idiff-other doesn't know what other file/buffer to use.")) + (let* (;; this binding is used by cvs-ediff-startup-hook + (cvs-transient-buffers (list rev1-buf rev2-buf))) + (funcall (car cvs-idiff-imerge-handlers) + rev1-buf rev2-buf))))) + + +(defun cvs-fileinfo-kill (c fi) + "Mark a fileinfo xor its members (in case of a directory) as dead." + (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE) + (dolist (fi (ewoc-collect c 'cvs-dir-member-p + (cvs-fileinfo->dir fi))) + (setf (cvs-fileinfo->type fi) 'DEAD)) + (setf (cvs-fileinfo->type fi) 'DEAD))) + +(defun* cvs-mode-run (cmd flags fis + &key (buf (cvs-temp-buffer)) + dont-change-disc cvsargs postproc) + "Generic cvs-mode-<foo> function. +Executes `cvs CVSARGS CMD FLAGS FIS'. +BUF is the buffer to be used for cvs' output. +DONT-CHANGE-DISC non-nil indicates that the command will not change the + contents of files. This is only used by the parser. +POSTPROC is a list of expressions to be evaluated at the very end (after + parsing if applicable). It will be prepended with `progn' is necessary." + (save-some-buffers) + (unless (listp flags) (error "flags should be a list of strings")) + (let* ((cvs-buf (current-buffer)) + (single-dir (or (not (listp cvs-execute-single-dir)) + (member cmd cvs-execute-single-dir))) + (parse (member cmd cvs-parse-known-commands)) + (args (append cvsargs (list cmd) flags)) + (after-mode (third (cdr (assoc cmd cvs-buffer-name-alist))))) + (cvs-cleanup-collection cvs-cookies ;cleanup remaining messages + (eq cvs-auto-remove-handled 'delayed) nil t) + (when (fboundp after-mode) + (setq postproc (append postproc `((,after-mode))))) + (when parse (push `(cvs-parse-process ',dont-change-disc) postproc)) + (when (member cmd '("status" "update")) ;FIXME: Yuck!! + ;; absence of `cvs update' output has a specific meaning. + (push + `(dolist (fi ',(or fis + (list (cvs-create-fileinfo 'DIRCHANGE "" "." "")))) + (cvs-fileinfo-kill ',cvs-cookies fi)) + postproc)) + (setq postproc (if (cdr postproc) (cons 'progn postproc) (car postproc))) + (cvs-update-header args fis) + (with-current-buffer buf + ;;(set (make-local-variable 'cvs-buffer) cvs-buf) + (let ((inhibit-read-only t)) (erase-buffer)) + (message "Running cvs %s ..." cmd) + (cvs-run-process args fis postproc single-dir)))) + + +(defun* cvs-mode-do (cmd flags filter + &key show dont-change-disc parse cvsargs postproc) + "Generic cvs-mode-<foo> function. +Executes `cvs CVSARGS CMD FLAGS' on the selected files. +FILTER is passed to `cvs-applicable-p' to only apply the command to + files for which it makes sense. +SHOW indicates that CMD should be not be run in the default temp buffer and + should be shown to the user. The buffer and mode to be used is determined + by `cvs-buffer-name-alist'. +DONT-CHANGE-DISC non-nil indicates that the command will not change the + contents of files. This is only used by the parser." + (cvs-mode-run cmd flags (cvs-mode-marked filter cmd) + :buf (cvs-temp-buffer (when show cmd)) + :dont-change-disc dont-change-disc + :cvsargs cvsargs + :postproc postproc)) + +(defun-cvs-mode (cvs-mode-status . SIMPLE) (flags) + "Show cvs status for all marked files. +With prefix argument, prompt for cvs flags." + (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags"))) + (cvs-mode-do "status" flags nil :dont-change-disc t :show t + :postproc (when (eq cvs-auto-remove-handled 'status) + '((with-current-buffer ,(current-buffer) + (cvs-mode-remove-handled)))))) + +(defun-cvs-mode (cvs-mode-tree . SIMPLE) (flags) + "Call cvstree using the file under the point as a keyfile." + (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags"))) + (cvs-mode-run "status" (cons "-v" flags) (cvs-mode-marked nil "status") + :buf (cvs-temp-buffer "tree") + :dont-change-disc t + :postproc '((cvs-status-trees)))) + +;; cvs log + +(defun-cvs-mode (cvs-mode-log . NOARGS) (flags) + "Display the cvs log of all selected files. +With prefix argument, prompt for cvs flags." + (interactive (list (cvs-add-branch-prefix + (cvs-flags-query 'cvs-log-flags "cvs log flags")))) + (cvs-mode-do "log" flags nil :show t)) + + +(defun-cvs-mode (cvs-mode-update . NOARGS) (flags) + "Update all marked files. +With a prefix argument, prompt for cvs flags." + (interactive + (list (cvs-add-branch-prefix + (cvs-add-secondary-branch-prefix + (cvs-flags-query 'cvs-update-flags "cvs update flags") + "-j") "-j"))) + (cvs-mode-do "update" flags 'update)) + + +(defun-cvs-mode (cvs-mode-examine . NOARGS) (flags) + "Re-examine all marked files. +With a prefix argument, prompt for cvs flags." + (interactive + (list (cvs-add-branch-prefix + (cvs-add-secondary-branch-prefix + (cvs-flags-query 'cvs-update-flags "cvs -n update flags") + "-j") "-j"))) + (cvs-mode-do "update" flags nil :cvsargs '("-n") :dont-change-disc t)) + + +(defun-cvs-mode cvs-mode-ignore (&optional pattern) + "Arrange so that CVS ignores the selected files. +This command ignores files that are not flagged as `Unknown'." + (interactive) + (dolist (fi (cvs-mode-marked 'ignore)) + (cvs-append-to-ignore (cvs-fileinfo->dir fi) (cvs-fileinfo->file fi)) + (setf (cvs-fileinfo->type fi) 'DEAD)) + (cvs-cleanup-collection cvs-cookies nil nil nil)) + + +(defun cvs-append-to-ignore (dir str) + "Add STR to the .cvsignore file in DIR." + (save-window-excursion + (set-buffer (find-file-noselect (expand-file-name ".cvsignore" dir))) + (when (ignore-errors + (and buffer-read-only + (eq 'CVS (vc-backend buffer-file-name)) + (not (vc-locking-user buffer-file-name)))) + ;; CVSREAD=on special case + (vc-toggle-read-only)) + (goto-char (point-max)) + (unless (zerop (current-column)) (insert "\n")) + (insert str "\n") + (if cvs-sort-ignore-file (sort-lines nil (point-min) (point-max))) + (save-buffer))) + + +(defun cvs-mode-find-file-other-window (e) + "Select a buffer containing the file in another window." + (interactive (list last-input-event)) + (cvs-mode-find-file e t)) + + +(defun cvs-find-modif (fi) + (with-temp-buffer + (call-process cvs-program nil (current-buffer) nil + "-f" "diff" (cvs-fileinfo->file fi)) + (goto-char (point-min)) + (if (re-search-forward "^\\([0-9]+\\)" nil t) + (string-to-number (match-string 1)) + 1))) + + +(defun cvs-mode-find-file (e &optional other) + "Select a buffer containing the file. +With a prefix, opens the buffer in an OTHER window." + (interactive (list last-input-event current-prefix-arg)) + (ignore-errors (mouse-set-point e)) ;for invocation via the mouse + (cvs-mode! + (lambda (&optional rev) + (interactive (list (cvs-prefix-get 'cvs-branch-prefix))) + (let* ((cvs-buf (current-buffer)) + (fi (cvs-mode-marked nil nil :one t))) + (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE) + (let ((odir default-directory)) + (setq default-directory + (cvs-expand-dir-name (cvs-fileinfo->dir fi))) + (if other + (dired-other-window default-directory) + (dired default-directory)) + (set-buffer cvs-buf) + (setq default-directory odir)) + (let ((buf (if rev (cvs-retrieve-revision fi rev) + (find-file-noselect (cvs-fileinfo->full-path fi))))) + (funcall (if other 'switch-to-buffer-other-window 'switch-to-buffer) + buf) + (when (and cvs-find-file-and-jump (cvs-applicable-p fi 'diff-base)) + (goto-line (cvs-find-modif fi))) + buf)))))) + + +(defun-cvs-mode (cvs-mode-undo . SIMPLE) (flags) + "Undo local changes to all marked files. +The file is removed and `cvs update FILE' is run." + ;;"With prefix argument, prompt for cvs FLAGS." + (interactive (list nil));; (cvs-flags-query 'cvs-undo-flags "undo flags") + (if current-prefix-arg (call-interactively 'cvs-mode-revert-to-rev) + (let* ((fis (cvs-do-removal 'undo "update" 'all)) + (removedp (lambda (fi) (eq (cvs-fileinfo->type fi) 'REMOVED))) + (fis-split (cvs-partition removedp fis)) + (fis-removed (car fis-split)) + (fis-other (cdr fis-split))) + (if (null fis-other) + (when fis-removed (cvs-mode-run "add" nil fis-removed)) + (cvs-mode-run "update" flags fis-other + :postproc + (when fis-removed + `((with-current-buffer ,(current-buffer) + (cvs-mode-run "add" nil ',fis-removed))))))))) + + +(defun-cvs-mode (cvs-mode-revert-to-rev . NOARGS) (rev) + "Revert the selected files to an old revision." + (interactive + (list (or (cvs-prefix-get 'cvs-branch-prefix) + (let ((current-prefix-arg '(4))) + (cvs-flags-query 'cvs-idiff-version))))) + (let* ((fis (cvs-mode-marked 'revert "revert" :file t)) + (tag (concat "tmp_pcl_tag_" (make-temp-name ""))) + (untag `((with-current-buffer ,(current-buffer) + (cvs-mode-run "tag" (list "-d" ',tag) ',fis)))) + (update `((with-current-buffer ,(current-buffer) + (cvs-mode-run "update" (list "-j" ',tag "-j" ',rev) ',fis + :postproc ',untag))))) + (cvs-mode-run "tag" (list tag) fis :postproc update))) + + +(defun-cvs-mode cvs-mode-delete-lock () + "Delete the lock file that CVS is waiting for. +Note that this can be dangerous. You should only do this +if you are convinced that the process that created the lock is dead." + (interactive) + (let* ((default-directory (cvs-expand-dir-name cvs-lock-file)) + (locks (directory-files default-directory nil cvs-lock-file-regexp))) + (cond + ((not locks) (error "No lock files found.")) + ((yes-or-no-p (concat "Really delete locks in " cvs-lock-file "? ")) + (dolist (lock locks) + (cond ((file-directory-p lock) (delete-directory lock)) + ((file-exists-p lock) (delete-file lock)))))))) + + +(defun-cvs-mode cvs-mode-remove-handled () + "Remove all lines that are handled. +Empty directories are removed." + (interactive) + (cvs-cleanup-collection cvs-cookies + t (or cvs-auto-remove-directories 'handled) t)) + + +(defun-cvs-mode cvs-mode-acknowledge () + "Remove all marked files from the buffer." + (interactive) + (dolist (fi (cvs-get-marked (cvs-ignore-marks-p "acknowledge") t)) + (setf (cvs-fileinfo->type fi) 'DEAD)) + (cvs-cleanup-collection cvs-cookies nil nil nil)) + +;;---------- +(defun cvs-insert-full-path (tin) + "Insert full path to the file described in TIN in the current buffer." + (insert (format "%s\n" (cvs-full-path tin)))) + +(defun cvs-do-removal (filter &optional cmd all) + "Remove files. +Returns a list of FIS that should be `cvs remove'd." + (let* ((files (cvs-mode-marked filter cmd :file t :read-only t)) + (fis (delete-if (lambda (fi) (eq (cvs-fileinfo->type fi) 'UNKNOWN)) + (cvs-mode-marked filter cmd))) + (silent (or (not cvs-confirm-removals) + (cvs-every (lambda (fi) + (or (not (file-exists-p + (cvs-fileinfo->full-path fi))) + (cvs-applicable-p fi 'safe-rm))) + files)))) + (when (and (not silent) (equal cvs-confirm-removals 'list)) + (save-excursion + (pop-to-buffer (cvs-temp-buffer)) + (dolist (fi fis) + (insert (cvs-fileinfo->full-path fi) "\n")))) + (if (not (or silent + (yes-or-no-p (format "Delete %d files? " (length files))))) + (progn (message "Aborting") nil) + (dolist (fi files) + (let* ((type (cvs-fileinfo->type fi)) + (file (cvs-fileinfo->full-path fi))) + (when (or all (eq type 'UNKNOWN)) + (when (file-exists-p file) (delete-file file)) + (unless all (setf (cvs-fileinfo->type fi) 'DEAD) t)))) + fis))) + +(defun-cvs-mode (cvs-mode-remove . SIMPLE) (flags) + "Remove all marked files. +With prefix argument, prompt for cvs flags." + (interactive (list (cvs-flags-query 'cvs-remove-flags "cvs remove flags"))) + (let ((fis (cvs-do-removal 'remove))) + (if fis (cvs-mode-run "remove" (cons "-f" flags) fis) + (cvs-cleanup-collection cvs-cookies nil nil nil)))) + + +(defvar cvs-tag-name "") +(defun-cvs-mode (cvs-mode-tag . SIMPLE) (tag &optional flags) + "Run `cvs tag TAG' on all selected files. +With prefix argument, prompt for cvs flags." + (interactive + (list (setq cvs-tag-name + (cvs-query-read cvs-tag-name "Tag name: " cvs-qtypedesc-tag)) + (cvs-flags-query 'cvs-tag-flags "tag flags"))) + (cvs-mode-do "tag" (append flags (list tag)) + (when cvs-force-dir-tag 'tag))) + +(defun-cvs-mode (cvs-mode-untag . SIMPLE) (tag &optional flags) + "Run `cvs tag -d TAG' on all selected files. +With prefix argument, prompt for cvs flags." + (interactive + (list (setq cvs-tag-name + (cvs-query-read cvs-tag-name "Tag to delete: " cvs-qtypedesc-tag)) + (cvs-flags-query 'cvs-tag-flags "tag flags"))) + (cvs-mode-do "tag" (append '("-d") flags (list tag)) + (when cvs-force-dir-tag 'tag))) + + +;; Byte compile files. + +(defun-cvs-mode cvs-mode-byte-compile-files () + "Run byte-compile-file on all selected files that end in '.el'." + (interactive) + (let ((marked (cvs-get-marked (cvs-ignore-marks-p "byte-compile")))) + (dolist (fi marked) + (let ((filename (cvs-fileinfo->full-path fi))) + (when (string-match "\\.el\\'" filename) + (byte-compile-file filename)))))) + +;; ChangeLog support. + +;;---------- +(defun-cvs-mode cvs-mode-add-change-log-entry-other-window () + "Add a ChangeLog entry in the ChangeLog of the current directory." + (interactive) + (let* ((fi (cvs-mode-marked nil nil :one t)) + (default-directory (cvs-expand-dir-name (cvs-fileinfo->dir fi))) + (buffer-file-name (expand-file-name (cvs-fileinfo->file fi)))) + ;; This `save-excursion' is necessary because of interaction between + ;; dynamic scoping and buffer-local variables: + ;; the above binding of `buffer-file-name' has temporarily changed the + ;; buffer-local variable (same thing for `default-directory'), so we + ;; need to switch back to the original buffer before the unbinding + ;; restores the old value. + (save-excursion (add-change-log-entry-other-window)))) + +;; interactive commands to set optional flags + +(defun cvs-mode-set-flags (flag) + "Ask for new setting of cvs-FLAG-flags." + (interactive + (list (completing-read + "Which flag: " + (mapcar 'list '("cvs" "diff" "update" "status" "log" "tag" ;"rtag" + "commit" "remove" "undo" "checkout")) + nil t))) + (let* ((sym (intern (concat "cvs-" flag "-flags")))) + (let ((current-prefix-arg '(16))) + (cvs-flags-query sym (concat flag " flags"))))) + + +;;;; +;;;; Utilities for the *cvs* buffer +;;;; + +;;---------- +(defun cvs-full-path (tin) + "Return the full path for the file that is described in TIN." + (cvs-fileinfo->full-path (ewoc-data tin))) + +;;---------- +(defun cvs-dir-member-p (fileinfo dir) + "Return true if FILEINFO represents a file in directory DIR." + (and (not (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE)) + (cvs-string-prefix-p dir (cvs-fileinfo->dir fileinfo)) + (not (memq (cvs-fileinfo->subtype fileinfo) '(HEADER FOOTER))))) + +(defun cvs-execute-single-file (fi extractor program constant-args) + "Internal function for `cvs-execute-single-file-list'." + (let* ((cur-dir (cvs-fileinfo->dir fi)) + (default-directory (cvs-expand-dir-name cur-dir)) + (inhibit-read-only t) + (arg-list (funcall extractor fi))) + + ;; Execute the command unless extractor returned t. + (when (listp arg-list) + (let* ((args (append constant-args arg-list))) + + (insert (format "=== cd %s\n=== %s %s\n\n" + cur-dir program (cvs-strings->string args))) + + ;; FIXME: return the exit status? + (apply 'call-process program nil t t args) + (goto-char (point-max)))))) + +;; FIXME: make this run in the background ala cvs-run-process... +(defun cvs-execute-single-file-list (fis extractor program constant-args) + "Run PROGRAM on all elements on FIS. +The PROGRAM will be called with pwd set to the directory the files +reside in. CONSTANT-ARGS is a list of strings to pass as arguments to +PROGRAM. The arguments given to the program will be CONSTANT-ARGS +followed by the list that EXTRACTOR returns. + +EXTRACTOR will be called once for each file on FIS. It is given +one argument, the cvs-fileinfo. It can return t, which means ignore +this file, or a list of arguments to send to the program." + (dolist (fi fis) + (cvs-execute-single-file fi extractor program constant-args))) + + +(defun cvs-revert-if-needed (fis) + (dolist (fileinfo fis) + (let* ((file (cvs-fileinfo->full-path fileinfo)) + (buffer (find-buffer-visiting file))) + ;; For a revert to happen the user must be editing the file... + (unless (or (null buffer) + (eq (cvs-fileinfo->type fileinfo) 'MESSAGE) + ;; FIXME: check whether revert is really needed. + ;; `(verify-visited-file-modtime buffer)' doesn't cut it + ;; because it only looks at the time stamp (it ignores + ;; read-write changes) which is not changed by `commit'. + (buffer-modified-p buffer)) + (with-current-buffer buffer + (let ((cvs-buf-was-ro buffer-read-only)) + (ignore-errors + ;; Ideally, we'd like to prevent changing the (minor) modes. + ;; But we do want to reset the mode for some cases, most notably + ;; VC. Maybe it'd better to reset VC explicitely ? + (revert-buffer 'ignore-auto 'dont-ask)) ; 'preserve-modes + ;; protect the buffer-read-only setting + (if cvs-buf-was-ro (toggle-read-only 1)))))))) + + + +(defun cvs-change-cvsroot (newroot) + "Change the cvsroot." + (interactive "DNew repository: ") + (if (or (file-directory-p (expand-file-name "CVSROOT" newroot)) + (y-or-n-p (concat "Warning: no CVSROOT found inside repository." + " Change cvs-cvsroot anyhow?"))) + (setq cvs-cvsroot newroot))) + +;;;; +;;;; useful global settings +;;;; + +;;;###autoload +(add-to-list 'completion-ignored-extensions "CVS/") + +;; +;; Hook to allow calling PCL-CVS by visiting the /CVS subdirectory +;; + +;;;###autoload +(defcustom cvs-dired-use-hook '(4) + "Whether or not opening a CVS directory should run PCL-CVS. +NIL means never do it. +ALWAYS means to always do it unless a prefix argument is given to the + command that prompted the opening of the directory. +Anything else means to do it only if the prefix arg is equal to this value." + :group 'pcl-cvs + :type '(choice (const :tag "Never" nil) + (const :tag "Always" always) + (const :tag "Prefix" (4)))) + +;;;###autoload +(progn +(defun cvs-dired-noselect (dir) + "Run `cvs-examine' if DIR is a CVS administrative directory. +The exact behavior is determined also by `cvs-dired-use-hook'." + (when (stringp dir) + (setq dir (directory-file-name dir)) + (when (and (string= "CVS" (file-name-nondirectory dir)) + (file-readable-p (expand-file-name "Entries" dir)) + cvs-dired-use-hook + (if (eq cvs-dired-use-hook 'always) + (not current-prefix-arg) + (equal current-prefix-arg cvs-dired-use-hook))) + (save-excursion + (cvs-examine (file-name-directory dir) t t)))))) + +;; +;; hook into VC +;; + +(defadvice vc-simple-command (after pcl-cvs-vc activate) + (cvs-vc-command-advice "*vc-info*" (ad-get-arg 1) (ad-get-arg 3))) + +(defadvice vc-do-command (after pcl-cvs-vc activate) + (cvs-vc-command-advice (or (ad-get-arg 0) "*vc*") + (ad-get-arg 2) (ad-get-arg 5))) + +(defun cvs-vc-command-advice (buffer command cvscmd) + (when (and (setq buffer (get-buffer buffer)) + (equal command "cvs") + ;; don't parse output we don't understand. + (member cvscmd cvs-parse-known-commands)) + (save-excursion + (let ((dir (with-current-buffer buffer default-directory)) + (cvs-from-vc t)) + (dolist (cvs-buf (buffer-list)) + (set-buffer cvs-buf) + ;; look for a corresponding pcl-cvs buffer + (when (and (eq major-mode 'cvs-mode) + (cvs-string-prefix-p default-directory dir)) + (let ((subdir (substring dir (length default-directory)))) + (set-buffer buffer) + (set (make-local-variable 'cvs-buffer) cvs-buf) + ;; VC never (?) does `cvs -n update' so dcd=nil + ;; should probably always be the right choice. + (cvs-parse-process nil subdir)))))))) + +;; +;; Hook into write-buffer +;; + +(defun cvs-mark-buffer-changed () + (let* ((file (expand-file-name buffer-file-name)) + (version (and (fboundp 'vc-backend) + (eq (vc-backend file) 'CVS) + (vc-workfile-version file)))) + (when version + (save-excursion + (dolist (cvs-buf (buffer-list)) + (set-buffer cvs-buf) + ;; look for a corresponding pcl-cvs buffer + (when (and (eq major-mode 'cvs-mode) + (cvs-string-prefix-p default-directory file)) + (let* ((file (substring file (length default-directory))) + (fi (cvs-create-fileinfo + (if (string= "0" version) + 'ADDED 'MODIFIED) + (or (file-name-directory file) "") + (file-name-nondirectory file) + "cvs-mark-buffer-changed"))) + (cvs-addto-collection cvs-cookies fi)))))))) + +(add-hook 'after-save-hook 'cvs-mark-buffer-changed) + +;; +;; hook into uniquify +;; + +(defadvice uniquify-buffer-file-name (after pcl-cvs-uniquify activate) + (or ad-return-value + (save-excursion + (set-buffer (ad-get-arg 0)) + (when (eq major-mode 'cvs-mode) + (setq ad-return-value list-buffers-directory))))) + + +(provide 'pcvs) + +;;; pcvs.el ends here