lisp/pcvs.el

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