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