From 7da7c83c9123c5f7cd3ccd1b0ee4f4abdb9429ae Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Wed, 25 Jun 2025 19:44:18 +0200 Subject: [PATCH] Drop pcvs-*.el --- lisp/files.el | 4 +- lisp/vc/cvs-status.el | 533 --------- lisp/vc/log-edit.el | 2 - lisp/vc/log-view.el | 35 - lisp/vc/pcvs-defs.el | 337 ------ lisp/vc/pcvs-info.el | 478 -------- lisp/vc/pcvs-parse.el | 545 --------- lisp/vc/pcvs.el | 2598 ----------------------------------------- 8 files changed, 2 insertions(+), 4530 deletions(-) delete mode 100644 lisp/vc/cvs-status.el delete mode 100644 lisp/vc/pcvs-defs.el delete mode 100644 lisp/vc/pcvs-info.el delete mode 100644 lisp/vc/pcvs-parse.el delete mode 100644 lisp/vc/pcvs.el diff --git a/lisp/files.el b/lisp/files.el index f4f5513ed80..61c6698459a 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -578,11 +578,11 @@ To visit the directory, `find-file' runs `find-directory-functions'." :type 'boolean :group 'find-file) -(defcustom find-directory-functions '(cvs-dired-noselect dired-noselect) +(defcustom find-directory-functions '(dired-noselect) "List of functions to try in sequence to visit a directory. Each function is called with the directory name as the sole argument and should return either a buffer or nil." - :type '(hook :options (cvs-dired-noselect dired-noselect)) + :type '(hook :options (dired-noselect)) :group 'find-file) (defcustom file-name-at-point-functions '(thing-at-point-file-at-point) diff --git a/lisp/vc/cvs-status.el b/lisp/vc/cvs-status.el deleted file mode 100644 index 97d19132e39..00000000000 --- a/lisp/vc/cvs-status.el +++ /dev/null @@ -1,533 +0,0 @@ -;;; cvs-status.el --- major mode for browsing `cvs status' output -*- lexical-binding: t -*- - -;; Copyright (C) 1999-2025 Free Software Foundation, Inc. - -;; Author: Stefan Monnier -;; Keywords: pcl-cvs cvs status tree vc tools - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;; Todo: - -;; - Somehow allow cvs-status-tree to work on-the-fly - -;;; Code: - -(require 'cl-lib) -(require 'pcvs) - -;;; - -(defvar-keymap cvs-status-mode-map - :parent cvs-mode-map - "n" #'next-line - "p" #'previous-line - "N" #'cvs-status-next - "P" #'cvs-status-prev - "M-n" #'cvs-status-next - "M-p" #'cvs-status-prev - "t" #'cvs-status-cvstrees - "T" #'cvs-status-trees - ">" #'cvs-mode-checkout) - -;;(easy-menu-define cvs-status-menu cvs-status-mode-map -;; "Menu for `cvs-status-mode'." -;; '("CVS-Status" -;; ["Show Tag Trees" cvs-status-tree t] -;; )) - -(defvar cvs-status-mode-hook nil - "Hook run at the end of `cvs-status-mode'.") - -(defconst cvs-status-tags-leader-re "^ Existing Tags:$") -(defconst cvs-status-entry-leader-re - "^File:\\s-+\\(?:no file \\)?\\(.*\\S-\\)\\s-+Status: \\(.+\\)$") -(defconst cvs-status-dir-re "^cvs[.ex]* [a-z]+: Examining \\(.+\\)$") -(defconst cvs-status-rev-re "[0-9][.0-9]*\\.[.0-9]*[0-9]") -(defconst cvs-status-tag-re "[ \t]\\([a-zA-Z][^ \t\n.]*\\)") - -(defconst cvs-status-font-lock-keywords - `((,cvs-status-entry-leader-re - (1 'cvs-filename) - (2 'cvs-need-action)) - (,cvs-status-tags-leader-re - (,cvs-status-rev-re - (save-excursion (re-search-forward "^\n" nil 'move) (point)) - (progn (re-search-backward cvs-status-tags-leader-re nil t) - (forward-line 1)) - (0 font-lock-comment-face)) - (,cvs-status-tag-re - (save-excursion (re-search-forward "^\n" nil 'move) (point)) - (progn (re-search-backward cvs-status-tags-leader-re nil t) - (forward-line 1)) - (1 font-lock-function-name-face))))) -(defconst cvs-status-font-lock-defaults - '(cvs-status-font-lock-keywords t nil nil nil (font-lock-multiline . t))) - -(defvar cvs-minor-wrap-function) -(defvar cvs-force-command) -(defvar cvs-minor-current-files) -(defvar cvs-secondary-branch-prefix) -(defvar cvs-branch-prefix) -(defvar cvs-tag-print-rev) - -(put 'cvs-status-mode 'mode-class 'special) -;;;###autoload -(define-derived-mode cvs-status-mode fundamental-mode "CVS-Status" - "Mode used for cvs status output." - (setq-local font-lock-defaults cvs-status-font-lock-defaults) - (setq-local cvs-minor-wrap-function #'cvs-status-minor-wrap)) - -;; Define cvs-status-next and cvs-status-prev -(easy-mmode-define-navigation cvs-status cvs-status-entry-leader-re "entry") - -(defun cvs-status-current-file () - (save-excursion - (forward-line 1) - (or (re-search-backward cvs-status-entry-leader-re nil t) - (re-search-forward cvs-status-entry-leader-re)) - (let* ((file (match-string 1)) - (cvsdir (and (re-search-backward cvs-status-dir-re nil t) - (match-string 1))) - (pcldir (and (if (boundp 'cvs-pcl-cvs-dirchange-re) - (re-search-backward cvs-pcl-cvs-dirchange-re nil t)) - (match-string 1))) - (dir "")) - (let ((default-directory "")) - (when pcldir (setq dir (expand-file-name pcldir dir))) - (when cvsdir (setq dir (expand-file-name cvsdir dir))) - (expand-file-name file dir))))) - -(defun cvs-status-current-tag () - (save-excursion - (let ((pt (point)) - (col (current-column)) - (start (progn (re-search-backward cvs-status-tags-leader-re nil t) (point))) - (end (progn (re-search-forward "^$" nil t) (point)))) - (when (and (< start pt) (> end pt)) - (goto-char pt) - (end-of-line) - (let ((tag nil) (dist pt) (end (point))) - (beginning-of-line) - (while (re-search-forward cvs-status-tag-re end t) - (let* ((cole (current-column)) - (colb (save-excursion - (goto-char (match-beginning 1)) (current-column))) - (ndist (min (abs (- cole col)) (abs (- colb col))))) - (when (< ndist dist) - (setq dist ndist) - (setq tag (match-string 1))))) - tag))))) - -(defun cvs-status-minor-wrap (buf f) - (let ((data (with-current-buffer buf - (cons - (cons (cvs-status-current-file) - (cvs-status-current-tag)) - (when mark-active - (save-excursion - (goto-char (mark)) - (cons (cvs-status-current-file) - (cvs-status-current-tag)))))))) - (let ((cvs-branch-prefix (cdar data)) - (cvs-secondary-branch-prefix (and (cdar data) (cddr data))) - (cvs-minor-current-files - (cons (caar data) - (when (and (cadr data) (not (equal (caar data) (cadr data)))) - (list (cadr data))))) - ;; FIXME: I need to force because the fileinfos are UNKNOWN - (cvs-force-command "/F")) - (funcall f)))) - -;; -;; Tagelt, tag element -;; - -(cl-defstruct (cvs-tag - (:constructor nil) - (:constructor cvs-tag-make - (vlist &optional name type)) - (:conc-name cvs-tag->)) - vlist - name - type) - -(defsubst cvs-status-vl-to-str (vl) (mapconcat #'number-to-string vl ".")) - -(defun cvs-tag->string (tag) - (if (stringp tag) tag - (let ((name (cvs-tag->name tag)) - (vl (cvs-tag->vlist tag))) - (if (null name) (cvs-status-vl-to-str vl) - (let ((rev (if vl (concat " (" (cvs-status-vl-to-str vl) ")") ""))) - (if (consp name) (mapcar (lambda (name) (concat name rev)) name) - (concat name rev))))))) - -(defun cvs-tag-compare-1 (vl1 vl2) - (cond - ((and (null vl1) (null vl2)) 'equal) - ((null vl1) 'more2) - ((null vl2) 'more1) - (t (let ((v1 (car vl1)) - (v2 (car vl2))) - (cond - ((> v1 v2) 'more1) - ((< v1 v2) 'more2) - (t (cvs-tag-compare-1 (cdr vl1) (cdr vl2)))))))) - -(defsubst cvs-tag-compare (tag1 tag2) - (cvs-tag-compare-1 (cvs-tag->vlist tag1) (cvs-tag->vlist tag2))) - -(defun cvs-tag-merge (tag1 tag2) - "Merge TAG1 and TAG2 into one." - (let ((type1 (cvs-tag->type tag1)) - (type2 (cvs-tag->type tag2)) - (name1 (cvs-tag->name tag1)) - (name2 (cvs-tag->name tag2))) - (unless (equal (cvs-tag->vlist tag1) (cvs-tag->vlist tag2)) - (setf (cvs-tag->vlist tag1) nil)) - (if type1 - (unless (or (not type2) (equal type1 type2)) - (setf (cvs-tag->type tag1) nil)) - (setf (cvs-tag->type tag1) type2)) - (if name1 - (setf (cvs-tag->name tag1) (cvs-append name1 name2)) - (setf (cvs-tag->name tag1) name2)) - tag1)) - -(defun cvs-tree-print (tags printer column) - "Print the tree of TAGS where each tag's string is given by PRINTER. -PRINTER should accept both a tag (in which case it should return a string) -or a string (in which case it should simply return its argument). -A tag cannot be a CONS. The return value can also be a list of strings, -if several nodes where merged into one. -The tree will be printed no closer than column COLUMN." - - (let* ((eol (save-excursion (end-of-line) (current-column))) - (column (max (+ eol 2) column))) - (if (null tags) column - (let* ((rev (cvs-car tags)) - (name (funcall printer (cvs-car rev))) - (rest (append (cvs-cdr name) (cvs-cdr tags))) - (prefix - (save-excursion - (or (= (forward-line 1) 0) (insert "\n")) - (cvs-tree-print rest printer column)))) - (cl-assert (>= prefix column)) - (move-to-column prefix t) - (cl-assert (eolp)) - (insert (cvs-car name)) - (dolist (br (cvs-cdr rev)) - (let* ((column (current-column)) - (brrev (funcall printer (cvs-car br))) - (brlength (length (cvs-car brrev))) - (brfill (concat (make-string (/ brlength 2) ? ) "|")) - (prefix - (save-excursion - (insert " -- ") - (cvs-tree-print (cvs-append brrev brfill (cvs-cdr br)) - printer (current-column))))) - (delete-region (save-excursion (move-to-column prefix) (point)) - (point)) - (insert " " (make-string (- prefix column 2) ?-) " ") - (end-of-line))) - prefix)))) - -(defun cvs-tree-merge (tree1 tree2) - "Merge tags trees TREE1 and TREE2 into one. -BEWARE: because of stability issues, this is not a symmetric operation." - (cl-assert (and (listp tree1) (listp tree2))) - (cond - ((null tree1) tree2) - ((null tree2) tree1) - (t - (let* ((rev1 (car tree1)) - (tag1 (cvs-car rev1)) - (vl1 (cvs-tag->vlist tag1)) - (l1 (length vl1)) - (rev2 (car tree2)) - (tag2 (cvs-car rev2)) - (vl2 (cvs-tag->vlist tag2)) - (l2 (length vl2))) - (cond - ((= l1 l2) - (pcase (cvs-tag-compare tag1 tag2) - ('more1 (cons rev2 (cvs-tree-merge tree1 (cdr tree2)))) - ('more2 (cons rev1 (cvs-tree-merge (cdr tree1) tree2))) - ('equal - (cons (cons (cvs-tag-merge tag1 tag2) - (cvs-tree-merge (cvs-cdr rev1) (cvs-cdr rev2))) - (cvs-tree-merge (cdr tree1) (cdr tree2)))))) - ((> l1 l2) - (cvs-tree-merge - (list (cons (cvs-tag-make (butlast vl1)) tree1)) tree2)) - ((< l1 l2) - (cvs-tree-merge - tree1 (list (cons (cvs-tag-make (butlast vl2)) tree2))))))))) - -(defun cvs-tag-make-tag (tag) - (let ((vl (mapcar #'string-to-number (split-string (nth 2 tag) "\\.")))) - (cvs-tag-make vl (nth 0 tag) (intern (nth 1 tag))))) - -(defun cvs-tags->tree (tags) - "Make a tree out of a list of TAGS." - (let ((tags - (mapcar - (lambda (tag) - (let ((tag (cvs-tag-make-tag tag))) - (list (if (not (eq (cvs-tag->type tag) 'branch)) tag - (list (cvs-tag-make (butlast (cvs-tag->vlist tag))) - tag))))) - tags))) - (while (cdr tags) - (let (tl) - (while tags - (push (cvs-tree-merge (pop tags) (pop tags)) tl)) - (setq tags (nreverse tl)))) - (car tags))) - -(defun cvs-status-get-tags () - "Look for a list of tags, read them in and delete them. -Return nil if there was an empty list of tags and t if there wasn't -even a list. Else, return the list of tags where each element of -the list is a three-string list TAG, KIND, REV." - (let ((tags nil)) - (if (not (re-search-forward cvs-status-tags-leader-re nil t)) t - (forward-char 1) - (let ((pt (point)) - (lastrev nil) - (case-fold-search t)) - (or - (looking-at "\\s-+no\\s-+tags") - - (progn ; normal listing - (while (looking-at "^[ \t]+\\([^ \t\n]+\\)[ \t]+(\\([a-z]+\\): \\(.+\\))$") - (push (list (match-string 1) (match-string 2) (match-string 3)) tags) - (forward-line 1)) - (unless (looking-at "^$") (setq tags nil) (goto-char pt)) - tags) - - (progn ; cvstree-style listing - (while (or (looking-at "^ .+\\(.\\) \\([0-9.]+\\): \\([^\n\t .0-9][^\n\t ]*\\)?$") - (and lastrev - (looking-at "^ .+\\(\\) \\(8\\)? \\([^\n\t .0-9][^\n\t ]*\\)$"))) - (setq lastrev (or (match-string 2) lastrev)) - (push (list (match-string 3) - (if (equal (match-string 1) " ") "branch" "revision") - lastrev) tags) - (forward-line 1)) - (unless (looking-at "^$") (setq tags nil) (goto-char pt)) - (setq tags (nreverse tags))) - - (progn ; new tree style listing - (let* ((re-lead "[ \t]*\\(-+\\)?\\(|\n?[ \t]+\\)*") - (re3 (concat re-lead "\\(\\.\\)?\\(" cvs-status-rev-re "\\)")) - (re2 (concat re-lead cvs-status-tag-re "\\(\\)")) - (re1 (concat re-lead cvs-status-tag-re - " (\\(" cvs-status-rev-re "\\))"))) - (while (or (looking-at re1) (looking-at re2) (looking-at re3)) - (push (list (match-string 3) - (if (match-string 1) "branch" "revision") - (match-string 4)) tags) - (goto-char (match-end 0)) - (when (eolp) (forward-char 1)))) - (unless (looking-at "^$") (setq tags nil) (goto-char pt)) - (setq tags (nreverse tags)))) - - (delete-region pt (point))) - tags))) - -;; (defun cvs-refontify (beg end) -;; (when font-lock-mode -;; (font-lock-fontify-region (1- beg) (1+ end)))) - -(defun cvs-status-trees () - "Look for a lists of tags, and replace them with trees." - (interactive) - (save-excursion - (goto-char (point-min)) - (let ((inhibit-read-only t) - (tags nil)) - (while (listp (setq tags (cvs-status-get-tags))) - ;;(let ((pt (save-excursion (forward-line -1) (point)))) - (save-restriction - (narrow-to-region (point) (point)) - ;;(newline) - (combine-after-change-calls - (cvs-tree-print (cvs-tags->tree tags) 'cvs-tag->string 3))) - ;;(cvs-refontify pt (point)) - ;;(sit-for 0) - ;;) - )))) - -;;;; -;;;; CVSTree-style trees -;;;; - -(defvar cvs-tree-use-jisx0208 nil) ;Old compat var. -(defvar cvs-tree-use-charset - (cond - (cvs-tree-use-jisx0208 'jisx0208) - ((char-displayable-p ?━) 'unicode) - ((char-displayable-p (make-char 'japanese-jisx0208 40 44)) 'jisx0208)) - "Non-nil if we should use the graphical glyphs from `japanese-jisx0208'. -Otherwise, default to ASCII chars like +, - and |.") - -(defconst cvs-tree-char-space - (pcase cvs-tree-use-charset - ('jisx0208 (make-char 'japanese-jisx0208 33 33)) - ('unicode " ") - (_ " "))) -(defconst cvs-tree-char-hbar - (pcase cvs-tree-use-charset - ('jisx0208 (make-char 'japanese-jisx0208 40 44)) - ('unicode "━") - (_ "--"))) -(defconst cvs-tree-char-vbar - (pcase cvs-tree-use-charset - ('jisx0208 (make-char 'japanese-jisx0208 40 45)) - ('unicode "┃") - (_ "| "))) -(defconst cvs-tree-char-branch - (pcase cvs-tree-use-charset - ('jisx0208 (make-char 'japanese-jisx0208 40 50)) - ('unicode "┣") - (_ "+-"))) -(defconst cvs-tree-char-eob ;end of branch - (pcase cvs-tree-use-charset - ('jisx0208 (make-char 'japanese-jisx0208 40 49)) - ('unicode "┗") - (_ "`-"))) -(defconst cvs-tree-char-bob ;beginning of branch - (pcase cvs-tree-use-charset - ('jisx0208 (make-char 'japanese-jisx0208 40 51)) - ('unicode "┳") - (_ "+-"))) - -(defun cvs-tag-lessp (tag1 tag2) - (eq (cvs-tag-compare tag1 tag2) 'more2)) - -(defvar cvs-tree-nomerge nil) - -(defun cvs-status-cvstrees (&optional arg) - "Look for a list of tags, and replace it with a tree. -Optional prefix ARG chooses between two representations." - (interactive "P") - (when (and cvs-tree-use-charset - (not enable-multibyte-characters)) - ;; We need to convert the buffer from unibyte to multibyte - ;; since we'll use multibyte chars for the tree. - (let ((modified (buffer-modified-p)) - (inhibit-read-only t) - (inhibit-modification-hooks t)) - (unwind-protect - (progn - (decode-coding-region (point-min) (point-max) 'undecided) - (set-buffer-multibyte t)) - (restore-buffer-modified-p modified)))) - (save-excursion - (goto-char (point-min)) - (let ((inhibit-read-only t) - (tags nil) - (cvs-tree-nomerge (if arg (not cvs-tree-nomerge) cvs-tree-nomerge))) - (while (listp (setq tags (cvs-status-get-tags))) - (let ((tags (mapcar #'cvs-tag-make-tag tags)) - ;;(pt (save-excursion (forward-line -1) (point))) - ) - (setq tags (sort tags #'cvs-tag-lessp)) - (let* ((first (car tags)) - (prev (if (cvs-tag-p first) - (list (car (cvs-tag->vlist first))) nil))) - (combine-after-change-calls - (cvs-tree-tags-insert tags prev)) - ;;(cvs-refontify pt (point)) - ;;(sit-for 0) - )))))) - -(defun cvs-tree-tags-insert (tags prev) - (when tags - (let* ((tag (car tags)) - (vlist (cvs-tag->vlist tag)) - (nprev ;"next prev" - (let* ((next (cvs-car (cadr tags))) - (nprev (if (and cvs-tree-nomerge next - (equal vlist (cvs-tag->vlist next))) - prev vlist))) - (cl-mapcar (lambda (v _p) v) nprev prev))) - (after (save-excursion - (newline) - (cvs-tree-tags-insert (cdr tags) nprev))) - (pe t) ;"prev equal" - (nas nil)) ;"next afters" to be returned - (insert " ") - (cl-do* ((vs vlist (cdr vs)) - (ps prev (cdr ps)) - (as after (cdr as))) - ((and (null as) (null vs) (null ps)) - (let ((revname (cvs-status-vl-to-str vlist))) - (if (cl-every #'identity (cl-mapcar #'equal prev vlist)) - (insert (make-string (+ 4 (length revname)) ? ) - (or (cvs-tag->name tag) "")) - (insert " " revname ": " (or (cvs-tag->name tag) ""))))) - (let* ((eq (and pe (equal (car ps) (car vs)))) - (next-eq (equal (cadr ps) (cadr vs)))) - (let* ((na+char - (if (car as) - (if eq - (if next-eq (cons t cvs-tree-char-vbar) - (cons t cvs-tree-char-branch)) - (cons nil cvs-tree-char-bob)) - (if eq - (if next-eq (cons nil cvs-tree-char-space) - (cons t cvs-tree-char-eob)) - (cons nil (if (and (eq (cvs-tag->type tag) 'branch) - (cl-every #'null as)) - cvs-tree-char-space - cvs-tree-char-hbar)))))) - (insert (cdr na+char)) - (push (car na+char) nas)) - (setq pe eq))) - (nreverse nas)))) - -;;;; -;;;; Merged trees from different files -;;;; - -;; (defun cvs-tree-fuzzy-merge-1 (trees tree prev) -;; ) - -;; (defun cvs-tree-fuzzy-merge (trees tree) -;; "Do the impossible: merge TREE into TREES." -;; ()) - -;; (defun cvs-tree () -;; "Get tags from the status output and merge them all into a big tree." -;; (save-excursion -;; (goto-char (point-min)) -;; (let ((inhibit-read-only t) -;; (trees (make-vector 31 0)) tree) -;; (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags)))) -;; (cvs-tree-fuzzy-merge trees tree)) -;; (erase-buffer) -;; (let ((cvs-tag-print-rev nil)) -;; (cvs-tree-print tree 'cvs-tag->string 3))))) - - -(provide 'cvs-status) - -;;; cvs-status.el ends here diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index d9b8afb2542..181d4f309f5 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -46,8 +46,6 @@ :prefix "log-edit-") ;; compiler pacifiers -(defvar cvs-buffer) - ;; The main keymap diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index 6394fdde6c8..65b164f8c77 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -115,9 +115,6 @@ (autoload 'vc-find-revision "vc") (autoload 'vc-diff-internal "vc") -(defvar cvs-minor-wrap-function) -(defvar cvs-force-command) - (defgroup log-view nil "Major mode for browsing log output of revision log histories." :group 'pcl-cvs @@ -256,7 +253,6 @@ The match group number 1 should match the revision number itself.") (setq-local font-lock-defaults log-view-font-lock-defaults) (setq-local beginning-of-defun-function #'log-view-beginning-of-defun) (setq-local end-of-defun-function #'log-view-end-of-defun) - (setq-local cvs-minor-wrap-function #'log-view-minor-wrap) (hack-dir-local-variables-non-file-buffer)) ;;;; @@ -472,37 +468,6 @@ Works like `end-of-defun'." (log-view-end-of-defun-1) t))) -(defvar cvs-minor-current-files) -(defvar cvs-branch-prefix) -(defvar cvs-secondary-branch-prefix) - -(defun log-view-minor-wrap (buf f) - (let ((data (with-current-buffer buf - (let* ((beg (point)) - (end (if (use-region-p) (mark) (point))) - (fr (log-view-current-tag beg)) - (to (log-view-current-tag end))) - (when (string-equal fr to) - (save-excursion - (goto-char end) - (log-view-msg-next) - (setq to (log-view-current-tag)))) - (cons - ;; The first revision has to be the one at point, for - ;; operations that only take one revision - ;; (e.g. cvs-mode-edit). - (cons (log-view-current-file) fr) - (cons (log-view-current-file) to)))))) - (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)))) - (defun log-view-find-revision (pos) "Visit the version at POS. If called interactively, visit the version at point." diff --git a/lisp/vc/pcvs-defs.el b/lisp/vc/pcvs-defs.el deleted file mode 100644 index d32b6633bda..00000000000 --- a/lisp/vc/pcvs-defs.el +++ /dev/null @@ -1,337 +0,0 @@ -;;; pcvs-defs.el --- variable definitions for PCL-CVS -*- lexical-binding: t; -*- - -;; Copyright (C) 1991-2025 Free Software Foundation, Inc. - -;; Author: Stefan Monnier -;; Keywords: pcl-cvs -;; Package: pcvs - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - - -;;; Code: - -(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 - ;; With the divergence of the CVSNT codebase and version numbers, this is - ;; not really good any more. - (ignore-errors - (with-temp-buffer - (call-process cvs-program nil t nil "-v") - (goto-char (point-min)) - (when (re-search-forward "(CVS\\(NT\\)?) \\([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: - -(defgroup pcl-cvs nil - "Special support for the CVS versioning system." - :version "21.1" - :group 'tools - :prefix "cvs-") - -;; -;; cvsrc options -;; - -(defcustom cvs-cvsrc-file (convert-standard-filename "~/.cvsrc") - "Path to your cvsrc file." - :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." - :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 `handled', only non-handled directories will be shown. -If `empty', only non-empty directories will be shown." - :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." - :type '(boolean)) - -(defcustom cvs-sort-ignore-file t - "Non-nil if `cvs-mode-ignore' should sort the .cvsignore automatically." - :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." - :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-invert-ignore-marks'." - :type '(boolean)) - -(defcustom cvs-invert-ignore-marks - (let ((l ())) - (unless (equal cvs-default-ignore-marks t) - (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'." - :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." - :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." - :type '(choice (const :tag "Prompt" nil) - (string))) - -(defcustom cvs-find-file-and-jump nil - "Jump to the modified area when finding a file. -If non-nil, `cvs-mode-find-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." - :type '(boolean)) - -(defcustom cvs-buffer-name-alist - '(("diff" "*cvs-diff*" diff-mode) - ("status" "*cvs-info*" cvs-status-mode) - ("tree" "*cvs-info*" 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." - :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 - ;; Was '(expand-file-name " *cvs-tmp*" dir), but that causes them to - ;; become non-hidden if uniquification is done `forward'. - " *cvs-tmp*" - "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." - :type '(choice (const :tag "Ediff" (cvs-ediff-diff . cvs-ediff-merge)) - (const :tag "Emerge" (cvs-emerge-diff . cvs-emerge-merge)))) - -(defvar cvs-mode-hook nil - "Run after `cvs-mode' was setup.") - - -;;;; -;;;; 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." - :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-vendor-branch "1.1.1" - "The default branch used by CVS for vendor code.") - -(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 the global menu -;;;; - -;;;###autoload -(defvar cvs-global-menu - (let ((m (make-sparse-keymap "PCL-CVS"))) - (define-key m [status] - '(menu-item "Directory Status" cvs-status - :help "A more verbose status of a workarea")) - (define-key m [checkout] - '(menu-item "Checkout Module" cvs-checkout - :help "Check out a module from the repository")) - (define-key m [update] - '(menu-item "Update Directory" cvs-update - :help "Fetch updates from the repository")) - (define-key m [examine] - '(menu-item "Examine Directory" cvs-examine - :help "Examine the current state of a workarea")) - (fset 'cvs-global-menu m)) - "Global menu used by PCL-CVS.") - - -;; 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 (or (null cvs-version) - (or (>= (cdr cvs-version) 10) (> (car cvs-version) 1))) - ;; Supposedly some recent versions of CVS output some directory info - ;; as they recurse down the tree, but it's not good enough in the case - ;; where we run "cvs status foo bar/foo". - '("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 telling you to change this variable.") - -;; -(provide 'pcvs-defs) - -;;; pcvs-defs.el ends here diff --git a/lisp/vc/pcvs-info.el b/lisp/vc/pcvs-info.el deleted file mode 100644 index d47c5ed537a..00000000000 --- a/lisp/vc/pcvs-info.el +++ /dev/null @@ -1,478 +0,0 @@ -;;; pcvs-info.el --- internal representation of a fileinfo entry -*- lexical-binding: t; -*- - -;; Copyright (C) 1991-2025 Free Software Foundation, Inc. - -;; Author: Stefan Monnier -;; Keywords: pcl-cvs -;; Package: pcvs - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; 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-lib)) -(require 'pcvs-util) -;;(require 'pcvs-defs) - -;;;; -;;;; config variables -;;;; - -(defcustom cvs-display-full-name t - "Specifies how the filenames should be displayed in the listing. -If non-nil, their full filename name will be displayed, else only the -non-directory part." - :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 - '((((class color) (background dark)) - (:foreground "lightyellow" :weight bold)) - (((class color) (background light)) - (:foreground "blue4" :weight bold)) - (t (:weight bold))) - "PCL-CVS face used to highlight directory changes." - :group 'pcl-cvs) - -(defface cvs-filename - '((((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 - '((((class color) (background dark)) - (:foreground "red1")) - (((class color) (background light)) - (:foreground "red1")) - (t (:slant italic))) - "PCL-CVS face used to highlight unknown file status." - :group 'pcl-cvs) - -(defface cvs-handled - '((((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 - '((((class color) (background dark)) - (:foreground "orange")) - (((class color) (background light)) - (:foreground "orange")) - (t (:slant italic))) - "PCL-CVS face used to highlight status of files needing action." - :group 'pcl-cvs) - -(defface cvs-marked - '((((min-colors 88) (class color) (background dark)) - (:foreground "green1" :weight bold)) - (((class color) (background dark)) - (:foreground "green" :weight bold)) - (((class color) (background light)) - (:foreground "green3" :weight bold)) - (t (:weight bold))) - "PCL-CVS face used to highlight marked file indicator." - :group 'pcl-cvs) - -(defface cvs-msg - '((t :slant italic)) - "PCL-CVS face used to highlight CVS messages." - :group 'pcl-cvs) - -(defvar cvs-fi-up-to-date-face 'cvs-handled) -(defvar cvs-fi-unknown-face 'cvs-unknown) -(defvar cvs-fi-conflict-face 'font-lock-warning-face) - -;; 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.") - -(declare-function cvs-mode-toggle-mark "pcvs" (e)) - -(defvar-keymap cvs-status-map - :doc "Local keymap for text properties of status." - "" #'cvs-mode-toggle-mark) - -;; Constructor: - -(cl-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-name ;; 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 - ) -(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-name (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. - (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-name - (cvs-fileinfo->full-name 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) "\\(\\.[0-9]+\\.[0-9]+\\)+\\'"))) - bf) - (dolist (f files) - (when (and (file-readable-p f) - (or (null bf) (file-newer-than-file-p f bf))) - (setq bf f))) - (concat dir bf))) - -;; (defun cvs-fileinfo->handled (fileinfo) -;; "Tell if this requires further action" -;; (memq (cvs-fileinfo->type fileinfo) '(UP-TO-DATE DEAD))) - - -;; Predicate: - -(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) (memq marked '(t nil)) - (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) - (pcase type - ('DIRCHANGE (and (null subtype) (string= "." file))) - ((or 'NEED-UPDATE 'ADDED 'MISSING 'DEAD 'MODIFIED 'MESSAGE - 'UP-TO-DATE 'REMOVED 'NEED-MERGE 'CONFLICT 'UNKNOWN) - 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 ignore) - (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-add-face (str face &optional keymap &rest props) - (when keymap - (when (keymapp keymap) - (setq props `(keymap ,keymap ,@props))) - (setq props `(mouse-face highlight ,@props))) - (add-text-properties 0 (length str) `(font-lock-face ,face ,@props) str) - str) - -(defun cvs-fileinfo-pp (fileinfo) - "Pretty print FILEINFO. Insert a printed representation in current buffer. -For use by the ewoc package." - (cvs-check-fileinfo fileinfo) - (let ((type (cvs-fileinfo->type fileinfo)) - (subtype (cvs-fileinfo->subtype fileinfo))) - (insert - (pcase type - ('DIRCHANGE (concat "In directory " - (cvs-add-face (cvs-fileinfo->full-name fileinfo) - 'cvs-header t 'cvs-goal-column t) - ":")) - ('MESSAGE - (cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo)) - 'cvs-msg)) - (_ - (let* ((status (if (cvs-fileinfo->marked fileinfo) - (cvs-add-face "*" 'cvs-marked) - " ")) - (file (cvs-add-face (cvs-fileinfo->pp-name fileinfo) - 'cvs-filename t 'cvs-goal-column t)) - (base (or (cvs-fileinfo->base-rev fileinfo) "")) - (head (cvs-fileinfo->head-rev fileinfo)) - (type - (let ((str (pcase type - ;;(MOD-CONFLICT "Not Removed") - ('DEAD "") - (_ (capitalize (symbol-name type))))) - (face (let ((sym (intern-soft - (concat "cvs-fi-" - (downcase (symbol-name type)) - "-face")))) - (or (and (boundp sym) (symbol-value sym)) - 'cvs-need-action)))) - (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 - ""))) - (format "%-11s %s %-11s %-11s %s" - side status type base file)))) - "\n"))) - - -(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 - ;; 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)))))) - -;;; -;;; Look at CVS/Entries to quickly find a first approximation of the status -;;; - -(defun cvs-fileinfo-from-entries (dir &optional all) - "List of fileinfos for DIR, extracted from CVS/Entries. -Unless ALL is non-nil, returns only the files that are not up-to-date. -DIR can also be a file." - (let* ((singlefile - (cond - ((equal dir "") nil) - ((file-directory-p dir) (setq dir (file-name-as-directory dir)) nil) - (t (prog1 (file-name-nondirectory dir) - (setq dir (or (file-name-directory dir) "")))))) - (file (expand-file-name "CVS/Entries" dir)) - (fis nil)) - (if (not (file-readable-p file)) - (push (cvs-create-fileinfo (if singlefile 'UNKNOWN 'DIRCHANGE) - dir (or singlefile ".") "") fis) - (with-temp-buffer - (insert-file-contents file) - (goto-char (point-min)) - ;; Select the single file entry in case we're only interested in a file. - (cond - ((not singlefile) - (push (cvs-create-fileinfo 'DIRCHANGE dir "." "") fis)) - ((re-search-forward - (concat "^[^/]*/" (regexp-quote singlefile) "/.*") nil t) - (setq all t) - (goto-char (match-beginning 0)) - (narrow-to-region (point) (match-end 0))) - (t - (push (cvs-create-fileinfo 'UNKNOWN dir singlefile "") fis) - (narrow-to-region (point-min) (point-min)))) - (while (looking-at "\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/") - (if (/= (match-beginning 1) (match-end 1)) - (setq fis (append (cvs-fileinfo-from-entries - (concat dir (file-name-as-directory - (match-string 2))) - all) - fis)) - (let ((f (match-string 2)) - (rev (match-string 3)) - (date (match-string 4)) - timestamp - (type 'MODIFIED) - (subtype nil)) - (cond - ((equal (substring rev 0 1) "-") - (setq type 'REMOVED rev (substring rev 1))) - ((not (file-exists-p (concat dir f))) (setq type 'MISSING)) - ((equal rev "0") (setq type 'ADDED rev nil)) - ((equal date "Result of merge") (setq subtype 'MERGED)) - ((let ((mtime (file-attribute-modification-time - (file-attributes (concat dir f)))) - (system-time-locale "C")) - (setq timestamp (format-time-string "%c" mtime t)) - ;; Solaris sometimes uses "Wed Sep 05", not "Wed Sep 5". - ;; See "grep '[^a-z_]ctime' cvs/src/*.c" for reference. - (if (= (aref timestamp 8) ?0) - (setq timestamp (concat (substring timestamp 0 8) - " " (substring timestamp 9)))) - (equal timestamp date)) - (setq type (if all 'UP-TO-DATE))) - ((equal date (concat "Result of merge+" timestamp)) - (setq type 'CONFLICT))) - (when type - (push (cvs-create-fileinfo type dir f "" - :base-rev rev :subtype subtype) - fis)))) - (forward-line 1)))) - fis)) - -(provide 'pcvs-info) - -;;; pcvs-info.el ends here diff --git a/lisp/vc/pcvs-parse.el b/lisp/vc/pcvs-parse.el deleted file mode 100644 index be44672df9f..00000000000 --- a/lisp/vc/pcvs-parse.el +++ /dev/null @@ -1,545 +0,0 @@ -;;; pcvs-parse.el --- the CVS output parser -*- lexical-binding: t; -*- - -;; Copyright (C) 1991-2025 Free Software Foundation, Inc. - -;; Author: Stefan Monnier -;; Keywords: pcl-cvs -;; Package: pcvs - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;;; Bugs: - -;; - when merging a modified file, if the merge says that the file already -;; contained in the changes, it marks the file as `up-to-date' although -;; it might still contain further changes. -;; Example: merging a zero-change commit. - -;;; Code: - -(eval-when-compile (require 'cl-lib)) -(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 dcd &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. -DCD just indicates whether the command was changing the disc - or not (useful to tell the difference between `cvs-examine' and `cvs-update' - output. -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 occurred." - (goto-char (point-min)) - (let ((fileinfos ()) - (dont-change-disc dcd) - (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 ',(car match) ,(cadr 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." - (declare (debug t)) - `(let ((-cvs-parse-point (point))) - ,(cons 'or - (mapcar (lambda (es) - `(or ,es (ignore (goto-char -cvs-parse-point)))) - alts)))) - -;; 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) - - (cl-dolist (re cvs-parse-ignored-messages) - (when (cvs-match re) (cl-return t))) - - ;; This is a parse error. Create a message-type fileinfo. - (and - (cvs-match ".*$") - (cvs-create-fileinfo 'MESSAGE cvs-current-dir " " - ;; (concat " Unknown msg: '" - (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 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'." - (with-suppressed-warnings ((lexical c file dir path base-rev subtype)) - (defvar c) (defvar file) (defvar dir) (defvar path) (defvar base-rev) - (defvar subtype)) - (let (c file dir path 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 - (pcase code - (?M 'MODIFIED) - (?A 'ADDED) - (?R 'REMOVED) - (?? 'UNKNOWN) - (?C - (if (not dont-change-disc) 'CONFLICT - ;; This is ambiguous. We should look for conflict markers in the - ;; file to decide between CONFLICT and NEED-MERGE. With CVS-1.10 - ;; servers, this should not be necessary, because they return - ;; a complete merge output. - (with-temp-buffer - (ignore-errors (insert-file-contents path)) - (goto-char (point-min)) - (if (re-search-forward "^<<<<<<< " nil t) - 'CONFLICT 'NEED-MERGE)))) - (?J 'NEED-MERGE) ;not supported by standard CVS - ((or ?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 - (let ((case-fold-search t)) - (cvs-match "cvs[.a-z]* [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)) - ;; These messages either correspond to a true new directory - ;; that an update will bring in, or to a directory that's empty - ;; on the current branch (either because it only exists in other - ;; branches, or because it's been removed). - (if (ignore-errors - (with-temp-buffer - (ignore-errors - (insert-file-contents - (expand-file-name ".cvsignore" (file-name-directory dir)))) - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote (file-name-nondirectory dir)) "/$") - nil t))) - t ;The user requested to ignore those messages. - (cvs-parsed-fileinfo '(NEED-UPDATE . NEW-DIR) dir t))) - - ;; File removed, since it is removed (by third party) in repository. - (and - (cvs-or - ;; some cvs versions output quotes around these files - (cvs-match "warning: `\\(.*\\)' is not (any longer) pertinent$" (file 1)) - (cvs-match "warning: \\(.*\\) is not (any longer) pertinent$" (file 1)) - (cvs-match "`\\(.*\\)' is no longer in the repository$" (file 1)) - (cvs-match "\\(.*\\) is no longer in the repository$" (file 1))) - (cvs-parsed-fileinfo - (if dont-change-disc '(NEED-UPDATE . REMOVED) '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 ' - (and - (cvs-match "`?\\(.*?\\)'?, version \\(.*\\), resurrected$" - (path 1) (base-rev 2)) - ;; FIXME: resurrection only brings back the original version, - ;; not the latest on the branch, so `up-to-date' is not always - ;; what we want. - (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)) - - ;; [commit] - (and (cvs-match "Up-to-date check failed for `\\(.+\\)'$" (file 1)) - (cvs-parsed-fileinfo 'NEED-MERGE file)) - - ;; 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 - (and (cvs-match "nothing known about \\(.*\\)$" (path 1)) - (cvs-parsed-fileinfo 'DEAD path 'trust)) - ;; [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-match "--> Using per-directory sticky tag `.*'") - - ;; 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 () - (with-suppressed-warnings ((lexical path base-rev head-rev type)) - (defvar path) (defvar base-rev) (defvar head-rev) (defvar type)) - (let (path base-rev head-rev 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 successful 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 "spurious" 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) - ;; FIXME: PATH might not be set yet. Sometimes the only path - ;; information is in `RCS file: ...' (yuck!!). - (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 () - (with-suppressed-warnings ((lexical nofile path base-rev head-rev type)) - (defvar nofile) (defvar path) (defvar base-rev) (defvar head-rev) - (defvar type)) - (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 "File had conflicts on merge$" (type 'MODIFIED)) - (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 "Entry Invalid" (type '(NEED-MERGE . REMOVED))) - (cvs-match ".*$" (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.]+\\).*$" (head-rev 1)) - (cvs-match " *Repository revision:[ \t]*\\([0-9.]+\\)[ \t]*\\(.*\\)$" - (head-rev 1)) - (cvs-match " *Repository revision:.*")) - (cvs-or (cvs-match " *Expansion option:.*")) ;Optional CVSNT thingie. - (cvs-or (cvs-match " *Commit Identifier:.*")) ;Optional CVSNT thingie. - (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. - (cvs-or (cvs-match " *Merge From:.*")) ;Optional CVSNT thingie. - (cvs-match "$") - ;; ignore the tags-listing in the case of `status -v' - (cvs-or (cvs-match " *Existing Tags:\n\\(\t.*\n\\)*$")) - (cvs-parsed-fileinfo type path nil - :base-rev base-rev - :head-rev head-rev)))) - -(defun cvs-parse-commit () - (with-suppressed-warnings ((lexical path file base-rev subtype)) - (defvar path) (defvar file) (defvar base-rev) (defvar subtype)) - (let (path file base-rev subtype) - (cvs-or - - (and - (cvs-or - (cvs-match "\\(Checking in\\|Removing\\) \\(.*\\);$" (path 2))) - (cvs-match ".*,v <-- \\(.*\\)$" (file 1)) - (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-or (cvs-match "done$")) - ;; In cvs-1.12.9 commit messages have been changed and became - ;; ambiguous. More specifically, the `path' above is not given. - ;; We assume here that in future releases the corresponding info will - ;; be put into `file'. - (progn - ;; Try to remove the temp files used by VC. - (vc-delete-automatic-version-backups (expand-file-name (or path file))) - ;; 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) - (or path file) 'trust - :base-rev base-rev))) - - ;; useless message added before the actual addition: ignored - (cvs-match "RCS file: .*\ndone$")))) - - -(provide 'pcvs-parse) - -;;; pcvs-parse.el ends here diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el deleted file mode 100644 index b5dd3bf1ce6..00000000000 --- a/lisp/vc/pcvs.el +++ /dev/null @@ -1,2598 +0,0 @@ -;;; pcvs.el --- a front-end to CVS -*- lexical-binding:t -*- - -;; Copyright (C) 1991-2025 Free Software Foundation, Inc. - -;; Author: The PCL-CVS Trust -;; Per Cederqvist -;; Greg A. Woods -;; Jim Blandy -;; Karl Fogel -;; Jim Kingdon -;; Stefan Monnier -;; Greg Klanderman -;; Jari Aalto -;; Maintainer: Stefan Monnier -;; Keywords: CVS, vc, release management - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;; PCL-CVS is a front-end to the CVS version control system. -;; It presents the status of all the files in your working area and -;; allows you to commit/update several of them at a time. -;; Compare with the general Emacs utility vc-dir, which tries -;; to be VCS-agnostic. You may find PCL-CVS better/faster for CVS. - -;; PCL-CVS was originally written by Per Cederqvist many years ago. This -;; version derives from the XEmacs-21 version, itself based on the 2.0b2 -;; version (last release from Per). It is a thorough rework. - -;; PCL-CVS is not a replacement for VC, but adds extra functionality. -;; As such, I've tried to make PCL-CVS and VC interoperate seamlessly -;; (I also use VC). - -;; To use PCL-CVS just use `M-x cvs-examine RET RET'. -;; There is a TeXinfo manual, which can be helpful to get started. - -;;; Bugs: - -;; - Extracting an old version seems not to recognize encoding correctly. -;; That's probably because it's done via a process rather than a file. - -;;; Todo: - -;; ******** FIX THE DOCUMENTATION ********* -;; -;; - rework the displaying of error messages. -;; - allow the flushing of messages only -;; - allow the protection of files like ChangeLog from flushing -;; - query the user for cvs-get-marked (for some cmds or if nothing's selected) -;; - don't return the first (resp last) FI if the cursor is before -;; (resp after) it. -;; - allow cvs-confirm-removals to force always confirmation. -;; - cvs-checkout should ask for a revision (with completion). -;; - removal confirmation should allow specifying another file name. -;; -;; - hide fileinfos without getting rid of them (will require ewok work). -;; - add toolbar entries -;; - marking -;; marking directories should jump to just after the dir. -;; allow (un)marking directories at a time with the mouse. -;; allow cvs-cmd-do to either clear the marks or not. -;; add a "marks active" notion, like transient-mark-mode does. -;; - liveness indicator -;; - indicate in docstring if the cmd understands the `b' prefix(es). -;; - call smerge-mode when opening CONFLICT files. -;; - have vc-checkin delegate to cvs-mode-commit when applicable -;; - higher-level CVS operations -;; cvs-mode-rename -;; cvs-mode-branch -;; - module-level commands -;; add support for parsing 'modules' file ("cvs co -c") -;; cvs-mode-rcs2log -;; cvs-rdiff -;; cvs-release -;; cvs-import -;; C-u M-x cvs-checkout should ask for a cvsroot -;; cvs-mode-handle-new-vendor-version -;; - checks out module, or alternately does update join -;; - does "cvs -n tag LAST_VENDOR" to find old files into *cvs* -;; cvs-export -;; (with completion on tag names and hooks to help generate full releases) -;; - display stickiness information. And current CVS/Tag as well. -;; - write 'cvs-mode-admin' to do arbitrary 'cvs admin' commands -;; Most interesting would be version removal and log message replacement. -;; The last one would be neat when called from log-view-mode. -;; - cvs-mode-incorporate -;; It would merge in the status from one *cvs* buffer into another. -;; This would be used to populate such a buffer that had been created with -;; a `cvs {update,status,checkout} -l'. -;; - cvs-mode-(i)diff-other-{file,buffer,cvs-buffer} -;; - offer the choice to kill the process when the user kills the cvs buffer. -;; right now, it's killed without further ado. -;; - make `cvs-mode-ignore' allow manually entering a pattern. -;; to which dir should it apply ? -;; - maybe poll/check CVS/Entries files to react to external `cvs' commands ? -;; - some kind of `cvs annotate' support ? -;; but vc-annotate can be used instead. -;; - proper `g' that passes safe args and uses either cvs-status or cvs-examine -;; maybe also use cvs-update depending on I-don't-know-what. -;; - add message-levels so that we can hide some levels of messages - -;;; Code: - -(require 'cl-lib) -(require 'ewoc) ;Ewoc was once cookie -(require 'pcvs-util) -(require 'pcvs-parse) -(require 'pcvs-info) -(require 'vc-cvs) -(require 'easy-mmode) - - -;;;; -;;;; global vars -;;;; - -(defvar cvs-cookies) ;;nil - ;;"Handle for the cookie structure that is displayed in the *cvs* buffer.") -;;(make-variable-buffer-local 'cvs-cookies) - -;;;; -;;;; Dynamically scoped variables -;;;; - -(defvar cvs-from-vc nil "Bound to t inside VC advice.") - -(defvar-keymap cvs-mode-diff-map - :name "Diff" - "E" (cons "imerge" #'cvs-mode-imerge) - "=" #'cvs-mode-diff - "e" (cons "idiff" #'cvs-mode-idiff) - "2" (cons "other" #'cvs-mode-idiff-other) - "d" (cons "diff" #'cvs-mode-diff) - "b" (cons "backup" #'cvs-mode-diff-backup) - "h" (cons "head" #'cvs-mode-diff-head) - "r" (cons "repository" #'cvs-mode-diff-repository) - "y" (cons "yesterday" #'cvs-mode-diff-yesterday) - "v" (cons "vendor" #'cvs-mode-diff-vendor)) -;; This is necessary to allow correct handling of \\[cvs-mode-diff-map] -;; in substitute-command-keys. -(fset 'cvs-mode-diff-map cvs-mode-diff-map) - -(defvar-keymap cvs-mode-map - :full t - :suppress t - ;; various - "?" #'cvs-help - "h" #'cvs-help - "q" #'cvs-bury-buffer - "z" #'kill-current-buffer - "F" #'cvs-mode-set-flags - "!" #'cvs-mode-force-command - "C-c C-c" #'cvs-mode-kill-process - ;; marking - "m" #'cvs-mode-mark - "M" #'cvs-mode-mark-all-files - "S" #'cvs-mode-mark-on-state - "u" #'cvs-mode-unmark - "DEL" #'cvs-mode-unmark-up - "%" #'cvs-mode-mark-matching-files - "T" #'cvs-mode-toggle-marks - "M-DEL" #'cvs-mode-unmark-all-files - ;; navigation keys - "SPC" #'cvs-mode-next-line - "n" #'cvs-mode-next-line - "p" #'cvs-mode-previous-line - "TAB" #'cvs-mode-next-line - "" #'cvs-mode-previous-line - ;; M- keys are usually those that operate on modules - "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 - "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 - "RET" #'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-view-file - "x" #'cvs-mode-remove-handled - ;; cvstree bindings - "+" #'cvs-mode-tree - ;; mouse bindings - "" #'cvs-mode-find-file - "" (lambda (pos) - (eq (get-char-property pos 'face) 'cvs-filename)) - "" #'cvs-menu - ;; dired-like bindings - "C-o" #'cvs-mode-display-file) - -(easy-menu-define cvs-menu cvs-mode-map "Menu used in `cvs-mode'." - '("CVS" - ["Open file" cvs-mode-find-file t] - ["Open in other window" cvs-mode-find-file-other-window t] - ["Display in other window" cvs-mode-display-file t] - ["Interactive merge" cvs-mode-imerge t] - ("View diff" - ["Interactive diff" cvs-mode-idiff t] - ["Current diff" cvs-mode-diff t] - ["Diff with head" cvs-mode-diff-head t] - ["Diff with vendor" cvs-mode-diff-vendor t] - ["Diff against yesterday" cvs-mode-diff-yesterday t] - ["Diff with backup" cvs-mode-diff-backup t]) - ["View log" cvs-mode-log t] - ["View status" cvs-mode-status t] - ["View tag tree" cvs-mode-tree t] - "----" - ["Insert" cvs-mode-insert] - ["Update" cvs-mode-update (cvs-enabledp 'update)] - ["Re-examine" cvs-mode-examine t] - ["Commit" cvs-mode-commit-setup (cvs-enabledp 'commit)] - ["Tag" cvs-mode-tag (cvs-enabledp (when cvs-force-dir-tag 'tag))] - ["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" cvs-mode-mark t] - ["Mark all" cvs-mode-mark-all-files t] - ["Mark by regexp..." cvs-mode-mark-matching-files t] - ["Mark by state..." cvs-mode-mark-on-state t] - ["Unmark" cvs-mode-unmark t] - ["Unmark all" cvs-mode-unmark-all-files t] - ["Hide handled" cvs-mode-remove-handled t] - "----" - ["PCL-CVS Manual" (lambda () (interactive) - (info "(pcl-cvs)Top")) t] - "----" - ["Quit" cvs-mode-quit t])) - -;;;; -;;;; CVS-Minor mode -;;;; - -(defcustom cvs-minor-mode-prefix "\C-xc" - "Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'." - :type 'string - :group 'pcl-cvs) - -(defvar-keymap cvs-minor-mode-map - (key-description cvs-minor-mode-prefix) 'cvs-mode-map - "e" '(menu-item nil cvs-mode-edit-log - :filter (lambda (x) - (and (derived-mode-p 'log-view-mode) x)))) - -(require 'pcvs-defs) - -;;;; -;;;; flags variables -;;;; - -(defun cvs-defaults (&rest defs) - (let ((defs (cvs-first defs cvs-shared-start))) - (append defs - (make-list (- cvs-shared-start (length defs)) (car defs)) - cvs-shared-flags))) - -;; For cvs flags, we need to add "-f" to override the cvsrc settings -;; we also want to evict the annoying -q and -Q options that hide useful -;; information from pcl-cvs. -(cvs-flags-define cvs-cvs-flags '(("-f"))) - -(cvs-flags-define cvs-checkout-flags (cvs-defaults '("-P"))) -(cvs-flags-define cvs-status-flags (cvs-defaults '("-v") nil)) -(cvs-flags-define cvs-log-flags (cvs-defaults nil)) -(cvs-flags-define cvs-diff-flags (cvs-defaults '("-u" "-N") '("-c" "-N") '("-u" "-b"))) -(cvs-flags-define cvs-tag-flags (cvs-defaults nil)) -(cvs-flags-define cvs-add-flags (cvs-defaults nil)) -(cvs-flags-define cvs-commit-flags (cvs-defaults nil)) -(cvs-flags-define cvs-remove-flags (cvs-defaults nil)) -;;(cvs-flags-define cvs-undo-flags (cvs-defaults nil)) -(cvs-flags-define cvs-update-flags (cvs-defaults '("-d" "-P"))) - -(defun cvs-reread-cvsrc () - "Reset the default arguments to those in the `cvs-cvsrc-file'." - (interactive) - (condition-case nil - (with-temp-buffer - (insert-file-contents cvs-cvsrc-file) - ;; fetch the values - (dolist (cmd '("cvs" "checkout" "status" "log" "diff" "tag" - "add" "commit" "remove" "update")) - (goto-char (point-min)) - (when (re-search-forward - (concat "^" cmd "\\(\\s-+\\(.*\\)\\)?$") nil t) - (let* ((sym (intern (concat "cvs-" cmd "-flags"))) - (val (split-string-and-unquote (or (match-string 2) "")))) - (cvs-flags-set sym 0 val)))) - ;; ensure that cvs doesn't have -q or -Q - (cvs-flags-set 'cvs-cvs-flags 0 - (cons "-f" - (cdr (cvs-partition - (lambda (x) (member x '("-q" "-Q" "-f"))) - (cvs-flags-query 'cvs-cvs-flags - nil 'noquery)))))) - (file-error nil))) - -;; initialize to cvsrc's default values -(cvs-reread-cvsrc) - - -;;;; -;;;; Mouse bindings and mode motion -;;;; - -(defvar cvs-minor-current-files) - -(defun cvs-menu (e) - "Popup the CVS menu." - (interactive "e") - (let ((cvs-minor-current-files - (list (ewoc-data (ewoc-locate - cvs-cookies (posn-point (event-end e))))))) - (popup-menu cvs-menu e))) - -(defvar cvs-mode-line-process nil - "Mode-line control for displaying info on cvs process status.") - - -;;;; -;;;; Query-Type-Descriptor for Tags -;;;; - -(autoload 'cvs-status-get-tags "cvs-status") -(defun cvs-tags-list () - "Return a list of acceptable tags, ready for completions." - (cl-assert (cvs-buffer-p)) - (let ((marked (cvs-get-marked))) - `(("BASE") ("HEAD") - ,@(when marked - (with-temp-buffer - (process-file cvs-program - nil ;no input - t ;output to current-buffer - nil ;don't update display while running - "status" - "-v" - (cvs-fileinfo->full-name (car marked))) - (goto-char (point-min)) - (let ((tags (cvs-status-get-tags))) - (when (listp tags) tags))))))) - -(defvar cvs-tag-history nil) -(defconst cvs-qtypedesc-tag - (cvs-qtypedesc-create 'identity 'identity 'cvs-tags-list 'cvs-tag-history)) - -;;;; - -(defun cvs-mode! (&optional -cvs-mode!-fun) - "Switch to the *cvs* buffer. -If -CVS-MODE!-FUN is provided, it is executed *cvs* being the current buffer - and with its window selected. Else, the *cvs* buffer is simply selected. --CVS-MODE!-FUN is called interactively if applicable and else with no argument." - (let* ((-cvs-mode!-buf (current-buffer)) - (cvsbuf (cond ((cvs-buffer-p) (current-buffer)) - ((and cvs-buffer (cvs-buffer-p cvs-buffer)) cvs-buffer) - (t (error "Can't find the *cvs* buffer")))) - (-cvs-mode!-wrapper cvs-minor-wrap-function) - (-cvs-mode!-cont (lambda () - (save-current-buffer - (if (commandp -cvs-mode!-fun) - (call-interactively -cvs-mode!-fun) - (funcall -cvs-mode!-fun)))))) - (if (not -cvs-mode!-fun) (set-buffer cvsbuf) - (let ((cvs-mode!-buf (current-buffer)) - (cvs-mode!-owin (selected-window)) - (cvs-mode!-nwin (get-buffer-window cvsbuf 'visible))) - (unwind-protect - (progn - (set-buffer cvsbuf) - (when cvs-mode!-nwin (select-window cvs-mode!-nwin)) - (if -cvs-mode!-wrapper - (funcall -cvs-mode!-wrapper -cvs-mode!-buf -cvs-mode!-cont) - (funcall -cvs-mode!-cont))) - (set-buffer cvs-mode!-buf) - (when (and cvs-mode!-nwin (eq cvs-mode!-nwin (selected-window))) - ;; the selected window has not been changed by FUN - (select-window cvs-mode!-owin))))))) - -;;;; -;;;; Prefixes -;;;; - -(defvar cvs-branches (list cvs-vendor-branch "HEAD" "HEAD")) -(cvs-prefix-define cvs-branch-prefix - "Current selected branch." - "version" - (cons cvs-vendor-branch cvs-branches) - cvs-qtypedesc-tag) - -(defun cvs-set-branch-prefix (arg) - "Set the branch prefix to take action at the next command. -See `cvs-prefix-set' for a further the description of the behavior. -\\[universal-argument] 1 selects the vendor branch -and \\[universal-argument] 2 selects the HEAD." - (interactive "P") - (cvs-mode!) - (cvs-prefix-set 'cvs-branch-prefix arg)) - -(defun cvs-add-branch-prefix (flags &optional arg) - "Add branch selection argument if the branch prefix was set. -The argument is added (or not) to the list of FLAGS and is constructed -by appending the branch to ARG which defaults to \"-r\"." - (let ((branch (cvs-prefix-get 'cvs-branch-prefix))) - ;; deactivate the secondary prefix, even if not used. - (cvs-prefix-get 'cvs-secondary-branch-prefix) - (if branch (cons (concat (or arg "-r") branch) flags) flags))) - -(cvs-prefix-define cvs-secondary-branch-prefix - "Current secondary selected branch." - "version" - (cons cvs-vendor-branch cvs-branches) - cvs-qtypedesc-tag) - -(defun cvs-set-secondary-branch-prefix (arg) - "Set the branch prefix to take action at the next command. -See `cvs-prefix-set' for a further the description of the behavior. -\\[universal-argument] 1 selects the vendor branch -and \\[universal-argument] 2 selects the HEAD." - (interactive "P") - (cvs-mode!) - (cvs-prefix-set 'cvs-secondary-branch-prefix arg)) - -(defun cvs-add-secondary-branch-prefix (flags &optional arg) - "Add branch selection argument if the secondary branch prefix was set. -The argument is added (or not) to the list of FLAGS and is constructed -by appending the branch to ARG which defaults to \"-r\". -Since the `cvs-secondary-branch-prefix' is only active if the primary -prefix is active, it is important to read the secondary prefix before -the primary since reading the primary can deactivate it." - (let ((branch (and (cvs-prefix-get 'cvs-branch-prefix 'read-only) - (cvs-prefix-get 'cvs-secondary-branch-prefix)))) - (if branch (cons (concat (or arg "-r") branch) flags) flags))) - -;;;; - -(define-minor-mode cvs-minor-mode - "This mode is used for buffers related to a main *cvs* buffer. -All the `cvs-mode' buffer operations are simply rebound under -the \\[cvs-mode-map] prefix." - :lighter " CVS" - :group 'pcl-cvs) -(put 'cvs-minor-mode 'permanent-local t) - - -(defvar cvs-temp-buffers nil) -(defun cvs-temp-buffer (&optional cmd normal nosetup) - "Create a temporary buffer to run CMD in. -If CMD is a string, use it to lookup `cvs-buffer-name-alist' to find -the buffer name to be used and its major mode. - -The selected window will not be changed. The new buffer will not maintain undo -information and will be read-only unless NORMAL is non-nil. It will be emptied -\(unless NOSETUP is non-nil) and its `default-directory' will be inherited -from the current buffer." - (let* ((cvs-buf (current-buffer)) - (info (cdr (assoc cmd cvs-buffer-name-alist))) - (name (eval (nth 0 info) `((cmd . ,cmd)))) - (mode (nth 1 info)) - (dir default-directory) - (buf (cond - (name (cvs-get-buffer-create name)) - ((and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer)) - cvs-temp-buffer) - (t - (setq-local cvs-temp-buffer - (cvs-get-buffer-create - (eval cvs-temp-buffer-name `((dir . ,dir))) - 'noreuse)))))) - - ;; Handle the potential pre-existing process. - (let ((proc (get-buffer-process buf))) - (when (and (not normal) (processp proc) - (memq (process-status proc) '(run stop))) - (if cmd - ;; When CMD is specified, the buffer is normally shown to the - ;; user, so interrupting the process is not harmful. - ;; Use `delete-process' rather than `kill-process' otherwise - ;; the pending output of the process will still get inserted - ;; after we erase the buffer. - (delete-process proc) - (error "Can not run two cvs processes simultaneously")))) - - (if (not name) (kill-local-variable 'other-window-scroll-buffer) - ;; Strangely, if no window is created, `display-buffer' ends up - ;; doing a `switch-to-buffer' which does a `set-buffer', hence - ;; the need for `save-excursion'. - (unless nosetup (save-excursion (display-buffer buf))) - ;; FIXME: this doesn't do the right thing if the user later on - ;; does a `find-file-other-window' and `scroll-other-window' - (setq-local other-window-scroll-buffer buf)) - - (add-to-list 'cvs-temp-buffers buf) - - (with-current-buffer buf - (setq buffer-read-only nil) - (setq default-directory dir) - (unless nosetup - ;; Disable undo before calling erase-buffer since it may generate - ;; a very large and unwanted undo record. - (buffer-disable-undo) - (erase-buffer)) - (setq-local cvs-buffer cvs-buf) - ;;(cvs-minor-mode 1) - (let ((lbd list-buffers-directory)) - (if (fboundp mode) (funcall mode) (fundamental-mode)) - (when lbd (setq list-buffers-directory lbd))) - (cvs-minor-mode 1) - ;;(setq-local cvs-buffer cvs-buf) - (if normal - (buffer-enable-undo) - (setq buffer-read-only t) - (buffer-disable-undo)) - buf))) - -(defun cvs-mode-kill-buffers () - "Kill all the \"temporary\" buffers created by the *cvs* buffer." - (interactive) - (dolist (buf cvs-temp-buffers) (ignore-errors (kill-buffer buf)))) - -(defun cvs-make-cvs-buffer (dir &optional new) - "Create the *cvs* buffer for directory DIR. -If non-nil, NEW means to create a new buffer no matter what." - ;; the real cvs-buffer creation - (setq dir (cvs-expand-dir-name dir)) - (let* ((buffer-name (eval cvs-buffer-name `((dir . ,dir)))) - (buffer - (or (and (not new) - (eq cvs-reuse-cvs-buffer 'current) - (cvs-buffer-p) ;reuse the current buffer if possible - (current-buffer)) - ;; look for another cvs buffer visiting the same directory - (save-excursion - (unless new - (cl-dolist (buffer (cons (current-buffer) (buffer-list))) - (set-buffer buffer) - (and (cvs-buffer-p) - (pcase cvs-reuse-cvs-buffer - ('always t) - ('subdir - (or (string-prefix-p default-directory dir) - (string-prefix-p dir default-directory))) - ('samedir (string= default-directory dir))) - (cl-return buffer))))) - ;; we really have to create a new buffer: - ;; we temporarily bind cwd to "" to prevent - ;; create-file-buffer from using directory info - ;; unless it is explicitly in the cvs-buffer-name. - (cvs-get-buffer-create buffer-name new)))) - (with-current-buffer buffer - (or - (and (string= dir default-directory) (cvs-buffer-p) - ;; just a refresh - (ignore-errors - (cvs-cleanup-collection cvs-cookies nil nil t) - (current-buffer))) - ;; setup from scratch - (progn - (setq default-directory dir) - (setq buffer-read-only nil) - (erase-buffer) - (insert "Repository : " (directory-file-name (cvs-get-cvsroot)) - "\nModule : " (cvs-get-module) - "\nWorking dir: " (abbreviate-file-name dir) - (if (not (file-readable-p "CVS/Tag")) "\n" - (let ((tag (cvs-file-to-string "CVS/Tag"))) - (cond - ((string-match "\\`T" tag) - (concat "\nTag : " (substring tag 1))) - ((string-match "\\`D" tag) - (concat "\nDate : " (substring tag 1))) - ("\n")))) - "\n") - (setq buffer-read-only t) - (cvs-mode) - (setq-local list-buffers-directory buffer-name) - ;;(setq-local cvs-temp-buffer (cvs-temp-buffer)) - (let ((cookies (ewoc-create 'cvs-fileinfo-pp "\n\n" "\n" t))) - (setq-local cvs-cookies cookies) - (add-hook 'kill-buffer-hook - (lambda () - (ignore-errors (kill-buffer cvs-temp-buffer))) - nil t) - ;;(set-buffer buf) - buffer)))))) - -(cl-defun cvs-cmd-do (cmd dir flags fis new - &key cvsargs noexist dont-change-disc noshow) - (let* ((dir (file-name-as-directory - (abbreviate-file-name (expand-file-name dir)))) - (cvsbuf (cvs-make-cvs-buffer dir new))) - ;; Check that dir is under CVS control. - (unless (file-directory-p dir) - (error "%s is not a directory" dir)) - (unless (or noexist (file-directory-p (expand-file-name "CVS" dir)) - (file-expand-wildcards (expand-file-name "*/CVS" dir))) - (error "%s does not contain CVS controlled files" dir)) - - (set-buffer cvsbuf) - (cvs-mode-run cmd flags fis - :cvsargs cvsargs :dont-change-disc dont-change-disc) - - (if noshow cvsbuf - (let ((pop-up-windows nil)) (pop-to-buffer cvsbuf))))) -;; (funcall (if (and (boundp 'pop-up-frames) pop-up-frames) -;; 'pop-to-buffer 'switch-to-buffer) -;; cvsbuf)))) - -(defun cvs-run-process (args fis postprocess &optional single-dir) - (cl-assert (cvs-buffer-p cvs-buffer)) - (save-current-buffer - (let ((procbuf (current-buffer)) - (cvsbuf cvs-buffer) - (single-dir (or single-dir (eq cvs-execute-single-dir t)))) - - (set-buffer procbuf) - (goto-char (point-max)) - (unless (bolp) (let ((inhibit-read-only t)) (insert "\n"))) - ;; find the set of files we'll process in this round - (let* ((dir+files+rest - (if (or (null fis) (not single-dir)) - ;; not single-dir mode: just process the whole thing - (list "" (mapcar #'cvs-fileinfo->full-name fis) nil) - ;; single-dir mode: extract the same-dir-elements - (let ((dir (cvs-fileinfo->dir (car fis)))) - ;; output the concerned dir so the parser can translate paths - (let ((inhibit-read-only t)) - (insert "pcl-cvs: descending directory " dir "\n")) - ;; loop to find the same-dir-elems - (cl-do* ((files () (cons (cvs-fileinfo->file fi) files)) - (fis fis (cdr fis)) - (fi (car fis) (car fis))) - ((not (and fis (string= dir (cvs-fileinfo->dir fi)))) - (list dir files fis)))))) - (dir (nth 0 dir+files+rest)) - (files (nth 1 dir+files+rest)) - (rest (nth 2 dir+files+rest))) - - (add-hook 'kill-buffer-hook - (lambda () - (let ((proc (get-buffer-process (current-buffer)))) - (when (processp proc) - (set-process-filter proc nil) - ;; Abort postprocessing but leave the sentinel so it - ;; will update the list of running procs. - (process-put proc 'cvs-postprocess nil) - (interrupt-process proc)))) - nil t) - - ;; create the new process and setup the procbuffer correspondingly - (let* ((msg (cvs-header-msg args fis)) - (args (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery) - (if cvs-cvsroot (list "-d" cvs-cvsroot)) - args - files)) - ;; If process-connection-type is nil and the repository - ;; is accessed via SSH, a bad interaction between libc, - ;; CVS and SSH can lead to garbled output. - ;; It might be a glibc-specific problem (but it can also happens - ;; under macOS, it seems). - ;; It seems that using a pty can help circumvent the problem, - ;; but at the cost of screwing up when the process thinks it - ;; can ask for user input (such as password or host-key - ;; confirmation). A better workaround is to set CVS_RSH to - ;; an appropriate script, or to use a later version of CVS. - (process-connection-type nil) ; Use a pipe, not a pty. - (process - ;; the process will be run in the selected dir - (let ((default-directory (cvs-expand-dir-name dir))) - (apply 'start-file-process "cvs" procbuf cvs-program args)))) - ;; setup the process. - (process-put process 'cvs-buffer cvs-buffer) - (with-current-buffer cvs-buffer (cvs-update-header msg 'add)) - (process-put process 'cvs-header msg) - (process-put - process 'cvs-postprocess - (if (null rest) - ;; this is the last invocation - postprocess - ;; else, we have to register ourselves to be rerun on the rest - (lambda () (cvs-run-process args rest postprocess single-dir)))) - (set-process-sentinel process 'cvs-sentinel) - (set-process-filter process 'cvs-update-filter) - (set-marker (process-mark process) (point-max)) - (ignore-errors (process-send-eof process)) ;close its stdin to avoid hangs - - ;; now finish setting up the cvs-buffer - (set-buffer cvsbuf) - (setq cvs-mode-line-process (symbol-name (process-status process))) - (force-mode-line-update))))) - - ;; The following line is said to improve display updates on some - ;; emacsen. It shouldn't be needed, but it does no harm. - (sit-for 0)) - -(defun cvs-header-msg (args fis) - (let* ((lastarg nil) - (args (mapcar (lambda (arg) - (cond - ;; filter out the largish commit message - ((and (eq lastarg nil) (string= arg "commit")) - (setq lastarg 'commit) arg) - ((and (eq lastarg 'commit) (string= arg "-m")) - (setq lastarg '-m) arg) - ((eq lastarg '-m) - (setq lastarg 'done) "") - ;; filter out the largish `admin -mrev:msg' message - ((and (eq lastarg nil) (string= arg "admin")) - (setq lastarg 'admin) arg) - ((and (eq lastarg 'admin) - (string-match "\\`-m[^:]*:" arg)) - (setq lastarg 'done) - (concat (match-string 0 arg) "")) - ;; Keep the rest as is. - (t arg))) - args))) - (concat cvs-program " " - (combine-and-quote-strings - (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery) - (if cvs-cvsroot (list "-d" cvs-cvsroot)) - args - (mapcar 'cvs-fileinfo->full-name fis)))))) - -(defun cvs-update-header (cmd add) - (let* ((hf (ewoc-get-hf cvs-cookies)) - (str (car hf)) - (done "") - (tin (ewoc-nth cvs-cookies 0))) - ;; look for the first *real* fileinfo (to determine emptiness) - (while - (and tin - (memq (cvs-fileinfo->type (ewoc-data tin)) - '(MESSAGE DIRCHANGE))) - (setq tin (ewoc-next cvs-cookies tin))) - (if add - (progn - ;; Remove the default empty line, if applicable. - (if (not (string-match "." str)) (setq str "\n")) - (setq str (concat "-- Running " cmd " ...\n" str))) - (if (not (string-match - ;; FIXME: If `cmd' is large, this will bump into the - ;; compiled-regexp size limit. We could drop the "^" anchor - ;; and use search-forward to circumvent the problem. - (concat "^-- Running " (regexp-quote cmd) " \\.\\.\\.\n") str)) - (error "Internal PCL-CVS error while removing message") - (setq str (replace-match "" t t str)) - ;; Re-add the default empty line, if applicable. - (if (not (string-match "." str)) (setq str "\n\n")) - (setq done (concat "-- last cmd: " cmd " --\n")))) - ;; set the new header and footer - (ewoc-set-hf cvs-cookies - str (concat "\n--------------------- " - (if tin "End" "Empty") - " ---------------------\n" - done)))) - - -(defun cvs-sentinel (proc _msg) - "Sentinel for the cvs update process. -This is responsible for parsing the output from the cvs update when -it is finished." - (when (memq (process-status proc) '(signal exit)) - (let ((cvs-postproc (process-get proc 'cvs-postprocess)) - (cvs-buf (process-get proc 'cvs-buffer)) - (procbuf (process-buffer proc))) - (unless (buffer-live-p cvs-buf) (setq cvs-buf nil)) - (unless (buffer-live-p procbuf) (setq procbuf nil)) - ;; Since the buffer and mode line will show that the - ;; process is dead, we can delete it now. Otherwise it - ;; will stay around until M-x list-processes. - (process-put proc 'postprocess nil) - (delete-process proc) - ;; Don't do anything if the main buffer doesn't exist any more. - (when cvs-buf - (with-current-buffer cvs-buf - (cvs-update-header (process-get proc 'cvs-header) nil) - (setq cvs-mode-line-process (symbol-name (process-status proc))) - (force-mode-line-update) - (when cvs-postproc - (if (null procbuf) - ;;(set-process-buffer proc nil) - (error "CVS process buffer was killed") - (with-current-buffer procbuf - ;; Do the postprocessing like parsing and such. - (save-excursion - (funcall cvs-postproc))))))) - ;; Check whether something is left. - (when (and procbuf (not (get-buffer-process procbuf))) - (with-current-buffer procbuf - ;; IIRC, we enable undo again once the process is finished - ;; for cases where the output was inserted in *vc-diff* or - ;; in a file-like buffer. --Stef - (buffer-enable-undo) - (with-current-buffer (or cvs-buf (current-buffer)) - (message "CVS process has completed in %s" - (buffer-name)))))))) - -(defun cvs-parse-process (dcd &optional subdir old-fis) - "Parse the output of a cvs process. -DCD is the `dont-change-disc' flag to use when parsing that output. -SUBDIR is the subdirectory (if any) where this command was run. -OLD-FIS is the list of fileinfos on which the cvs command was applied and - which should be considered up-to-date if they are missing from the output." - (when (eq system-type 'darwin) - ;; Fixup the ^D^H^H inserted at beginning of buffer sometimes on macOS - ;; because of the call to `process-send-eof'. - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "^\\^D\^H+" nil t) - (let ((inhibit-read-only t)) - (delete-region (match-beginning 0) (match-end 0)))))) - (let* ((fileinfos (cvs-parse-buffer 'cvs-parse-table dcd subdir)) - last) - (with-current-buffer cvs-buffer - ;; Expand OLD-FIS to actual files. - (let ((fis nil)) - (dolist (fi old-fis) - (setq fis (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE) - (nconc (ewoc-collect cvs-cookies 'cvs-dir-member-p - (cvs-fileinfo->dir fi)) - fis) - (cons fi fis)))) - (setq old-fis fis)) - ;; Drop OLD-FIS which were already up-to-date. - (let ((fis nil)) - (dolist (fi old-fis) - (unless (eq (cvs-fileinfo->type fi) 'UP-TO-DATE) (push fi fis))) - (setq old-fis fis)) - ;; Add the new fileinfos to the ewoc. - (dolist (fi fileinfos) - (setq last (cvs-addto-collection cvs-cookies fi last)) - ;; This FI was in the output, so remove it from OLD-FIS. - (setq old-fis (delq (ewoc-data last) old-fis))) - ;; Process the "silent output" (i.e. absence means up-to-date). - (dolist (fi old-fis) - (setf (cvs-fileinfo->type fi) 'UP-TO-DATE) - (setq last (cvs-addto-collection cvs-cookies fi last))) - (setq fileinfos (nconc old-fis fileinfos)) - ;; Clean up the ewoc as requested by the user. - (cvs-cleanup-collection cvs-cookies - (eq cvs-auto-remove-handled t) - cvs-auto-remove-directories - nil) - ;; Revert buffers if necessary. - (when (and cvs-auto-revert (not dcd) (not cvs-from-vc)) - (cvs-revert-if-needed fileinfos))))) - -(defmacro defun-cvs-mode (fun args docstring interact &rest body) - "Define a function to be used in a *cvs* buffer. -This will look for a *cvs* buffer and execute BODY in it. -Since the interactive arguments might need to be queried after -switching to the *cvs* buffer, the generic code is rather ugly, -but luckily we can often use simpler alternatives. - -FUN can be either a symbol (i.e. STYLE is nil) or a cons (FUN . STYLE). -ARGS and DOCSTRING are the normal argument list. -INTERACT is the interactive specification or nil for non-commands. - -STYLE can be either `SIMPLE', `NOARGS' or `DOUBLE'. It's an error for it -to have any other value, unless other details of the function make it -clear what alternative to use. -- `SIMPLE' will get all the interactive arguments from the original buffer. -- `NOARGS' will get all the arguments from the *cvs* buffer and will - always behave as if called interactively. -- `DOUBLE' is the generic case." - (declare (debug (&define sexp lambda-list stringp - ("interactive" interactive) def-body)) - (indent defun) - (doc-string 3)) - (let ((style (cvs-cdr fun)) - (fun (cvs-car fun))) - (cond - ;; a trivial interaction, no need to move it - ((or (eq style 'SIMPLE) - (null (nth 1 interact)) - (stringp (nth 1 interact))) - `(defun ,fun ,args ,docstring ,interact - (cvs-mode! (lambda () ,@body)))) - - ;; fun is only called interactively: move all the args to the inner fun - ((eq style 'NOARGS) - `(defun ,fun () ,docstring (interactive) - (cvs-mode! (lambda ,args ,interact ,@body)))) - - ;; bad case - ((eq style 'DOUBLE) - (string-match ".*" docstring) - (let ((line1 (match-string 0 docstring)) - (fun-1 (intern (concat (symbol-name fun) "-1")))) - `(progn - (defun ,fun-1 ,args - ,(concat docstring "\nThis function only works within a *cvs* buffer. -For interactive use, use `" (symbol-name fun) "' instead.") - ,interact - ,@body) - (put ',fun-1 'definition-name ',fun) - (defun ,fun () - ,(concat line1 "\nWrapper function that switches to a *cvs* buffer -before calling the real function `" (symbol-name fun-1) "'.\n") - (interactive) - (cvs-mode! ',fun-1))))) - - (t (error "Unknown style %s in `defun-cvs-mode'" style))))) - -(defun-cvs-mode cvs-mode-kill-process () - "Kill the temporary buffer and associated process." - (interactive) - (when (and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer)) - (let ((proc (get-buffer-process cvs-temp-buffer))) - (when proc (delete-process proc))))) - -;; -;; Maintaining the collection in the face of updates -;; - -(defun cvs-addto-collection (c fi &optional tin) - "Add FI to C and return FI's corresponding tin. -FI is inserted in its proper place or maybe even merged with a preexisting - fileinfo if applicable. -TIN specifies an optional starting point." - (unless tin (setq tin (ewoc-nth c 0))) - (while (and tin (cvs-fileinfo< fi (ewoc-data tin))) - (setq tin (ewoc-prev c tin))) - (if (null tin) (ewoc-enter-first c fi) ;empty collection - (cl-assert (not (cvs-fileinfo< fi (ewoc-data tin)))) - (let ((next-tin (ewoc-next c tin))) - (while (not (or (null next-tin) - (cvs-fileinfo< fi (ewoc-data next-tin)))) - (setq tin next-tin next-tin (ewoc-next c next-tin))) - (if (or (cvs-fileinfo< (ewoc-data tin) fi) - (eq (cvs-fileinfo->type fi) 'MESSAGE)) - ;; tin < fi < next-tin - (ewoc-enter-after c tin fi) - ;; fi == tin - (cvs-fileinfo-update (ewoc-data tin) fi) - (ewoc-invalidate c tin) - ;; Move cursor back to where it belongs. - (when (bolp) (cvs-move-to-goal-column)) - tin)))) - -(defcustom cvs-cleanup-functions nil - "Functions to tweak the cleanup process. -The functions are called with a single argument (a FILEINFO) and should -return a non-nil value if that fileinfo should be removed." - :group 'pcl-cvs - :type '(hook :options (cvs-cleanup-removed))) - -(defun cvs-cleanup-removed (fi) - "Non-nil if FI has been cvs-removed but still exists. -This is intended for use on `cvs-cleanup-functions' when you have cvs-removed -automatically generated files (which should hence not be under CVS control) -but can't commit the removal because the repository's owner doesn't understand -the problem." - (and (or (eq (cvs-fileinfo->type fi) 'REMOVED) - (and (eq (cvs-fileinfo->type fi) 'CONFLICT) - (eq (cvs-fileinfo->subtype fi) 'REMOVED))) - (file-exists-p (cvs-fileinfo->full-name fi)))) - -;; called at the following times: -;; - postparse ((eq cvs-auto-remove-handled t) cvs-auto-remove-directories nil) -;; - pre-run ((eq cvs-auto-remove-handled 'delayed) nil t) -;; - remove-handled (t (or cvs-auto-remove-directories 'handled) t) -;; - cvs-cmd-do (nil nil t) -;; - post-ignore (nil nil nil) -;; - acknowledge (nil nil nil) -;; - remove (nil nil nil) -(defun cvs-cleanup-collection (c rm-handled rm-dirs rm-msgs) - "Remove undesired entries. -C is the collection -RM-HANDLED if non-nil means remove handled entries (if file is currently - visited, only remove if value is `all'). -RM-DIRS behaves like `cvs-auto-remove-directories'. -RM-MSGS if non-nil means remove messages." - (let (last-fi first-dir (rerun t)) - (while rerun - (setq rerun nil) - (setq first-dir t) - (setq last-fi (cvs-create-fileinfo 'DEAD "../" "" "")) ;place-holder - (ewoc-filter - c (lambda (fi) - (let* ((type (cvs-fileinfo->type fi)) - (subtype (cvs-fileinfo->subtype fi)) - (keep - (pcase type - ;; Remove temp messages and keep the others. - ('MESSAGE (not (or rm-msgs (eq subtype 'TEMP)))) - ;; Remove dead entries. - ('DEAD nil) - ;; Handled also? - ('UP-TO-DATE - (not - (if (find-buffer-visiting (cvs-fileinfo->full-name fi)) - (eq rm-handled 'all) - rm-handled))) - ;; Keep the rest. - (_ (not (run-hook-with-args-until-success - 'cvs-cleanup-functions fi)))))) - - ;; mark dirs for removal - (when (and keep rm-dirs - (eq (cvs-fileinfo->type last-fi) 'DIRCHANGE) - (not (when first-dir (setq first-dir nil) t)) - (or (eq rm-dirs 'all) - (not (string-prefix-p - (cvs-fileinfo->dir last-fi) - (cvs-fileinfo->dir fi))) - (and (eq type 'DIRCHANGE) (eq rm-dirs 'empty)) - (eq subtype 'FOOTER))) - (setf (cvs-fileinfo->type last-fi) 'DEAD) - (setq rerun t)) - (when keep (setq last-fi fi))))) - ;; remove empty last dir - (when (and rm-dirs - (not first-dir) - (eq (cvs-fileinfo->type last-fi) 'DIRCHANGE)) - (setf (cvs-fileinfo->type last-fi) 'DEAD) - (setq rerun t))))) - -(defun cvs-get-cvsroot () - "Get the CVSROOT for DIR." - (let ((cvs-cvsroot-file (expand-file-name "Root" "CVS"))) - (or (cvs-file-to-string cvs-cvsroot-file t) - cvs-cvsroot - (getenv "CVSROOT") - "?????"))) - -(defun cvs-get-module () - "Return the current CVS module. -This usually doesn't really work but is a handy initval in a prompt." - (let* ((repfile (expand-file-name "Repository" "CVS")) - (rep (cvs-file-to-string repfile t))) - (cond - ((null rep) "") - ((not (file-name-absolute-p rep)) rep) - (t - (let* ((root (cvs-get-cvsroot)) - (str (concat (file-name-as-directory (or root "/")) " || " rep))) - (if (and root (string-match "\\(.*\\) || \\1\\(.*\\)\\'" str)) - (match-string 2 str) - (file-name-nondirectory rep))))))) - - - -;;;; -;;;; running a "cvs checkout". -;;;; - -;;;###autoload -(defun cvs-checkout (modules dir flags &optional root) - "Run a `cvs checkout MODULES' in DIR. -Feed the output to a *cvs* buffer, display it in the current window, -and run `cvs-mode' on it. - -With a prefix argument, prompt for cvs FLAGS to use." - (interactive - (let ((root (cvs-get-cvsroot))) - (if (or (null root) current-prefix-arg) - (setq root (read-string "CVS Root: "))) - (list (split-string-and-unquote - (read-string "Module(s): " (cvs-get-module))) - (read-directory-name "CVS Checkout Directory: " - nil default-directory nil) - (cvs-add-branch-prefix - (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags")) - root))) - (when (eq flags t) - (setf flags (cvs-flags-query 'cvs-checkout-flags nil 'noquery))) - (let ((cvs-cvsroot root)) - (cvs-cmd-do "checkout" (or dir default-directory) - (append flags modules) nil 'new - :noexist t))) - -(defun-cvs-mode (cvs-mode-checkout . NOARGS) (dir) - "Run `cvs checkout' against the current branch. -The files are stored to DIR." - (interactive - (let* ((branch (cvs-prefix-get 'cvs-branch-prefix)) - (prompt (format-message "CVS Checkout Directory for `%s%s': " - (cvs-get-module) - (if branch (format " (branch: %s)" branch) - "")))) - (list (read-directory-name prompt nil default-directory nil)))) - (let ((modules (split-string-and-unquote (cvs-get-module))) - (flags (cvs-add-branch-prefix - (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags"))) - (cvs-cvsroot (cvs-get-cvsroot))) - (cvs-checkout modules dir flags))) - -;;;; -;;;; The code for running a "cvs update" and friends in various ways. -;;;; - -(defun-cvs-mode (cvs-mode-revert-buffer . SIMPLE) - (&optional _ignore-auto _noconfirm) - "Rerun `cvs-examine' on the current directory with the default flags." - (interactive) - (cvs-examine default-directory t)) - -(defun cvs-query-directory (prompt) - "Read directory name, prompting with PROMPT. -If in a *cvs* buffer, don't prompt unless a prefix argument is given." - (if (and (cvs-buffer-p) - (not current-prefix-arg)) - default-directory - (read-directory-name prompt nil default-directory nil))) - -;;;###autoload -(defun cvs-quickdir (dir &optional _flags noshow) - "Open a *cvs* buffer on DIR without running cvs. -With a prefix argument, prompt for a directory to use. -A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), - prevents reuse of an existing *cvs* buffer. -Optional argument NOSHOW if non-nil means not to display the buffer. -FLAGS is ignored." - (interactive (list (cvs-query-directory "CVS quickdir (directory): "))) - ;; FIXME: code duplication with cvs-cmd-do and cvs-parse-process - (let* ((dir (file-name-as-directory - (abbreviate-file-name (expand-file-name dir)))) - (new (> (prefix-numeric-value current-prefix-arg) 8)) - (cvsbuf (cvs-make-cvs-buffer dir new)) - last) - ;; Check that dir is under CVS control. - (unless (file-directory-p dir) - (error "%s is not a directory" dir)) - (unless (file-directory-p (expand-file-name "CVS" dir)) - (error "%s does not contain CVS controlled files" dir)) - (set-buffer cvsbuf) - (dolist (fi (cvs-fileinfo-from-entries "")) - (setq last (cvs-addto-collection cvs-cookies fi last))) - (cvs-cleanup-collection cvs-cookies - (eq cvs-auto-remove-handled t) - cvs-auto-remove-directories - nil) - (if noshow cvsbuf - (let ((pop-up-windows nil)) (pop-to-buffer cvsbuf))))) - -;;;###autoload -(defun cvs-examine (directory flags &optional noshow) - "Run a `cvs -n update' in the specified DIRECTORY. -That is, check what needs to be done, but don't change the disc. -Feed the output to a *cvs* buffer and run `cvs-mode' on it. -With a prefix argument, prompt for a directory and cvs FLAGS to use. -A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), - prevents reuse of an existing *cvs* buffer. -Optional argument NOSHOW if non-nil means not to display the buffer." - (interactive (list (cvs-query-directory "CVS Examine (directory): ") - (cvs-flags-query 'cvs-update-flags "cvs -n update flags"))) - (when (eq flags t) - (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery))) - (when find-file-visit-truename (setq directory (file-truename directory))) - (cvs-cmd-do "update" directory flags nil - (> (prefix-numeric-value current-prefix-arg) 8) - :cvsargs '("-n") - :noshow noshow - :dont-change-disc t)) - - -;;;###autoload -(defun cvs-update (directory flags) - "Run a `cvs update' in the current working DIRECTORY. -Feed the output to a *cvs* buffer and run `cvs-mode' on it. -With a \\[universal-argument] prefix argument, prompt for a directory to use. -A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), - prevents reuse of an existing *cvs* buffer. -The prefix is also passed to `cvs-flags-query' to select the FLAGS - passed to cvs." - (interactive (list (cvs-query-directory "CVS Update (directory): ") - (cvs-flags-query 'cvs-update-flags "cvs update flags"))) - (when (eq flags t) - (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery))) - (cvs-cmd-do "update" directory flags nil - (> (prefix-numeric-value current-prefix-arg) 8))) - - -;;;###autoload -(defun cvs-status (directory flags &optional noshow) - "Run a `cvs status' in the current working DIRECTORY. -Feed the output to a *cvs* buffer and run `cvs-mode' on it. -With a prefix argument, prompt for a directory and cvs FLAGS to use. -A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), - prevents reuse of an existing *cvs* buffer. -Optional argument NOSHOW if non-nil means not to display the buffer." - (interactive (list (cvs-query-directory "CVS Status (directory): ") - (cvs-flags-query 'cvs-status-flags "cvs status flags"))) - (when (eq flags t) - (setf flags (cvs-flags-query 'cvs-status-flags nil 'noquery))) - (cvs-cmd-do "status" directory flags nil - (> (prefix-numeric-value current-prefix-arg) 8) - :noshow noshow :dont-change-disc t)) - -(defun cvs-update-filter (proc string) - "Filter function for PCL-CVS. -This function gets the output that CVS sends to stdout. It inserts -the STRING into (process-buffer PROC) but it also checks if CVS is waiting -for a lock file. If so, it inserts a message cookie in the *cvs* buffer." - (save-match-data - (with-current-buffer (process-buffer proc) - (let ((inhibit-read-only t)) - (save-excursion - ;; Insert the text, moving the process-marker. - (goto-char (process-mark proc)) - (insert string) - (set-marker (process-mark proc) (point)) - ;; FIXME: Delete any old lock message - ;;(if (tin-nth cookies 1) - ;; (tin-delete cookies - ;; (tin-nth cookies 1))) - ;; Check if CVS is waiting for a lock. - (beginning-of-line 0) ;Move to beginning of last complete line. - (when (looking-at "^[ a-z]+: \\(.*waiting for .*lock in \\(.*\\)\\)$") - (let ((msg (match-string 1)) - (lock (match-string 2))) - (with-current-buffer cvs-buffer - (setq-local cvs-lock-file lock) - ;; display the lock situation in the *cvs* buffer: - (ewoc-enter-last - cvs-cookies - (cvs-create-fileinfo - 'MESSAGE "" " " - (concat msg - (when (file-exists-p lock) - (substitute-command-keys - "\n\t(type \\[cvs-mode-delete-lock] to delete it)"))) - :subtype 'TEMP)) - (pop-to-buffer (current-buffer)) - (goto-char (point-max)) - (beep))))))))) - - -;;;; -;;;; The cvs-mode and its associated commands. -;;;; - -(cvs-prefix-define cvs-force-command "" "" '("/F") cvs-qtypedesc-string1) -(defun-cvs-mode cvs-mode-force-command (arg) - "Force the next cvs command to operate on all the selected files. -By default, cvs commands only operate on files on which the command -\"makes sense\". This overrides the safety feature on the next cvs command. -It actually behaves as a toggle. If prefixed by \\[universal-argument] \\[universal-argument], -the override will persist until the next toggle." - (interactive "P") - (cvs-prefix-set 'cvs-force-command arg)) - -(put 'cvs-mode 'mode-class 'special) -(define-derived-mode cvs-mode nil "CVS" - "Mode used for PCL-CVS, a frontend to CVS. -Full documentation is in the Texinfo file." - (setq mode-line-process - '("" cvs-force-command cvs-ignore-marks-modif - ":" (cvs-branch-prefix - ("" cvs-branch-prefix (cvs-secondary-branch-prefix - ("->" cvs-secondary-branch-prefix)))) - " " cvs-mode-line-process)) - (if buffer-file-name - (error (substitute-command-keys - "Use \\[cvs-quickdir] to get a *cvs* buffer"))) - (buffer-disable-undo) - ;;(setq-local goal-column cvs-cursor-column) - (setq-local revert-buffer-function 'cvs-mode-revert-buffer) - (setq truncate-lines t) - (cvs-prefix-make-local 'cvs-branch-prefix) - (cvs-prefix-make-local 'cvs-secondary-branch-prefix) - (cvs-prefix-make-local 'cvs-force-command) - (cvs-prefix-make-local 'cvs-ignore-marks-modif) - (make-local-variable 'cvs-mode-line-process) - (make-local-variable 'cvs-temp-buffers)) - - -(defun cvs-buffer-p (&optional buffer) - "Return whether the (by default current) BUFFER is a `cvs-mode' buffer." - (save-excursion - (if buffer (set-buffer buffer)) - (and (eq major-mode 'cvs-mode)))) - -(defun cvs-buffer-check () - "Check that the current buffer follows cvs-buffer's conventions." - (let ((buf (current-buffer)) - (check 'none)) - (or (and (setq check 'collection) - (eq (ewoc-buffer cvs-cookies) buf) - (setq check 'cvs-temp-buffer) - (or (null cvs-temp-buffer) - (null (buffer-live-p cvs-temp-buffer)) - (and (eq (with-current-buffer cvs-temp-buffer cvs-buffer) buf) - (equal (with-current-buffer cvs-temp-buffer - default-directory) - default-directory))) - t) - (error "Inconsistent %s in buffer %s" check (buffer-name buf))))) - - -(defun cvs-mode-quit () - "Quit PCL-CVS, killing the *cvs* buffer." - (interactive) - (and (y-or-n-p "Quit pcl-cvs? ") (kill-buffer (current-buffer)))) - -;; Give help.... - -(defun cvs-help () - "Display help for various PCL-CVS commands." - (interactive) - (if (eq last-command 'cvs-help) - (describe-function 'cvs-mode) ; would need minor-mode for log-edit-mode - (message "%s" - (substitute-command-keys - "`\\[cvs-help]':help `\\[cvs-mode-add]':add `\\[cvs-mode-commit]':commit \ -`\\[cvs-mode-diff-map]':diff* `\\[cvs-mode-log]':log \ -`\\[cvs-mode-remove]':remove `\\[cvs-mode-status]':status \ -`\\[cvs-mode-undo]':undo")))) - -;; Move around in the buffer - -(defun cvs-move-to-goal-column () - (let* ((eol (line-end-position)) - (fpos (next-single-property-change (point) 'cvs-goal-column nil eol))) - (when (< fpos eol) - (goto-char fpos)))) - -(defun-cvs-mode cvs-mode-previous-line (arg) - "Go to the previous line. -If a prefix argument is given, move by that many lines." - (interactive "p") - (ewoc-goto-prev cvs-cookies arg) - (cvs-move-to-goal-column)) - -(defun-cvs-mode cvs-mode-next-line (arg) - "Go to the next line. -If a prefix argument is given, move by that many lines." - (interactive "p") - (ewoc-goto-next cvs-cookies arg) - (cvs-move-to-goal-column)) - -;;;; -;;;; Mark handling -;;;; - -(defun-cvs-mode cvs-mode-mark (&optional arg) - "Mark the fileinfo on the current line. -If the fileinfo is a directory, all the contents of that directory are -marked instead. A directory can never be marked." - (interactive) - (let* ((tin (ewoc-locate cvs-cookies)) - (fi (ewoc-data tin))) - (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE) - ;; it's a directory: let's mark all files inside - (ewoc-map - (lambda (f dir) - (when (cvs-dir-member-p f dir) - (setf (cvs-fileinfo->marked f) - (not (if (eq arg 'toggle) (cvs-fileinfo->marked f) arg))) - t)) ;Tell cookie to redisplay this cookie. - cvs-cookies - (cvs-fileinfo->dir fi)) - ;; not a directory: just do the obvious - (setf (cvs-fileinfo->marked fi) - (not (if (eq arg 'toggle) (cvs-fileinfo->marked fi) arg))) - (ewoc-invalidate cvs-cookies tin) - (cvs-mode-next-line 1)))) - -(defalias 'cvs-mouse-toggle-mark 'cvs-mode-toggle-mark) -(defun cvs-mode-toggle-mark (e) - "Toggle the mark of the entry at point." - (interactive (list last-input-event)) - (save-excursion - (posn-set-point (event-end e)) - (cvs-mode-mark 'toggle))) - -(defun-cvs-mode cvs-mode-unmark () - "Unmark the fileinfo on the current line." - (interactive) - (cvs-mode-mark t)) - -(defun-cvs-mode cvs-mode-mark-all-files () - "Mark all files." - (interactive) - (ewoc-map (lambda (cookie) - (unless (eq (cvs-fileinfo->type cookie) 'DIRCHANGE) - (setf (cvs-fileinfo->marked cookie) t))) - cvs-cookies)) - -(defun-cvs-mode (cvs-mode-mark-on-state . SIMPLE) (state) - "Mark all files in state STATE." - (interactive - (list - (let ((default - (condition-case nil - (downcase - (symbol-name - (cvs-fileinfo->type - (cvs-mode-marked nil nil :read-only t :one t :noquery t)))) - (error nil)))) - (intern - (upcase - (completing-read - (format-prompt "Mark files in state" default) - (mapcar (lambda (x) - (list (downcase (symbol-name (car x))))) - cvs-states) - nil t nil nil default)))))) - (ewoc-map (lambda (fi) - (when (eq (cvs-fileinfo->type fi) state) - (setf (cvs-fileinfo->marked fi) t))) - cvs-cookies)) - -(defun-cvs-mode cvs-mode-mark-matching-files (regex) - "Mark all files matching REGEX." - (interactive "sMark files matching: ") - (ewoc-map (lambda (cookie) - (when (and (not (eq (cvs-fileinfo->type cookie) 'DIRCHANGE)) - (string-match regex (cvs-fileinfo->file cookie))) - (setf (cvs-fileinfo->marked cookie) t))) - cvs-cookies)) - -(defun-cvs-mode cvs-mode-unmark-all-files () - "Unmark all files. -Directories are also unmarked, but that doesn't matter, since -they should always be unmarked." - (interactive) - (ewoc-map (lambda (cookie) - (setf (cvs-fileinfo->marked cookie) nil) - t) - cvs-cookies)) - -(defun-cvs-mode cvs-mode-unmark-up () - "Unmark the file on the previous line." - (interactive) - (let ((tin (ewoc-goto-prev cvs-cookies 1))) - (when tin - (setf (cvs-fileinfo->marked (ewoc-data tin)) nil) - (ewoc-invalidate cvs-cookies tin))) - (cvs-move-to-goal-column)) - -(defconst cvs-ignore-marks-alternatives - '(("toggle-marks" . "/TM") - ("force-marks" . "/FM") - ("ignore-marks" . "/IM"))) - -(cvs-prefix-define cvs-ignore-marks-modif - "Prefix to decide whether to ignore marks or not." - "active" - (mapcar 'cdr cvs-ignore-marks-alternatives) - (cvs-qtypedesc-create - (lambda (str) (cdr (assoc str cvs-ignore-marks-alternatives))) - (lambda (obj) (car (rassoc obj cvs-ignore-marks-alternatives))) - (lambda () cvs-ignore-marks-alternatives) - nil t)) - -(defun-cvs-mode cvs-mode-toggle-marks (arg) - "Toggle whether the next CVS command uses marks. -See `cvs-prefix-set' for further description of the behavior. -\\[universal-argument] 1 selects `force-marks', -\\[universal-argument] 2 selects `ignore-marks', -\\[universal-argument] 3 selects `toggle-marks'." - (interactive "P") - (cvs-prefix-set 'cvs-ignore-marks-modif arg)) - -(defun cvs-ignore-marks-p (cmd &optional read-only) - (let ((default (if (member cmd cvs-invert-ignore-marks) - (not cvs-default-ignore-marks) - cvs-default-ignore-marks)) - (modif (cvs-prefix-get 'cvs-ignore-marks-modif read-only))) - (cond - ((equal modif "/IM") t) - ((equal modif "/TM") (not default)) - ((equal modif "/FM") nil) - (t default)))) - -(defun cvs-mode-mark-get-modif (cmd) - (if (cvs-ignore-marks-p cmd 'read-only) "/IM" "/FM")) - -(defun cvs-get-marked (&optional ignore-marks ignore-contents) - "Return a list of all selected fileinfos. -If there are any marked tins, and IGNORE-MARKS is nil, return them. -Otherwise, if the cursor selects a directory, and IGNORE-CONTENTS is -nil, return all files in it, else return just the directory. -Otherwise return (a list containing) the file the cursor points to, or -an empty list if it doesn't point to a file at all." - (let ((fis nil)) - (dolist (fi (if (and (boundp 'cvs-minor-current-files) - (consp cvs-minor-current-files)) - (mapcar - (lambda (f) - (if (cvs-fileinfo-p f) f - (let ((f (file-relative-name f))) - (if (file-directory-p f) - (cvs-create-fileinfo - 'DIRCHANGE (file-name-as-directory f) "." "") - (let ((dir (file-name-directory f)) - (file (file-name-nondirectory f))) - (cvs-create-fileinfo - 'UNKNOWN (or dir "") file "")))))) - cvs-minor-current-files) - (or (and (not ignore-marks) - (ewoc-collect cvs-cookies 'cvs-fileinfo->marked)) - (list (ewoc-data (ewoc-locate cvs-cookies)))))) - - (if (or ignore-contents (not (eq (cvs-fileinfo->type fi) 'DIRCHANGE))) - (push fi fis) - ;; If a directory is selected, return members, if any. - (setq fis - (append (ewoc-collect - cvs-cookies 'cvs-dir-member-p (cvs-fileinfo->dir fi)) - fis)))) - (nreverse fis))) - -(cl-defun cvs-mode-marked (filter &optional cmd - &key read-only one file noquery) - "Get the list of marked FIS. -CMD is used to determine whether to use the marks or not. -Only files for which FILTER is applicable are returned. -If READ-ONLY is non-nil, the current toggling is left intact. -If ONE is non-nil, marks are ignored and a single FI is returned. -If FILE is non-nil, directory entries won't be selected." - (unless cmd (setq cmd (symbol-name filter))) - (let* ((fis (cvs-get-marked (or one (cvs-ignore-marks-p cmd read-only)) - (and (not file) - (cvs-applicable-p 'DIRCHANGE filter)))) - (force (cvs-prefix-get 'cvs-force-command)) - (fis (car (cvs-partition - (lambda (fi) (cvs-applicable-p fi (and (not force) filter))) - fis)))) - (when (and (or (null fis) (and one (cdr fis))) (not noquery)) - (message (if (null fis) - "`%s' is not applicable to any of the selected files." - "`%s' is only applicable to a single file.") cmd) - (sit-for 1) - (setq fis (list (cvs-insert-file - (read-file-name (format "File to %s: " cmd)))))) - (if one (car fis) fis))) - -(defun cvs-enabledp (filter) - "Determine whether FILTER applies to at least one of the selected files." - (ignore-errors (cvs-mode-marked filter nil :read-only t :noquery t))) - -(defun cvs-mode-files (&rest -cvs-mode-files-args) - (cvs-mode! - (lambda () - (mapcar 'cvs-fileinfo->full-name - (apply 'cvs-mode-marked -cvs-mode-files-args))))) - -;; -;; Interface between Log-Edit and PCL-CVS -;; - -(defun cvs-mode-commit-setup () - "Run `cvs-mode-commit' with setup." - (interactive) - (cvs-mode-commit 'force)) - -(defcustom cvs-mode-commit-hook nil - "Hook run after setting up the commit buffer." - :type 'hook - :options '(cvs-mode-diff) - :group 'pcl-cvs) - -(defun cvs-mode-commit (setup) - "Check in all marked files, or the current file. -The user will be asked for a log message in a buffer. -The buffer's mode and name is determined by the \"message\" setting - of `cvs-buffer-name-alist'. -The POSTPROC specified there (typically `log-edit') is then called, - passing it the SETUP argument." - (interactive "P") - ;; It seems that the save-excursion that happens if I use the better - ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which - ;; end up being rather annoying (like log-edit-mode's message being - ;; displayed in the wrong minibuffer). - (cvs-mode!) - (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup)) - (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist))) - 'log-edit))) - (funcall setupfun 'cvs-do-commit setup - '((log-edit-listfun . cvs-commit-filelist) - (log-edit-diff-function . cvs-mode-diff)) buf) - (setq-local cvs-minor-wrap-function 'cvs-commit-minor-wrap) - (run-hooks 'cvs-mode-commit-hook))) - -(defun cvs-commit-minor-wrap (_buf f) - (let ((cvs-ignore-marks-modif (cvs-mode-mark-get-modif "commit"))) - (funcall f))) - -(defun cvs-commit-filelist () - (cvs-mode-files 'commit nil :read-only t :file t :noquery t)) - -(defun cvs-do-commit (flags) - "Do the actual commit, using the current buffer as the log message." - (interactive (list (cvs-flags-query 'cvs-commit-flags "cvs commit flags"))) - (let ((msg (buffer-substring-no-properties (point-min) (point-max)))) - (cvs-mode!) - ;;(pop-to-buffer cvs-buffer) - (cvs-mode-do "commit" `("-m" ,msg ,@flags) 'commit))) - - -;;;; Editing existing commit log messages. - -(defun cvs-edit-log-text-at-point () - (save-excursion - (end-of-line) - (when (re-search-backward "^revision " nil t) - (forward-line 1) - (if (looking-at "date:") (forward-line 1)) - (if (looking-at "branches:") (forward-line 1)) - (buffer-substring - (point) - (if (re-search-forward - "^\\(-\\{28\\}\\|=\\{77\\}\\|revision [.0-9]+\\)$" - nil t) - (match-beginning 0) - (point)))))) - -(defvar cvs-edit-log-revision) -(defvar cvs-edit-log-files) (put 'cvs-edit-log-files 'permanent-local t) -(defun cvs-mode-edit-log (file rev &optional text) - "Edit log message at point. -This is best called from a `log-view-mode' buffer." - (interactive - (list - (or (cvs-mode! (lambda () - (car (cvs-mode-files nil nil - :read-only t :file t :noquery t)))) - (read-string "File name: ")) - (or (cvs-mode! (lambda () (cvs-prefix-get 'cvs-branch-prefix))) - (read-string "Revision to edit: ")) - (cvs-edit-log-text-at-point))) - ;; It seems that the save-excursion that happens if I use the better - ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which - ;; end up being rather annoying (like log-edit-mode's message being - ;; displayed in the wrong minibuffer). - (cvs-mode!) - (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup)) - (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist))) - 'log-edit))) - (with-current-buffer buf - ;; Set the filename before, so log-edit can correctly setup its - ;; log-edit-initial-files variable. - (setq-local cvs-edit-log-files (list file))) - (funcall setupfun 'cvs-do-edit-log nil - '((log-edit-listfun . cvs-edit-log-filelist) - (log-edit-diff-function . cvs-mode-diff)) - buf) - (when text (erase-buffer) (insert text)) - (setq-local cvs-edit-log-revision rev) - (setq-local cvs-minor-wrap-function 'cvs-edit-log-minor-wrap) - ;; (run-hooks 'cvs-mode-commit-hook) - )) - -(defun cvs-edit-log-minor-wrap (buf f) - (let ((cvs-branch-prefix (with-current-buffer buf cvs-edit-log-revision)) - (cvs-minor-current-files - (with-current-buffer buf cvs-edit-log-files)) - ;; FIXME: I need to force because the fileinfos are UNKNOWN - (cvs-force-command "/F")) - (funcall f))) - -(defun cvs-edit-log-filelist () - (if cvs-minor-wrap-function - (cvs-mode-files nil nil :read-only t :file t :noquery t) - cvs-edit-log-files)) - -(defun cvs-do-edit-log (rev) - "Do the actual commit, using the current buffer as the log message." - (interactive (list cvs-edit-log-revision)) - (let ((msg (buffer-substring-no-properties (point-min) (point-max)))) - (cvs-mode! - (lambda () - (cvs-mode-do "admin" (list (concat "-m" rev ":" msg)) nil))))) - - -;;;; -;;;; CVS Mode commands -;;;; - -(defun-cvs-mode (cvs-mode-insert . NOARGS) (file) - "Insert an entry for a specific file into the current listing. -This is typically used if the file is up-to-date (or has been added -outside of PCL-CVS) and one wants to do some operation on it." - (interactive - (list (read-file-name - "File to insert: " - ;; Can't use ignore-errors here because interactive - ;; specs aren't byte-compiled. - (condition-case nil - (file-name-as-directory - (expand-file-name - (cvs-fileinfo->dir - (cvs-mode-marked nil nil :read-only t :one t :noquery t)))) - (error nil))))) - (cvs-insert-file file)) - -(defun cvs-insert-file (file) - "Insert FILE (and its contents if it's a dir) and return its FI." - (let ((file (file-relative-name (directory-file-name file))) last) - (dolist (fi (cvs-fileinfo-from-entries file)) - (setq last (cvs-addto-collection cvs-cookies fi last))) - ;; There should have been at least one entry. - (goto-char (ewoc-location last)) - (ewoc-data last))) - -(defun cvs-mark-fis-dead (fis) - ;; Helper function, introduced because of the need for macro-expansion. - (dolist (fi fis) - (setf (cvs-fileinfo->type fi) 'DEAD))) - -(defun-cvs-mode (cvs-mode-add . SIMPLE) (flags) - "Add marked files to the cvs repository. -With prefix argument, prompt for cvs flags." - (interactive (list (cvs-flags-query 'cvs-add-flags "cvs add flags"))) - (let ((fis (cvs-mode-marked 'add)) - (needdesc nil) (dirs nil)) - ;; Find directories and look for fis needing a description. - (dolist (fi fis) - (cond - ((file-directory-p (cvs-fileinfo->full-name fi)) (push fi dirs)) - ((eq (cvs-fileinfo->type fi) 'UNKNOWN) (setq needdesc t)))) - ;; Prompt for description if necessary. - (let* ((msg (if (and needdesc - (or current-prefix-arg (not cvs-add-default-message))) - (read-from-minibuffer "Enter description: ") - (or cvs-add-default-message ""))) - (flags `("-m" ,msg ,@flags)) - (postproc - ;; Setup postprocessing for the directory entries. - (when dirs - (lambda () - (cvs-run-process (list "-n" "update") - dirs - (lambda () (cvs-parse-process t))) - (cvs-mark-fis-dead dirs))))) - (cvs-mode-run "add" flags fis :postproc postproc)))) - -(defun-cvs-mode (cvs-mode-diff . DOUBLE) (flags) - "Diff the selected files against the repository. -This command compares the files in your working area against the -revision which they are based upon." - (interactive - (list (cvs-add-branch-prefix - (cvs-add-secondary-branch-prefix - (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))))) - (cvs-mode-do "diff" flags 'diff - :show t)) ;; :ignore-exit t - -(defun-cvs-mode (cvs-mode-diff-head . SIMPLE) (flags) - "Diff the selected files against the head of the current branch. -See `cvs-mode-diff' for more info." - (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) - (cvs-mode-diff-1 (cons "-rHEAD" flags))) - -(defun-cvs-mode (cvs-mode-diff-repository . SIMPLE) (flags) - "Diff the files for changes in the repository since last co/update/commit. -See `cvs-mode-diff' for more info." - (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) - (cvs-mode-diff-1 (cons "-rBASE" (cons "-rHEAD" flags)))) - -(defun-cvs-mode (cvs-mode-diff-yesterday . SIMPLE) (flags) - "Diff the selected files against yesterday's head of the current branch. -See `cvs-mode-diff' for more info." - (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) - (cvs-mode-diff-1 (cons "-Dyesterday" flags))) - -(defun-cvs-mode (cvs-mode-diff-vendor . SIMPLE) (flags) - "Diff the selected files against the head of the vendor branch. -See `cvs-mode-diff' for more info." - (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) - (cvs-mode-diff-1 (cons (concat "-r" cvs-vendor-branch) flags))) - -;; sadly, this is not provided by cvs, so we have to roll our own -(defun-cvs-mode (cvs-mode-diff-backup . SIMPLE) (flags) - "Diff the files against the backup file. -This command can be used on files that are marked with \"Merged\" -or \"Conflict\" in the *cvs* buffer." - (interactive (list (cvs-flags-query 'cvs-diff-flags "diff flags"))) - (unless (listp flags) (error "Flags should be a list of strings")) - (save-some-buffers) - (let* ((marked (cvs-get-marked (cvs-ignore-marks-p "diff"))) - (fis (car (cvs-partition 'cvs-fileinfo->backup-file marked)))) - (unless (consp fis) - (error "No files with a backup file selected!")) - (set-buffer (cvs-temp-buffer "diff")) - (message "cvs diff backup...") - (cvs-execute-single-file-list fis 'cvs-diff-backup-extractor - cvs-diff-program flags)) - (message "cvs diff backup... Done.")) - -(defun cvs-diff-backup-extractor (fileinfo) - "Return the filename and the name of the backup file as a list. -Signal an error if there is no backup file." - (let ((backup-file (cvs-fileinfo->backup-file fileinfo))) - (unless backup-file - (error "%s has no backup file" (cvs-fileinfo->full-name fileinfo))) - (list backup-file (cvs-fileinfo->full-name fileinfo)))) - -;; -;; Emerge support -;; -(defun cvs-emerge-diff (b1 b2) (emerge-buffers b1 b2 b1)) -(defun cvs-emerge-merge (b1 b2 base out) - (emerge-buffers-with-ancestor b1 b2 base (find-file-noselect out))) - -;; -;; Ediff support -;; - -(defvar ediff-after-quit-destination-buffer) -(defvar ediff-after-quit-hook-internal) -(defvar cvs-transient-buffers) -(defun cvs-ediff-startup-hook () - (add-hook 'ediff-after-quit-hook-internal - `(lambda () - (cvs-ediff-exit-hook - ',ediff-after-quit-destination-buffer ',cvs-transient-buffers)) - nil 'local)) - -(defun cvs-ediff-exit-hook (cvs-buf tmp-bufs) - ;; kill the temp buffers (and their associated windows) - (dolist (tb tmp-bufs) - (when (and tb (buffer-live-p tb) (not (buffer-modified-p tb))) - (let ((win (get-buffer-window tb t))) - (kill-buffer tb) - (when (window-live-p win) (ignore-errors (delete-window win)))))) - ;; switch back to the *cvs* buffer - (when (and cvs-buf (buffer-live-p cvs-buf) - (not (get-buffer-window cvs-buf t))) - (ignore-errors (switch-to-buffer cvs-buf)))) - -(defun cvs-ediff-diff (b1 b2) - (let ((ediff-after-quit-destination-buffer (current-buffer)) - (startup-hook '(cvs-ediff-startup-hook))) - (ediff-buffers b1 b2 startup-hook 'ediff-revision))) - -(defun cvs-ediff-merge (b1 b2 base out) - (let ((ediff-after-quit-destination-buffer (current-buffer)) - (startup-hook '(cvs-ediff-startup-hook))) - (ediff-merge-buffers-with-ancestor - b1 b2 base startup-hook - 'ediff-merge-revisions-with-ancestor - out))) - -;; -;; Interactive merge/diff support. -;; - -(defun cvs-retrieve-revision (fileinfo rev) - "Retrieve the given REVision of the file in FILEINFO into a new buffer." - (let* ((file (cvs-fileinfo->full-name fileinfo)) - (buffile (concat file "." rev))) - (or (find-buffer-visiting buffile) - (with-current-buffer (create-file-buffer buffile) - (message "Retrieving revision %s..." rev) - ;; Discard stderr output to work around the CVS+SSH+libc - ;; problem when stdout and stderr are the same. - (let ((res - (let ((coding-system-for-read 'binary)) - (apply 'process-file cvs-program nil '(t nil) nil - "-q" "update" "-p" - ;; If `rev' is HEAD, don't pass it at all: - ;; the default behavior is to get the head - ;; of the current branch whereas "-r HEAD" - ;; stupidly gives you the head of the trunk. - (append (unless (equal rev "HEAD") (list "-r" rev)) - (list file)))))) - (when (and res (not (and (equal 0 res)))) - (error "Something went wrong retrieving revision %s: %s" rev res)) - ;; Figure out the encoding used and decode the byte-sequence - ;; into a sequence of chars. - (decode-coding-inserted-region - (point-min) (point-max) file t nil nil t) - ;; Set buffer-file-coding-system. - (after-insert-file-set-coding (buffer-size) t) - (set-buffer-modified-p nil) - (let ((buffer-file-name (expand-file-name file))) - (after-find-file)) - (setq buffer-read-only t) - (message "Retrieving revision %s... Done" rev) - (current-buffer)))))) - -;; FIXME: The user should be able to specify ancestor/head/backup and we should -;; provide sensible defaults when merge info is unavailable (rather than rely -;; on smerge-ediff). Also provide sane defaults for need-merge files. -(defun-cvs-mode cvs-mode-imerge () - "Merge interactively appropriate revisions of the selected file." - (interactive) - (let ((fi (cvs-mode-marked 'merge nil :one t :file t))) - (let ((merge (cvs-fileinfo->merge fi)) - (file (cvs-fileinfo->full-name fi)) - (backup-file (cvs-fileinfo->backup-file fi))) - (if (not (and merge backup-file)) - (let ((buf (find-file-noselect file))) - (message "Missing merge info or backup file, using VC.") - (with-current-buffer buf - (smerge-ediff))) - (let* ((ancestor-buf (cvs-retrieve-revision fi (car merge))) - (head-buf (cvs-retrieve-revision fi (cdr merge))) - (backup-buf (let ((auto-mode-alist nil)) - (find-file-noselect backup-file))) - ;; this binding is used by cvs-ediff-startup-hook - (cvs-transient-buffers (list ancestor-buf backup-buf head-buf))) - (with-current-buffer backup-buf - (let ((buffer-file-name (expand-file-name file))) - (after-find-file))) - (funcall (cdr cvs-idiff-imerge-handlers) - backup-buf head-buf ancestor-buf file)))))) - -(cvs-flags-define cvs-idiff-version - (list "BASE" cvs-vendor-branch cvs-vendor-branch "BASE" "BASE") - "version: " cvs-qtypedesc-tag) - -(defun-cvs-mode (cvs-mode-idiff . NOARGS) (&optional rev1 rev2) - "Diff interactively current file to revisions." - (interactive - (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix)) - (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix)))) - (list (or rev1 (cvs-flags-query 'cvs-idiff-version)) - rev2))) - (let ((fi (cvs-mode-marked 'diff "idiff" :one t :file t))) - (let* ((file (cvs-fileinfo->full-name fi)) - (rev1-buf (cvs-retrieve-revision fi (or rev1 "BASE"))) - (rev2-buf (if rev2 (cvs-retrieve-revision fi rev2))) - ;; this binding is used by cvs-ediff-startup-hook - (cvs-transient-buffers (list rev1-buf rev2-buf))) - (funcall (car cvs-idiff-imerge-handlers) - rev1-buf (or rev2-buf (find-file-noselect file)))))) - -(defun-cvs-mode (cvs-mode-idiff-other . NOARGS) () - "Diff interactively current file to revisions." - (interactive) - (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix)) - (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix))) - (fis (cvs-mode-marked 'diff "idiff" :file t))) - (when (> (length fis) 2) - (error "idiff-other cannot be applied to more than 2 files at a time")) - (let* ((fi1 (car fis)) - (rev1-buf (if rev1 (cvs-retrieve-revision fi1 rev1) - (find-file-noselect (cvs-fileinfo->full-name fi1)))) - rev2-buf) - (if (cdr fis) - (let ((fi2 (nth 1 fis))) - (setq rev2-buf - (if rev2 (cvs-retrieve-revision fi2 rev2) - (find-file-noselect (cvs-fileinfo->full-name fi2))))) - (error "idiff-other doesn't know what other file/buffer to use")) - (let* (;; this binding is used by cvs-ediff-startup-hook - (cvs-transient-buffers (list rev1-buf rev2-buf))) - (funcall (car cvs-idiff-imerge-handlers) - rev1-buf rev2-buf))))) - - -(defun cvs-is-within-p (fis dir) - "Non-nil if buffer is inside one of FIS (in DIR)." - (when (stringp buffer-file-name) - (setq buffer-file-name (expand-file-name buffer-file-name)) - (let (ret) - (dolist (fi (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." "")))) - (when (string-prefix-p - (expand-file-name (cvs-fileinfo->full-name fi) dir) - buffer-file-name) - (setq ret t))) - ret))) - -(cl-defun cvs-mode-run (cmd flags fis - &key (buf (cvs-temp-buffer)) - dont-change-disc cvsargs postproc) - "Generic cvs-mode- function. -Executes `cvs CVSARGS CMD FLAGS FIS'. -BUF is the buffer to be used for cvs' output. -DONT-CHANGE-DISC non-nil indicates that the command will not change the - contents of files. This is only used by the parser. -POSTPROC is a function of no argument to be evaluated at the very end (after - parsing if applicable)." - (unless postproc (setq postproc #'ignore)) - (let ((def-dir default-directory)) - ;; Save the relevant buffers - (save-some-buffers nil (lambda () (cvs-is-within-p fis def-dir)))) - (unless (listp flags) (error "Flags should be a list of strings")) - ;; Some w32 versions of CVS don't like an explicit . too much. - (when (and (car fis) (null (cdr fis)) - (eq (cvs-fileinfo->type (car fis)) 'DIRCHANGE) - ;; (equal (cvs-fileinfo->file (car fis)) ".") - (equal (cvs-fileinfo->dir (car fis)) "")) - (setq fis nil)) - (let* ((single-dir (or (not (listp cvs-execute-single-dir)) - (member cmd cvs-execute-single-dir))) - (parse (member cmd cvs-parse-known-commands)) - (args (append cvsargs (list cmd) flags)) - (after-mode (nth 2 (cdr (assoc cmd cvs-buffer-name-alist))))) - (cvs-cleanup-collection cvs-cookies ;cleanup remaining messages - (eq cvs-auto-remove-handled 'delayed) nil t) - (when (fboundp after-mode) - (setq postproc (let ((pp postproc)) - (lambda () (funcall pp) (funcall after-mode))))) - (when parse - (let ((old-fis - (when (member cmd '("status" "update")) ;FIXME: Yuck!! - ;; absence of `cvs update' output has a specific meaning. - (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." ""))))) - (pp postproc)) - (setq postproc (lambda () - (cvs-parse-process dont-change-disc nil old-fis) - (funcall pp))))) - (with-current-buffer buf - (let ((inhibit-read-only t)) (erase-buffer)) - (message "Running cvs %s ..." cmd) - (cvs-run-process args fis postproc single-dir)))) - - -(cl-defun cvs-mode-do (cmd flags filter - &key show dont-change-disc cvsargs postproc) - "Generic cvs-mode- function. -Executes `cvs CVSARGS CMD FLAGS' on the selected files. -FILTER is passed to `cvs-applicable-p' to only apply the command to - files for which it makes sense. -SHOW indicates that CMD should be not be run in the default temp buffer and - should be shown to the user. The buffer and mode to be used are determined - by `cvs-buffer-name-alist'. -DONT-CHANGE-DISC non-nil indicates that the command will not change the - contents of files. This is only used by the parser." - (cvs-mode-run cmd flags (cvs-mode-marked filter cmd) - :buf (cvs-temp-buffer (when show cmd)) - :dont-change-disc dont-change-disc - :cvsargs cvsargs - :postproc postproc)) - -(defun-cvs-mode (cvs-mode-status . SIMPLE) (flags) - "Show cvs status for all marked files. -With prefix argument, prompt for cvs flags." - (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags"))) - (cvs-mode-do "status" flags nil :dont-change-disc t :show t - :postproc (when (eq cvs-auto-remove-handled 'status) - (let ((buf (current-buffer))) - (lambda () (with-current-buffer buf - (cvs-mode-remove-handled))))))) - -(autoload 'cvs-status-cvstrees "cvs-status") - -(defun-cvs-mode (cvs-mode-tree . SIMPLE) (flags) - "Call cvstree using the file under the point as a keyfile." - (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags"))) - (cvs-mode-run "status" (cons "-v" flags) (cvs-mode-marked nil "status") - :buf (cvs-temp-buffer "tree") - :dont-change-disc t - :postproc #'cvs-status-cvstrees)) - -;; cvs log - -(defun-cvs-mode (cvs-mode-log . NOARGS) (flags) - "Display the cvs log of all selected files. -With prefix argument, prompt for cvs flags." - (interactive (list (cvs-add-branch-prefix - (cvs-flags-query 'cvs-log-flags "cvs log flags")))) - (cvs-mode-do "log" flags nil :show t)) - - -(defun-cvs-mode (cvs-mode-update . NOARGS) (flags) - "Update all marked files. -With a prefix argument, prompt for cvs flags." - (interactive - (list (cvs-add-branch-prefix - (cvs-add-secondary-branch-prefix - (cvs-flags-query 'cvs-update-flags "cvs update flags") - "-j") "-j"))) - (cvs-mode-do "update" flags 'update)) - - -(defun-cvs-mode (cvs-mode-examine . NOARGS) (flags) - "Re-examine all marked files. -With a prefix argument, prompt for cvs flags." - (interactive - (list (cvs-add-branch-prefix - (cvs-add-secondary-branch-prefix - (cvs-flags-query 'cvs-update-flags "cvs -n update flags") - "-j") "-j"))) - (cvs-mode-do "update" flags nil :cvsargs '("-n") :dont-change-disc t)) - - -(defun-cvs-mode cvs-mode-ignore () - "Arrange so that CVS ignores the selected files. -This command ignores files that are not flagged as `Unknown'." - (interactive) - (dolist (fi (cvs-mode-marked 'ignore)) - (vc-cvs-append-to-ignore (cvs-fileinfo->dir fi) (cvs-fileinfo->file fi) - (eq (cvs-fileinfo->subtype fi) 'NEW-DIR) - cvs-sort-ignore-file) - (setf (cvs-fileinfo->type fi) 'DEAD)) - (cvs-cleanup-collection cvs-cookies nil nil nil)) - -(define-obsolete-function-alias 'cvs-append-to-ignore 'vc-cvs-append-to-ignore - "24.4") - - -(defun cvs-mode-find-file-other-window (e) - "Select a buffer containing the file in another window." - (interactive (list last-input-event)) - (cvs-mode-find-file e t)) - - -(defun cvs-mode-display-file (e) - "Show a buffer containing the file in another window." - (interactive (list last-input-event)) - (cvs-mode-find-file e 'dont-select)) - - -(defun cvs-mode-view-file (e) - "View the file." - (interactive (list last-input-event)) - (cvs-mode-find-file e nil t)) - - -(defun cvs-mode-view-file-other-window (e) - "View the file in another window." - (interactive (list last-input-event)) - (cvs-mode-find-file e t t)) - - -(defun cvs-find-modif (fi) - (with-temp-buffer - (process-file cvs-program nil (current-buffer) nil - "-f" "diff" (cvs-fileinfo->file fi)) - (goto-char (point-min)) - (if (re-search-forward "^\\([0-9]+\\)" nil t) - (string-to-number (match-string 1)) - 1))) - - -(defun cvs-mode-find-file (e &optional other view) - "Select a buffer containing the file. -With a prefix, opens the buffer in an OTHER window." - (interactive (list last-input-event current-prefix-arg)) - ;; If the event moves point, check that it moves it to a valid location. - (when (and (/= (point) (progn (posn-set-point (event-end e)) (point))) - (not (memq (get-text-property (1- (line-end-position)) - 'font-lock-face) - '(cvs-header cvs-filename)))) - (error "Not a file name")) - (cvs-mode! - (lambda (&optional rev) - (interactive (list (cvs-prefix-get 'cvs-branch-prefix))) - (let* ((cvs-buf (current-buffer)) - (fi (cvs-mode-marked nil nil :one t))) - (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE) - (let ((odir default-directory)) - (setq default-directory - (cvs-expand-dir-name (cvs-fileinfo->dir fi))) - (cond ((eq other 'dont-select) - (display-buffer (find-file-noselect default-directory))) - (other (dired-other-window default-directory)) - (t (dired default-directory))) - (set-buffer cvs-buf) - (setq default-directory odir)) - (let ((buf (if rev (cvs-retrieve-revision fi rev) - (find-file-noselect (cvs-fileinfo->full-name fi))))) - (funcall (cond ((eq other 'dont-select) 'display-buffer) - (other - (if view 'view-buffer-other-window - 'switch-to-buffer-other-window)) - (t (if view 'view-buffer 'switch-to-buffer))) - buf) - (when (and cvs-find-file-and-jump (cvs-applicable-p fi 'diff-base)) - (save-restriction - (widen) - (goto-char (point-min)) - (forward-line (1- (cvs-find-modif fi))))) - buf)))))) - - -(defun-cvs-mode (cvs-mode-undo . SIMPLE) (flags) - "Undo local changes to all marked files. -The file is removed and `cvs update FILE' is run." - ;;"With prefix argument, prompt for cvs FLAGS." - (interactive (list nil));; (cvs-flags-query 'cvs-undo-flags "undo flags") - (if current-prefix-arg (call-interactively 'cvs-mode-revert-to-rev) - (let* ((fis (cvs-do-removal 'undo "update" 'all)) - (removedp (lambda (fi) - (or (eq (cvs-fileinfo->type fi) 'REMOVED) - (and (eq (cvs-fileinfo->type fi) 'CONFLICT) - (eq (cvs-fileinfo->subtype fi) 'REMOVED))))) - (fis-split (cvs-partition removedp fis)) - (fis-removed (car fis-split)) - (fis-other (cdr fis-split))) - (if (null fis-other) - (when fis-removed (cvs-mode-run "add" nil fis-removed)) - (cvs-mode-run "update" flags fis-other - :postproc - (when fis-removed - (let ((buf (current-buffer))) - (lambda () - (with-current-buffer buf - (cvs-mode-run "add" nil fis-removed)))))))))) - - -(defun-cvs-mode (cvs-mode-revert-to-rev . NOARGS) (rev) - "Revert the selected files to an old revision." - (interactive - (list (or (cvs-prefix-get 'cvs-branch-prefix) - (let ((current-prefix-arg '(4))) - (cvs-flags-query 'cvs-idiff-version))))) - (let* ((fis (cvs-mode-marked 'revert "revert" :file t)) - (tag (concat "tmp_pcl_tag_" (make-temp-name ""))) - (buf (current-buffer)) - (untag (lambda () - (with-current-buffer buf - (cvs-mode-run "tag" (list "-d" tag) fis)))) - (update (lambda () - (with-current-buffer buf - (cvs-mode-run "update" (list "-j" tag "-j" rev) fis - :postproc untag))))) - (cvs-mode-run "tag" (list tag) fis :postproc update))) - - -(defun-cvs-mode cvs-mode-delete-lock () - "Delete the lock file that CVS is waiting for. -Note that this can be dangerous. You should only do this -if you are convinced that the process that created the lock is dead." - (interactive) - (let* ((default-directory (cvs-expand-dir-name cvs-lock-file)) - (locks (directory-files default-directory nil cvs-lock-file-regexp))) - (cond - ((not locks) (error "No lock files found")) - ((yes-or-no-p (concat "Really delete locks in " cvs-lock-file "? ")) - (dolist (lock locks) - (cond ((file-directory-p lock) (delete-directory lock)) - ((file-exists-p lock) (delete-file lock)))))))) - - -(defun-cvs-mode cvs-mode-remove-handled () - "Remove all lines that are handled. -Empty directories are removed." - (interactive) - (cvs-cleanup-collection cvs-cookies - 'all (or cvs-auto-remove-directories 'handled) t)) - - -(defun-cvs-mode cvs-mode-acknowledge () - "Remove all marked files from the buffer." - (interactive) - (dolist (fi (cvs-get-marked (cvs-ignore-marks-p "acknowledge") t)) - (setf (cvs-fileinfo->type fi) 'DEAD)) - (cvs-cleanup-collection cvs-cookies nil nil nil)) - -(defun cvs-do-removal (filter &optional cmd all) - "Remove files. -Returns a list of FIS that should be `cvs remove'd." - (let* ((files (cvs-mode-marked filter cmd :file t :read-only t)) - (fis (cdr (cvs-partition (lambda (fi) - (eq (cvs-fileinfo->type fi) 'UNKNOWN)) - (cvs-mode-marked filter cmd)))) - (silent (or (not cvs-confirm-removals) - (cl-every (lambda (fi) - (or (not (file-exists-p - (cvs-fileinfo->full-name fi))) - (cvs-applicable-p fi 'safe-rm))) - files))) - (tmpbuf (cvs-temp-buffer))) - (when (and (not silent) (equal cvs-confirm-removals 'list)) - (with-current-buffer tmpbuf - (let ((inhibit-read-only t)) - (cvs-insert-strings (mapcar 'cvs-fileinfo->full-name fis)) - (cvs-pop-to-buffer-same-frame (current-buffer)) - (shrink-window-if-larger-than-buffer)))) - (if (not (or silent - (unwind-protect - (yes-or-no-p - (let ((nfiles (length files)) - (verb (if (eq filter 'undo) "Undo" "Delete"))) - (if (= 1 nfiles) - (format "%s file: \"%s\" ? " - verb - (cvs-fileinfo->file (car files))) - (format "%s %d files? " - verb - nfiles)))) - (cvs-bury-buffer tmpbuf cvs-buffer)))) - (progn (message "Aborting") nil) - (dolist (fi files) - (let* ((type (cvs-fileinfo->type fi)) - (file (cvs-fileinfo->full-name fi))) - (when (or all (eq type 'UNKNOWN)) - (when (file-exists-p file) (delete-file file)) - (unless all (setf (cvs-fileinfo->type fi) 'DEAD) t)))) - fis))) - -(defun-cvs-mode (cvs-mode-remove . SIMPLE) (flags) - "Remove all marked files. -With prefix argument, prompt for cvs flags." - (interactive (list (cvs-flags-query 'cvs-remove-flags "cvs remove flags"))) - (let ((fis (cvs-do-removal 'remove))) - (if fis (cvs-mode-run "remove" (cons "-f" flags) fis) - (cvs-cleanup-collection cvs-cookies nil nil nil)))) - - -(defvar cvs-tag-name "") -(defun-cvs-mode (cvs-mode-tag . SIMPLE) (tag &optional flags) - "Run `cvs tag TAG' on all selected files. -With prefix argument, prompt for cvs flags. -By default this can only be used on directories. -Use \\[cvs-mode-force-command] or change `cvs-force-dir-tag' if you need -to use it on individual files." - (interactive - (list (setq cvs-tag-name - (cvs-query-read cvs-tag-name "Tag name: " cvs-qtypedesc-tag)) - (cvs-flags-query 'cvs-tag-flags "tag flags"))) - (cvs-mode-do "tag" (append flags (list tag)) - (when cvs-force-dir-tag 'tag))) - -(defun-cvs-mode (cvs-mode-untag . SIMPLE) (tag &optional flags) - "Run `cvs tag -d TAG' on all selected files. -With prefix argument, prompt for cvs flags." - (interactive - (list (setq cvs-tag-name - (cvs-query-read cvs-tag-name "Tag to delete: " - cvs-qtypedesc-tag)) - (cvs-flags-query 'cvs-tag-flags "tag flags"))) - (cvs-mode-do "tag" (append '("-d") flags (list tag)) - (when cvs-force-dir-tag 'tag))) - - -;; Byte compile files. - -(defun-cvs-mode cvs-mode-byte-compile-files () - "Run byte-compile-file on all selected files with `.el' extension." - (interactive) - (let ((marked (cvs-get-marked (cvs-ignore-marks-p "byte-compile")))) - (dolist (fi marked) - (let ((filename (cvs-fileinfo->full-name fi))) - (when (string-match "\\.el\\'" filename) - (byte-compile-file filename)))))) - -;; ChangeLog support. -(defvar add-log-buffer-file-name-function) - -(defun-cvs-mode cvs-mode-add-change-log-entry-other-window () - "Add a ChangeLog entry in the ChangeLog of the current directory." - (interactive) - ;; Require `add-log' explicitly, because if it gets autoloaded when we call - ;; add-change-log-entry-other-window below, the - ;; add-log-buffer-file-name-function ends up unbound when we leave the `let'. - (require 'add-log) - (dolist (fi (cvs-mode-marked nil nil)) - (let* ((default-directory (cvs-expand-dir-name (cvs-fileinfo->dir fi))) - (add-log-buffer-file-name-function - (lambda () - (let ((file (expand-file-name (cvs-fileinfo->file fi)))) - (if (file-directory-p file) - ;; Be careful to use a directory name, otherwise add-log - ;; starts looking for a ChangeLog file in the - ;; parent dir. - (file-name-as-directory file) - file))))) - (kill-local-variable 'change-log-default-name) - (save-excursion (add-change-log-entry-other-window))))) - -;; interactive commands to set optional flags - -(defun cvs-mode-set-flags (flag) - "Ask for new setting of cvs-FLAG-flags." - (interactive - (list (completing-read - "Which flag: " - '("cvs" "diff" "update" "status" "log" "tag" ;"rtag" - "commit" "remove" "undo" "checkout") - nil t))) - (let* ((sym (intern (concat "cvs-" flag "-flags")))) - (let ((current-prefix-arg '(16))) - (cvs-flags-query sym (concat flag " flags"))))) - - -;;;; -;;;; Utilities for the *cvs* buffer -;;;; - -(defun cvs-dir-member-p (fileinfo dir) - "Return non-nil if FILEINFO represents a file in directory DIR." - (and (not (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE)) - (string-prefix-p dir (cvs-fileinfo->dir fileinfo)))) - -(defun cvs-execute-single-file (fi extractor program constant-args) - "Internal function for `cvs-execute-single-file-list'." - (let* ((arg-list (funcall extractor fi)) - (inhibit-read-only t)) - - ;; Execute the command unless extractor returned t. - (when (listp arg-list) - (let* ((args (append constant-args arg-list))) - - (insert (format "=== %s %s\n\n" - program (split-string-and-unquote args))) - - ;; FIXME: return the exit status? - (apply 'process-file program nil t t args) - (goto-char (point-max)))))) - -;; FIXME: make this run in the background ala cvs-run-process... -(defun cvs-execute-single-file-list (fis extractor program constant-args) - "Run PROGRAM on all elements on FIS. -CONSTANT-ARGS is a list of strings to pass as arguments to PROGRAM. -The arguments given to the program will be CONSTANT-ARGS followed by -the list that EXTRACTOR returns. - -EXTRACTOR will be called once for each file on FIS. It is given -one argument, the cvs-fileinfo. It can return t, which means ignore -this file, or a list of arguments to send to the program." - (dolist (fi fis) - (cvs-execute-single-file fi extractor program constant-args))) - - -(defun cvs-revert-if-needed (fis) - (dolist (fileinfo fis) - (let* ((file (cvs-fileinfo->full-name fileinfo)) - (buffer (find-buffer-visiting file))) - ;; For a revert to happen the user must be editing the file... - (unless (or (null buffer) - (memq (cvs-fileinfo->type fileinfo) '(MESSAGE UNKNOWN)) - ;; FIXME: check whether revert is really needed. - ;; `(verify-visited-file-modtime buffer)' doesn't cut it - ;; because it only looks at the time stamp (it ignores - ;; read-write changes) which is not changed by `commit'. - (buffer-modified-p buffer)) - (with-current-buffer buffer - (ignore-errors - (revert-buffer 'ignore-auto 'dont-ask 'preserve-modes) - ;; `preserve-modes' avoids changing the (minor) modes. But we - ;; do want to reset the mode for VC, so we do it explicitly. - (vc-refresh-state) - (when (eq (cvs-fileinfo->type fileinfo) 'CONFLICT) - (smerge-start-session)))))))) - - -(defun cvs-change-cvsroot (newroot) - "Change the CVSROOT to NEWROOT." - (interactive "DNew repository: ") - (if (or (file-directory-p (expand-file-name "CVSROOT" newroot)) - (y-or-n-p (concat "Warning: no CVSROOT found inside repository." - " Change cvs-cvsroot anyhow? "))) - (setq cvs-cvsroot newroot))) - -;;;; -;;;; useful global settings -;;;; - -;; -;; Hook to allow calling PCL-CVS by visiting the /CVS subdirectory -;; - -;;;###autoload -(defcustom cvs-dired-action 'cvs-quickdir - "The action to be performed when opening a CVS directory. -Sensible values are `cvs-examine', `cvs-status' and `cvs-quickdir'." - :group 'pcl-cvs - :type '(choice (const cvs-examine) (const cvs-status) (const cvs-quickdir))) - -;;;###autoload -(defcustom cvs-dired-use-hook '(4) - "Whether or not opening a CVS directory should run PCL-CVS. -A value of nil means never do it. -`always' means to always do it unless a prefix argument is given to the - command that prompted the opening of the directory. -Anything else means to do it only if the prefix arg is equal to this value." - :group 'pcl-cvs - :type '(choice (const :tag "Never" nil) - (const :tag "Always" always) - (const :tag "Prefix" (4)))) - -;;;###autoload -(progn (defun cvs-dired-noselect (dir) - "Run `cvs-examine' if DIR is a CVS administrative directory. -The exact behavior is determined also by `cvs-dired-use-hook'." - (when (stringp dir) - (setq dir (directory-file-name dir)) - (when (and (string= "CVS" (file-name-nondirectory dir)) - (file-readable-p (expand-file-name "Entries" dir)) - cvs-dired-use-hook - (if (eq cvs-dired-use-hook 'always) - (not current-prefix-arg) - (equal current-prefix-arg cvs-dired-use-hook))) - (save-excursion - (funcall cvs-dired-action (file-name-directory dir) t t)))))) - -;; -;; hook into VC -;; - -(add-hook 'vc-post-command-functions 'cvs-vc-command-advice) - -(defun cvs-vc-command-advice (command files flags) - (when (and (equal command "cvs") - (progn - (while (and (stringp (car flags)) - (string-match "\\`-" (car flags))) - (pop flags)) - ;; don't parse output we don't understand. - (member (car flags) cvs-parse-known-commands)) - ;; Don't parse "update -p" output. - (not (and (member (car flags) '("update" "checkout")) - (let ((found-p nil)) - (dolist (flag flags found-p) - (if (equal flag "-p") (setq found-p t))))))) - (save-current-buffer - (let ((buffer (current-buffer)) - (dir default-directory) - (cvs-from-vc t)) - (dolist (cvs-buf (buffer-list)) - (set-buffer cvs-buf) - ;; look for a corresponding pcl-cvs buffer - (when (and (eq major-mode 'cvs-mode) - (string-prefix-p default-directory dir)) - (let ((subdir (substring dir (length default-directory)))) - (set-buffer buffer) - (setq-local cvs-buffer cvs-buf) - ;; `cvs -q add file' produces no useful output :-( - (when (and (equal (car flags) "add") - (goto-char (point-min)) - (looking-at ".*to add this file permanently\n\\'")) - (dolist (file (if (listp files) files (list files))) - (insert (format-message - "cvs add: scheduling file `%s' for addition\n" - (file-name-nondirectory file))))) - ;; VC never (?) does `cvs -n update' so dcd=nil - ;; should probably always be the right choice. - (cvs-parse-process nil subdir)))))))) - -;; -;; Hook into write-buffer -;; - -(defun cvs-mark-buffer-changed () - (let* ((file (expand-file-name buffer-file-name)) - (version (and (fboundp 'vc-backend) - (eq (vc-backend file) 'CVS) - (vc-working-revision file)))) - (when version - (save-excursion - (dolist (cvs-buf (buffer-list)) - (set-buffer cvs-buf) - ;; look for a corresponding pcl-cvs buffer - (when (and (eq major-mode 'cvs-mode) - (string-prefix-p default-directory file)) - (let* ((file (substring file (length default-directory))) - (fi (cvs-create-fileinfo - (if (string= "0" version) - 'ADDED 'MODIFIED) - (or (file-name-directory file) "") - (file-name-nondirectory file) - "cvs-mark-buffer-changed"))) - (cvs-addto-collection cvs-cookies fi)))))))) - -(add-hook 'after-save-hook 'cvs-mark-buffer-changed) - -(defun cvs-insert-visited-file () - (let* ((file (expand-file-name buffer-file-name)) - (version (and (fboundp 'vc-backend) - (eq (vc-backend file) 'CVS) - (vc-working-revision file)))) - (when version - (save-current-buffer - (dolist (cvs-buf (buffer-list)) - (set-buffer cvs-buf) - ;; look for a corresponding pcl-cvs buffer - (when (and (eq major-mode 'cvs-mode) - (string-prefix-p default-directory file)) - (cvs-insert-file file))))))) - -(add-hook 'find-file-hook 'cvs-insert-visited-file 'append) - -(provide 'pcvs) - -;;; pcvs.el ends here -- 2.39.5