lisp/pcvs.el

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