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