1 |
;;; pcvs.el --- a front-end to CVS |
;;; pcvs.el --- a front-end to CVS |
2 |
|
|
3 |
;; Copyright (C) 1991,92,93,94,95,95,97,98,99,2000 Free Software Foundation, Inc. |
;; Copyright (C) 1991,92,93,94,95,95,97,98,99,2000,2002 |
4 |
|
;; Free Software Foundation, Inc. |
5 |
|
|
6 |
;; Author: (The PCL-CVS Trust) pcl-cvs@cyclic.com |
;; Author: (The PCL-CVS Trust) pcl-cvs@cyclic.com |
7 |
;; (Per Cederqvist) ceder@lysator.liu.se |
;; (Per Cederqvist) ceder@lysator.liu.se |
60 |
;;; Todo: |
;;; Todo: |
61 |
|
|
62 |
;; ******** FIX THE DOCUMENTATION ********* |
;; ******** FIX THE DOCUMENTATION ********* |
63 |
;; |
;; |
64 |
;; - rework the displaying of error messages. |
;; - rework the displaying of error messages. |
|
;; - use UP-TO-DATE rather than DEAD when cleaning before `examine'. |
|
65 |
;; - allow to flush messages only |
;; - allow to flush messages only |
66 |
;; - allow to protect files like ChangeLog from flushing |
;; - allow to protect files like ChangeLog from flushing |
67 |
;; - automatically cvs-mode-insert files from find-file-hook |
;; - automatically cvs-mode-insert files from find-file-hook |
72 |
;; - allow cvs-confirm-removals to force always confirmation. |
;; - allow cvs-confirm-removals to force always confirmation. |
73 |
;; - cvs-checkout should ask for a revision (with completion). |
;; - cvs-checkout should ask for a revision (with completion). |
74 |
;; - removal confirmation should allow specifying another file name. |
;; - removal confirmation should allow specifying another file name. |
75 |
;; |
;; |
76 |
;; - hide fileinfos without getting rid of them (will require ewok work). |
;; - hide fileinfos without getting rid of them (will require ewok work). |
77 |
;; - add toolbar entries |
;; - add toolbar entries |
78 |
;; - marking |
;; - marking |
243 |
|
|
244 |
;;;; |
;;;; |
245 |
|
|
246 |
(defun cvs-mode! (&optional -cvs-mode!-fun -cvs-mode!-noerror) |
(defun cvs-mode! (&optional -cvs-mode!-fun) |
247 |
"Switch to the *cvs* buffer. |
"Switch to the *cvs* buffer. |
248 |
If -CVS-MODE!-FUN is provided, it is executed *cvs* being the current buffer |
If -CVS-MODE!-FUN is provided, it is executed *cvs* being the current buffer |
249 |
and with its window selected. Else, the *cvs* buffer is simply selected. |
and with its window selected. Else, the *cvs* buffer is simply selected. |
|
If -CVS-MODE!-NOERROR is non-nil, then failure to find a *cvs* buffer does |
|
|
not generate an error and the current buffer is kept selected. |
|
250 |
-CVS-MODE!-FUN is called interactively if applicable and else with no argument." |
-CVS-MODE!-FUN is called interactively if applicable and else with no argument." |
251 |
(let* ((-cvs-mode!-buf (current-buffer)) |
(let* ((-cvs-mode!-buf (current-buffer)) |
252 |
(cvsbuf (cond ((cvs-buffer-p) (current-buffer)) |
(cvsbuf (cond ((cvs-buffer-p) (current-buffer)) |
253 |
((and cvs-buffer (cvs-buffer-p cvs-buffer)) cvs-buffer) |
((and cvs-buffer (cvs-buffer-p cvs-buffer)) cvs-buffer) |
|
(-cvs-mode!-noerror (current-buffer)) |
|
254 |
(t (error "can't find the *cvs* buffer")))) |
(t (error "can't find the *cvs* buffer")))) |
255 |
(-cvs-mode!-wrapper cvs-minor-wrap-function) |
(-cvs-mode!-wrapper cvs-minor-wrap-function) |
256 |
(-cvs-mode!-cont (lambda () |
(-cvs-mode!-cont (lambda () |
335 |
"This mode is used for buffers related to a main *cvs* buffer. |
"This mode is used for buffers related to a main *cvs* buffer. |
336 |
All the `cvs-mode' buffer operations are simply rebound under |
All the `cvs-mode' buffer operations are simply rebound under |
337 |
the \\[cvs-mode-map] prefix." |
the \\[cvs-mode-map] prefix." |
338 |
nil " CVS") |
nil " CVS" |
339 |
|
:group 'pcl-cvs) |
340 |
(put 'cvs-minor-mode 'permanent-local t) |
(put 'cvs-minor-mode 'permanent-local t) |
341 |
|
|
342 |
|
|
535 |
(if cvs-cvsroot (list "-d" cvs-cvsroot)) |
(if cvs-cvsroot (list "-d" cvs-cvsroot)) |
536 |
args |
args |
537 |
files)) |
files)) |
538 |
(process-connection-type nil) ; Use a pipe, not a pty. |
;; If process-connection-type is nil and the repository |
539 |
|
;; is accessed via SSH, a bad interaction between libc, |
540 |
|
;; CVS and SSH can lead to garbled output. |
541 |
|
;; It might be a glibc-specific problem (but it also happens |
542 |
|
;; under Mac OS X, it seems). |
543 |
|
;; Until the problem is cleared, we'll use a pty rather than |
544 |
|
;; a pipe. |
545 |
|
;; (process-connection-type nil) ; Use a pipe, not a pty. |
546 |
(process |
(process |
547 |
;; the process will be run in the selected dir |
;; the process will be run in the selected dir |
548 |
(let ((default-directory (cvs-expand-dir-name dir))) |
(let ((default-directory (cvs-expand-dir-name dir))) |
563 |
|
|
564 |
(defun cvs-update-header (args fis) ; inline |
(defun cvs-update-header (args fis) ; inline |
565 |
(let* ((lastarg nil) |
(let* ((lastarg nil) |
|
;; filter out the largish commit message |
|
566 |
(args (mapcar (lambda (arg) |
(args (mapcar (lambda (arg) |
567 |
(cond |
(cond |
568 |
|
;; filter out the largish commit message |
569 |
((and (eq lastarg nil) (string= arg "commit")) |
((and (eq lastarg nil) (string= arg "commit")) |
570 |
(setq lastarg 'commit) arg) |
(setq lastarg 'commit) arg) |
571 |
((and (eq lastarg 'commit) (string= arg "-m")) |
((and (eq lastarg 'commit) (string= arg "-m")) |
572 |
(setq lastarg '-m) arg) |
(setq lastarg '-m) arg) |
573 |
((eq lastarg '-m) |
((eq lastarg '-m) |
574 |
(setq lastarg 'done) "<log message>") |
(setq lastarg 'done) "<log message>") |
575 |
|
;; filter out the largish `admin -mrev:msg' message |
576 |
|
((and (eq lastarg nil) (string= arg "admin")) |
577 |
|
(setq lastarg 'admin) arg) |
578 |
|
((and (eq lastarg 'admin) |
579 |
|
(string-match "\\`-m[^:]*:" arg)) |
580 |
|
(setq lastarg 'done) |
581 |
|
(concat (match-string 0 arg) "<log message>")) |
582 |
|
;; Keep the rest as is. |
583 |
(t arg))) |
(t arg))) |
584 |
args)) |
args)) |
585 |
;; turn them into a string |
;; turn them into a string |
639 |
(save-excursion (eval cvs-postproc)) |
(save-excursion (eval cvs-postproc)) |
640 |
;; check whether something is left |
;; check whether something is left |
641 |
(unless cvs-postprocess |
(unless cvs-postprocess |
642 |
|
;; IIRC, we enable undo again once the process is finished |
643 |
|
;; for cases where the output was inserted in *vc-diff* or |
644 |
|
;; in a file-like buffer. -stef |
645 |
(buffer-enable-undo) |
(buffer-enable-undo) |
646 |
(with-current-buffer cvs-buffer |
(with-current-buffer cvs-buffer |
647 |
(cvs-update-header nil nil) ;FIXME: might need to be inline |
(cvs-update-header nil nil) ;FIXME: might need to be inline |
648 |
(message "CVS process has completed")))) |
(message "CVS process has completed in %s" (buffer-name))))) |
649 |
;; This might not even be necessary |
;; This might not even be necessary |
650 |
(set-buffer obuf))))) |
(set-buffer obuf))))) |
651 |
|
|
652 |
(defun cvs-parse-process (dcd &optional subdir) |
(defun cvs-parse-process (dcd &optional subdir old-fis) |
653 |
"FIXME: bad name, no doc." |
"Parse the output of a cvs process. |
654 |
(let* ((from-buf (current-buffer)) |
DCD is the `dont-change-disc' flag to use when parsing that output. |
655 |
(fileinfos (cvs-parse-buffer 'cvs-parse-table dcd subdir)) |
SUBDIR is the subdirectory (if any) where this command was run. |
656 |
(_ (set-buffer cvs-buffer)) |
OLD-FIS is the list of fileinfos on which the cvs command was applied and |
657 |
last |
which should be considered up-to-date if they are missing from the output." |
658 |
(from-pt (point))) |
(let* ((fileinfos (cvs-parse-buffer 'cvs-parse-table dcd subdir)) |
659 |
;; add the new fileinfos |
last) |
660 |
(dolist (fi fileinfos) |
(with-current-buffer cvs-buffer |
661 |
(setq last (cvs-addto-collection cvs-cookies fi last))) |
;; Expand OLD-FIS to actual files. |
662 |
(cvs-cleanup-collection cvs-cookies |
(let ((fis nil)) |
663 |
(eq cvs-auto-remove-handled t) |
(dolist (fi old-fis) |
664 |
cvs-auto-remove-directories |
(setq fis (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE) |
665 |
nil) |
(nconc (ewoc-collect cvs-cookies 'cvs-dir-member-p |
666 |
;; update the display (might be unnecessary) |
(cvs-fileinfo->dir fi)) |
667 |
;;(ewoc-refresh cvs-cookies) |
fis) |
668 |
;; revert buffers if necessary |
(cons fi fis)))) |
669 |
(when (and cvs-auto-revert (not dcd) (not cvs-from-vc)) |
(setq old-fis fis)) |
670 |
(cvs-revert-if-needed fileinfos)) |
;; Drop OLD-FIS which were already up-to-date. |
671 |
;; get back to where we were. `save-excursion' doesn't seem to |
(let ((fis nil)) |
672 |
;; work in this case, probably because the buffer is reconstructed |
(dolist (fi old-fis) |
673 |
;; by the cookie code. |
(unless (eq (cvs-fileinfo->type fi) 'UP-TO-DATE) (push fi fis))) |
674 |
(goto-char from-pt) |
(setq old-fis fis)) |
675 |
(set-buffer from-buf))) |
;; Add the new fileinfos to the ewoc. |
676 |
|
(dolist (fi fileinfos) |
677 |
|
(setq last (cvs-addto-collection cvs-cookies fi last)) |
678 |
|
;; This FI was in the output, so remove it from OLD-FIS. |
679 |
|
(setq old-fis (delq (ewoc-data last) old-fis))) |
680 |
|
;; Process the "silent output" (i.e. absence means up-to-date). |
681 |
|
(dolist (fi old-fis) |
682 |
|
(setf (cvs-fileinfo->type fi) 'UP-TO-DATE) |
683 |
|
(setq last (cvs-addto-collection cvs-cookies fi last))) |
684 |
|
(setq fileinfos (nconc old-fis fileinfos)) |
685 |
|
;; Clean up the ewoc as requested by the user. |
686 |
|
(cvs-cleanup-collection cvs-cookies |
687 |
|
(eq cvs-auto-remove-handled t) |
688 |
|
cvs-auto-remove-directories |
689 |
|
nil) |
690 |
|
;; Revert buffers if necessary. |
691 |
|
(when (and cvs-auto-revert (not dcd) (not cvs-from-vc)) |
692 |
|
(cvs-revert-if-needed fileinfos))))) |
693 |
|
|
694 |
(defmacro defun-cvs-mode (fun args docstring interact &rest body) |
(defmacro defun-cvs-mode (fun args docstring interact &rest body) |
695 |
"Define a function to be used in a *cvs* buffer. |
"Define a function to be used in a *cvs* buffer. |
709 |
- NOARGS will get all the arguments from the *cvs* buffer and will |
- NOARGS will get all the arguments from the *cvs* buffer and will |
710 |
always behave as if called interactively. |
always behave as if called interactively. |
711 |
- DOUBLE is the generic case." |
- DOUBLE is the generic case." |
712 |
|
(declare (debug (&define sexp lambda-list stringp ("interactive" interactive) def-body))) |
713 |
(let ((style (cvs-cdr fun)) |
(let ((style (cvs-cdr fun)) |
714 |
(fun (cvs-car fun))) |
(fun (cvs-car fun))) |
715 |
(cond |
(cond |
744 |
(cvs-mode! ',fun-1))))) |
(cvs-mode! ',fun-1))))) |
745 |
|
|
746 |
(t (error "unknown style %s in `defun-cvs-mode'" style))))) |
(t (error "unknown style %s in `defun-cvs-mode'" style))))) |
|
(def-edebug-spec defun-cvs-mode (&define sexp lambda-list stringp ("interactive" interactive) def-body)) |
|
747 |
|
|
748 |
(defun-cvs-mode cvs-mode-kill-process () |
(defun-cvs-mode cvs-mode-kill-process () |
749 |
"Kill the temporary buffer and associated process." |
"Kill the temporary buffer and associated process." |
777 |
;; fi == tin |
;; fi == tin |
778 |
(cvs-fileinfo-update (ewoc-data tin) fi) |
(cvs-fileinfo-update (ewoc-data tin) fi) |
779 |
(ewoc-invalidate c tin) |
(ewoc-invalidate c tin) |
780 |
|
;; Move cursor back to where it belongs. |
781 |
|
(when (bolp) (cvs-move-to-goal-column)) |
782 |
tin)))) |
tin)))) |
783 |
|
|
784 |
(defcustom cvs-cleanup-functions nil |
(defcustom cvs-cleanup-functions nil |
892 |
With a prefix argument, prompt for cvs FLAGS to use." |
With a prefix argument, prompt for cvs FLAGS to use." |
893 |
(interactive |
(interactive |
894 |
(list (cvs-string->strings (read-string "Module(s): " (cvs-get-module))) |
(list (cvs-string->strings (read-string "Module(s): " (cvs-get-module))) |
895 |
(read-file-name "CVS Checkout Directory: " |
(read-directory-name "CVS Checkout Directory: " |
896 |
nil default-directory nil) |
nil default-directory nil) |
897 |
(cvs-add-branch-prefix |
(cvs-add-branch-prefix |
898 |
(cvs-flags-query 'cvs-checkout-flags "cvs checkout flags")))) |
(cvs-flags-query 'cvs-checkout-flags "cvs checkout flags")))) |
919 |
(not current-prefix-arg) |
(not current-prefix-arg) |
920 |
(not (eq last-command-char ?\r))) |
(not (eq last-command-char ?\r))) |
921 |
default-directory |
default-directory |
922 |
(read-file-name msg nil default-directory nil))) |
(read-directory-name msg nil default-directory nil))) |
923 |
|
|
924 |
;;;###autoload |
;;;###autoload |
925 |
(defun cvs-quickdir (dir &optional flags noshow) |
(defun cvs-quickdir (dir &optional flags noshow) |
975 |
(defun cvs-update (directory flags) |
(defun cvs-update (directory flags) |
976 |
"Run a `cvs update' in the current working DIRECTORY. |
"Run a `cvs update' in the current working DIRECTORY. |
977 |
Feed the output to a *cvs* buffer and run `cvs-mode' on it. |
Feed the output to a *cvs* buffer and run `cvs-mode' on it. |
978 |
With a prefix argument, prompt for a directory and cvs FLAGS to use. |
With a \\[universal-argument] prefix argument, prompt for a directory to use. |
979 |
A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), |
A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), |
980 |
prevents reuse of an existing *cvs* buffer." |
prevents reuse of an existing *cvs* buffer. |
981 |
|
The prefix is also passed to `cvs-flags-query' to select the FLAGS |
982 |
|
passed to cvs." |
983 |
(interactive (list (cvs-query-directory "CVS Update (directory): ") |
(interactive (list (cvs-query-directory "CVS Update (directory): ") |
984 |
(cvs-flags-query 'cvs-update-flags "cvs update flags"))) |
(cvs-flags-query 'cvs-update-flags "cvs update flags"))) |
985 |
(when (eq flags t) |
(when (eq flags t) |
1067 |
("" cvs-branch-prefix (cvs-secondary-branch-prefix |
("" cvs-branch-prefix (cvs-secondary-branch-prefix |
1068 |
("->" cvs-secondary-branch-prefix)))) |
("->" cvs-secondary-branch-prefix)))) |
1069 |
" " cvs-mode-line-process)) |
" " cvs-mode-line-process)) |
1070 |
(buffer-disable-undo (current-buffer)) |
(buffer-disable-undo) |
1071 |
;;(set (make-local-variable 'goal-column) cvs-cursor-column) |
;;(set (make-local-variable 'goal-column) cvs-cursor-column) |
1072 |
(set (make-local-variable 'revert-buffer-function) 'cvs-mode-revert-buffer) |
(set (make-local-variable 'revert-buffer-function) 'cvs-mode-revert-buffer) |
1073 |
(setq truncate-lines t) |
(setq truncate-lines t) |
1123 |
|
|
1124 |
;; Move around in the buffer |
;; Move around in the buffer |
1125 |
|
|
1126 |
|
(defun cvs-move-to-goal-column () |
1127 |
|
(let* ((eol (line-end-position)) |
1128 |
|
(fpos (next-single-property-change (point) 'cvs-goal-column nil eol))) |
1129 |
|
(when (< fpos eol) |
1130 |
|
(goto-char fpos)))) |
1131 |
|
|
1132 |
(defun-cvs-mode cvs-mode-previous-line (arg) |
(defun-cvs-mode cvs-mode-previous-line (arg) |
1133 |
"Go to the previous line. |
"Go to the previous line. |
1134 |
If a prefix argument is given, move by that many lines." |
If a prefix argument is given, move by that many lines." |
1135 |
(interactive "p") |
(interactive "p") |
1136 |
(ewoc-goto-prev cvs-cookies arg) |
(ewoc-goto-prev cvs-cookies arg) |
1137 |
(let ((fpos (next-single-property-change |
(cvs-move-to-goal-column)) |
|
(point) 'cvs-goal-column |
|
|
(current-buffer) (line-end-position))) |
|
|
(eol (line-end-position))) |
|
|
(when (< fpos eol) |
|
|
(goto-char fpos)))) |
|
1138 |
|
|
1139 |
(defun-cvs-mode cvs-mode-next-line (arg) |
(defun-cvs-mode cvs-mode-next-line (arg) |
1140 |
"Go to the next line. |
"Go to the next line. |
1141 |
If a prefix argument is given, move by that many lines." |
If a prefix argument is given, move by that many lines." |
1142 |
(interactive "p") |
(interactive "p") |
1143 |
(ewoc-goto-next cvs-cookies arg) |
(ewoc-goto-next cvs-cookies arg) |
1144 |
(let ((fpos (next-single-property-change |
(cvs-move-to-goal-column)) |
|
(point) 'cvs-goal-column |
|
|
(current-buffer) (line-end-position))) |
|
|
(eol (line-end-position))) |
|
|
(when (< fpos eol) |
|
|
(goto-char fpos)))) |
|
1145 |
|
|
1146 |
;;;; |
;;;; |
1147 |
;;;; Mark handling |
;;;; Mark handling |
1366 |
(defcustom cvs-mode-commit-hook nil |
(defcustom cvs-mode-commit-hook nil |
1367 |
"Hook run after setting up the commit buffer." |
"Hook run after setting up the commit buffer." |
1368 |
:type 'hook |
:type 'hook |
1369 |
:options '(cvs-mode-diff)) |
:options '(cvs-mode-diff) |
1370 |
|
:group 'pcl-cvs) |
1371 |
|
|
1372 |
(defun cvs-mode-commit (setup) |
(defun cvs-mode-commit (setup) |
1373 |
"Check in all marked files, or the current file. |
"Check in all marked files, or the current file. |
1407 |
(cvs-mode-do "commit" (list* "-m" msg flags) 'commit))) |
(cvs-mode-do "commit" (list* "-m" msg flags) 'commit))) |
1408 |
|
|
1409 |
|
|
1410 |
|
;;;; Editing existing commit log messages. |
1411 |
|
|
1412 |
|
(defun cvs-edit-log-text-at-point () |
1413 |
|
(save-excursion |
1414 |
|
(end-of-line) |
1415 |
|
(when (re-search-backward "^revision " nil t) |
1416 |
|
(forward-line 1) |
1417 |
|
(if (looking-at "date:") (forward-line 1)) |
1418 |
|
(if (looking-at "branches:") (forward-line 1)) |
1419 |
|
(buffer-substring |
1420 |
|
(point) |
1421 |
|
(if (re-search-forward |
1422 |
|
"^\\(-\\{28\\}\\|=\\{77\\}\\|revision [.0-9]+\\)$" |
1423 |
|
nil t) |
1424 |
|
(match-beginning 0) |
1425 |
|
(point)))))) |
1426 |
|
|
1427 |
|
(defun cvs-mode-edit-log (rev &optional text) |
1428 |
|
"Edit the log message at point. |
1429 |
|
This is best called from a `log-view-mode' buffer." |
1430 |
|
(interactive |
1431 |
|
(list |
1432 |
|
(or (cvs-mode! (lambda () (cvs-prefix-get 'cvs-branch-prefix))) |
1433 |
|
(read-string "Revision to edit: ")) |
1434 |
|
(cvs-edit-log-text-at-point))) |
1435 |
|
;; It seems that the save-excursion that happens if I use the better |
1436 |
|
;; form of `(cvs-mode! (lambda ...))' screws up a couple things which |
1437 |
|
;; end up being rather annoying (like log-edit-mode's message being |
1438 |
|
;; displayed in the wrong minibuffer). |
1439 |
|
(cvs-mode!) |
1440 |
|
(let ((buf (cvs-temp-buffer "message" 'normal 'nosetup)) |
1441 |
|
(lbd list-buffers-directory) |
1442 |
|
(setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist))) |
1443 |
|
'log-edit))) |
1444 |
|
(funcall setupfun 'cvs-do-edit-log nil 'cvs-edit-log-filelist buf) |
1445 |
|
(when text (erase-buffer) (insert text)) |
1446 |
|
(set (make-local-variable 'cvs-edit-log-revision) rev) |
1447 |
|
(set (make-local-variable 'cvs-minor-wrap-function) 'cvs-edit-log-minor-wrap) |
1448 |
|
(set (make-local-variable 'list-buffers-directory) lbd) |
1449 |
|
;; (run-hooks 'cvs-mode-commit-hook) |
1450 |
|
)) |
1451 |
|
|
1452 |
|
(defun cvs-edit-log-minor-wrap (buf f) |
1453 |
|
(let ((cvs-ignore-marks-modif (cvs-mode-mark-get-modif "commit"))) |
1454 |
|
(funcall f))) |
1455 |
|
|
1456 |
|
(defun cvs-edit-log-filelist () |
1457 |
|
(cvs-mode-files nil nil :read-only t :file t :noquery t)) |
1458 |
|
|
1459 |
|
(defun cvs-do-edit-log (rev) |
1460 |
|
"Do the actual commit, using the current buffer as the log message." |
1461 |
|
(interactive (list cvs-edit-log-revision)) |
1462 |
|
(let ((msg (buffer-substring-no-properties (point-min) (point-max)))) |
1463 |
|
(cvs-mode!) |
1464 |
|
(cvs-mode-do "admin" (list (concat "-m" rev ":" msg)) nil))) |
1465 |
|
|
1466 |
|
|
1467 |
;;;; |
;;;; |
1468 |
;;;; CVS Mode commands |
;;;; CVS Mode commands |
1469 |
;;;; |
;;;; |
1635 |
(or (find-buffer-visiting buffile) |
(or (find-buffer-visiting buffile) |
1636 |
(with-current-buffer (create-file-buffer buffile) |
(with-current-buffer (create-file-buffer buffile) |
1637 |
(message "Retrieving revision %s..." rev) |
(message "Retrieving revision %s..." rev) |
1638 |
(let ((res (call-process cvs-program nil t nil |
;; Discard stderr output to work around the CVS+SSH+libc |
1639 |
|
;; problem when stdout and stderr are the same. |
1640 |
|
;; FIXME: this doesn't seem to make any difference :-( |
1641 |
|
(let ((res (call-process cvs-program nil '(t . nil) nil |
1642 |
"-q" "update" "-p" "-r" rev file))) |
"-q" "update" "-p" "-r" rev file))) |
1643 |
(when (and res (not (and (equal 0 res)))) |
(when (and res (not (and (equal 0 res)))) |
1644 |
(error "Something went wrong retrieving revision %s: %s" rev res)) |
(error "Something went wrong retrieving revision %s: %s" rev res)) |
1722 |
rev1-buf rev2-buf))))) |
rev1-buf rev2-buf))))) |
1723 |
|
|
1724 |
|
|
|
(defun cvs-fileinfo-kill (c fi) |
|
|
"Mark a fileinfo xor its members (in case of a directory) as dead." |
|
|
(if (eq (cvs-fileinfo->type fi) 'DIRCHANGE) |
|
|
(dolist (fi (ewoc-collect c 'cvs-dir-member-p |
|
|
(cvs-fileinfo->dir fi))) |
|
|
(setf (cvs-fileinfo->type fi) 'DEAD)) |
|
|
(setf (cvs-fileinfo->type fi) 'DEAD))) |
|
|
|
|
1725 |
(defun cvs-is-within-p (fis dir) |
(defun cvs-is-within-p (fis dir) |
1726 |
"Non-nil is buffer is inside one of FIS (in DIR)." |
"Non-nil is buffer is inside one of FIS (in DIR)." |
1727 |
(when (stringp buffer-file-name) |
(when (stringp buffer-file-name) |
1748 |
;; Save the relevant buffers |
;; Save the relevant buffers |
1749 |
(save-some-buffers nil (lambda () (cvs-is-within-p fis def-dir)))) |
(save-some-buffers nil (lambda () (cvs-is-within-p fis def-dir)))) |
1750 |
(unless (listp flags) (error "flags should be a list of strings")) |
(unless (listp flags) (error "flags should be a list of strings")) |
1751 |
|
;; Some w32 versions of CVS don't like an explicit . too much. |
1752 |
|
(when (and (car fis) (null (cdr fis)) |
1753 |
|
(eq (cvs-fileinfo->type (car fis)) 'DIRCHANGE) |
1754 |
|
;; (equal (cvs-fileinfo->file (car fis)) ".") |
1755 |
|
(equal (cvs-fileinfo->dir (car fis)) "")) |
1756 |
|
(setq fis nil)) |
1757 |
(let* ((cvs-buf (current-buffer)) |
(let* ((cvs-buf (current-buffer)) |
1758 |
(single-dir (or (not (listp cvs-execute-single-dir)) |
(single-dir (or (not (listp cvs-execute-single-dir)) |
1759 |
(member cmd cvs-execute-single-dir))) |
(member cmd cvs-execute-single-dir))) |
1764 |
(eq cvs-auto-remove-handled 'delayed) nil t) |
(eq cvs-auto-remove-handled 'delayed) nil t) |
1765 |
(when (fboundp after-mode) |
(when (fboundp after-mode) |
1766 |
(setq postproc (append postproc `((,after-mode))))) |
(setq postproc (append postproc `((,after-mode))))) |
1767 |
(when parse (push `(cvs-parse-process ',dont-change-disc) postproc)) |
(when parse |
1768 |
(when (member cmd '("status" "update")) ;FIXME: Yuck!! |
(let ((old-fis |
1769 |
;; absence of `cvs update' output has a specific meaning. |
(when (member cmd '("status" "update")) ;FIXME: Yuck!! |
1770 |
(push |
;; absence of `cvs update' output has a specific meaning. |
1771 |
`(dolist (fi ',(or fis |
(or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." "")))))) |
1772 |
(list (cvs-create-fileinfo 'DIRCHANGE "" "." "")))) |
(push `(cvs-parse-process ',dont-change-disc nil ',old-fis) postproc))) |
|
(cvs-fileinfo-kill ',cvs-cookies fi)) |
|
|
postproc)) |
|
1773 |
(setq postproc (if (cdr postproc) (cons 'progn postproc) (car postproc))) |
(setq postproc (if (cdr postproc) (cons 'progn postproc) (car postproc))) |
1774 |
(cvs-update-header args fis) |
(cvs-update-header args fis) |
1775 |
(with-current-buffer buf |
(with-current-buffer buf |
1899 |
With a prefix, opens the buffer in an OTHER window." |
With a prefix, opens the buffer in an OTHER window." |
1900 |
(interactive (list last-input-event current-prefix-arg)) |
(interactive (list last-input-event current-prefix-arg)) |
1901 |
(when (ignore-errors (mouse-set-point e) t) ;for invocation via the mouse |
(when (ignore-errors (mouse-set-point e) t) ;for invocation via the mouse |
1902 |
(unless (memq (get-text-property (point) 'face) |
(unless (memq (get-text-property (1- (line-end-position)) 'font-lock-face) |
1903 |
'(cvs-header-face cvs-filename-face)) |
'(cvs-header-face cvs-filename-face)) |
1904 |
(error "Not a file name"))) |
(error "Not a file name"))) |
1905 |
(cvs-mode! |
(cvs-mode! |
1935 |
(interactive (list nil));; (cvs-flags-query 'cvs-undo-flags "undo flags") |
(interactive (list nil));; (cvs-flags-query 'cvs-undo-flags "undo flags") |
1936 |
(if current-prefix-arg (call-interactively 'cvs-mode-revert-to-rev) |
(if current-prefix-arg (call-interactively 'cvs-mode-revert-to-rev) |
1937 |
(let* ((fis (cvs-do-removal 'undo "update" 'all)) |
(let* ((fis (cvs-do-removal 'undo "update" 'all)) |
1938 |
(removedp (lambda (fi) (eq (cvs-fileinfo->type fi) 'REMOVED))) |
(removedp (lambda (fi) |
1939 |
|
(or (eq (cvs-fileinfo->type fi) 'REMOVED) |
1940 |
|
(and (eq (cvs-fileinfo->type fi) 'CONFLICT) |
1941 |
|
(eq (cvs-fileinfo->subtype fi) 'REMOVED))))) |
1942 |
(fis-split (cvs-partition removedp fis)) |
(fis-split (cvs-partition removedp fis)) |
1943 |
(fis-removed (car fis-split)) |
(fis-removed (car fis-split)) |
1944 |
(fis-other (cdr fis-split))) |
(fis-other (cdr fis-split))) |
2013 |
(tmpbuf (cvs-temp-buffer))) |
(tmpbuf (cvs-temp-buffer))) |
2014 |
(when (and (not silent) (equal cvs-confirm-removals 'list)) |
(when (and (not silent) (equal cvs-confirm-removals 'list)) |
2015 |
(with-current-buffer tmpbuf |
(with-current-buffer tmpbuf |
2016 |
(cvs-insert-strings (mapcar 'cvs-fileinfo->full-path fis)) |
(let ((inhibit-read-only t)) |
2017 |
(cvs-pop-to-buffer-same-frame (current-buffer)) |
(cvs-insert-strings (mapcar 'cvs-fileinfo->full-path fis)) |
2018 |
(shrink-window-if-larger-than-buffer))) |
(cvs-pop-to-buffer-same-frame (current-buffer)) |
2019 |
|
(shrink-window-if-larger-than-buffer)))) |
2020 |
(if (not (or silent |
(if (not (or silent |
2021 |
(unwind-protect |
(unwind-protect |
2022 |
(yes-or-no-p (format "Delete %d files? " (length files))) |
(yes-or-no-p (format "Delete %d files? " (length files))) |
2042 |
(defvar cvs-tag-name "") |
(defvar cvs-tag-name "") |
2043 |
(defun-cvs-mode (cvs-mode-tag . SIMPLE) (tag &optional flags) |
(defun-cvs-mode (cvs-mode-tag . SIMPLE) (tag &optional flags) |
2044 |
"Run `cvs tag TAG' on all selected files. |
"Run `cvs tag TAG' on all selected files. |
2045 |
With prefix argument, prompt for cvs flags." |
With prefix argument, prompt for cvs flags. |
2046 |
|
By default this can only be used on directories. |
2047 |
|
Use \\[cvs-mode-force-command] or change `cvs-force-dir-tag' if you need |
2048 |
|
to use it on individual files." |
2049 |
(interactive |
(interactive |
2050 |
(list (setq cvs-tag-name |
(list (setq cvs-tag-name |
2051 |
(cvs-query-read cvs-tag-name "Tag name: " cvs-qtypedesc-tag)) |
(cvs-query-read cvs-tag-name "Tag name: " cvs-qtypedesc-tag)) |
2223 |
|
|
2224 |
(defun cvs-vc-command-advice (command file flags) |
(defun cvs-vc-command-advice (command file flags) |
2225 |
(when (and (equal command "cvs") |
(when (and (equal command "cvs") |
2226 |
;; don't parse output we don't understand. |
(progn |
2227 |
(member (car flags) cvs-parse-known-commands)) |
(while (and (stringp (car flags)) |
2228 |
(save-excursion |
(string-match "\\`-" (car flags))) |
2229 |
|
(pop flags)) |
2230 |
|
;; don't parse output we don't understand. |
2231 |
|
(member (car flags) cvs-parse-known-commands))) |
2232 |
|
(save-current-buffer |
2233 |
(let ((buffer (current-buffer)) |
(let ((buffer (current-buffer)) |
2234 |
(dir default-directory) |
(dir default-directory) |
2235 |
(cvs-from-vc t)) |
(cvs-from-vc t)) |
2241 |
(let ((subdir (substring dir (length default-directory)))) |
(let ((subdir (substring dir (length default-directory)))) |
2242 |
(set-buffer buffer) |
(set-buffer buffer) |
2243 |
(set (make-local-variable 'cvs-buffer) cvs-buf) |
(set (make-local-variable 'cvs-buffer) cvs-buf) |
2244 |
|
;; `cvs -q add file' produces no useful output :-( |
2245 |
|
(when (and (equal (car flags) "add") |
2246 |
|
(goto-char (point-min)) |
2247 |
|
(looking-at ".*to add this file permanently\n\\'")) |
2248 |
|
(insert "cvs add: scheduling file `" |
2249 |
|
(file-name-nondirectory file) |
2250 |
|
"' for addition\n")) |
2251 |
;; VC never (?) does `cvs -n update' so dcd=nil |
;; VC never (?) does `cvs -n update' so dcd=nil |
2252 |
;; should probably always be the right choice. |
;; should probably always be the right choice. |
2253 |
(cvs-parse-process nil subdir)))))))) |
(cvs-parse-process nil subdir)))))))) |