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