1;;; pcvs.el --- a front-end to CVS -*- lexical-binding:t -*- 2 3;; Copyright (C) 1991-2021 Free Software Foundation, Inc. 4 5;; Author: The PCL-CVS Trust <pcl-cvs@cyclic.com> 6;; Per Cederqvist <ceder@lysator.liu.se> 7;; Greg A. Woods <woods@weird.com> 8;; Jim Blandy <jimb@cyclic.com> 9;; Karl Fogel <kfogel@floss.red-bean.com> 10;; Jim Kingdon <kingdon@cyclic.com> 11;; Stefan Monnier <monnier@cs.yale.edu> 12;; Greg Klanderman <greg@alphatech.com> 13;; Jari Aalto <jari.aalto@poboxes.com> 14;; Maintainer: Stefan Monnier <monnier@gnu.org> 15;; Keywords: CVS, vc, release management 16 17;; This file is part of GNU Emacs. 18 19;; GNU Emacs is free software: you can redistribute it and/or modify 20;; it under the terms of the GNU General Public License as published by 21;; the Free Software Foundation, either version 3 of the License, or 22;; (at your option) any later version. 23 24;; GNU Emacs is distributed in the hope that it will be useful, 25;; but WITHOUT ANY WARRANTY; without even the implied warranty of 26;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 27;; GNU General Public License for more details. 28 29;; You should have received a copy of the GNU General Public License 30;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 31 32;;; Commentary: 33 34;; PCL-CVS is a front-end to the CVS version control system. 35;; It presents the status of all the files in your working area and 36;; allows you to commit/update several of them at a time. 37;; Compare with the general Emacs utility vc-dir, which tries 38;; to be VCS-agnostic. You may find PCL-CVS better/faster for CVS. 39 40;; PCL-CVS was originally written by Per Cederqvist many years ago. This 41;; version derives from the XEmacs-21 version, itself based on the 2.0b2 42;; version (last release from Per). It is a thorough rework. 43 44;; PCL-CVS is not a replacement for VC, but adds extra functionality. 45;; As such, I've tried to make PCL-CVS and VC interoperate seamlessly 46;; (I also use VC). 47 48;; To use PCL-CVS just use `M-x cvs-examine RET <dir> RET'. 49;; There is a TeXinfo manual, which can be helpful to get started. 50 51;;; Bugs: 52 53;; - Extracting an old version seems not to recognize encoding correctly. 54;; That's probably because it's done via a process rather than a file. 55 56;;; Todo: 57 58;; ******** FIX THE DOCUMENTATION ********* 59;; 60;; - rework the displaying of error messages. 61;; - allow the flushing of messages only 62;; - allow the protection of files like ChangeLog from flushing 63;; - query the user for cvs-get-marked (for some cmds or if nothing's selected) 64;; - don't return the first (resp last) FI if the cursor is before 65;; (resp after) it. 66;; - allow cvs-confirm-removals to force always confirmation. 67;; - cvs-checkout should ask for a revision (with completion). 68;; - removal confirmation should allow specifying another file name. 69;; 70;; - hide fileinfos without getting rid of them (will require ewok work). 71;; - add toolbar entries 72;; - marking 73;; marking directories should jump to just after the dir. 74;; allow (un)marking directories at a time with the mouse. 75;; allow cvs-cmd-do to either clear the marks or not. 76;; add a "marks active" notion, like transient-mark-mode does. 77;; - liveness indicator 78;; - indicate in docstring if the cmd understands the `b' prefix(es). 79;; - call smerge-mode when opening CONFLICT files. 80;; - have vc-checkin delegate to cvs-mode-commit when applicable 81;; - higher-level CVS operations 82;; cvs-mode-rename 83;; cvs-mode-branch 84;; - module-level commands 85;; add support for parsing 'modules' file ("cvs co -c") 86;; cvs-mode-rcs2log 87;; cvs-rdiff 88;; cvs-release 89;; cvs-import 90;; C-u M-x cvs-checkout should ask for a cvsroot 91;; cvs-mode-handle-new-vendor-version 92;; - checks out module, or alternately does update join 93;; - does "cvs -n tag LAST_VENDOR" to find old files into *cvs* 94;; cvs-export 95;; (with completion on tag names and hooks to help generate full releases) 96;; - display stickiness information. And current CVS/Tag as well. 97;; - write 'cvs-mode-admin' to do arbitrary 'cvs admin' commands 98;; Most interesting would be version removal and log message replacement. 99;; The last one would be neat when called from log-view-mode. 100;; - cvs-mode-incorporate 101;; It would merge in the status from one *cvs* buffer into another. 102;; This would be used to populate such a buffer that had been created with 103;; a `cvs {update,status,checkout} -l'. 104;; - cvs-mode-(i)diff-other-{file,buffer,cvs-buffer} 105;; - offer the choice to kill the process when the user kills the cvs buffer. 106;; right now, it's killed without further ado. 107;; - make `cvs-mode-ignore' allow manually entering a pattern. 108;; to which dir should it apply ? 109;; - maybe poll/check CVS/Entries files to react to external `cvs' commands ? 110;; - some kind of `cvs annotate' support ? 111;; but vc-annotate can be used instead. 112;; - proper `g' that passes safe args and uses either cvs-status or cvs-examine 113;; maybe also use cvs-update depending on I-don't-know-what. 114;; - add message-levels so that we can hide some levels of messages 115 116;;; Code: 117 118(eval-when-compile (require 'cl-lib)) 119(require 'ewoc) ;Ewoc was once cookie 120(require 'pcvs-defs) 121(require 'pcvs-util) 122(require 'pcvs-parse) 123(require 'pcvs-info) 124(require 'vc-cvs) 125 126 127;;;; 128;;;; global vars 129;;;; 130 131(defvar cvs-cookies) ;;nil 132 ;;"Handle for the cookie structure that is displayed in the *cvs* buffer.") 133;;(make-variable-buffer-local 'cvs-cookies) 134 135;;;; 136;;;; Dynamically scoped variables 137;;;; 138 139(defvar cvs-from-vc nil "Bound to t inside VC advice.") 140 141;;;; 142;;;; flags variables 143;;;; 144 145(defun cvs-defaults (&rest defs) 146 (let ((defs (cvs-first defs cvs-shared-start))) 147 (append defs 148 (make-list (- cvs-shared-start (length defs)) (car defs)) 149 cvs-shared-flags))) 150 151;; For cvs flags, we need to add "-f" to override the cvsrc settings 152;; we also want to evict the annoying -q and -Q options that hide useful 153;; information from pcl-cvs. 154(cvs-flags-define cvs-cvs-flags '(("-f"))) 155 156(cvs-flags-define cvs-checkout-flags (cvs-defaults '("-P"))) 157(cvs-flags-define cvs-status-flags (cvs-defaults '("-v") nil)) 158(cvs-flags-define cvs-log-flags (cvs-defaults nil)) 159(cvs-flags-define cvs-diff-flags (cvs-defaults '("-u" "-N") '("-c" "-N") '("-u" "-b"))) 160(cvs-flags-define cvs-tag-flags (cvs-defaults nil)) 161(cvs-flags-define cvs-add-flags (cvs-defaults nil)) 162(cvs-flags-define cvs-commit-flags (cvs-defaults nil)) 163(cvs-flags-define cvs-remove-flags (cvs-defaults nil)) 164;;(cvs-flags-define cvs-undo-flags (cvs-defaults nil)) 165(cvs-flags-define cvs-update-flags (cvs-defaults '("-d" "-P"))) 166 167(defun cvs-reread-cvsrc () 168 "Reset the default arguments to those in the `cvs-cvsrc-file'." 169 (interactive) 170 (condition-case nil 171 (with-temp-buffer 172 (insert-file-contents cvs-cvsrc-file) 173 ;; fetch the values 174 (dolist (cmd '("cvs" "checkout" "status" "log" "diff" "tag" 175 "add" "commit" "remove" "update")) 176 (goto-char (point-min)) 177 (when (re-search-forward 178 (concat "^" cmd "\\(\\s-+\\(.*\\)\\)?$") nil t) 179 (let* ((sym (intern (concat "cvs-" cmd "-flags"))) 180 (val (split-string-and-unquote (or (match-string 2) "")))) 181 (cvs-flags-set sym 0 val)))) 182 ;; ensure that cvs doesn't have -q or -Q 183 (cvs-flags-set 'cvs-cvs-flags 0 184 (cons "-f" 185 (cdr (cvs-partition 186 (lambda (x) (member x '("-q" "-Q" "-f"))) 187 (cvs-flags-query 'cvs-cvs-flags 188 nil 'noquery)))))) 189 (file-error nil))) 190 191;; initialize to cvsrc's default values 192(cvs-reread-cvsrc) 193 194 195;;;; 196;;;; Mouse bindings and mode motion 197;;;; 198 199(defvar cvs-minor-current-files) 200 201(defun cvs-menu (e) 202 "Popup the CVS menu." 203 (interactive "e") 204 (let ((cvs-minor-current-files 205 (list (ewoc-data (ewoc-locate 206 cvs-cookies (posn-point (event-end e))))))) 207 (popup-menu cvs-menu e))) 208 209(defvar cvs-mode-line-process nil 210 "Mode-line control for displaying info on cvs process status.") 211 212 213;;;; 214;;;; Query-Type-Descriptor for Tags 215;;;; 216 217(autoload 'cvs-status-get-tags "cvs-status") 218(defun cvs-tags-list () 219 "Return a list of acceptable tags, ready for completions." 220 (cl-assert (cvs-buffer-p)) 221 (let ((marked (cvs-get-marked))) 222 `(("BASE") ("HEAD") 223 ,@(when marked 224 (with-temp-buffer 225 (process-file cvs-program 226 nil ;no input 227 t ;output to current-buffer 228 nil ;don't update display while running 229 "status" 230 "-v" 231 (cvs-fileinfo->full-name (car marked))) 232 (goto-char (point-min)) 233 (let ((tags (cvs-status-get-tags))) 234 (when (listp tags) tags))))))) 235 236(defvar cvs-tag-history nil) 237(defconst cvs-qtypedesc-tag 238 (cvs-qtypedesc-create 'identity 'identity 'cvs-tags-list 'cvs-tag-history)) 239 240;;;; 241 242(defun cvs-mode! (&optional -cvs-mode!-fun) 243 "Switch to the *cvs* buffer. 244If -CVS-MODE!-FUN is provided, it is executed *cvs* being the current buffer 245 and with its window selected. Else, the *cvs* buffer is simply selected. 246-CVS-MODE!-FUN is called interactively if applicable and else with no argument." 247 (let* ((-cvs-mode!-buf (current-buffer)) 248 (cvsbuf (cond ((cvs-buffer-p) (current-buffer)) 249 ((and cvs-buffer (cvs-buffer-p cvs-buffer)) cvs-buffer) 250 (t (error "can't find the *cvs* buffer")))) 251 (-cvs-mode!-wrapper cvs-minor-wrap-function) 252 (-cvs-mode!-cont (lambda () 253 (save-current-buffer 254 (if (commandp -cvs-mode!-fun) 255 (call-interactively -cvs-mode!-fun) 256 (funcall -cvs-mode!-fun)))))) 257 (if (not -cvs-mode!-fun) (set-buffer cvsbuf) 258 (let ((cvs-mode!-buf (current-buffer)) 259 (cvs-mode!-owin (selected-window)) 260 (cvs-mode!-nwin (get-buffer-window cvsbuf 'visible))) 261 (unwind-protect 262 (progn 263 (set-buffer cvsbuf) 264 (when cvs-mode!-nwin (select-window cvs-mode!-nwin)) 265 (if -cvs-mode!-wrapper 266 (funcall -cvs-mode!-wrapper -cvs-mode!-buf -cvs-mode!-cont) 267 (funcall -cvs-mode!-cont))) 268 (set-buffer cvs-mode!-buf) 269 (when (and cvs-mode!-nwin (eq cvs-mode!-nwin (selected-window))) 270 ;; the selected window has not been changed by FUN 271 (select-window cvs-mode!-owin))))))) 272 273;;;; 274;;;; Prefixes 275;;;; 276 277(defvar cvs-branches (list cvs-vendor-branch "HEAD" "HEAD")) 278(cvs-prefix-define cvs-branch-prefix 279 "Current selected branch." 280 "version" 281 (cons cvs-vendor-branch cvs-branches) 282 cvs-qtypedesc-tag) 283 284(defun cvs-set-branch-prefix (arg) 285 "Set the branch prefix to take action at the next command. 286See `cvs-prefix-set' for a further the description of the behavior. 287\\[universal-argument] 1 selects the vendor branch 288and \\[universal-argument] 2 selects the HEAD." 289 (interactive "P") 290 (cvs-mode!) 291 (cvs-prefix-set 'cvs-branch-prefix arg)) 292 293(defun cvs-add-branch-prefix (flags &optional arg) 294 "Add branch selection argument if the branch prefix was set. 295The argument is added (or not) to the list of FLAGS and is constructed 296by appending the branch to ARG which defaults to \"-r\"." 297 (let ((branch (cvs-prefix-get 'cvs-branch-prefix))) 298 ;; deactivate the secondary prefix, even if not used. 299 (cvs-prefix-get 'cvs-secondary-branch-prefix) 300 (if branch (cons (concat (or arg "-r") branch) flags) flags))) 301 302(cvs-prefix-define cvs-secondary-branch-prefix 303 "Current secondary selected branch." 304 "version" 305 (cons cvs-vendor-branch cvs-branches) 306 cvs-qtypedesc-tag) 307 308(defun cvs-set-secondary-branch-prefix (arg) 309 "Set the branch prefix to take action at the next command. 310See `cvs-prefix-set' for a further the description of the behavior. 311\\[universal-argument] 1 selects the vendor branch 312and \\[universal-argument] 2 selects the HEAD." 313 (interactive "P") 314 (cvs-mode!) 315 (cvs-prefix-set 'cvs-secondary-branch-prefix arg)) 316 317(defun cvs-add-secondary-branch-prefix (flags &optional arg) 318 "Add branch selection argument if the secondary branch prefix was set. 319The argument is added (or not) to the list of FLAGS and is constructed 320by appending the branch to ARG which defaults to \"-r\". 321Since the `cvs-secondary-branch-prefix' is only active if the primary 322prefix is active, it is important to read the secondary prefix before 323the primary since reading the primary can deactivate it." 324 (let ((branch (and (cvs-prefix-get 'cvs-branch-prefix 'read-only) 325 (cvs-prefix-get 'cvs-secondary-branch-prefix)))) 326 (if branch (cons (concat (or arg "-r") branch) flags) flags))) 327 328;;;; 329 330(define-minor-mode cvs-minor-mode 331 "This mode is used for buffers related to a main *cvs* buffer. 332All the `cvs-mode' buffer operations are simply rebound under 333the \\[cvs-mode-map] prefix." 334 nil " CVS" 335 :group 'pcl-cvs) 336(put 'cvs-minor-mode 'permanent-local t) 337 338 339(defvar cvs-temp-buffers nil) 340(defun cvs-temp-buffer (&optional cmd normal nosetup) 341 "Create a temporary buffer to run CMD in. 342If CMD is a string, use it to lookup `cvs-buffer-name-alist' to find 343the buffer name to be used and its major mode. 344 345The selected window will not be changed. The new buffer will not maintain undo 346information and will be read-only unless NORMAL is non-nil. It will be emptied 347\(unless NOSETUP is non-nil) and its `default-directory' will be inherited 348from the current buffer." 349 (let* ((cvs-buf (current-buffer)) 350 (info (cdr (assoc cmd cvs-buffer-name-alist))) 351 (name (eval (nth 0 info) `((cmd . ,cmd)))) 352 (mode (nth 1 info)) 353 (dir default-directory) 354 (buf (cond 355 (name (cvs-get-buffer-create name)) 356 ((and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer)) 357 cvs-temp-buffer) 358 (t 359 (set (make-local-variable 'cvs-temp-buffer) 360 (cvs-get-buffer-create 361 (eval cvs-temp-buffer-name `((dir . ,dir))) 362 'noreuse)))))) 363 364 ;; Handle the potential pre-existing process. 365 (let ((proc (get-buffer-process buf))) 366 (when (and (not normal) (processp proc) 367 (memq (process-status proc) '(run stop))) 368 (if cmd 369 ;; When CMD is specified, the buffer is normally shown to the 370 ;; user, so interrupting the process is not harmful. 371 ;; Use `delete-process' rather than `kill-process' otherwise 372 ;; the pending output of the process will still get inserted 373 ;; after we erase the buffer. 374 (delete-process proc) 375 (error "Can not run two cvs processes simultaneously")))) 376 377 (if (not name) (kill-local-variable 'other-window-scroll-buffer) 378 ;; Strangely, if no window is created, `display-buffer' ends up 379 ;; doing a `switch-to-buffer' which does a `set-buffer', hence 380 ;; the need for `save-excursion'. 381 (unless nosetup (save-excursion (display-buffer buf))) 382 ;; FIXME: this doesn't do the right thing if the user later on 383 ;; does a `find-file-other-window' and `scroll-other-window' 384 (set (make-local-variable 'other-window-scroll-buffer) buf)) 385 386 (add-to-list 'cvs-temp-buffers buf) 387 388 (with-current-buffer buf 389 (setq buffer-read-only nil) 390 (setq default-directory dir) 391 (unless nosetup 392 ;; Disable undo before calling erase-buffer since it may generate 393 ;; a very large and unwanted undo record. 394 (buffer-disable-undo) 395 (erase-buffer)) 396 (set (make-local-variable 'cvs-buffer) cvs-buf) 397 ;;(cvs-minor-mode 1) 398 (let ((lbd list-buffers-directory)) 399 (if (fboundp mode) (funcall mode) (fundamental-mode)) 400 (when lbd (setq list-buffers-directory lbd))) 401 (cvs-minor-mode 1) 402 ;;(set (make-local-variable 'cvs-buffer) cvs-buf) 403 (if normal 404 (buffer-enable-undo) 405 (setq buffer-read-only t) 406 (buffer-disable-undo)) 407 buf))) 408 409(defun cvs-mode-kill-buffers () 410 "Kill all the \"temporary\" buffers created by the *cvs* buffer." 411 (interactive) 412 (dolist (buf cvs-temp-buffers) (ignore-errors (kill-buffer buf)))) 413 414(defun cvs-make-cvs-buffer (dir &optional new) 415 "Create the *cvs* buffer for directory DIR. 416If non-nil, NEW means to create a new buffer no matter what." 417 ;; the real cvs-buffer creation 418 (setq dir (cvs-expand-dir-name dir)) 419 (let* ((buffer-name (eval cvs-buffer-name `((dir . ,dir)))) 420 (buffer 421 (or (and (not new) 422 (eq cvs-reuse-cvs-buffer 'current) 423 (cvs-buffer-p) ;reuse the current buffer if possible 424 (current-buffer)) 425 ;; look for another cvs buffer visiting the same directory 426 (save-excursion 427 (unless new 428 (cl-dolist (buffer (cons (current-buffer) (buffer-list))) 429 (set-buffer buffer) 430 (and (cvs-buffer-p) 431 (pcase cvs-reuse-cvs-buffer 432 ('always t) 433 ('subdir 434 (or (string-prefix-p default-directory dir) 435 (string-prefix-p dir default-directory))) 436 ('samedir (string= default-directory dir))) 437 (cl-return buffer))))) 438 ;; we really have to create a new buffer: 439 ;; we temporarily bind cwd to "" to prevent 440 ;; create-file-buffer from using directory info 441 ;; unless it is explicitly in the cvs-buffer-name. 442 (cvs-get-buffer-create buffer-name new)))) 443 (with-current-buffer buffer 444 (or 445 (and (string= dir default-directory) (cvs-buffer-p) 446 ;; just a refresh 447 (ignore-errors 448 (cvs-cleanup-collection cvs-cookies nil nil t) 449 (current-buffer))) 450 ;; setup from scratch 451 (progn 452 (setq default-directory dir) 453 (setq buffer-read-only nil) 454 (erase-buffer) 455 (insert "Repository : " (directory-file-name (cvs-get-cvsroot)) 456 "\nModule : " (cvs-get-module) 457 "\nWorking dir: " (abbreviate-file-name dir) 458 (if (not (file-readable-p "CVS/Tag")) "\n" 459 (let ((tag (cvs-file-to-string "CVS/Tag"))) 460 (cond 461 ((string-match "\\`T" tag) 462 (concat "\nTag : " (substring tag 1))) 463 ((string-match "\\`D" tag) 464 (concat "\nDate : " (substring tag 1))) 465 ("\n")))) 466 "\n") 467 (setq buffer-read-only t) 468 (cvs-mode) 469 (set (make-local-variable 'list-buffers-directory) buffer-name) 470 ;;(set (make-local-variable 'cvs-temp-buffer) (cvs-temp-buffer)) 471 (let ((cookies (ewoc-create 'cvs-fileinfo-pp "\n\n" "\n" t))) 472 (set (make-local-variable 'cvs-cookies) cookies) 473 (add-hook 'kill-buffer-hook 474 (lambda () 475 (ignore-errors (kill-buffer cvs-temp-buffer))) 476 nil t) 477 ;;(set-buffer buf) 478 buffer)))))) 479 480(cl-defun cvs-cmd-do (cmd dir flags fis new 481 &key cvsargs noexist dont-change-disc noshow) 482 (let* ((dir (file-name-as-directory 483 (abbreviate-file-name (expand-file-name dir)))) 484 (cvsbuf (cvs-make-cvs-buffer dir new))) 485 ;; Check that dir is under CVS control. 486 (unless (file-directory-p dir) 487 (error "%s is not a directory" dir)) 488 (unless (or noexist (file-directory-p (expand-file-name "CVS" dir)) 489 (file-expand-wildcards (expand-file-name "*/CVS" dir))) 490 (error "%s does not contain CVS controlled files" dir)) 491 492 (set-buffer cvsbuf) 493 (cvs-mode-run cmd flags fis 494 :cvsargs cvsargs :dont-change-disc dont-change-disc) 495 496 (if noshow cvsbuf 497 (let ((pop-up-windows nil)) (pop-to-buffer cvsbuf))))) 498;; (funcall (if (and (boundp 'pop-up-frames) pop-up-frames) 499;; 'pop-to-buffer 'switch-to-buffer) 500;; cvsbuf)))) 501 502(defun cvs-run-process (args fis postprocess &optional single-dir) 503 (cl-assert (cvs-buffer-p cvs-buffer)) 504 (save-current-buffer 505 (let ((procbuf (current-buffer)) 506 (cvsbuf cvs-buffer) 507 (single-dir (or single-dir (eq cvs-execute-single-dir t)))) 508 509 (set-buffer procbuf) 510 (goto-char (point-max)) 511 (unless (bolp) (let ((inhibit-read-only t)) (insert "\n"))) 512 ;; find the set of files we'll process in this round 513 (let* ((dir+files+rest 514 (if (or (null fis) (not single-dir)) 515 ;; not single-dir mode: just process the whole thing 516 (list "" (mapcar 'cvs-fileinfo->full-name fis) nil) 517 ;; single-dir mode: extract the same-dir-elements 518 (let ((dir (cvs-fileinfo->dir (car fis)))) 519 ;; output the concerned dir so the parser can translate paths 520 (let ((inhibit-read-only t)) 521 (insert "pcl-cvs: descending directory " dir "\n")) 522 ;; loop to find the same-dir-elems 523 (cl-do* ((files () (cons (cvs-fileinfo->file fi) files)) 524 (fis fis (cdr fis)) 525 (fi (car fis) (car fis))) 526 ((not (and fis (string= dir (cvs-fileinfo->dir fi)))) 527 (list dir files fis)))))) 528 (dir (nth 0 dir+files+rest)) 529 (files (nth 1 dir+files+rest)) 530 (rest (nth 2 dir+files+rest))) 531 532 (add-hook 'kill-buffer-hook 533 (lambda () 534 (let ((proc (get-buffer-process (current-buffer)))) 535 (when (processp proc) 536 (set-process-filter proc nil) 537 ;; Abort postprocessing but leave the sentinel so it 538 ;; will update the list of running procs. 539 (process-put proc 'cvs-postprocess nil) 540 (interrupt-process proc)))) 541 nil t) 542 543 ;; create the new process and setup the procbuffer correspondingly 544 (let* ((msg (cvs-header-msg args fis)) 545 (args (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery) 546 (if cvs-cvsroot (list "-d" cvs-cvsroot)) 547 args 548 files)) 549 ;; If process-connection-type is nil and the repository 550 ;; is accessed via SSH, a bad interaction between libc, 551 ;; CVS and SSH can lead to garbled output. 552 ;; It might be a glibc-specific problem (but it can also happens 553 ;; under macOS, it seems). 554 ;; It seems that using a pty can help circumvent the problem, 555 ;; but at the cost of screwing up when the process thinks it 556 ;; can ask for user input (such as password or host-key 557 ;; confirmation). A better workaround is to set CVS_RSH to 558 ;; an appropriate script, or to use a later version of CVS. 559 (process-connection-type nil) ; Use a pipe, not a pty. 560 (process 561 ;; the process will be run in the selected dir 562 (let ((default-directory (cvs-expand-dir-name dir))) 563 (apply 'start-file-process "cvs" procbuf cvs-program args)))) 564 ;; setup the process. 565 (process-put process 'cvs-buffer cvs-buffer) 566 (with-current-buffer cvs-buffer (cvs-update-header msg 'add)) 567 (process-put process 'cvs-header msg) 568 (process-put 569 process 'cvs-postprocess 570 (if (null rest) 571 ;; this is the last invocation 572 postprocess 573 ;; else, we have to register ourselves to be rerun on the rest 574 (lambda () (cvs-run-process args rest postprocess single-dir)))) 575 (set-process-sentinel process 'cvs-sentinel) 576 (set-process-filter process 'cvs-update-filter) 577 (set-marker (process-mark process) (point-max)) 578 (ignore-errors (process-send-eof process)) ;close its stdin to avoid hangs 579 580 ;; now finish setting up the cvs-buffer 581 (set-buffer cvsbuf) 582 (setq cvs-mode-line-process (symbol-name (process-status process))) 583 (force-mode-line-update))))) 584 585 ;; The following line is said to improve display updates on some 586 ;; emacsen. It shouldn't be needed, but it does no harm. 587 (sit-for 0)) 588 589(defun cvs-header-msg (args fis) 590 (let* ((lastarg nil) 591 (args (mapcar (lambda (arg) 592 (cond 593 ;; filter out the largish commit message 594 ((and (eq lastarg nil) (string= arg "commit")) 595 (setq lastarg 'commit) arg) 596 ((and (eq lastarg 'commit) (string= arg "-m")) 597 (setq lastarg '-m) arg) 598 ((eq lastarg '-m) 599 (setq lastarg 'done) "<log message>") 600 ;; filter out the largish `admin -mrev:msg' message 601 ((and (eq lastarg nil) (string= arg "admin")) 602 (setq lastarg 'admin) arg) 603 ((and (eq lastarg 'admin) 604 (string-match "\\`-m[^:]*:" arg)) 605 (setq lastarg 'done) 606 (concat (match-string 0 arg) "<log message>")) 607 ;; Keep the rest as is. 608 (t arg))) 609 args))) 610 (concat cvs-program " " 611 (combine-and-quote-strings 612 (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery) 613 (if cvs-cvsroot (list "-d" cvs-cvsroot)) 614 args 615 (mapcar 'cvs-fileinfo->full-name fis)))))) 616 617(defun cvs-update-header (cmd add) 618 (let* ((hf (ewoc-get-hf cvs-cookies)) 619 (str (car hf)) 620 (done "") 621 (tin (ewoc-nth cvs-cookies 0))) 622 ;; look for the first *real* fileinfo (to determine emptiness) 623 (while 624 (and tin 625 (memq (cvs-fileinfo->type (ewoc-data tin)) 626 '(MESSAGE DIRCHANGE))) 627 (setq tin (ewoc-next cvs-cookies tin))) 628 (if add 629 (progn 630 ;; Remove the default empty line, if applicable. 631 (if (not (string-match "." str)) (setq str "\n")) 632 (setq str (concat "-- Running " cmd " ...\n" str))) 633 (if (not (string-match 634 ;; FIXME: If `cmd' is large, this will bump into the 635 ;; compiled-regexp size limit. We could drop the "^" anchor 636 ;; and use search-forward to circumvent the problem. 637 (concat "^-- Running " (regexp-quote cmd) " \\.\\.\\.\n") str)) 638 (error "Internal PCL-CVS error while removing message") 639 (setq str (replace-match "" t t str)) 640 ;; Re-add the default empty line, if applicable. 641 (if (not (string-match "." str)) (setq str "\n\n")) 642 (setq done (concat "-- last cmd: " cmd " --\n")))) 643 ;; set the new header and footer 644 (ewoc-set-hf cvs-cookies 645 str (concat "\n--------------------- " 646 (if tin "End" "Empty") 647 " ---------------------\n" 648 done)))) 649 650 651(defun cvs-sentinel (proc _msg) 652 "Sentinel for the cvs update process. 653This is responsible for parsing the output from the cvs update when 654it is finished." 655 (when (memq (process-status proc) '(signal exit)) 656 (let ((cvs-postproc (process-get proc 'cvs-postprocess)) 657 (cvs-buf (process-get proc 'cvs-buffer)) 658 (procbuf (process-buffer proc))) 659 (unless (buffer-live-p cvs-buf) (setq cvs-buf nil)) 660 (unless (buffer-live-p procbuf) (setq procbuf nil)) 661 ;; Since the buffer and mode line will show that the 662 ;; process is dead, we can delete it now. Otherwise it 663 ;; will stay around until M-x list-processes. 664 (process-put proc 'postprocess nil) 665 (delete-process proc) 666 ;; Don't do anything if the main buffer doesn't exist any more. 667 (when cvs-buf 668 (with-current-buffer cvs-buf 669 (cvs-update-header (process-get proc 'cvs-header) nil) 670 (setq cvs-mode-line-process (symbol-name (process-status proc))) 671 (force-mode-line-update) 672 (when cvs-postproc 673 (if (null procbuf) 674 ;;(set-process-buffer proc nil) 675 (error "cvs' process buffer was killed") 676 (with-current-buffer procbuf 677 ;; Do the postprocessing like parsing and such. 678 (save-excursion 679 (funcall cvs-postproc))))))) 680 ;; Check whether something is left. 681 (when (and procbuf (not (get-buffer-process procbuf))) 682 (with-current-buffer procbuf 683 ;; IIRC, we enable undo again once the process is finished 684 ;; for cases where the output was inserted in *vc-diff* or 685 ;; in a file-like buffer. --Stef 686 (buffer-enable-undo) 687 (with-current-buffer (or cvs-buf (current-buffer)) 688 (message "CVS process has completed in %s" 689 (buffer-name)))))))) 690 691(defun cvs-parse-process (dcd &optional subdir old-fis) 692 "Parse the output of a cvs process. 693DCD is the `dont-change-disc' flag to use when parsing that output. 694SUBDIR is the subdirectory (if any) where this command was run. 695OLD-FIS is the list of fileinfos on which the cvs command was applied and 696 which should be considered up-to-date if they are missing from the output." 697 (when (eq system-type 'darwin) 698 ;; Fixup the ^D^H^H inserted at beginning of buffer sometimes on macOS 699 ;; because of the call to `process-send-eof'. 700 (save-excursion 701 (goto-char (point-min)) 702 (while (re-search-forward "^\\^D\^H+" nil t) 703 (let ((inhibit-read-only t)) 704 (delete-region (match-beginning 0) (match-end 0)))))) 705 (let* ((fileinfos (cvs-parse-buffer 'cvs-parse-table dcd subdir)) 706 last) 707 (with-current-buffer cvs-buffer 708 ;; Expand OLD-FIS to actual files. 709 (let ((fis nil)) 710 (dolist (fi old-fis) 711 (setq fis (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE) 712 (nconc (ewoc-collect cvs-cookies 'cvs-dir-member-p 713 (cvs-fileinfo->dir fi)) 714 fis) 715 (cons fi fis)))) 716 (setq old-fis fis)) 717 ;; Drop OLD-FIS which were already up-to-date. 718 (let ((fis nil)) 719 (dolist (fi old-fis) 720 (unless (eq (cvs-fileinfo->type fi) 'UP-TO-DATE) (push fi fis))) 721 (setq old-fis fis)) 722 ;; Add the new fileinfos to the ewoc. 723 (dolist (fi fileinfos) 724 (setq last (cvs-addto-collection cvs-cookies fi last)) 725 ;; This FI was in the output, so remove it from OLD-FIS. 726 (setq old-fis (delq (ewoc-data last) old-fis))) 727 ;; Process the "silent output" (i.e. absence means up-to-date). 728 (dolist (fi old-fis) 729 (setf (cvs-fileinfo->type fi) 'UP-TO-DATE) 730 (setq last (cvs-addto-collection cvs-cookies fi last))) 731 (setq fileinfos (nconc old-fis fileinfos)) 732 ;; Clean up the ewoc as requested by the user. 733 (cvs-cleanup-collection cvs-cookies 734 (eq cvs-auto-remove-handled t) 735 cvs-auto-remove-directories 736 nil) 737 ;; Revert buffers if necessary. 738 (when (and cvs-auto-revert (not dcd) (not cvs-from-vc)) 739 (cvs-revert-if-needed fileinfos))))) 740 741(defmacro defun-cvs-mode (fun args docstring interact &rest body) 742 "Define a function to be used in a *cvs* buffer. 743This will look for a *cvs* buffer and execute BODY in it. 744Since the interactive arguments might need to be queried after 745switching to the *cvs* buffer, the generic code is rather ugly, 746but luckily we can often use simpler alternatives. 747 748FUN can be either a symbol (i.e. STYLE is nil) or a cons (FUN . STYLE). 749ARGS and DOCSTRING are the normal argument list. 750INTERACT is the interactive specification or nil for non-commands. 751 752STYLE can be either `SIMPLE', `NOARGS' or `DOUBLE'. It's an error for it 753to have any other value, unless other details of the function make it 754clear what alternative to use. 755- `SIMPLE' will get all the interactive arguments from the original buffer. 756- `NOARGS' will get all the arguments from the *cvs* buffer and will 757 always behave as if called interactively. 758- `DOUBLE' is the generic case." 759 (declare (debug (&define sexp lambda-list stringp 760 ("interactive" interactive) def-body)) 761 (doc-string 3)) 762 (let ((style (cvs-cdr fun)) 763 (fun (cvs-car fun))) 764 (cond 765 ;; a trivial interaction, no need to move it 766 ((or (eq style 'SIMPLE) 767 (null (nth 1 interact)) 768 (stringp (nth 1 interact))) 769 `(defun ,fun ,args ,docstring ,interact 770 (cvs-mode! (lambda () ,@body)))) 771 772 ;; fun is only called interactively: move all the args to the inner fun 773 ((eq style 'NOARGS) 774 `(defun ,fun () ,docstring (interactive) 775 (cvs-mode! (lambda ,args ,interact ,@body)))) 776 777 ;; bad case 778 ((eq style 'DOUBLE) 779 (string-match ".*" docstring) 780 (let ((line1 (match-string 0 docstring)) 781 (fun-1 (intern (concat (symbol-name fun) "-1")))) 782 `(progn 783 (defun ,fun-1 ,args 784 ,(concat docstring "\nThis function only works within a *cvs* buffer. 785For interactive use, use `" (symbol-name fun) "' instead.") 786 ,interact 787 ,@body) 788 (put ',fun-1 'definition-name ',fun) 789 (defun ,fun () 790 ,(concat line1 "\nWrapper function that switches to a *cvs* buffer 791before calling the real function `" (symbol-name fun-1) "'.\n") 792 (interactive) 793 (cvs-mode! ',fun-1))))) 794 795 (t (error "Unknown style %s in `defun-cvs-mode'" style))))) 796 797(defun-cvs-mode cvs-mode-kill-process () 798 "Kill the temporary buffer and associated process." 799 (interactive) 800 (when (and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer)) 801 (let ((proc (get-buffer-process cvs-temp-buffer))) 802 (when proc (delete-process proc))))) 803 804;; 805;; Maintaining the collection in the face of updates 806;; 807 808(defun cvs-addto-collection (c fi &optional tin) 809 "Add FI to C and return FI's corresponding tin. 810FI is inserted in its proper place or maybe even merged with a preexisting 811 fileinfo if applicable. 812TIN specifies an optional starting point." 813 (unless tin (setq tin (ewoc-nth c 0))) 814 (while (and tin (cvs-fileinfo< fi (ewoc-data tin))) 815 (setq tin (ewoc-prev c tin))) 816 (if (null tin) (ewoc-enter-first c fi) ;empty collection 817 (cl-assert (not (cvs-fileinfo< fi (ewoc-data tin)))) 818 (let ((next-tin (ewoc-next c tin))) 819 (while (not (or (null next-tin) 820 (cvs-fileinfo< fi (ewoc-data next-tin)))) 821 (setq tin next-tin next-tin (ewoc-next c next-tin))) 822 (if (or (cvs-fileinfo< (ewoc-data tin) fi) 823 (eq (cvs-fileinfo->type fi) 'MESSAGE)) 824 ;; tin < fi < next-tin 825 (ewoc-enter-after c tin fi) 826 ;; fi == tin 827 (cvs-fileinfo-update (ewoc-data tin) fi) 828 (ewoc-invalidate c tin) 829 ;; Move cursor back to where it belongs. 830 (when (bolp) (cvs-move-to-goal-column)) 831 tin)))) 832 833(defcustom cvs-cleanup-functions nil 834 "Functions to tweak the cleanup process. 835The functions are called with a single argument (a FILEINFO) and should 836return a non-nil value if that fileinfo should be removed." 837 :group 'pcl-cvs 838 :type '(hook :options (cvs-cleanup-removed))) 839 840(defun cvs-cleanup-removed (fi) 841 "Non-nil if FI has been cvs-removed but still exists. 842This is intended for use on `cvs-cleanup-functions' when you have cvs-removed 843automatically generated files (which should hence not be under CVS control) 844but can't commit the removal because the repository's owner doesn't understand 845the problem." 846 (and (or (eq (cvs-fileinfo->type fi) 'REMOVED) 847 (and (eq (cvs-fileinfo->type fi) 'CONFLICT) 848 (eq (cvs-fileinfo->subtype fi) 'REMOVED))) 849 (file-exists-p (cvs-fileinfo->full-name fi)))) 850 851;; called at the following times: 852;; - postparse ((eq cvs-auto-remove-handled t) cvs-auto-remove-directories nil) 853;; - pre-run ((eq cvs-auto-remove-handled 'delayed) nil t) 854;; - remove-handled (t (or cvs-auto-remove-directories 'handled) t) 855;; - cvs-cmd-do (nil nil t) 856;; - post-ignore (nil nil nil) 857;; - acknowledge (nil nil nil) 858;; - remove (nil nil nil) 859(defun cvs-cleanup-collection (c rm-handled rm-dirs rm-msgs) 860 "Remove undesired entries. 861C is the collection 862RM-HANDLED if non-nil means remove handled entries (if file is currently 863 visited, only remove if value is `all'). 864RM-DIRS behaves like `cvs-auto-remove-directories'. 865RM-MSGS if non-nil means remove messages." 866 (let (last-fi first-dir (rerun t)) 867 (while rerun 868 (setq rerun nil) 869 (setq first-dir t) 870 (setq last-fi (cvs-create-fileinfo 'DEAD "../" "" "")) ;place-holder 871 (ewoc-filter 872 c (lambda (fi) 873 (let* ((type (cvs-fileinfo->type fi)) 874 (subtype (cvs-fileinfo->subtype fi)) 875 (keep 876 (pcase type 877 ;; Remove temp messages and keep the others. 878 ('MESSAGE (not (or rm-msgs (eq subtype 'TEMP)))) 879 ;; Remove dead entries. 880 ('DEAD nil) 881 ;; Handled also? 882 ('UP-TO-DATE 883 (not 884 (if (find-buffer-visiting (cvs-fileinfo->full-name fi)) 885 (eq rm-handled 'all) 886 rm-handled))) 887 ;; Keep the rest. 888 (_ (not (run-hook-with-args-until-success 889 'cvs-cleanup-functions fi)))))) 890 891 ;; mark dirs for removal 892 (when (and keep rm-dirs 893 (eq (cvs-fileinfo->type last-fi) 'DIRCHANGE) 894 (not (when first-dir (setq first-dir nil) t)) 895 (or (eq rm-dirs 'all) 896 (not (string-prefix-p 897 (cvs-fileinfo->dir last-fi) 898 (cvs-fileinfo->dir fi))) 899 (and (eq type 'DIRCHANGE) (eq rm-dirs 'empty)) 900 (eq subtype 'FOOTER))) 901 (setf (cvs-fileinfo->type last-fi) 'DEAD) 902 (setq rerun t)) 903 (when keep (setq last-fi fi))))) 904 ;; remove empty last dir 905 (when (and rm-dirs 906 (not first-dir) 907 (eq (cvs-fileinfo->type last-fi) 'DIRCHANGE)) 908 (setf (cvs-fileinfo->type last-fi) 'DEAD) 909 (setq rerun t))))) 910 911(defun cvs-get-cvsroot () 912 "Get the CVSROOT for DIR." 913 (let ((cvs-cvsroot-file (expand-file-name "Root" "CVS"))) 914 (or (cvs-file-to-string cvs-cvsroot-file t) 915 cvs-cvsroot 916 (getenv "CVSROOT") 917 "?????"))) 918 919(defun cvs-get-module () 920 "Return the current CVS module. 921This usually doesn't really work but is a handy initval in a prompt." 922 (let* ((repfile (expand-file-name "Repository" "CVS")) 923 (rep (cvs-file-to-string repfile t))) 924 (cond 925 ((null rep) "") 926 ((not (file-name-absolute-p rep)) rep) 927 (t 928 (let* ((root (cvs-get-cvsroot)) 929 (str (concat (file-name-as-directory (or root "/")) " || " rep))) 930 (if (and root (string-match "\\(.*\\) || \\1\\(.*\\)\\'" str)) 931 (match-string 2 str) 932 (file-name-nondirectory rep))))))) 933 934 935 936;;;; 937;;;; running a "cvs checkout". 938;;;; 939 940;;;###autoload 941(defun cvs-checkout (modules dir flags &optional root) 942 "Run a `cvs checkout MODULES' in DIR. 943Feed the output to a *cvs* buffer, display it in the current window, 944and run `cvs-mode' on it. 945 946With a prefix argument, prompt for cvs FLAGS to use." 947 (interactive 948 (let ((root (cvs-get-cvsroot))) 949 (if (or (null root) current-prefix-arg) 950 (setq root (read-string "CVS Root: "))) 951 (list (split-string-and-unquote 952 (read-string "Module(s): " (cvs-get-module))) 953 (read-directory-name "CVS Checkout Directory: " 954 nil default-directory nil) 955 (cvs-add-branch-prefix 956 (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags")) 957 root))) 958 (when (eq flags t) 959 (setf flags (cvs-flags-query 'cvs-checkout-flags nil 'noquery))) 960 (let ((cvs-cvsroot root)) 961 (cvs-cmd-do "checkout" (or dir default-directory) 962 (append flags modules) nil 'new 963 :noexist t))) 964 965(defun-cvs-mode (cvs-mode-checkout . NOARGS) (dir) 966 "Run `cvs checkout' against the current branch. 967The files are stored to DIR." 968 (interactive 969 (let* ((branch (cvs-prefix-get 'cvs-branch-prefix)) 970 (prompt (format-message "CVS Checkout Directory for `%s%s': " 971 (cvs-get-module) 972 (if branch (format " (branch: %s)" branch) 973 "")))) 974 (list (read-directory-name prompt nil default-directory nil)))) 975 (let ((modules (split-string-and-unquote (cvs-get-module))) 976 (flags (cvs-add-branch-prefix 977 (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags"))) 978 (cvs-cvsroot (cvs-get-cvsroot))) 979 (cvs-checkout modules dir flags))) 980 981;;;; 982;;;; The code for running a "cvs update" and friends in various ways. 983;;;; 984 985(defun-cvs-mode (cvs-mode-revert-buffer . SIMPLE) 986 (&optional _ignore-auto _noconfirm) 987 "Rerun `cvs-examine' on the current directory with the default flags." 988 (interactive) 989 (cvs-examine default-directory t)) 990 991(defun cvs-query-directory (prompt) 992 "Read directory name, prompting with PROMPT. 993If in a *cvs* buffer, don't prompt unless a prefix argument is given." 994 (if (and (cvs-buffer-p) 995 (not current-prefix-arg)) 996 default-directory 997 (read-directory-name prompt nil default-directory nil))) 998 999;;;###autoload 1000(defun cvs-quickdir (dir &optional _flags noshow) 1001 "Open a *cvs* buffer on DIR without running cvs. 1002With a prefix argument, prompt for a directory to use. 1003A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), 1004 prevents reuse of an existing *cvs* buffer. 1005Optional argument NOSHOW if non-nil means not to display the buffer. 1006FLAGS is ignored." 1007 (interactive (list (cvs-query-directory "CVS quickdir (directory): "))) 1008 ;; FIXME: code duplication with cvs-cmd-do and cvs-parse-process 1009 (let* ((dir (file-name-as-directory 1010 (abbreviate-file-name (expand-file-name dir)))) 1011 (new (> (prefix-numeric-value current-prefix-arg) 8)) 1012 (cvsbuf (cvs-make-cvs-buffer dir new)) 1013 last) 1014 ;; Check that dir is under CVS control. 1015 (unless (file-directory-p dir) 1016 (error "%s is not a directory" dir)) 1017 (unless (file-directory-p (expand-file-name "CVS" dir)) 1018 (error "%s does not contain CVS controlled files" dir)) 1019 (set-buffer cvsbuf) 1020 (dolist (fi (cvs-fileinfo-from-entries "")) 1021 (setq last (cvs-addto-collection cvs-cookies fi last))) 1022 (cvs-cleanup-collection cvs-cookies 1023 (eq cvs-auto-remove-handled t) 1024 cvs-auto-remove-directories 1025 nil) 1026 (if noshow cvsbuf 1027 (let ((pop-up-windows nil)) (pop-to-buffer cvsbuf))))) 1028 1029;;;###autoload 1030(defun cvs-examine (directory flags &optional noshow) 1031 "Run a `cvs -n update' in the specified DIRECTORY. 1032That is, check what needs to be done, but don't change the disc. 1033Feed the output to a *cvs* buffer and run `cvs-mode' on it. 1034With a prefix argument, prompt for a directory and cvs FLAGS to use. 1035A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), 1036 prevents reuse of an existing *cvs* buffer. 1037Optional argument NOSHOW if non-nil means not to display the buffer." 1038 (interactive (list (cvs-query-directory "CVS Examine (directory): ") 1039 (cvs-flags-query 'cvs-update-flags "cvs -n update flags"))) 1040 (when (eq flags t) 1041 (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery))) 1042 (when find-file-visit-truename (setq directory (file-truename directory))) 1043 (cvs-cmd-do "update" directory flags nil 1044 (> (prefix-numeric-value current-prefix-arg) 8) 1045 :cvsargs '("-n") 1046 :noshow noshow 1047 :dont-change-disc t)) 1048 1049 1050;;;###autoload 1051(defun cvs-update (directory flags) 1052 "Run a `cvs update' in the current working DIRECTORY. 1053Feed the output to a *cvs* buffer and run `cvs-mode' on it. 1054With a \\[universal-argument] prefix argument, prompt for a directory to use. 1055A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), 1056 prevents reuse of an existing *cvs* buffer. 1057The prefix is also passed to `cvs-flags-query' to select the FLAGS 1058 passed to cvs." 1059 (interactive (list (cvs-query-directory "CVS Update (directory): ") 1060 (cvs-flags-query 'cvs-update-flags "cvs update flags"))) 1061 (when (eq flags t) 1062 (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery))) 1063 (cvs-cmd-do "update" directory flags nil 1064 (> (prefix-numeric-value current-prefix-arg) 8))) 1065 1066 1067;;;###autoload 1068(defun cvs-status (directory flags &optional noshow) 1069 "Run a `cvs status' in the current working DIRECTORY. 1070Feed the output to a *cvs* buffer and run `cvs-mode' on it. 1071With a prefix argument, prompt for a directory and cvs FLAGS to use. 1072A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), 1073 prevents reuse of an existing *cvs* buffer. 1074Optional argument NOSHOW if non-nil means not to display the buffer." 1075 (interactive (list (cvs-query-directory "CVS Status (directory): ") 1076 (cvs-flags-query 'cvs-status-flags "cvs status flags"))) 1077 (when (eq flags t) 1078 (setf flags (cvs-flags-query 'cvs-status-flags nil 'noquery))) 1079 (cvs-cmd-do "status" directory flags nil 1080 (> (prefix-numeric-value current-prefix-arg) 8) 1081 :noshow noshow :dont-change-disc t)) 1082 1083(defun cvs-update-filter (proc string) 1084 "Filter function for PCL-CVS. 1085This function gets the output that CVS sends to stdout. It inserts 1086the STRING into (process-buffer PROC) but it also checks if CVS is waiting 1087for a lock file. If so, it inserts a message cookie in the *cvs* buffer." 1088 (save-match-data 1089 (with-current-buffer (process-buffer proc) 1090 (let ((inhibit-read-only t)) 1091 (save-excursion 1092 ;; Insert the text, moving the process-marker. 1093 (goto-char (process-mark proc)) 1094 (insert string) 1095 (set-marker (process-mark proc) (point)) 1096 ;; FIXME: Delete any old lock message 1097 ;;(if (tin-nth cookies 1) 1098 ;; (tin-delete cookies 1099 ;; (tin-nth cookies 1))) 1100 ;; Check if CVS is waiting for a lock. 1101 (beginning-of-line 0) ;Move to beginning of last complete line. 1102 (when (looking-at "^[ a-z]+: \\(.*waiting for .*lock in \\(.*\\)\\)$") 1103 (let ((msg (match-string 1)) 1104 (lock (match-string 2))) 1105 (with-current-buffer cvs-buffer 1106 (set (make-local-variable 'cvs-lock-file) lock) 1107 ;; display the lock situation in the *cvs* buffer: 1108 (ewoc-enter-last 1109 cvs-cookies 1110 (cvs-create-fileinfo 1111 'MESSAGE "" " " 1112 (concat msg 1113 (when (file-exists-p lock) 1114 (substitute-command-keys 1115 "\n\t(type \\[cvs-mode-delete-lock] to delete it)"))) 1116 :subtype 'TEMP)) 1117 (pop-to-buffer (current-buffer)) 1118 (goto-char (point-max)) 1119 (beep))))))))) 1120 1121 1122;;;; 1123;;;; The cvs-mode and its associated commands. 1124;;;; 1125 1126(cvs-prefix-define cvs-force-command "" "" '("/F") cvs-qtypedesc-string1) 1127(defun-cvs-mode cvs-mode-force-command (arg) 1128 "Force the next cvs command to operate on all the selected files. 1129By default, cvs commands only operate on files on which the command 1130\"makes sense\". This overrides the safety feature on the next cvs command. 1131It actually behaves as a toggle. If prefixed by \\[universal-argument] \\[universal-argument], 1132the override will persist until the next toggle." 1133 (interactive "P") 1134 (cvs-prefix-set 'cvs-force-command arg)) 1135 1136(put 'cvs-mode 'mode-class 'special) 1137(define-derived-mode cvs-mode nil "CVS" 1138 "Mode used for PCL-CVS, a frontend to CVS. 1139Full documentation is in the Texinfo file." 1140 (setq mode-line-process 1141 '("" cvs-force-command cvs-ignore-marks-modif 1142 ":" (cvs-branch-prefix 1143 ("" cvs-branch-prefix (cvs-secondary-branch-prefix 1144 ("->" cvs-secondary-branch-prefix)))) 1145 " " cvs-mode-line-process)) 1146 (if buffer-file-name 1147 (error "Use M-x cvs-quickdir to get a *cvs* buffer")) 1148 (buffer-disable-undo) 1149 ;;(set (make-local-variable 'goal-column) cvs-cursor-column) 1150 (set (make-local-variable 'revert-buffer-function) 'cvs-mode-revert-buffer) 1151 (setq truncate-lines t) 1152 (cvs-prefix-make-local 'cvs-branch-prefix) 1153 (cvs-prefix-make-local 'cvs-secondary-branch-prefix) 1154 (cvs-prefix-make-local 'cvs-force-command) 1155 (cvs-prefix-make-local 'cvs-ignore-marks-modif) 1156 (make-local-variable 'cvs-mode-line-process) 1157 (make-local-variable 'cvs-temp-buffers)) 1158 1159 1160(defun cvs-buffer-p (&optional buffer) 1161 "Return whether the (by default current) BUFFER is a `cvs-mode' buffer." 1162 (save-excursion 1163 (if buffer (set-buffer buffer)) 1164 (and (eq major-mode 'cvs-mode)))) 1165 1166(defun cvs-buffer-check () 1167 "Check that the current buffer follows cvs-buffer's conventions." 1168 (let ((buf (current-buffer)) 1169 (check 'none)) 1170 (or (and (setq check 'collection) 1171 (eq (ewoc-buffer cvs-cookies) buf) 1172 (setq check 'cvs-temp-buffer) 1173 (or (null cvs-temp-buffer) 1174 (null (buffer-live-p cvs-temp-buffer)) 1175 (and (eq (with-current-buffer cvs-temp-buffer cvs-buffer) buf) 1176 (equal (with-current-buffer cvs-temp-buffer 1177 default-directory) 1178 default-directory))) 1179 t) 1180 (error "Inconsistent %s in buffer %s" check (buffer-name buf))))) 1181 1182 1183(defun cvs-mode-quit () 1184 "Quit PCL-CVS, killing the *cvs* buffer." 1185 (interactive) 1186 (and (y-or-n-p "Quit pcl-cvs? ") (kill-buffer (current-buffer)))) 1187 1188;; Give help.... 1189 1190(defun cvs-help () 1191 "Display help for various PCL-CVS commands." 1192 (interactive) 1193 (if (eq last-command 'cvs-help) 1194 (describe-function 'cvs-mode) ; would need minor-mode for log-edit-mode 1195 (message "%s" 1196 (substitute-command-keys 1197 "`\\[cvs-help]':help `\\[cvs-mode-add]':add `\\[cvs-mode-commit]':commit \ 1198`\\[cvs-mode-diff-map]':diff* `\\[cvs-mode-log]':log \ 1199`\\[cvs-mode-remove]':remove `\\[cvs-mode-status]':status \ 1200`\\[cvs-mode-undo]':undo")))) 1201 1202;; Move around in the buffer 1203 1204(defun cvs-move-to-goal-column () 1205 (let* ((eol (line-end-position)) 1206 (fpos (next-single-property-change (point) 'cvs-goal-column nil eol))) 1207 (when (< fpos eol) 1208 (goto-char fpos)))) 1209 1210(defun-cvs-mode cvs-mode-previous-line (arg) 1211 "Go to the previous line. 1212If a prefix argument is given, move by that many lines." 1213 (interactive "p") 1214 (ewoc-goto-prev cvs-cookies arg) 1215 (cvs-move-to-goal-column)) 1216 1217(defun-cvs-mode cvs-mode-next-line (arg) 1218 "Go to the next line. 1219If a prefix argument is given, move by that many lines." 1220 (interactive "p") 1221 (ewoc-goto-next cvs-cookies arg) 1222 (cvs-move-to-goal-column)) 1223 1224;;;; 1225;;;; Mark handling 1226;;;; 1227 1228(defun-cvs-mode cvs-mode-mark (&optional arg) 1229 "Mark the fileinfo on the current line. 1230If the fileinfo is a directory, all the contents of that directory are 1231marked instead. A directory can never be marked." 1232 (interactive) 1233 (let* ((tin (ewoc-locate cvs-cookies)) 1234 (fi (ewoc-data tin))) 1235 (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE) 1236 ;; it's a directory: let's mark all files inside 1237 (ewoc-map 1238 (lambda (f dir) 1239 (when (cvs-dir-member-p f dir) 1240 (setf (cvs-fileinfo->marked f) 1241 (not (if (eq arg 'toggle) (cvs-fileinfo->marked f) arg))) 1242 t)) ;Tell cookie to redisplay this cookie. 1243 cvs-cookies 1244 (cvs-fileinfo->dir fi)) 1245 ;; not a directory: just do the obvious 1246 (setf (cvs-fileinfo->marked fi) 1247 (not (if (eq arg 'toggle) (cvs-fileinfo->marked fi) arg))) 1248 (ewoc-invalidate cvs-cookies tin) 1249 (cvs-mode-next-line 1)))) 1250 1251(defalias 'cvs-mouse-toggle-mark 'cvs-mode-toggle-mark) 1252(defun cvs-mode-toggle-mark (e) 1253 "Toggle the mark of the entry at point." 1254 (interactive (list last-input-event)) 1255 (save-excursion 1256 (posn-set-point (event-end e)) 1257 (cvs-mode-mark 'toggle))) 1258 1259(defun-cvs-mode cvs-mode-unmark () 1260 "Unmark the fileinfo on the current line." 1261 (interactive) 1262 (cvs-mode-mark t)) 1263 1264(defun-cvs-mode cvs-mode-mark-all-files () 1265 "Mark all files." 1266 (interactive) 1267 (ewoc-map (lambda (cookie) 1268 (unless (eq (cvs-fileinfo->type cookie) 'DIRCHANGE) 1269 (setf (cvs-fileinfo->marked cookie) t))) 1270 cvs-cookies)) 1271 1272(defun-cvs-mode (cvs-mode-mark-on-state . SIMPLE) (state) 1273 "Mark all files in state STATE." 1274 (interactive 1275 (list 1276 (let ((default 1277 (condition-case nil 1278 (downcase 1279 (symbol-name 1280 (cvs-fileinfo->type 1281 (cvs-mode-marked nil nil :read-only t :one t :noquery t)))) 1282 (error nil)))) 1283 (intern 1284 (upcase 1285 (completing-read 1286 (concat 1287 "Mark files in state" (if default (concat " [" default "]")) ": ") 1288 (mapcar (lambda (x) 1289 (list (downcase (symbol-name (car x))))) 1290 cvs-states) 1291 nil t nil nil default)))))) 1292 (ewoc-map (lambda (fi) 1293 (when (eq (cvs-fileinfo->type fi) state) 1294 (setf (cvs-fileinfo->marked fi) t))) 1295 cvs-cookies)) 1296 1297(defun-cvs-mode cvs-mode-mark-matching-files (regex) 1298 "Mark all files matching REGEX." 1299 (interactive "sMark files matching: ") 1300 (ewoc-map (lambda (cookie) 1301 (when (and (not (eq (cvs-fileinfo->type cookie) 'DIRCHANGE)) 1302 (string-match regex (cvs-fileinfo->file cookie))) 1303 (setf (cvs-fileinfo->marked cookie) t))) 1304 cvs-cookies)) 1305 1306(defun-cvs-mode cvs-mode-unmark-all-files () 1307 "Unmark all files. 1308Directories are also unmarked, but that doesn't matter, since 1309they should always be unmarked." 1310 (interactive) 1311 (ewoc-map (lambda (cookie) 1312 (setf (cvs-fileinfo->marked cookie) nil) 1313 t) 1314 cvs-cookies)) 1315 1316(defun-cvs-mode cvs-mode-unmark-up () 1317 "Unmark the file on the previous line." 1318 (interactive) 1319 (let ((tin (ewoc-goto-prev cvs-cookies 1))) 1320 (when tin 1321 (setf (cvs-fileinfo->marked (ewoc-data tin)) nil) 1322 (ewoc-invalidate cvs-cookies tin))) 1323 (cvs-move-to-goal-column)) 1324 1325(defconst cvs-ignore-marks-alternatives 1326 '(("toggle-marks" . "/TM") 1327 ("force-marks" . "/FM") 1328 ("ignore-marks" . "/IM"))) 1329 1330(cvs-prefix-define cvs-ignore-marks-modif 1331 "Prefix to decide whether to ignore marks or not." 1332 "active" 1333 (mapcar 'cdr cvs-ignore-marks-alternatives) 1334 (cvs-qtypedesc-create 1335 (lambda (str) (cdr (assoc str cvs-ignore-marks-alternatives))) 1336 (lambda (obj) (car (rassoc obj cvs-ignore-marks-alternatives))) 1337 (lambda () cvs-ignore-marks-alternatives) 1338 nil t)) 1339 1340(defun-cvs-mode cvs-mode-toggle-marks (arg) 1341 "Toggle whether the next CVS command uses marks. 1342See `cvs-prefix-set' for further description of the behavior. 1343\\[universal-argument] 1 selects `force-marks', 1344\\[universal-argument] 2 selects `ignore-marks', 1345\\[universal-argument] 3 selects `toggle-marks'." 1346 (interactive "P") 1347 (cvs-prefix-set 'cvs-ignore-marks-modif arg)) 1348 1349(defun cvs-ignore-marks-p (cmd &optional read-only) 1350 (let ((default (if (member cmd cvs-invert-ignore-marks) 1351 (not cvs-default-ignore-marks) 1352 cvs-default-ignore-marks)) 1353 (modif (cvs-prefix-get 'cvs-ignore-marks-modif read-only))) 1354 (cond 1355 ((equal modif "/IM") t) 1356 ((equal modif "/TM") (not default)) 1357 ((equal modif "/FM") nil) 1358 (t default)))) 1359 1360(defun cvs-mode-mark-get-modif (cmd) 1361 (if (cvs-ignore-marks-p cmd 'read-only) "/IM" "/FM")) 1362 1363(defun cvs-get-marked (&optional ignore-marks ignore-contents) 1364 "Return a list of all selected fileinfos. 1365If there are any marked tins, and IGNORE-MARKS is nil, return them. 1366Otherwise, if the cursor selects a directory, and IGNORE-CONTENTS is 1367nil, return all files in it, else return just the directory. 1368Otherwise return (a list containing) the file the cursor points to, or 1369an empty list if it doesn't point to a file at all." 1370 (let ((fis nil)) 1371 (dolist (fi (if (and (boundp 'cvs-minor-current-files) 1372 (consp cvs-minor-current-files)) 1373 (mapcar 1374 (lambda (f) 1375 (if (cvs-fileinfo-p f) f 1376 (let ((f (file-relative-name f))) 1377 (if (file-directory-p f) 1378 (cvs-create-fileinfo 1379 'DIRCHANGE (file-name-as-directory f) "." "") 1380 (let ((dir (file-name-directory f)) 1381 (file (file-name-nondirectory f))) 1382 (cvs-create-fileinfo 1383 'UNKNOWN (or dir "") file "")))))) 1384 cvs-minor-current-files) 1385 (or (and (not ignore-marks) 1386 (ewoc-collect cvs-cookies 'cvs-fileinfo->marked)) 1387 (list (ewoc-data (ewoc-locate cvs-cookies)))))) 1388 1389 (if (or ignore-contents (not (eq (cvs-fileinfo->type fi) 'DIRCHANGE))) 1390 (push fi fis) 1391 ;; If a directory is selected, return members, if any. 1392 (setq fis 1393 (append (ewoc-collect 1394 cvs-cookies 'cvs-dir-member-p (cvs-fileinfo->dir fi)) 1395 fis)))) 1396 (nreverse fis))) 1397 1398(cl-defun cvs-mode-marked (filter &optional cmd 1399 &key read-only one file noquery) 1400 "Get the list of marked FIS. 1401CMD is used to determine whether to use the marks or not. 1402Only files for which FILTER is applicable are returned. 1403If READ-ONLY is non-nil, the current toggling is left intact. 1404If ONE is non-nil, marks are ignored and a single FI is returned. 1405If FILE is non-nil, directory entries won't be selected." 1406 (unless cmd (setq cmd (symbol-name filter))) 1407 (let* ((fis (cvs-get-marked (or one (cvs-ignore-marks-p cmd read-only)) 1408 (and (not file) 1409 (cvs-applicable-p 'DIRCHANGE filter)))) 1410 (force (cvs-prefix-get 'cvs-force-command)) 1411 (fis (car (cvs-partition 1412 (lambda (fi) (cvs-applicable-p fi (and (not force) filter))) 1413 fis)))) 1414 (when (and (or (null fis) (and one (cdr fis))) (not noquery)) 1415 (message (if (null fis) 1416 "`%s' is not applicable to any of the selected files." 1417 "`%s' is only applicable to a single file.") cmd) 1418 (sit-for 1) 1419 (setq fis (list (cvs-insert-file 1420 (read-file-name (format "File to %s: " cmd)))))) 1421 (if one (car fis) fis))) 1422 1423(defun cvs-enabledp (filter) 1424 "Determine whether FILTER applies to at least one of the selected files." 1425 (ignore-errors (cvs-mode-marked filter nil :read-only t :noquery t))) 1426 1427(defun cvs-mode-files (&rest -cvs-mode-files-args) 1428 (cvs-mode! 1429 (lambda () 1430 (mapcar 'cvs-fileinfo->full-name 1431 (apply 'cvs-mode-marked -cvs-mode-files-args))))) 1432 1433;; 1434;; Interface between Log-Edit and PCL-CVS 1435;; 1436 1437(defun cvs-mode-commit-setup () 1438 "Run `cvs-mode-commit' with setup." 1439 (interactive) 1440 (cvs-mode-commit 'force)) 1441 1442(defcustom cvs-mode-commit-hook nil 1443 "Hook run after setting up the commit buffer." 1444 :type 'hook 1445 :options '(cvs-mode-diff) 1446 :group 'pcl-cvs) 1447 1448(defun cvs-mode-commit (setup) 1449 "Check in all marked files, or the current file. 1450The user will be asked for a log message in a buffer. 1451The buffer's mode and name is determined by the \"message\" setting 1452 of `cvs-buffer-name-alist'. 1453The POSTPROC specified there (typically `log-edit') is then called, 1454 passing it the SETUP argument." 1455 (interactive "P") 1456 ;; It seems that the save-excursion that happens if I use the better 1457 ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which 1458 ;; end up being rather annoying (like log-edit-mode's message being 1459 ;; displayed in the wrong minibuffer). 1460 (cvs-mode!) 1461 (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup)) 1462 (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist))) 1463 'log-edit))) 1464 (funcall setupfun 'cvs-do-commit setup 1465 '((log-edit-listfun . cvs-commit-filelist) 1466 (log-edit-diff-function . cvs-mode-diff)) buf) 1467 (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-commit-minor-wrap) 1468 (run-hooks 'cvs-mode-commit-hook))) 1469 1470(defun cvs-commit-minor-wrap (_buf f) 1471 (let ((cvs-ignore-marks-modif (cvs-mode-mark-get-modif "commit"))) 1472 (funcall f))) 1473 1474(defun cvs-commit-filelist () 1475 (cvs-mode-files 'commit nil :read-only t :file t :noquery t)) 1476 1477(defun cvs-do-commit (flags) 1478 "Do the actual commit, using the current buffer as the log message." 1479 (interactive (list (cvs-flags-query 'cvs-commit-flags "cvs commit flags"))) 1480 (let ((msg (buffer-substring-no-properties (point-min) (point-max)))) 1481 (cvs-mode!) 1482 ;;(pop-to-buffer cvs-buffer) 1483 (cvs-mode-do "commit" `("-m" ,msg ,@flags) 'commit))) 1484 1485 1486;;;; Editing existing commit log messages. 1487 1488(defun cvs-edit-log-text-at-point () 1489 (save-excursion 1490 (end-of-line) 1491 (when (re-search-backward "^revision " nil t) 1492 (forward-line 1) 1493 (if (looking-at "date:") (forward-line 1)) 1494 (if (looking-at "branches:") (forward-line 1)) 1495 (buffer-substring 1496 (point) 1497 (if (re-search-forward 1498 "^\\(-\\{28\\}\\|=\\{77\\}\\|revision [.0-9]+\\)$" 1499 nil t) 1500 (match-beginning 0) 1501 (point)))))) 1502 1503(defvar cvs-edit-log-revision) 1504(defvar cvs-edit-log-files) (put 'cvs-edit-log-files 'permanent-local t) 1505(defun cvs-mode-edit-log (file rev &optional text) 1506 "Edit the log message at point. 1507This is best called from a `log-view-mode' buffer." 1508 (interactive 1509 (list 1510 (or (cvs-mode! (lambda () 1511 (car (cvs-mode-files nil nil 1512 :read-only t :file t :noquery t)))) 1513 (read-string "File name: ")) 1514 (or (cvs-mode! (lambda () (cvs-prefix-get 'cvs-branch-prefix))) 1515 (read-string "Revision to edit: ")) 1516 (cvs-edit-log-text-at-point))) 1517 ;; It seems that the save-excursion that happens if I use the better 1518 ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which 1519 ;; end up being rather annoying (like log-edit-mode's message being 1520 ;; displayed in the wrong minibuffer). 1521 (cvs-mode!) 1522 (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup)) 1523 (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist))) 1524 'log-edit))) 1525 (with-current-buffer buf 1526 ;; Set the filename before, so log-edit can correctly setup its 1527 ;; log-edit-initial-files variable. 1528 (set (make-local-variable 'cvs-edit-log-files) (list file))) 1529 (funcall setupfun 'cvs-do-edit-log nil 1530 '((log-edit-listfun . cvs-edit-log-filelist) 1531 (log-edit-diff-function . cvs-mode-diff)) 1532 buf) 1533 (when text (erase-buffer) (insert text)) 1534 (set (make-local-variable 'cvs-edit-log-revision) rev) 1535 (set (make-local-variable 'cvs-minor-wrap-function) 1536 'cvs-edit-log-minor-wrap) 1537 ;; (run-hooks 'cvs-mode-commit-hook) 1538 )) 1539 1540(defun cvs-edit-log-minor-wrap (buf f) 1541 (let ((cvs-branch-prefix (with-current-buffer buf cvs-edit-log-revision)) 1542 (cvs-minor-current-files 1543 (with-current-buffer buf cvs-edit-log-files)) 1544 ;; FIXME: I need to force because the fileinfos are UNKNOWN 1545 (cvs-force-command "/F")) 1546 (funcall f))) 1547 1548(defun cvs-edit-log-filelist () 1549 (if cvs-minor-wrap-function 1550 (cvs-mode-files nil nil :read-only t :file t :noquery t) 1551 cvs-edit-log-files)) 1552 1553(defun cvs-do-edit-log (rev) 1554 "Do the actual commit, using the current buffer as the log message." 1555 (interactive (list cvs-edit-log-revision)) 1556 (let ((msg (buffer-substring-no-properties (point-min) (point-max)))) 1557 (cvs-mode! 1558 (lambda () 1559 (cvs-mode-do "admin" (list (concat "-m" rev ":" msg)) nil))))) 1560 1561 1562;;;; 1563;;;; CVS Mode commands 1564;;;; 1565 1566(defun-cvs-mode (cvs-mode-insert . NOARGS) (file) 1567 "Insert an entry for a specific file into the current listing. 1568This is typically used if the file is up-to-date (or has been added 1569outside of PCL-CVS) and one wants to do some operation on it." 1570 (interactive 1571 (list (read-file-name 1572 "File to insert: " 1573 ;; Can't use ignore-errors here because interactive 1574 ;; specs aren't byte-compiled. 1575 (condition-case nil 1576 (file-name-as-directory 1577 (expand-file-name 1578 (cvs-fileinfo->dir 1579 (cvs-mode-marked nil nil :read-only t :one t :noquery t)))) 1580 (error nil))))) 1581 (cvs-insert-file file)) 1582 1583(defun cvs-insert-file (file) 1584 "Insert FILE (and its contents if it's a dir) and return its FI." 1585 (let ((file (file-relative-name (directory-file-name file))) last) 1586 (dolist (fi (cvs-fileinfo-from-entries file)) 1587 (setq last (cvs-addto-collection cvs-cookies fi last))) 1588 ;; There should have been at least one entry. 1589 (goto-char (ewoc-location last)) 1590 (ewoc-data last))) 1591 1592(defun cvs-mark-fis-dead (fis) 1593 ;; Helper function, introduced because of the need for macro-expansion. 1594 (dolist (fi fis) 1595 (setf (cvs-fileinfo->type fi) 'DEAD))) 1596 1597(defun-cvs-mode (cvs-mode-add . SIMPLE) (flags) 1598 "Add marked files to the cvs repository. 1599With prefix argument, prompt for cvs flags." 1600 (interactive (list (cvs-flags-query 'cvs-add-flags "cvs add flags"))) 1601 (let ((fis (cvs-mode-marked 'add)) 1602 (needdesc nil) (dirs nil)) 1603 ;; Find directories and look for fis needing a description. 1604 (dolist (fi fis) 1605 (cond 1606 ((file-directory-p (cvs-fileinfo->full-name fi)) (push fi dirs)) 1607 ((eq (cvs-fileinfo->type fi) 'UNKNOWN) (setq needdesc t)))) 1608 ;; Prompt for description if necessary. 1609 (let* ((msg (if (and needdesc 1610 (or current-prefix-arg (not cvs-add-default-message))) 1611 (read-from-minibuffer "Enter description: ") 1612 (or cvs-add-default-message ""))) 1613 (flags `("-m" ,msg ,@flags)) 1614 (postproc 1615 ;; Setup postprocessing for the directory entries. 1616 (when dirs 1617 (lambda () 1618 (cvs-run-process (list "-n" "update") 1619 dirs 1620 (lambda () (cvs-parse-process t))) 1621 (cvs-mark-fis-dead dirs))))) 1622 (cvs-mode-run "add" flags fis :postproc postproc)))) 1623 1624(defun-cvs-mode (cvs-mode-diff . DOUBLE) (flags) 1625 "Diff the selected files against the repository. 1626This command compares the files in your working area against the 1627revision which they are based upon." 1628 (interactive 1629 (list (cvs-add-branch-prefix 1630 (cvs-add-secondary-branch-prefix 1631 (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))))) 1632 (cvs-mode-do "diff" flags 'diff 1633 :show t)) ;; :ignore-exit t 1634 1635(defun-cvs-mode (cvs-mode-diff-head . SIMPLE) (flags) 1636 "Diff the selected files against the head of the current branch. 1637See `cvs-mode-diff' for more info." 1638 (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) 1639 (cvs-mode-diff-1 (cons "-rHEAD" flags))) 1640 1641(defun-cvs-mode (cvs-mode-diff-repository . SIMPLE) (flags) 1642 "Diff the files for changes in the repository since last co/update/commit. 1643See `cvs-mode-diff' for more info." 1644 (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) 1645 (cvs-mode-diff-1 (cons "-rBASE" (cons "-rHEAD" flags)))) 1646 1647(defun-cvs-mode (cvs-mode-diff-yesterday . SIMPLE) (flags) 1648 "Diff the selected files against yesterday's head of the current branch. 1649See `cvs-mode-diff' for more info." 1650 (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) 1651 (cvs-mode-diff-1 (cons "-Dyesterday" flags))) 1652 1653(defun-cvs-mode (cvs-mode-diff-vendor . SIMPLE) (flags) 1654 "Diff the selected files against the head of the vendor branch. 1655See `cvs-mode-diff' for more info." 1656 (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) 1657 (cvs-mode-diff-1 (cons (concat "-r" cvs-vendor-branch) flags))) 1658 1659;; sadly, this is not provided by cvs, so we have to roll our own 1660(defun-cvs-mode (cvs-mode-diff-backup . SIMPLE) (flags) 1661 "Diff the files against the backup file. 1662This command can be used on files that are marked with \"Merged\" 1663or \"Conflict\" in the *cvs* buffer." 1664 (interactive (list (cvs-flags-query 'cvs-diff-flags "diff flags"))) 1665 (unless (listp flags) (error "flags should be a list of strings")) 1666 (save-some-buffers) 1667 (let* ((marked (cvs-get-marked (cvs-ignore-marks-p "diff"))) 1668 (fis (car (cvs-partition 'cvs-fileinfo->backup-file marked)))) 1669 (unless (consp fis) 1670 (error "No files with a backup file selected!")) 1671 (set-buffer (cvs-temp-buffer "diff")) 1672 (message "cvs diff backup...") 1673 (cvs-execute-single-file-list fis 'cvs-diff-backup-extractor 1674 cvs-diff-program flags)) 1675 (message "cvs diff backup... Done.")) 1676 1677(defun cvs-diff-backup-extractor (fileinfo) 1678 "Return the filename and the name of the backup file as a list. 1679Signal an error if there is no backup file." 1680 (let ((backup-file (cvs-fileinfo->backup-file fileinfo))) 1681 (unless backup-file 1682 (error "%s has no backup file" (cvs-fileinfo->full-name fileinfo))) 1683 (list backup-file (cvs-fileinfo->full-name fileinfo)))) 1684 1685;; 1686;; Emerge support 1687;; 1688(defun cvs-emerge-diff (b1 b2) (emerge-buffers b1 b2 b1)) 1689(defun cvs-emerge-merge (b1 b2 base out) 1690 (emerge-buffers-with-ancestor b1 b2 base (find-file-noselect out))) 1691 1692;; 1693;; Ediff support 1694;; 1695 1696(defvar ediff-after-quit-destination-buffer) 1697(defvar ediff-after-quit-hook-internal) 1698(defvar cvs-transient-buffers) 1699(defun cvs-ediff-startup-hook () 1700 (add-hook 'ediff-after-quit-hook-internal 1701 `(lambda () 1702 (cvs-ediff-exit-hook 1703 ',ediff-after-quit-destination-buffer ',cvs-transient-buffers)) 1704 nil 'local)) 1705 1706(defun cvs-ediff-exit-hook (cvs-buf tmp-bufs) 1707 ;; kill the temp buffers (and their associated windows) 1708 (dolist (tb tmp-bufs) 1709 (when (and tb (buffer-live-p tb) (not (buffer-modified-p tb))) 1710 (let ((win (get-buffer-window tb t))) 1711 (kill-buffer tb) 1712 (when (window-live-p win) (ignore-errors (delete-window win)))))) 1713 ;; switch back to the *cvs* buffer 1714 (when (and cvs-buf (buffer-live-p cvs-buf) 1715 (not (get-buffer-window cvs-buf t))) 1716 (ignore-errors (switch-to-buffer cvs-buf)))) 1717 1718(defun cvs-ediff-diff (b1 b2) 1719 (let ((ediff-after-quit-destination-buffer (current-buffer)) 1720 (startup-hook '(cvs-ediff-startup-hook))) 1721 (ediff-buffers b1 b2 startup-hook 'ediff-revision))) 1722 1723(defun cvs-ediff-merge (b1 b2 base out) 1724 (let ((ediff-after-quit-destination-buffer (current-buffer)) 1725 (startup-hook '(cvs-ediff-startup-hook))) 1726 (ediff-merge-buffers-with-ancestor 1727 b1 b2 base startup-hook 1728 'ediff-merge-revisions-with-ancestor 1729 out))) 1730 1731;; 1732;; Interactive merge/diff support. 1733;; 1734 1735(defun cvs-retrieve-revision (fileinfo rev) 1736 "Retrieve the given REVision of the file in FILEINFO into a new buffer." 1737 (let* ((file (cvs-fileinfo->full-name fileinfo)) 1738 (buffile (concat file "." rev))) 1739 (or (find-buffer-visiting buffile) 1740 (with-current-buffer (create-file-buffer buffile) 1741 (message "Retrieving revision %s..." rev) 1742 ;; Discard stderr output to work around the CVS+SSH+libc 1743 ;; problem when stdout and stderr are the same. 1744 (let ((res 1745 (let ((coding-system-for-read 'binary)) 1746 (apply 'process-file cvs-program nil '(t nil) nil 1747 "-q" "update" "-p" 1748 ;; If `rev' is HEAD, don't pass it at all: 1749 ;; the default behavior is to get the head 1750 ;; of the current branch whereas "-r HEAD" 1751 ;; stupidly gives you the head of the trunk. 1752 (append (unless (equal rev "HEAD") (list "-r" rev)) 1753 (list file)))))) 1754 (when (and res (not (and (equal 0 res)))) 1755 (error "Something went wrong retrieving revision %s: %s" rev res)) 1756 ;; Figure out the encoding used and decode the byte-sequence 1757 ;; into a sequence of chars. 1758 (decode-coding-inserted-region 1759 (point-min) (point-max) file t nil nil t) 1760 ;; Set buffer-file-coding-system. 1761 (after-insert-file-set-coding (buffer-size) t) 1762 (set-buffer-modified-p nil) 1763 (let ((buffer-file-name (expand-file-name file))) 1764 (after-find-file)) 1765 (setq buffer-read-only t) 1766 (message "Retrieving revision %s... Done" rev) 1767 (current-buffer)))))) 1768 1769;; FIXME: The user should be able to specify ancestor/head/backup and we should 1770;; provide sensible defaults when merge info is unavailable (rather than rely 1771;; on smerge-ediff). Also provide sane defaults for need-merge files. 1772(defun-cvs-mode cvs-mode-imerge () 1773 "Merge interactively appropriate revisions of the selected file." 1774 (interactive) 1775 (let ((fi (cvs-mode-marked 'merge nil :one t :file t))) 1776 (let ((merge (cvs-fileinfo->merge fi)) 1777 (file (cvs-fileinfo->full-name fi)) 1778 (backup-file (cvs-fileinfo->backup-file fi))) 1779 (if (not (and merge backup-file)) 1780 (let ((buf (find-file-noselect file))) 1781 (message "Missing merge info or backup file, using VC.") 1782 (with-current-buffer buf 1783 (smerge-ediff))) 1784 (let* ((ancestor-buf (cvs-retrieve-revision fi (car merge))) 1785 (head-buf (cvs-retrieve-revision fi (cdr merge))) 1786 (backup-buf (let ((auto-mode-alist nil)) 1787 (find-file-noselect backup-file))) 1788 ;; this binding is used by cvs-ediff-startup-hook 1789 (cvs-transient-buffers (list ancestor-buf backup-buf head-buf))) 1790 (with-current-buffer backup-buf 1791 (let ((buffer-file-name (expand-file-name file))) 1792 (after-find-file))) 1793 (funcall (cdr cvs-idiff-imerge-handlers) 1794 backup-buf head-buf ancestor-buf file)))))) 1795 1796(cvs-flags-define cvs-idiff-version 1797 (list "BASE" cvs-vendor-branch cvs-vendor-branch "BASE" "BASE") 1798 "version: " cvs-qtypedesc-tag) 1799 1800(defun-cvs-mode (cvs-mode-idiff . NOARGS) (&optional rev1 rev2) 1801 "Diff interactively current file to revisions." 1802 (interactive 1803 (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix)) 1804 (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix)))) 1805 (list (or rev1 (cvs-flags-query 'cvs-idiff-version)) 1806 rev2))) 1807 (let ((fi (cvs-mode-marked 'diff "idiff" :one t :file t))) 1808 (let* ((file (cvs-fileinfo->full-name fi)) 1809 (rev1-buf (cvs-retrieve-revision fi (or rev1 "BASE"))) 1810 (rev2-buf (if rev2 (cvs-retrieve-revision fi rev2))) 1811 ;; this binding is used by cvs-ediff-startup-hook 1812 (cvs-transient-buffers (list rev1-buf rev2-buf))) 1813 (funcall (car cvs-idiff-imerge-handlers) 1814 rev1-buf (or rev2-buf (find-file-noselect file)))))) 1815 1816(defun-cvs-mode (cvs-mode-idiff-other . NOARGS) () 1817 "Diff interactively current file to revisions." 1818 (interactive) 1819 (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix)) 1820 (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix))) 1821 (fis (cvs-mode-marked 'diff "idiff" :file t))) 1822 (when (> (length fis) 2) 1823 (error "idiff-other cannot be applied to more than 2 files at a time")) 1824 (let* ((fi1 (car fis)) 1825 (rev1-buf (if rev1 (cvs-retrieve-revision fi1 rev1) 1826 (find-file-noselect (cvs-fileinfo->full-name fi1)))) 1827 rev2-buf) 1828 (if (cdr fis) 1829 (let ((fi2 (nth 1 fis))) 1830 (setq rev2-buf 1831 (if rev2 (cvs-retrieve-revision fi2 rev2) 1832 (find-file-noselect (cvs-fileinfo->full-name fi2))))) 1833 (error "idiff-other doesn't know what other file/buffer to use")) 1834 (let* (;; this binding is used by cvs-ediff-startup-hook 1835 (cvs-transient-buffers (list rev1-buf rev2-buf))) 1836 (funcall (car cvs-idiff-imerge-handlers) 1837 rev1-buf rev2-buf))))) 1838 1839 1840(defun cvs-is-within-p (fis dir) 1841 "Non-nil if buffer is inside one of FIS (in DIR)." 1842 (when (stringp buffer-file-name) 1843 (setq buffer-file-name (expand-file-name buffer-file-name)) 1844 (let (ret) 1845 (dolist (fi (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." "")))) 1846 (when (string-prefix-p 1847 (expand-file-name (cvs-fileinfo->full-name fi) dir) 1848 buffer-file-name) 1849 (setq ret t))) 1850 ret))) 1851 1852(cl-defun cvs-mode-run (cmd flags fis 1853 &key (buf (cvs-temp-buffer)) 1854 dont-change-disc cvsargs postproc) 1855 "Generic cvs-mode-<foo> function. 1856Executes `cvs CVSARGS CMD FLAGS FIS'. 1857BUF is the buffer to be used for cvs' output. 1858DONT-CHANGE-DISC non-nil indicates that the command will not change the 1859 contents of files. This is only used by the parser. 1860POSTPROC is a function of no argument to be evaluated at the very end (after 1861 parsing if applicable)." 1862 (unless postproc (setq postproc #'ignore)) 1863 (let ((def-dir default-directory)) 1864 ;; Save the relevant buffers 1865 (save-some-buffers nil (lambda () (cvs-is-within-p fis def-dir)))) 1866 (unless (listp flags) (error "flags should be a list of strings")) 1867 ;; Some w32 versions of CVS don't like an explicit . too much. 1868 (when (and (car fis) (null (cdr fis)) 1869 (eq (cvs-fileinfo->type (car fis)) 'DIRCHANGE) 1870 ;; (equal (cvs-fileinfo->file (car fis)) ".") 1871 (equal (cvs-fileinfo->dir (car fis)) "")) 1872 (setq fis nil)) 1873 (let* ((single-dir (or (not (listp cvs-execute-single-dir)) 1874 (member cmd cvs-execute-single-dir))) 1875 (parse (member cmd cvs-parse-known-commands)) 1876 (args (append cvsargs (list cmd) flags)) 1877 (after-mode (nth 2 (cdr (assoc cmd cvs-buffer-name-alist))))) 1878 (cvs-cleanup-collection cvs-cookies ;cleanup remaining messages 1879 (eq cvs-auto-remove-handled 'delayed) nil t) 1880 (when (fboundp after-mode) 1881 (setq postproc (let ((pp postproc)) 1882 (lambda () (funcall pp) (funcall after-mode))))) 1883 (when parse 1884 (let ((old-fis 1885 (when (member cmd '("status" "update")) ;FIXME: Yuck!! 1886 ;; absence of `cvs update' output has a specific meaning. 1887 (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." ""))))) 1888 (pp postproc)) 1889 (setq postproc (lambda () 1890 (cvs-parse-process dont-change-disc nil old-fis) 1891 (funcall pp))))) 1892 (with-current-buffer buf 1893 (let ((inhibit-read-only t)) (erase-buffer)) 1894 (message "Running cvs %s ..." cmd) 1895 (cvs-run-process args fis postproc single-dir)))) 1896 1897 1898(cl-defun cvs-mode-do (cmd flags filter 1899 &key show dont-change-disc cvsargs postproc) 1900 "Generic cvs-mode-<foo> function. 1901Executes `cvs CVSARGS CMD FLAGS' on the selected files. 1902FILTER is passed to `cvs-applicable-p' to only apply the command to 1903 files for which it makes sense. 1904SHOW indicates that CMD should be not be run in the default temp buffer and 1905 should be shown to the user. The buffer and mode to be used are determined 1906 by `cvs-buffer-name-alist'. 1907DONT-CHANGE-DISC non-nil indicates that the command will not change the 1908 contents of files. This is only used by the parser." 1909 (cvs-mode-run cmd flags (cvs-mode-marked filter cmd) 1910 :buf (cvs-temp-buffer (when show cmd)) 1911 :dont-change-disc dont-change-disc 1912 :cvsargs cvsargs 1913 :postproc postproc)) 1914 1915(defun-cvs-mode (cvs-mode-status . SIMPLE) (flags) 1916 "Show cvs status for all marked files. 1917With prefix argument, prompt for cvs flags." 1918 (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags"))) 1919 (cvs-mode-do "status" flags nil :dont-change-disc t :show t 1920 :postproc (when (eq cvs-auto-remove-handled 'status) 1921 (let ((buf (current-buffer))) 1922 (lambda () (with-current-buffer buf 1923 (cvs-mode-remove-handled))))))) 1924 1925(autoload 'cvs-status-cvstrees "cvs-status") 1926 1927(defun-cvs-mode (cvs-mode-tree . SIMPLE) (flags) 1928 "Call cvstree using the file under the point as a keyfile." 1929 (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags"))) 1930 (cvs-mode-run "status" (cons "-v" flags) (cvs-mode-marked nil "status") 1931 :buf (cvs-temp-buffer "tree") 1932 :dont-change-disc t 1933 :postproc #'cvs-status-cvstrees)) 1934 1935;; cvs log 1936 1937(defun-cvs-mode (cvs-mode-log . NOARGS) (flags) 1938 "Display the cvs log of all selected files. 1939With prefix argument, prompt for cvs flags." 1940 (interactive (list (cvs-add-branch-prefix 1941 (cvs-flags-query 'cvs-log-flags "cvs log flags")))) 1942 (cvs-mode-do "log" flags nil :show t)) 1943 1944 1945(defun-cvs-mode (cvs-mode-update . NOARGS) (flags) 1946 "Update all marked files. 1947With a prefix argument, prompt for cvs flags." 1948 (interactive 1949 (list (cvs-add-branch-prefix 1950 (cvs-add-secondary-branch-prefix 1951 (cvs-flags-query 'cvs-update-flags "cvs update flags") 1952 "-j") "-j"))) 1953 (cvs-mode-do "update" flags 'update)) 1954 1955 1956(defun-cvs-mode (cvs-mode-examine . NOARGS) (flags) 1957 "Re-examine all marked files. 1958With a prefix argument, prompt for cvs flags." 1959 (interactive 1960 (list (cvs-add-branch-prefix 1961 (cvs-add-secondary-branch-prefix 1962 (cvs-flags-query 'cvs-update-flags "cvs -n update flags") 1963 "-j") "-j"))) 1964 (cvs-mode-do "update" flags nil :cvsargs '("-n") :dont-change-disc t)) 1965 1966 1967(defun-cvs-mode cvs-mode-ignore () 1968 "Arrange so that CVS ignores the selected files. 1969This command ignores files that are not flagged as `Unknown'." 1970 (interactive) 1971 (dolist (fi (cvs-mode-marked 'ignore)) 1972 (vc-cvs-append-to-ignore (cvs-fileinfo->dir fi) (cvs-fileinfo->file fi) 1973 (eq (cvs-fileinfo->subtype fi) 'NEW-DIR) 1974 cvs-sort-ignore-file) 1975 (setf (cvs-fileinfo->type fi) 'DEAD)) 1976 (cvs-cleanup-collection cvs-cookies nil nil nil)) 1977 1978(define-obsolete-function-alias 'cvs-append-to-ignore 'vc-cvs-append-to-ignore 1979 "24.4") 1980 1981 1982(defun cvs-mode-find-file-other-window (e) 1983 "Select a buffer containing the file in another window." 1984 (interactive (list last-input-event)) 1985 (cvs-mode-find-file e t)) 1986 1987 1988(defun cvs-mode-display-file (e) 1989 "Show a buffer containing the file in another window." 1990 (interactive (list last-input-event)) 1991 (cvs-mode-find-file e 'dont-select)) 1992 1993 1994(defun cvs-mode-view-file (e) 1995 "View the file." 1996 (interactive (list last-input-event)) 1997 (cvs-mode-find-file e nil t)) 1998 1999 2000(defun cvs-mode-view-file-other-window (e) 2001 "View the file in another window." 2002 (interactive (list last-input-event)) 2003 (cvs-mode-find-file e t t)) 2004 2005 2006(defun cvs-find-modif (fi) 2007 (with-temp-buffer 2008 (process-file cvs-program nil (current-buffer) nil 2009 "-f" "diff" (cvs-fileinfo->file fi)) 2010 (goto-char (point-min)) 2011 (if (re-search-forward "^\\([0-9]+\\)" nil t) 2012 (string-to-number (match-string 1)) 2013 1))) 2014 2015 2016(defun cvs-mode-find-file (e &optional other view) 2017 "Select a buffer containing the file. 2018With a prefix, opens the buffer in an OTHER window." 2019 (interactive (list last-input-event current-prefix-arg)) 2020 ;; If the event moves point, check that it moves it to a valid location. 2021 (when (and (/= (point) (progn (posn-set-point (event-end e)) (point))) 2022 (not (memq (get-text-property (1- (line-end-position)) 2023 'font-lock-face) 2024 '(cvs-header cvs-filename)))) 2025 (error "Not a file name")) 2026 (cvs-mode! 2027 (lambda (&optional rev) 2028 (interactive (list (cvs-prefix-get 'cvs-branch-prefix))) 2029 (let* ((cvs-buf (current-buffer)) 2030 (fi (cvs-mode-marked nil nil :one t))) 2031 (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE) 2032 (let ((odir default-directory)) 2033 (setq default-directory 2034 (cvs-expand-dir-name (cvs-fileinfo->dir fi))) 2035 (cond ((eq other 'dont-select) 2036 (display-buffer (find-file-noselect default-directory))) 2037 (other (dired-other-window default-directory)) 2038 (t (dired default-directory))) 2039 (set-buffer cvs-buf) 2040 (setq default-directory odir)) 2041 (let ((buf (if rev (cvs-retrieve-revision fi rev) 2042 (find-file-noselect (cvs-fileinfo->full-name fi))))) 2043 (funcall (cond ((eq other 'dont-select) 'display-buffer) 2044 (other 2045 (if view 'view-buffer-other-window 2046 'switch-to-buffer-other-window)) 2047 (t (if view 'view-buffer 'switch-to-buffer))) 2048 buf) 2049 (when (and cvs-find-file-and-jump (cvs-applicable-p fi 'diff-base)) 2050 (save-restriction 2051 (widen) 2052 (goto-char (point-min)) 2053 (forward-line (1- (cvs-find-modif fi))))) 2054 buf)))))) 2055 2056 2057(defun-cvs-mode (cvs-mode-undo . SIMPLE) (flags) 2058 "Undo local changes to all marked files. 2059The file is removed and `cvs update FILE' is run." 2060 ;;"With prefix argument, prompt for cvs FLAGS." 2061 (interactive (list nil));; (cvs-flags-query 'cvs-undo-flags "undo flags") 2062 (if current-prefix-arg (call-interactively 'cvs-mode-revert-to-rev) 2063 (let* ((fis (cvs-do-removal 'undo "update" 'all)) 2064 (removedp (lambda (fi) 2065 (or (eq (cvs-fileinfo->type fi) 'REMOVED) 2066 (and (eq (cvs-fileinfo->type fi) 'CONFLICT) 2067 (eq (cvs-fileinfo->subtype fi) 'REMOVED))))) 2068 (fis-split (cvs-partition removedp fis)) 2069 (fis-removed (car fis-split)) 2070 (fis-other (cdr fis-split))) 2071 (if (null fis-other) 2072 (when fis-removed (cvs-mode-run "add" nil fis-removed)) 2073 (cvs-mode-run "update" flags fis-other 2074 :postproc 2075 (when fis-removed 2076 (let ((buf (current-buffer))) 2077 (lambda () 2078 (with-current-buffer buf 2079 (cvs-mode-run "add" nil fis-removed)))))))))) 2080 2081 2082(defun-cvs-mode (cvs-mode-revert-to-rev . NOARGS) (rev) 2083 "Revert the selected files to an old revision." 2084 (interactive 2085 (list (or (cvs-prefix-get 'cvs-branch-prefix) 2086 (let ((current-prefix-arg '(4))) 2087 (cvs-flags-query 'cvs-idiff-version))))) 2088 (let* ((fis (cvs-mode-marked 'revert "revert" :file t)) 2089 (tag (concat "tmp_pcl_tag_" (make-temp-name ""))) 2090 (buf (current-buffer)) 2091 (untag (lambda () 2092 (with-current-buffer buf 2093 (cvs-mode-run "tag" (list "-d" tag) fis)))) 2094 (update (lambda () 2095 (with-current-buffer buf 2096 (cvs-mode-run "update" (list "-j" tag "-j" rev) fis 2097 :postproc untag))))) 2098 (cvs-mode-run "tag" (list tag) fis :postproc update))) 2099 2100 2101(defun-cvs-mode cvs-mode-delete-lock () 2102 "Delete the lock file that CVS is waiting for. 2103Note that this can be dangerous. You should only do this 2104if you are convinced that the process that created the lock is dead." 2105 (interactive) 2106 (let* ((default-directory (cvs-expand-dir-name cvs-lock-file)) 2107 (locks (directory-files default-directory nil cvs-lock-file-regexp))) 2108 (cond 2109 ((not locks) (error "No lock files found")) 2110 ((yes-or-no-p (concat "Really delete locks in " cvs-lock-file "? ")) 2111 (dolist (lock locks) 2112 (cond ((file-directory-p lock) (delete-directory lock)) 2113 ((file-exists-p lock) (delete-file lock)))))))) 2114 2115 2116(defun-cvs-mode cvs-mode-remove-handled () 2117 "Remove all lines that are handled. 2118Empty directories are removed." 2119 (interactive) 2120 (cvs-cleanup-collection cvs-cookies 2121 'all (or cvs-auto-remove-directories 'handled) t)) 2122 2123 2124(defun-cvs-mode cvs-mode-acknowledge () 2125 "Remove all marked files from the buffer." 2126 (interactive) 2127 (dolist (fi (cvs-get-marked (cvs-ignore-marks-p "acknowledge") t)) 2128 (setf (cvs-fileinfo->type fi) 'DEAD)) 2129 (cvs-cleanup-collection cvs-cookies nil nil nil)) 2130 2131(defun cvs-do-removal (filter &optional cmd all) 2132 "Remove files. 2133Returns a list of FIS that should be `cvs remove'd." 2134 (let* ((files (cvs-mode-marked filter cmd :file t :read-only t)) 2135 (fis (cdr (cvs-partition (lambda (fi) 2136 (eq (cvs-fileinfo->type fi) 'UNKNOWN)) 2137 (cvs-mode-marked filter cmd)))) 2138 (silent (or (not cvs-confirm-removals) 2139 (cvs-every (lambda (fi) 2140 (or (not (file-exists-p 2141 (cvs-fileinfo->full-name fi))) 2142 (cvs-applicable-p fi 'safe-rm))) 2143 files))) 2144 (tmpbuf (cvs-temp-buffer))) 2145 (when (and (not silent) (equal cvs-confirm-removals 'list)) 2146 (with-current-buffer tmpbuf 2147 (let ((inhibit-read-only t)) 2148 (cvs-insert-strings (mapcar 'cvs-fileinfo->full-name fis)) 2149 (cvs-pop-to-buffer-same-frame (current-buffer)) 2150 (shrink-window-if-larger-than-buffer)))) 2151 (if (not (or silent 2152 (unwind-protect 2153 (yes-or-no-p 2154 (let ((nfiles (length files)) 2155 (verb (if (eq filter 'undo) "Undo" "Delete"))) 2156 (if (= 1 nfiles) 2157 (format "%s file: \"%s\" ? " 2158 verb 2159 (cvs-fileinfo->file (car files))) 2160 (format "%s %d files? " 2161 verb 2162 nfiles)))) 2163 (cvs-bury-buffer tmpbuf cvs-buffer)))) 2164 (progn (message "Aborting") nil) 2165 (dolist (fi files) 2166 (let* ((type (cvs-fileinfo->type fi)) 2167 (file (cvs-fileinfo->full-name fi))) 2168 (when (or all (eq type 'UNKNOWN)) 2169 (when (file-exists-p file) (delete-file file)) 2170 (unless all (setf (cvs-fileinfo->type fi) 'DEAD) t)))) 2171 fis))) 2172 2173(defun-cvs-mode (cvs-mode-remove . SIMPLE) (flags) 2174 "Remove all marked files. 2175With prefix argument, prompt for cvs flags." 2176 (interactive (list (cvs-flags-query 'cvs-remove-flags "cvs remove flags"))) 2177 (let ((fis (cvs-do-removal 'remove))) 2178 (if fis (cvs-mode-run "remove" (cons "-f" flags) fis) 2179 (cvs-cleanup-collection cvs-cookies nil nil nil)))) 2180 2181 2182(defvar cvs-tag-name "") 2183(defun-cvs-mode (cvs-mode-tag . SIMPLE) (tag &optional flags) 2184 "Run `cvs tag TAG' on all selected files. 2185With prefix argument, prompt for cvs flags. 2186By default this can only be used on directories. 2187Use \\[cvs-mode-force-command] or change `cvs-force-dir-tag' if you need 2188to use it on individual files." 2189 (interactive 2190 (list (setq cvs-tag-name 2191 (cvs-query-read cvs-tag-name "Tag name: " cvs-qtypedesc-tag)) 2192 (cvs-flags-query 'cvs-tag-flags "tag flags"))) 2193 (cvs-mode-do "tag" (append flags (list tag)) 2194 (when cvs-force-dir-tag 'tag))) 2195 2196(defun-cvs-mode (cvs-mode-untag . SIMPLE) (tag &optional flags) 2197 "Run `cvs tag -d TAG' on all selected files. 2198With prefix argument, prompt for cvs flags." 2199 (interactive 2200 (list (setq cvs-tag-name 2201 (cvs-query-read cvs-tag-name "Tag to delete: " 2202 cvs-qtypedesc-tag)) 2203 (cvs-flags-query 'cvs-tag-flags "tag flags"))) 2204 (cvs-mode-do "tag" (append '("-d") flags (list tag)) 2205 (when cvs-force-dir-tag 'tag))) 2206 2207 2208;; Byte compile files. 2209 2210(defun-cvs-mode cvs-mode-byte-compile-files () 2211 "Run byte-compile-file on all selected files with `.el' extension." 2212 (interactive) 2213 (let ((marked (cvs-get-marked (cvs-ignore-marks-p "byte-compile")))) 2214 (dolist (fi marked) 2215 (let ((filename (cvs-fileinfo->full-name fi))) 2216 (when (string-match "\\.el\\'" filename) 2217 (byte-compile-file filename)))))) 2218 2219;; ChangeLog support. 2220(defvar add-log-buffer-file-name-function) 2221 2222(defun-cvs-mode cvs-mode-add-change-log-entry-other-window () 2223 "Add a ChangeLog entry in the ChangeLog of the current directory." 2224 (interactive) 2225 ;; Require `add-log' explicitly, because if it gets autoloaded when we call 2226 ;; add-change-log-entry-other-window below, the 2227 ;; add-log-buffer-file-name-function ends up unbound when we leave the `let'. 2228 (require 'add-log) 2229 (dolist (fi (cvs-mode-marked nil nil)) 2230 (let* ((default-directory (cvs-expand-dir-name (cvs-fileinfo->dir fi))) 2231 (add-log-buffer-file-name-function 2232 (lambda () 2233 (let ((file (expand-file-name (cvs-fileinfo->file fi)))) 2234 (if (file-directory-p file) 2235 ;; Be careful to use a directory name, otherwise add-log 2236 ;; starts looking for a ChangeLog file in the 2237 ;; parent dir. 2238 (file-name-as-directory file) 2239 file))))) 2240 (kill-local-variable 'change-log-default-name) 2241 (save-excursion (add-change-log-entry-other-window))))) 2242 2243;; interactive commands to set optional flags 2244 2245(defun cvs-mode-set-flags (flag) 2246 "Ask for new setting of cvs-FLAG-flags." 2247 (interactive 2248 (list (completing-read 2249 "Which flag: " 2250 '("cvs" "diff" "update" "status" "log" "tag" ;"rtag" 2251 "commit" "remove" "undo" "checkout") 2252 nil t))) 2253 (let* ((sym (intern (concat "cvs-" flag "-flags")))) 2254 (let ((current-prefix-arg '(16))) 2255 (cvs-flags-query sym (concat flag " flags"))))) 2256 2257 2258;;;; 2259;;;; Utilities for the *cvs* buffer 2260;;;; 2261 2262(defun cvs-dir-member-p (fileinfo dir) 2263 "Return true if FILEINFO represents a file in directory DIR." 2264 (and (not (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE)) 2265 (string-prefix-p dir (cvs-fileinfo->dir fileinfo)))) 2266 2267(defun cvs-execute-single-file (fi extractor program constant-args) 2268 "Internal function for `cvs-execute-single-file-list'." 2269 (let* ((arg-list (funcall extractor fi)) 2270 (inhibit-read-only t)) 2271 2272 ;; Execute the command unless extractor returned t. 2273 (when (listp arg-list) 2274 (let* ((args (append constant-args arg-list))) 2275 2276 (insert (format "=== %s %s\n\n" 2277 program (split-string-and-unquote args))) 2278 2279 ;; FIXME: return the exit status? 2280 (apply 'process-file program nil t t args) 2281 (goto-char (point-max)))))) 2282 2283;; FIXME: make this run in the background ala cvs-run-process... 2284(defun cvs-execute-single-file-list (fis extractor program constant-args) 2285 "Run PROGRAM on all elements on FIS. 2286CONSTANT-ARGS is a list of strings to pass as arguments to PROGRAM. 2287The arguments given to the program will be CONSTANT-ARGS followed by 2288the list that EXTRACTOR returns. 2289 2290EXTRACTOR will be called once for each file on FIS. It is given 2291one argument, the cvs-fileinfo. It can return t, which means ignore 2292this file, or a list of arguments to send to the program." 2293 (dolist (fi fis) 2294 (cvs-execute-single-file fi extractor program constant-args))) 2295 2296 2297(defun cvs-revert-if-needed (fis) 2298 (dolist (fileinfo fis) 2299 (let* ((file (cvs-fileinfo->full-name fileinfo)) 2300 (buffer (find-buffer-visiting file))) 2301 ;; For a revert to happen the user must be editing the file... 2302 (unless (or (null buffer) 2303 (memq (cvs-fileinfo->type fileinfo) '(MESSAGE UNKNOWN)) 2304 ;; FIXME: check whether revert is really needed. 2305 ;; `(verify-visited-file-modtime buffer)' doesn't cut it 2306 ;; because it only looks at the time stamp (it ignores 2307 ;; read-write changes) which is not changed by `commit'. 2308 (buffer-modified-p buffer)) 2309 (with-current-buffer buffer 2310 (ignore-errors 2311 (revert-buffer 'ignore-auto 'dont-ask 'preserve-modes) 2312 ;; `preserve-modes' avoids changing the (minor) modes. But we 2313 ;; do want to reset the mode for VC, so we do it explicitly. 2314 (vc-refresh-state) 2315 (when (eq (cvs-fileinfo->type fileinfo) 'CONFLICT) 2316 (smerge-start-session)))))))) 2317 2318 2319(defun cvs-change-cvsroot (newroot) 2320 "Change the CVSROOT." 2321 (interactive "DNew repository: ") 2322 (if (or (file-directory-p (expand-file-name "CVSROOT" newroot)) 2323 (y-or-n-p (concat "Warning: no CVSROOT found inside repository." 2324 " Change cvs-cvsroot anyhow? "))) 2325 (setq cvs-cvsroot newroot))) 2326 2327;;;; 2328;;;; useful global settings 2329;;;; 2330 2331;; 2332;; Hook to allow calling PCL-CVS by visiting the /CVS subdirectory 2333;; 2334 2335;;;###autoload 2336(defcustom cvs-dired-action 'cvs-quickdir 2337 "The action to be performed when opening a CVS directory. 2338Sensible values are `cvs-examine', `cvs-status' and `cvs-quickdir'." 2339 :group 'pcl-cvs 2340 :type '(choice (const cvs-examine) (const cvs-status) (const cvs-quickdir))) 2341 2342;;;###autoload 2343(defcustom cvs-dired-use-hook '(4) 2344 "Whether or not opening a CVS directory should run PCL-CVS. 2345A value of nil means never do it. 2346`always' means to always do it unless a prefix argument is given to the 2347 command that prompted the opening of the directory. 2348Anything else means to do it only if the prefix arg is equal to this value." 2349 :group 'pcl-cvs 2350 :type '(choice (const :tag "Never" nil) 2351 (const :tag "Always" always) 2352 (const :tag "Prefix" (4)))) 2353 2354;;;###autoload 2355(progn (defun cvs-dired-noselect (dir) 2356 "Run `cvs-examine' if DIR is a CVS administrative directory. 2357The exact behavior is determined also by `cvs-dired-use-hook'." 2358 (when (stringp dir) 2359 (setq dir (directory-file-name dir)) 2360 (when (and (string= "CVS" (file-name-nondirectory dir)) 2361 (file-readable-p (expand-file-name "Entries" dir)) 2362 cvs-dired-use-hook 2363 (if (eq cvs-dired-use-hook 'always) 2364 (not current-prefix-arg) 2365 (equal current-prefix-arg cvs-dired-use-hook))) 2366 (save-excursion 2367 (funcall cvs-dired-action (file-name-directory dir) t t)))))) 2368 2369;; 2370;; hook into VC 2371;; 2372 2373(add-hook 'vc-post-command-functions 'cvs-vc-command-advice) 2374 2375(defun cvs-vc-command-advice (command files flags) 2376 (when (and (equal command "cvs") 2377 (progn 2378 (while (and (stringp (car flags)) 2379 (string-match "\\`-" (car flags))) 2380 (pop flags)) 2381 ;; don't parse output we don't understand. 2382 (member (car flags) cvs-parse-known-commands)) 2383 ;; Don't parse "update -p" output. 2384 (not (and (member (car flags) '("update" "checkout")) 2385 (let ((found-p nil)) 2386 (dolist (flag flags found-p) 2387 (if (equal flag "-p") (setq found-p t))))))) 2388 (save-current-buffer 2389 (let ((buffer (current-buffer)) 2390 (dir default-directory) 2391 (cvs-from-vc t)) 2392 (dolist (cvs-buf (buffer-list)) 2393 (set-buffer cvs-buf) 2394 ;; look for a corresponding pcl-cvs buffer 2395 (when (and (eq major-mode 'cvs-mode) 2396 (string-prefix-p default-directory dir)) 2397 (let ((subdir (substring dir (length default-directory)))) 2398 (set-buffer buffer) 2399 (set (make-local-variable 'cvs-buffer) cvs-buf) 2400 ;; `cvs -q add file' produces no useful output :-( 2401 (when (and (equal (car flags) "add") 2402 (goto-char (point-min)) 2403 (looking-at ".*to add this file permanently\n\\'")) 2404 (dolist (file (if (listp files) files (list files))) 2405 (insert (format-message 2406 "cvs add: scheduling file `%s' for addition\n" 2407 (file-name-nondirectory file))))) 2408 ;; VC never (?) does `cvs -n update' so dcd=nil 2409 ;; should probably always be the right choice. 2410 (cvs-parse-process nil subdir)))))))) 2411 2412;; 2413;; Hook into write-buffer 2414;; 2415 2416(defun cvs-mark-buffer-changed () 2417 (let* ((file (expand-file-name buffer-file-name)) 2418 (version (and (fboundp 'vc-backend) 2419 (eq (vc-backend file) 'CVS) 2420 (vc-working-revision file)))) 2421 (when version 2422 (save-excursion 2423 (dolist (cvs-buf (buffer-list)) 2424 (set-buffer cvs-buf) 2425 ;; look for a corresponding pcl-cvs buffer 2426 (when (and (eq major-mode 'cvs-mode) 2427 (string-prefix-p default-directory file)) 2428 (let* ((file (substring file (length default-directory))) 2429 (fi (cvs-create-fileinfo 2430 (if (string= "0" version) 2431 'ADDED 'MODIFIED) 2432 (or (file-name-directory file) "") 2433 (file-name-nondirectory file) 2434 "cvs-mark-buffer-changed"))) 2435 (cvs-addto-collection cvs-cookies fi)))))))) 2436 2437(add-hook 'after-save-hook 'cvs-mark-buffer-changed) 2438 2439(defun cvs-insert-visited-file () 2440 (let* ((file (expand-file-name buffer-file-name)) 2441 (version (and (fboundp 'vc-backend) 2442 (eq (vc-backend file) 'CVS) 2443 (vc-working-revision file)))) 2444 (when version 2445 (save-current-buffer 2446 (dolist (cvs-buf (buffer-list)) 2447 (set-buffer cvs-buf) 2448 ;; look for a corresponding pcl-cvs buffer 2449 (when (and (eq major-mode 'cvs-mode) 2450 (string-prefix-p default-directory file)) 2451 (cvs-insert-file file))))))) 2452 2453(add-hook 'find-file-hook 'cvs-insert-visited-file 'append) 2454 2455(provide 'pcvs) 2456 2457;;; pcvs.el ends here 2458