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