lisp/pcvs.el

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