lisp/pcvs.el

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