lisp/pcvs.el

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