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