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