-;;; pcvs.el --- a front-end to CVS
+;;; pcvs.el --- a front-end to CVS -*- lexical-binding:t -*-
-;; Copyright (C) 1991-2012 Free Software Foundation, Inc.
+;; Copyright (C) 1991-2014 Free Software Foundation, Inc.
;; Author: (The PCL-CVS Trust) pcl-cvs@cyclic.com
;; (Per Cederqvist) ceder@lysator.liu.se
;; - rework the displaying of error messages.
;; - allow to flush messages only
;; - allow to protect files like ChangeLog from flushing
-;; - automatically cvs-mode-insert files from find-file-hook
-;; (and don't flush them as long as they are visited)
;; - 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.
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'ewoc) ;Ewoc was once cookie
(require 'pcvs-defs)
(require 'pcvs-util)
(require 'pcvs-parse)
(require 'pcvs-info)
+(require 'vc-cvs)
\f
;;;;
(autoload 'cvs-status-get-tags "cvs-status")
(defun cvs-tags-list ()
"Return a list of acceptable tags, ready for completions."
- (assert (cvs-buffer-p))
+ (cl-assert (cvs-buffer-p))
(let ((marked (cvs-get-marked)))
- (list* '("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)))))))
+ `(("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
from the current buffer."
(let* ((cvs-buf (current-buffer))
(info (cdr (assoc cmd cvs-buffer-name-alist)))
- (name (eval (nth 0 info)))
+ (name (eval (nth 0 info) `((cmd . ,cmd))))
(mode (nth 1 info))
(dir default-directory)
(buf (cond
(t
(set (make-local-variable 'cvs-temp-buffer)
(cvs-get-buffer-create
- (eval cvs-temp-buffer-name) 'noreuse))))))
+ (eval cvs-temp-buffer-name `((dir . ,dir)))
+ 'noreuse))))))
- ;; handle the potential pre-existing process
+ ;; 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 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))
+ (let* ((buffer-name (eval cvs-buffer-name `((dir . ,dir))))
(buffer
(or (and (not new)
(eq cvs-reuse-cvs-buffer 'current)
;; look for another cvs buffer visiting the same directory
(save-excursion
(unless new
- (dolist (buffer (cons (current-buffer) (buffer-list)))
+ (cl-dolist (buffer (cons (current-buffer) (buffer-list)))
(set-buffer buffer)
(and (cvs-buffer-p)
- (case cvs-reuse-cvs-buffer
- (always t)
- (subdir
+ (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)))
- (return buffer)))))
+ (`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
;;(set-buffer buf)
buffer))))))
-(defun* cvs-cmd-do (cmd dir flags fis new
+(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))))
(defun cvs-run-process (args fis postprocess &optional single-dir)
- (assert (cvs-buffer-p cvs-buffer))
+ (cl-assert (cvs-buffer-p cvs-buffer))
(save-current-buffer
(let ((procbuf (current-buffer))
(cvsbuf cvs-buffer)
(let ((inhibit-read-only t))
(insert "pcl-cvs: descending directory " dir "\n"))
;; loop to find the same-dir-elems
- (do* ((files () (cons (cvs-fileinfo->file fi) files))
- (fis fis (cdr fis))
- (fi (car fis) (car fis)))
+ (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))
process 'cvs-postprocess
(if (null rest)
;; this is the last invocation
- postprocess
+ postprocess
;; else, we have to register ourselves to be rerun on the rest
- `(cvs-run-process ',args ',rest ',postprocess ',single-dir)))
+ (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))
done))))
-(defun cvs-sentinel (proc msg)
+(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."
(error "cvs' process buffer was killed")
(with-current-buffer procbuf
;; Do the postprocessing like parsing and such.
- (save-excursion (eval cvs-postproc)))))))
+ (save-excursion
+ (funcall cvs-postproc)))))))
;; Check whether something is left.
(when (and procbuf (not (get-buffer-process procbuf)))
(with-current-buffer procbuf
- 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))
+ (declare (debug (&define sexp lambda-list stringp
+ ("interactive" interactive) def-body))
(doc-string 3))
(let ((style (cvs-cdr fun))
(fun (cvs-car fun)))
(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
- (assert (not (cvs-fileinfo< fi (ewoc-data tin))))
+ (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))))
(defun cvs-cleanup-collection (c rm-handled rm-dirs rm-msgs)
"Remove undesired entries.
C is the collection
-RM-HANDLED if non-nil means remove handled entries.
+RM-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))
(let* ((type (cvs-fileinfo->type fi))
(subtype (cvs-fileinfo->subtype fi))
(keep
- (case type
- ;; remove temp messages and keep the others
- (MESSAGE (not (or rm-msgs (eq subtype 'TEMP))))
- ;; remove entries
- (DEAD nil)
- ;; handled also?
- (UP-TO-DATE (not rm-handled))
- ;; keep the rest
- (t (not (run-hook-with-args-until-success
+ (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
;;;;
(defun-cvs-mode (cvs-mode-revert-buffer . SIMPLE)
- (&optional ignore-auto noconfirm)
+ (&optional _ignore-auto _noconfirm)
"Rerun `cvs-examine' on the current directory with the default flags."
(interactive)
(cvs-examine default-directory t))
(read-directory-name prompt nil default-directory nil)))
;;;###autoload
-(defun cvs-quickdir (dir &optional flags noshow)
+(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]),
fis))))
(nreverse fis)))
-(defun* cvs-mode-marked (filter &optional cmd
+(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.
(set (make-local-variable 'cvs-minor-wrap-function) 'cvs-commit-minor-wrap)
(run-hooks 'cvs-mode-commit-hook)))
-(defun cvs-commit-minor-wrap (buf f)
+(defun cvs-commit-minor-wrap (_buf f)
(let ((cvs-ignore-marks-modif (cvs-mode-mark-get-modif "commit")))
(funcall f)))
(let ((msg (buffer-substring-no-properties (point-min) (point-max))))
(cvs-mode!)
;;(pop-to-buffer cvs-buffer)
- (cvs-mode-do "commit" (list* "-m" msg flags) 'commit)))
+ (cvs-mode-do "commit" `("-m" ,msg ,@flags) 'commit)))
;;;; Editing existing commit log messages.
(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
+ ;; 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
+ ;; Prompt for description if necessary.
(let* ((msg (if (and needdesc
(or current-prefix-arg (not cvs-add-default-message)))
(read-from-minibuffer "Enter description: ")
(or cvs-add-default-message "")))
- (flags (list* "-m" msg flags))
+ (flags `("-m" ,msg ,@flags))
(postproc
- ;; setup postprocessing for the directory entries
+ ;; Setup postprocessing for the directory entries.
(when dirs
- `((cvs-run-process (list "-n" "update")
- ',dirs
- '(cvs-parse-process t))
- (cvs-mark-fis-dead ',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."
+revision which they are based upon.
+See also `cvs-diff-ignore-marks'."
(interactive
(list (cvs-add-branch-prefix
(cvs-add-secondary-branch-prefix
(fis (car (cvs-partition 'cvs-fileinfo->backup-file marked))))
(unless (consp fis)
(error "No files with a backup file selected!"))
- ;; let's extract some info into the environment for `buffer-name'
- (let* ((dir (cvs-fileinfo->dir (car fis)))
- (file (cvs-fileinfo->file (car fis))))
- (set-buffer (cvs-temp-buffer "diff")))
+ (set-buffer (cvs-temp-buffer "diff"))
(message "cvs diff backup...")
(cvs-execute-single-file-list fis 'cvs-diff-backup-extractor
cvs-diff-program flags))
(set-buffer-modified-p nil)
(let ((buffer-file-name (expand-file-name file)))
(after-find-file))
- (toggle-read-only 1)
+ (setq buffer-read-only t)
(message "Retrieving revision %s... Done" rev)
(current-buffer))))))
(setq ret t)))
ret)))
-(defun* cvs-mode-run (cmd flags fis
- &key (buf (cvs-temp-buffer))
- dont-change-disc cvsargs postproc)
+(cl-defun cvs-mode-run (cmd flags fis
+ &key (buf (cvs-temp-buffer))
+ dont-change-disc cvsargs postproc)
"Generic cvs-mode-<foo> function.
Executes `cvs CVSARGS CMD FLAGS FIS'.
BUF is the buffer to be used for cvs' output.
DONT-CHANGE-DISC non-nil indicates that the command will not change the
contents of files. This is only used by the parser.
-POSTPROC is a list of expressions to be evaluated at the very end (after
- parsing if applicable). It will be prepended with `progn' if necessary."
+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))))
(cvs-cleanup-collection cvs-cookies ;cleanup remaining messages
(eq cvs-auto-remove-handled 'delayed) nil t)
(when (fboundp after-mode)
- (setq postproc (append postproc `((,after-mode)))))
+ (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 "" "." ""))))))
- (push `(cvs-parse-process ',dont-change-disc nil ',old-fis) postproc)))
- (setq postproc (if (cdr postproc) (cons 'progn postproc) (car postproc)))
+ (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))))
-(defun* cvs-mode-do (cmd flags filter
- &key show dont-change-disc cvsargs postproc)
+(cl-defun cvs-mode-do (cmd flags filter
+ &key show dont-change-disc cvsargs postproc)
"Generic cvs-mode-<foo> function.
Executes `cvs CVSARGS CMD FLAGS' on the selected files.
FILTER is passed to `cvs-applicable-p' to only apply the command to
(interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags")))
(cvs-mode-do "status" flags nil :dont-change-disc t :show t
:postproc (when (eq cvs-auto-remove-handled 'status)
- `((with-current-buffer ,(current-buffer)
- (cvs-mode-remove-handled))))))
+ (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."
(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))))
+ :postproc #'cvs-status-cvstrees))
;; cvs log
(cvs-mode-do "update" flags nil :cvsargs '("-n") :dont-change-disc t))
-(defun-cvs-mode cvs-mode-ignore (&optional pattern)
+(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))
- (cvs-append-to-ignore (cvs-fileinfo->dir fi) (cvs-fileinfo->file fi)
+ (vc-cvs-append-to-ignore (cvs-fileinfo->dir fi) (cvs-fileinfo->file fi)
(eq (cvs-fileinfo->subtype fi) 'NEW-DIR))
(setf (cvs-fileinfo->type fi) 'DEAD))
(cvs-cleanup-collection cvs-cookies nil nil nil))
(declare-function vc-editable-p "vc" (file))
(declare-function vc-checkout "vc" (file &optional writable rev))
-(defun cvs-append-to-ignore (dir str &optional old-dir)
- "Add STR to the .cvsignore file in DIR.
-If OLD-DIR is non-nil, then this is a directory that we don't want
-to hear about anymore."
- (with-current-buffer
- (find-file-noselect (expand-file-name ".cvsignore" dir))
- (when (ignore-errors
- (and buffer-read-only
- (eq 'CVS (vc-backend buffer-file-name))
- (not (vc-editable-p buffer-file-name))))
- ;; CVSREAD=on special case
- (vc-checkout buffer-file-name t))
- (goto-char (point-max))
- (unless (bolp) (insert "\n"))
- (insert str (if old-dir "/\n" "\n"))
- (if cvs-sort-ignore-file (sort-lines nil (point-min) (point-max)))
- (save-buffer)))
-
-
(defun cvs-mode-find-file-other-window (e)
"Select a buffer containing the file in another window."
(interactive (list last-input-event))
(cvs-mode-run "update" flags fis-other
:postproc
(when fis-removed
- `((with-current-buffer ,(current-buffer)
- (cvs-mode-run "add" nil ',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)
(cvs-flags-query 'cvs-idiff-version)))))
(let* ((fis (cvs-mode-marked 'revert "revert" :file t))
(tag (concat "tmp_pcl_tag_" (make-temp-name "")))
- (untag `((with-current-buffer ,(current-buffer)
- (cvs-mode-run "tag" (list "-d" ',tag) ',fis))))
- (update `((with-current-buffer ,(current-buffer)
- (cvs-mode-run "update" (list "-j" ',tag "-j" ',rev) ',fis
- :postproc ',untag)))))
+ (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)))
Empty directories are removed."
(interactive)
(cvs-cleanup-collection cvs-cookies
- t (or cvs-auto-remove-directories 'handled) t))
+ 'all (or cvs-auto-remove-directories 'handled) t))
(defun-cvs-mode cvs-mode-acknowledge ()
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-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-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."
(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)
\f
(provide 'pcvs)