mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-01-30 04:10:54 -08:00
Code Issues Projects Releases Wiki Activity

*** empty log message ***

Browse source
This commit is contained in:
Stefan Monnier 2000-03-11 03:51:31 +00:00
parent afa18a4e5d
commit 5b467bf4e2
10 changed files with 5730 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

13
lisp/ChangeLog
View file

@ -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

523
lisp/cvs-status.el Normal file
View file

@ -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

620
lisp/emacs-lisp/ewoc.el Normal file
View file

@ -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

448
lisp/log-edit.el Normal file
View file

@ -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

189
lisp/log-view.el Normal file
View file

@ -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

501
lisp/pcvs-defs.el Normal file
View file

@ -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

455
lisp/pcvs-info.el Normal file
View file

@ -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

478
lisp/pcvs-parse.el Normal file
View file

@ -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

381
lisp/pcvs-util.el Normal file
View file

@ -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

2122
lisp/pcvs.el Normal file
View file

File diff suppressed because it is too large Load diff