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