lisp/pcvs.el

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